summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2003-10-21 13:42:24 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2003-10-21 13:42:24 +0000
commit9dfe12ae5b94d03c997ea2903022a5d2d5c5f266 (patch)
treebdfc70477b60f1220cb05dd233a4570dd9c6bb5c
parent1c662558a1113238a624245a45382d3df90ccf13 (diff)
downloadgcc-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
-rw-r--r--gcc/ada/1ic.ads2
-rw-r--r--gcc/ada/31soccon.ads201
-rw-r--r--gcc/ada/31soliop.ads13
-rw-r--r--gcc/ada/3asoccon.ads201
-rw-r--r--gcc/ada/3bsoccon.ads201
-rw-r--r--gcc/ada/3gsoccon.ads201
-rw-r--r--gcc/ada/3hsoccon.ads201
-rw-r--r--gcc/ada/3psoccon.ads158
-rw-r--r--gcc/ada/3ssoccon.ads201
-rw-r--r--gcc/ada/3ssoliop.ads13
-rw-r--r--gcc/ada/3veacodu.adb73
-rw-r--r--gcc/ada/3vexpect.adb1187
-rw-r--r--gcc/ada/3vsoccon.ads158
-rw-r--r--gcc/ada/3vsocthi.adb577
-rw-r--r--gcc/ada/3vsocthi.ads445
-rw-r--r--gcc/ada/3vtrasym.adb185
-rw-r--r--gcc/ada/3wsoccon.ads220
-rw-r--r--gcc/ada/3wsocthi.adb339
-rw-r--r--gcc/ada/3wsocthi.ads161
-rw-r--r--gcc/ada/3wsoliop.ads14
-rw-r--r--gcc/ada/3zsoccon.ads158
-rw-r--r--gcc/ada/3zsocthi.adb632
-rw-r--r--gcc/ada/3zsocthi.ads446
-rw-r--r--gcc/ada/41intnam.ads2
-rw-r--r--gcc/ada/42intnam.ads2
-rw-r--r--gcc/ada/4aintnam.ads2
-rw-r--r--gcc/ada/4cintnam.ads2
-rw-r--r--gcc/ada/4dintnam.ads97
-rw-r--r--gcc/ada/4gintnam.ads20
-rw-r--r--gcc/ada/4hexcpol.adb2
-rw-r--r--gcc/ada/4hintnam.ads16
-rw-r--r--gcc/ada/4lintnam.ads2
-rw-r--r--gcc/ada/4mintnam.ads145
-rw-r--r--gcc/ada/4nintnam.ads2
-rw-r--r--gcc/ada/4ointnam.ads8
-rw-r--r--gcc/ada/4onumaux.ads2
-rw-r--r--gcc/ada/4pintnam.ads2
-rw-r--r--gcc/ada/4sintnam.ads2
-rw-r--r--gcc/ada/4uintnam.ads154
-rw-r--r--gcc/ada/4vcaldel.adb8
-rw-r--r--gcc/ada/4vcalend.adb43
-rw-r--r--gcc/ada/4vintnam.ads2
-rw-r--r--gcc/ada/4wexcpol.adb2
-rw-r--r--gcc/ada/4wintnam.ads4
-rw-r--r--gcc/ada/4zintnam.ads2
-rw-r--r--gcc/ada/50system.ads163
-rw-r--r--gcc/ada/51osinte.adb2
-rw-r--r--gcc/ada/51osinte.ads2
-rw-r--r--gcc/ada/51system.ads (renamed from gcc/ada/52system.ads)24
-rw-r--r--gcc/ada/52osinte.adb8
-rw-r--r--gcc/ada/52osinte.ads8
-rw-r--r--gcc/ada/53osinte.ads2
-rw-r--r--gcc/ada/54osinte.ads5
-rw-r--r--gcc/ada/55system.ads150
-rw-r--r--gcc/ada/56osinte.adb154
-rw-r--r--gcc/ada/56osinte.ads (renamed from gcc/ada/5mosinte.ads)345
-rw-r--r--gcc/ada/56taprop.adb1201
-rw-r--r--gcc/ada/56taspri.ads (renamed from gcc/ada/5qtaspri.ads)113
-rw-r--r--gcc/ada/56tpopsp.adb110
-rw-r--r--gcc/ada/57system.ads150
-rw-r--r--gcc/ada/58system.ads150
-rw-r--r--gcc/ada/59system.ads164
-rw-r--r--gcc/ada/5aml-tgt.adb385
-rw-r--r--gcc/ada/5aosinte.adb2
-rw-r--r--gcc/ada/5aosinte.ads2
-rw-r--r--gcc/ada/5asystem.ads15
-rw-r--r--gcc/ada/5ataprop.adb254
-rw-r--r--gcc/ada/5atasinf.ads24
-rw-r--r--gcc/ada/5ataspri.ads2
-rw-r--r--gcc/ada/5atpopsp.adb194
-rw-r--r--gcc/ada/5avxwork.ads2
-rw-r--r--gcc/ada/5bml-tgt.adb398
-rw-r--r--gcc/ada/5bosinte.adb23
-rw-r--r--gcc/ada/5bosinte.ads2
-rw-r--r--gcc/ada/5bsystem.ads15
-rw-r--r--gcc/ada/5cosinte.ads2
-rw-r--r--gcc/ada/5csystem.ads160
-rw-r--r--gcc/ada/5dosinte.ads536
-rw-r--r--gcc/ada/5dsystem.ads158
-rw-r--r--gcc/ada/5esystem.ads15
-rw-r--r--gcc/ada/5fintman.adb94
-rw-r--r--gcc/ada/5fosinte.adb120
-rw-r--r--gcc/ada/5fosinte.ads2
-rw-r--r--gcc/ada/5fsystem.ads15
-rw-r--r--gcc/ada/5ftaprop.adb204
-rw-r--r--gcc/ada/5ftasinf.ads24
-rw-r--r--gcc/ada/5ginterr.adb14
-rw-r--r--gcc/ada/5gintman.adb97
-rw-r--r--gcc/ada/5gmastop.adb12
-rw-r--r--gcc/ada/5gml-tgt.adb368
-rw-r--r--gcc/ada/5gosinte.ads2
-rw-r--r--gcc/ada/5gproinf.ads3
-rw-r--r--gcc/ada/5gsystem.ads24
-rw-r--r--gcc/ada/5gtaprop.adb75
-rw-r--r--gcc/ada/5gtasinf.ads23
-rw-r--r--gcc/ada/5gtpgetc.adb2
-rw-r--r--gcc/ada/5hml-tgt.adb373
-rw-r--r--gcc/ada/5hosinte.adb21
-rw-r--r--gcc/ada/5hosinte.ads8
-rw-r--r--gcc/ada/5hparame.ads14
-rw-r--r--gcc/ada/5hsystem.ads15
-rw-r--r--gcc/ada/5htaprop.adb213
-rw-r--r--gcc/ada/5htaspri.ads2
-rw-r--r--gcc/ada/5htraceb.adb16
-rw-r--r--gcc/ada/5iosinte.adb8
-rw-r--r--gcc/ada/5isystem.ads166
-rw-r--r--gcc/ada/5itaprop.adb275
-rw-r--r--gcc/ada/5itaspri.ads2
-rw-r--r--gcc/ada/5ksystem.ads15
-rw-r--r--gcc/ada/5kvxwork.ads2
-rw-r--r--gcc/ada/5lintman.adb111
-rw-r--r--gcc/ada/5lml-tgt.adb274
-rw-r--r--gcc/ada/5losinte.ads2
-rw-r--r--gcc/ada/5lparame.adb73
-rw-r--r--gcc/ada/5lsystem.ads21
-rw-r--r--gcc/ada/5msystem.ads158
-rw-r--r--gcc/ada/5mvxwork.ads2
-rw-r--r--gcc/ada/5ninmaop.adb2
-rw-r--r--gcc/ada/5nintman.adb2
-rw-r--r--gcc/ada/5nosinte.ads2
-rw-r--r--gcc/ada/5ntaprop.adb22
-rw-r--r--gcc/ada/5ntaspri.ads2
-rw-r--r--gcc/ada/5ointerr.adb8
-rw-r--r--gcc/ada/5omastop.adb2
-rw-r--r--gcc/ada/5oosinte.adb8
-rw-r--r--gcc/ada/5oosinte.ads8
-rw-r--r--gcc/ada/5oosprim.adb2
-rw-r--r--gcc/ada/5oparame.adb2
-rw-r--r--gcc/ada/5osystem.ads15
-rw-r--r--gcc/ada/5otaprop.adb75
-rw-r--r--gcc/ada/5otaspri.ads8
-rw-r--r--gcc/ada/5posinte.ads2
-rw-r--r--gcc/ada/5posprim.adb38
-rw-r--r--gcc/ada/5psystem.ads150
-rw-r--r--gcc/ada/5pvxwork.ads2
-rw-r--r--gcc/ada/5qosinte.ads186
-rw-r--r--gcc/ada/5qtaprop.adb1776
-rw-r--r--gcc/ada/5sintman.adb87
-rw-r--r--gcc/ada/5sml-tgt.adb367
-rw-r--r--gcc/ada/5sosinte.adb8
-rw-r--r--gcc/ada/5sosinte.ads2
-rw-r--r--gcc/ada/5sosprim.adb124
-rw-r--r--gcc/ada/5ssystem.ads15
-rw-r--r--gcc/ada/5staprop.adb653
-rw-r--r--gcc/ada/5stasinf.ads24
-rw-r--r--gcc/ada/5staspri.ads2
-rw-r--r--gcc/ada/5stpopse.adb204
-rw-r--r--gcc/ada/5stpopsp.adb109
-rw-r--r--gcc/ada/5svxwork.ads2
-rw-r--r--gcc/ada/5tosinte.ads2
-rw-r--r--gcc/ada/5tsystem.ads236
-rw-r--r--gcc/ada/5uintman.adb257
-rw-r--r--gcc/ada/5uosinte.ads552
-rw-r--r--gcc/ada/5usystem.ads150
-rw-r--r--gcc/ada/5vasthan.adb49
-rw-r--r--gcc/ada/5vinmaop.adb42
-rw-r--r--gcc/ada/5vinterr.adb137
-rw-r--r--gcc/ada/5vintman.adb4
-rw-r--r--gcc/ada/5vintman.ads6
-rw-r--r--gcc/ada/5vmastop.adb86
-rw-r--r--gcc/ada/5vml-tgt.adb571
-rw-r--r--gcc/ada/5vosinte.adb8
-rw-r--r--gcc/ada/5vosinte.ads2
-rw-r--r--gcc/ada/5vosprim.adb2
-rw-r--r--gcc/ada/5vparame.ads14
-rw-r--r--gcc/ada/5vsymbol.adb528
-rw-r--r--gcc/ada/5vsystem.ads15
-rw-r--r--gcc/ada/5vtaprop.adb197
-rw-r--r--gcc/ada/5vtaspri.ads2
-rw-r--r--gcc/ada/5vtpopde.adb32
-rw-r--r--gcc/ada/5vtpopde.ads6
-rw-r--r--gcc/ada/5vtraent.adb77
-rw-r--r--gcc/ada/5vtraent.ads68
-rw-r--r--gcc/ada/5wgloloc.adb3
-rw-r--r--gcc/ada/5wintman.adb4
-rw-r--r--gcc/ada/5wmemory.adb8
-rw-r--r--gcc/ada/5wml-tgt.adb354
-rw-r--r--gcc/ada/5wosprim.adb119
-rw-r--r--gcc/ada/5wsystem.ads24
-rw-r--r--gcc/ada/5wtaprop.adb360
-rw-r--r--gcc/ada/5wtaspri.ads9
-rw-r--r--gcc/ada/5xparame.ads203
-rw-r--r--gcc/ada/5xsystem.ads236
-rw-r--r--gcc/ada/5xvxwork.ads (renamed from gcc/ada/5etpopse.adb)43
-rw-r--r--gcc/ada/5yparame.ads203
-rw-r--r--gcc/ada/5ysystem.ads22
-rw-r--r--gcc/ada/5ytiitho.adb66
-rw-r--r--gcc/ada/5zinit.adb285
-rw-r--r--gcc/ada/5zinterr.adb35
-rw-r--r--gcc/ada/5zintman.adb50
-rw-r--r--gcc/ada/5zml-tgt.adb322
-rw-r--r--gcc/ada/5zosinte.adb6
-rw-r--r--gcc/ada/5zosinte.ads21
-rw-r--r--gcc/ada/5zosprim.adb30
-rw-r--r--gcc/ada/5zparame.ads203
-rw-r--r--gcc/ada/5zsystem.ads22
-rw-r--r--gcc/ada/5ztaprop.adb464
-rw-r--r--gcc/ada/5ztaspri.ads95
-rw-r--r--gcc/ada/5ztfsetr.adb107
-rw-r--r--gcc/ada/5zthrini.adb113
-rw-r--r--gcc/ada/5ztiitho.adb52
-rw-r--r--gcc/ada/5ztpopsp.adb (renamed from gcc/ada/5qstache.adb)69
-rw-r--r--gcc/ada/6vcpp.adb8
-rw-r--r--gcc/ada/6vcstrea.adb8
-rw-r--r--gcc/ada/6vinterf.ads34
-rw-r--r--gcc/ada/7sinmaop.adb8
-rw-r--r--gcc/ada/7sintman.adb109
-rw-r--r--gcc/ada/7sosinte.adb18
-rw-r--r--gcc/ada/7sosprim.adb16
-rw-r--r--gcc/ada/7staprop.adb234
-rw-r--r--gcc/ada/7staspri.ads8
-rw-r--r--gcc/ada/7stfsetr.adb313
-rw-r--r--gcc/ada/7stpopsp.adb37
-rw-r--r--gcc/ada/7straceb.adb33
-rw-r--r--gcc/ada/7straces.adb (renamed from gcc/ada/s-explin.ads)57
-rw-r--r--gcc/ada/7strafor.adb113
-rw-r--r--gcc/ada/7strafor.ads62
-rw-r--r--gcc/ada/7stratas.adb367
-rw-r--r--gcc/ada/9drpc.adb2
-rw-r--r--gcc/ada/ChangeLog259
-rw-r--r--gcc/ada/Make-lang.in3165
-rw-r--r--gcc/ada/Makefile.adalib45
-rw-r--r--gcc/ada/Makefile.generic409
-rw-r--r--gcc/ada/Makefile.in1622
-rw-r--r--gcc/ada/Makefile.prolog47
-rw-r--r--gcc/ada/Makefile.rtl448
-rw-r--r--gcc/ada/a-caldel.adb8
-rw-r--r--gcc/ada/a-caldel.ads2
-rw-r--r--gcc/ada/a-charac.ads3
-rw-r--r--gcc/ada/a-colien.ads8
-rw-r--r--gcc/ada/a-comlin.adb46
-rw-r--r--gcc/ada/a-diocst.adb18
-rw-r--r--gcc/ada/a-diocst.ads9
-rw-r--r--gcc/ada/a-direio.adb5
-rw-r--r--gcc/ada/a-excach.adb71
-rw-r--r--gcc/ada/a-except.adb2458
-rw-r--r--gcc/ada/a-except.ads68
-rw-r--r--gcc/ada/a-excpol.adb2
-rw-r--r--gcc/ada/a-exctra.adb14
-rw-r--r--gcc/ada/a-exctra.ads23
-rw-r--r--gcc/ada/a-exexda.adb526
-rw-r--r--gcc/ada/a-exexpr.adb525
-rw-r--r--gcc/ada/a-exextr.adb327
-rw-r--r--gcc/ada/a-exstat.adb255
-rw-r--r--gcc/ada/a-filico.adb4
-rw-r--r--gcc/ada/a-interr.adb8
-rw-r--r--gcc/ada/a-intsig.adb6
-rw-r--r--gcc/ada/a-intsig.ads6
-rw-r--r--gcc/ada/a-ngcefu.adb11
-rw-r--r--gcc/ada/a-ngcoty.adb11
-rw-r--r--gcc/ada/a-ngelfu.adb25
-rw-r--r--gcc/ada/a-nudira.adb11
-rw-r--r--gcc/ada/a-nudira.ads15
-rw-r--r--gcc/ada/a-nuflra.adb8
-rw-r--r--gcc/ada/a-nuflra.ads10
-rw-r--r--gcc/ada/a-reatim.adb9
-rw-r--r--gcc/ada/a-reatim.ads8
-rw-r--r--gcc/ada/a-retide.ads6
-rw-r--r--gcc/ada/a-sequio.adb18
-rw-r--r--gcc/ada/a-siocst.adb18
-rw-r--r--gcc/ada/a-siocst.ads9
-rw-r--r--gcc/ada/a-ssicst.adb18
-rw-r--r--gcc/ada/a-ssicst.ads9
-rw-r--r--gcc/ada/a-strbou.adb1687
-rw-r--r--gcc/ada/a-strbou.ads426
-rw-r--r--gcc/ada/a-strfix.adb9
-rw-r--r--gcc/ada/a-strmap.adb4
-rw-r--r--gcc/ada/a-strsea.ads2
-rw-r--r--gcc/ada/a-strsup.adb1807
-rw-r--r--gcc/ada/a-strsup.ads473
-rw-r--r--gcc/ada/a-strunb.adb497
-rw-r--r--gcc/ada/a-strunb.ads20
-rw-r--r--gcc/ada/a-ststio.adb30
-rw-r--r--gcc/ada/a-stunau.adb32
-rw-r--r--gcc/ada/a-stunau.ads6
-rw-r--r--gcc/ada/a-stwibo.adb1728
-rw-r--r--gcc/ada/a-stwibo.ads429
-rw-r--r--gcc/ada/a-stwifi.adb7
-rw-r--r--gcc/ada/a-stwima.adb4
-rw-r--r--gcc/ada/a-stwisu.adb1809
-rw-r--r--gcc/ada/a-stwisu.ads478
-rw-r--r--gcc/ada/a-stwiun.adb550
-rw-r--r--gcc/ada/a-stwiun.ads12
-rw-r--r--gcc/ada/a-tags.adb69
-rw-r--r--gcc/ada/a-tags.ads22
-rw-r--r--gcc/ada/a-tasatt.adb356
-rw-r--r--gcc/ada/a-taside.adb10
-rw-r--r--gcc/ada/a-teioed.adb170
-rw-r--r--gcc/ada/a-textio.adb56
-rw-r--r--gcc/ada/a-textio.ads9
-rw-r--r--gcc/ada/a-tienau.adb42
-rw-r--r--gcc/ada/a-tifiio.adb555
-rw-r--r--gcc/ada/a-tiflau.adb3
-rw-r--r--gcc/ada/a-tiflio.adb29
-rw-r--r--gcc/ada/a-tigeau.adb9
-rw-r--r--gcc/ada/a-tigeau.ads11
-rw-r--r--gcc/ada/a-tiinau.adb4
-rw-r--r--gcc/ada/a-timoau.adb4
-rw-r--r--gcc/ada/a-tiocst.adb18
-rw-r--r--gcc/ada/a-tiocst.ads9
-rw-r--r--gcc/ada/a-witeio.adb23
-rw-r--r--gcc/ada/a-witeio.ads2
-rw-r--r--gcc/ada/a-wtcstr.adb18
-rw-r--r--gcc/ada/a-wtcstr.ads9
-rw-r--r--gcc/ada/a-wtdeio.adb4
-rw-r--r--gcc/ada/a-wtedit.adb10
-rw-r--r--gcc/ada/a-wtenau.adb8
-rw-r--r--gcc/ada/a-wtflau.adb3
-rw-r--r--gcc/ada/a-wtinau.adb6
-rw-r--r--gcc/ada/a-wtmoau.adb6
-rw-r--r--gcc/ada/ada-tree.def3
-rw-r--r--gcc/ada/adaint.c648
-rw-r--r--gcc/ada/adaint.h210
-rw-r--r--gcc/ada/ali-util.adb306
-rw-r--r--gcc/ada/ali-util.ads14
-rw-r--r--gcc/ada/ali.adb847
-rw-r--r--gcc/ada/ali.ads159
-rw-r--r--gcc/ada/atree.adb83
-rw-r--r--gcc/ada/atree.ads32
-rw-r--r--gcc/ada/bcheck.adb253
-rw-r--r--gcc/ada/binde.adb157
-rw-r--r--gcc/ada/bindgen.adb1225
-rw-r--r--gcc/ada/bindusg.adb13
-rw-r--r--gcc/ada/bld-io.adb273
-rw-r--r--gcc/ada/bld-io.ads73
-rw-r--r--gcc/ada/bld.adb3538
-rw-r--r--gcc/ada/bld.ads (renamed from gcc/ada/s-expflt.ads)29
-rw-r--r--gcc/ada/checks.adb1894
-rw-r--r--gcc/ada/checks.ads155
-rw-r--r--gcc/ada/cio.c5
-rw-r--r--gcc/ada/clean.adb1444
-rw-r--r--gcc/ada/clean.ads (renamed from gcc/ada/s-explfl.ads)27
-rw-r--r--gcc/ada/comperr.adb58
-rw-r--r--gcc/ada/comperr.ads22
-rw-r--r--gcc/ada/csets.adb20
-rw-r--r--gcc/ada/cstand.adb59
-rw-r--r--gcc/ada/cstreams.c26
-rw-r--r--gcc/ada/ctrl_c.c158
-rw-r--r--gcc/ada/debug.adb275
-rw-r--r--gcc/ada/debug.ads70
-rw-r--r--gcc/ada/debug_a.adb31
-rw-r--r--gcc/ada/debug_a.ads8
-rw-r--r--gcc/ada/decl.c866
-rw-r--r--gcc/ada/einfo.adb695
-rw-r--r--gcc/ada/einfo.ads726
-rw-r--r--gcc/ada/einfo.h174
-rw-r--r--gcc/ada/err_vars.ads114
-rw-r--r--gcc/ada/errout.adb2061
-rw-r--r--gcc/ada/errout.ads152
-rw-r--r--gcc/ada/erroutc.adb1013
-rw-r--r--gcc/ada/erroutc.ads398
-rw-r--r--gcc/ada/errutil.adb744
-rw-r--r--gcc/ada/errutil.ads250
-rw-r--r--gcc/ada/eval_fat.adb232
-rw-r--r--gcc/ada/eval_fat.ads33
-rw-r--r--gcc/ada/exp_aggr.adb1196
-rw-r--r--gcc/ada/exp_attr.adb584
-rw-r--r--gcc/ada/exp_ch11.adb132
-rw-r--r--gcc/ada/exp_ch13.adb26
-rw-r--r--gcc/ada/exp_ch2.adb258
-rw-r--r--gcc/ada/exp_ch3.adb829
-rw-r--r--gcc/ada/exp_ch3.ads10
-rw-r--r--gcc/ada/exp_ch4.adb2583
-rw-r--r--gcc/ada/exp_ch5.adb574
-rw-r--r--gcc/ada/exp_ch6.adb544
-rw-r--r--gcc/ada/exp_ch7.adb705
-rw-r--r--gcc/ada/exp_ch7.ads76
-rw-r--r--gcc/ada/exp_ch8.adb19
-rw-r--r--gcc/ada/exp_ch9.adb720
-rw-r--r--gcc/ada/exp_code.adb8
-rw-r--r--gcc/ada/exp_dbug.adb413
-rw-r--r--gcc/ada/exp_dbug.ads180
-rw-r--r--gcc/ada/exp_disp.adb118
-rw-r--r--gcc/ada/exp_dist.adb621
-rw-r--r--gcc/ada/exp_fixd.adb69
-rw-r--r--gcc/ada/exp_imgv.adb4
-rw-r--r--gcc/ada/exp_intr.adb137
-rw-r--r--gcc/ada/exp_pakd.adb188
-rw-r--r--gcc/ada/exp_prag.adb290
-rw-r--r--gcc/ada/exp_strm.adb225
-rw-r--r--gcc/ada/exp_strm.ads30
-rw-r--r--gcc/ada/exp_tss.adb197
-rw-r--r--gcc/ada/exp_tss.ads113
-rw-r--r--gcc/ada/exp_util.adb1186
-rw-r--r--gcc/ada/exp_util.ads81
-rw-r--r--gcc/ada/exp_vfpt.adb1
-rw-r--r--gcc/ada/expander.adb432
-rw-r--r--gcc/ada/expander.ads12
-rw-r--r--gcc/ada/expect.c232
-rw-r--r--gcc/ada/fe.h130
-rw-r--r--gcc/ada/final.c (renamed from gcc/ada/adafinal.c)19
-rw-r--r--gcc/ada/fmap.adb203
-rw-r--r--gcc/ada/fmap.ads22
-rw-r--r--gcc/ada/fname-uf.adb22
-rw-r--r--gcc/ada/fname-uf.ads5
-rw-r--r--gcc/ada/fname.adb15
-rw-r--r--gcc/ada/fname.ads9
-rw-r--r--gcc/ada/freeze.adb953
-rw-r--r--gcc/ada/freeze.ads12
-rw-r--r--gcc/ada/frontend.adb294
-rw-r--r--gcc/ada/g-arrspl.adb309
-rw-r--r--gcc/ada/g-arrspl.ads187
-rw-r--r--gcc/ada/g-awk.adb27
-rw-r--r--gcc/ada/g-awk.ads7
-rw-r--r--gcc/ada/g-boubuf.adb93
-rw-r--r--gcc/ada/g-boubuf.ads101
-rw-r--r--gcc/ada/g-boumai.ads98
-rw-r--r--gcc/ada/g-bubsor.adb (renamed from gcc/ada/s-exnflt.ads)34
-rw-r--r--gcc/ada/g-bubsor.ads68
-rw-r--r--gcc/ada/g-busora.adb3
-rw-r--r--gcc/ada/g-busora.ads13
-rw-r--r--gcc/ada/g-busorg.adb3
-rw-r--r--gcc/ada/g-busorg.ads31
-rw-r--r--gcc/ada/g-casuti.adb80
-rw-r--r--gcc/ada/g-casuti.ads32
-rw-r--r--gcc/ada/g-catiio.adb51
-rw-r--r--gcc/ada/g-catiio.ads14
-rw-r--r--gcc/ada/g-cgi.adb3
-rw-r--r--gcc/ada/g-cgi.ads3
-rw-r--r--gcc/ada/g-cgicoo.adb5
-rw-r--r--gcc/ada/g-cgicoo.ads3
-rw-r--r--gcc/ada/g-cgideb.adb3
-rw-r--r--gcc/ada/g-cgideb.ads3
-rw-r--r--gcc/ada/g-comlin.adb51
-rw-r--r--gcc/ada/g-comlin.ads27
-rw-r--r--gcc/ada/g-comver.adb69
-rw-r--r--gcc/ada/g-comver.ads64
-rw-r--r--gcc/ada/g-crc32.adb3
-rw-r--r--gcc/ada/g-crc32.ads3
-rw-r--r--gcc/ada/g-ctrl_c.ads67
-rw-r--r--gcc/ada/g-debpoo.adb1570
-rw-r--r--gcc/ada/g-debpoo.ads272
-rw-r--r--gcc/ada/g-debuti.adb95
-rw-r--r--gcc/ada/g-debuti.ads40
-rw-r--r--gcc/ada/g-diopit.adb41
-rw-r--r--gcc/ada/g-diopit.ads3
-rw-r--r--gcc/ada/g-dirope.adb172
-rw-r--r--gcc/ada/g-dirope.ads85
-rw-r--r--gcc/ada/g-dynhta.adb344
-rw-r--r--gcc/ada/g-dynhta.ads240
-rw-r--r--gcc/ada/g-dyntab.adb131
-rw-r--r--gcc/ada/g-dyntab.ads38
-rw-r--r--gcc/ada/g-eacodu.adb51
-rw-r--r--gcc/ada/g-enblsp.adb115
-rw-r--r--gcc/ada/g-excact.adb134
-rw-r--r--gcc/ada/g-excact.ads118
-rw-r--r--gcc/ada/g-except.ads15
-rw-r--r--gcc/ada/g-exctra.adb3
-rw-r--r--gcc/ada/g-exctra.ads3
-rw-r--r--gcc/ada/g-expect.adb142
-rw-r--r--gcc/ada/g-expect.ads44
-rw-r--r--gcc/ada/g-heasor.adb132
-rw-r--r--gcc/ada/g-heasor.ads73
-rw-r--r--gcc/ada/g-hesora.adb3
-rw-r--r--gcc/ada/g-hesora.ads17
-rw-r--r--gcc/ada/g-hesorg.adb21
-rw-r--r--gcc/ada/g-hesorg.ads43
-rw-r--r--gcc/ada/g-htable.adb336
-rw-r--r--gcc/ada/g-htable.ads200
-rw-r--r--gcc/ada/g-io.adb3
-rw-r--r--gcc/ada/g-io.ads3
-rw-r--r--gcc/ada/g-io_aux.adb3
-rw-r--r--gcc/ada/g-io_aux.ads3
-rw-r--r--gcc/ada/g-locfil.adb4
-rw-r--r--gcc/ada/g-locfil.ads3
-rw-r--r--gcc/ada/g-md5.adb3
-rw-r--r--gcc/ada/g-md5.ads7
-rw-r--r--gcc/ada/g-memdum.adb125
-rw-r--r--gcc/ada/g-memdum.ads56
-rw-r--r--gcc/ada/g-os_lib.adb783
-rw-r--r--gcc/ada/g-os_lib.ads272
-rw-r--r--gcc/ada/g-pehage.adb2400
-rw-r--r--gcc/ada/g-pehage.ads186
-rw-r--r--gcc/ada/g-perhas.ads67
-rw-r--r--gcc/ada/g-regexp.adb3
-rw-r--r--gcc/ada/g-regexp.ads3
-rw-r--r--gcc/ada/g-regist.adb61
-rw-r--r--gcc/ada/g-regist.ads25
-rw-r--r--gcc/ada/g-regpat.adb563
-rw-r--r--gcc/ada/g-regpat.ads100
-rw-r--r--gcc/ada/g-semaph.adb86
-rw-r--r--gcc/ada/g-semaph.ads100
-rw-r--r--gcc/ada/g-soccon.ads201
-rw-r--r--gcc/ada/g-socket.adb880
-rw-r--r--gcc/ada/g-socket.ads559
-rw-r--r--gcc/ada/g-socthi.adb242
-rw-r--r--gcc/ada/g-socthi.ads150
-rw-r--r--gcc/ada/g-soliop.ads13
-rw-r--r--gcc/ada/g-souinf.ads3
-rw-r--r--gcc/ada/g-speche.adb7
-rw-r--r--gcc/ada/g-speche.ads3
-rw-r--r--gcc/ada/g-spipat.adb45
-rw-r--r--gcc/ada/g-spipat.ads22
-rw-r--r--gcc/ada/g-spitbo.adb3
-rw-r--r--gcc/ada/g-spitbo.ads3
-rw-r--r--gcc/ada/g-sptabo.ads3
-rw-r--r--gcc/ada/g-sptain.ads3
-rw-r--r--gcc/ada/g-sptavs.ads3
-rw-r--r--gcc/ada/g-string.adb (renamed from gcc/ada/s-exnsfl.ads)39
-rw-r--r--gcc/ada/g-string.ads (renamed from gcc/ada/s-exngen.ads)48
-rw-r--r--gcc/ada/g-strspl.ads (renamed from gcc/ada/s-exnlfl.ads)26
-rw-r--r--gcc/ada/g-table.adb3
-rw-r--r--gcc/ada/g-table.ads22
-rw-r--r--gcc/ada/g-tasloc.adb3
-rw-r--r--gcc/ada/g-tasloc.ads3
-rw-r--r--gcc/ada/g-thread.adb90
-rw-r--r--gcc/ada/g-thread.ads53
-rw-r--r--gcc/ada/g-traceb.adb3
-rw-r--r--gcc/ada/g-traceb.ads8
-rw-r--r--gcc/ada/g-trasym.adb3
-rw-r--r--gcc/ada/g-trasym.ads16
-rw-r--r--gcc/ada/g-wistsp.ads (renamed from gcc/ada/s-exnlin.ads)26
-rw-r--r--gcc/ada/gigi.h65
-rw-r--r--gcc/ada/gmem.c146
-rw-r--r--gcc/ada/gnat1drv.adb199
-rw-r--r--gcc/ada/gnatbind.adb205
-rw-r--r--gcc/ada/gnatchop.adb5
-rw-r--r--gcc/ada/gnatclean.adb42
-rw-r--r--gcc/ada/gnatcmd.adb4399
-rw-r--r--gcc/ada/gnatfind.adb25
-rw-r--r--gcc/ada/gnatkr.adb33
-rw-r--r--gcc/ada/gnatlbr.adb2
-rw-r--r--gcc/ada/gnatlink.adb613
-rw-r--r--gcc/ada/gnatls.adb46
-rw-r--r--gcc/ada/gnatmake.adb2
-rw-r--r--gcc/ada/gnatmem.adb936
-rw-r--r--gcc/ada/gnatname.adb75
-rw-r--r--gcc/ada/gnatprep.adb1529
-rw-r--r--gcc/ada/gnatprep.ads17
-rw-r--r--gcc/ada/gnatpsta.adb1
-rw-r--r--gcc/ada/gnatsym.adb239
-rw-r--r--gcc/ada/gnatvsn.adb54
-rw-r--r--gcc/ada/gnatvsn.ads29
-rw-r--r--gcc/ada/gnatxref.adb24
-rw-r--r--gcc/ada/gpr2make.adb34
-rw-r--r--gcc/ada/gpr2make.ads30
-rw-r--r--gcc/ada/gprcmd.adb423
-rw-r--r--gcc/ada/gprep.adb439
-rw-r--r--gcc/ada/gprep.ads34
-rw-r--r--gcc/ada/hostparm.ads5
-rw-r--r--gcc/ada/i-c.ads34
-rw-r--r--gcc/ada/i-cobol.adb3
-rw-r--r--gcc/ada/i-cpp.adb4
-rw-r--r--gcc/ada/i-cstrea.ads2
-rw-r--r--gcc/ada/i-cstrin.adb25
-rw-r--r--gcc/ada/i-cstrin.ads13
-rw-r--r--gcc/ada/i-pacdec.ads3
-rw-r--r--gcc/ada/i-vthrea.adb386
-rw-r--r--gcc/ada/i-vthrea.ads93
-rw-r--r--gcc/ada/i-vxwoio.adb80
-rw-r--r--gcc/ada/i-vxwoio.ads228
-rw-r--r--gcc/ada/i-vxwork.ads20
-rw-r--r--gcc/ada/impunit.adb46
-rw-r--r--gcc/ada/init.c524
-rw-r--r--gcc/ada/inline.adb200
-rw-r--r--gcc/ada/interfac.ads32
-rw-r--r--gcc/ada/io-aux.c53
-rw-r--r--gcc/ada/itypes.adb8
-rw-r--r--gcc/ada/itypes.ads4
-rw-r--r--gcc/ada/lang-specs.h7
-rw-r--r--gcc/ada/lang.opt22
-rw-r--r--gcc/ada/layout.adb631
-rw-r--r--gcc/ada/lib-list.adb7
-rw-r--r--gcc/ada/lib-load.adb108
-rw-r--r--gcc/ada/lib-load.ads15
-rw-r--r--gcc/ada/lib-sort.adb20
-rw-r--r--gcc/ada/lib-util.adb4
-rw-r--r--gcc/ada/lib-writ.adb117
-rw-r--r--gcc/ada/lib-writ.ads72
-rw-r--r--gcc/ada/lib-xref.adb931
-rw-r--r--gcc/ada/lib-xref.ads92
-rw-r--r--gcc/ada/lib.adb180
-rw-r--r--gcc/ada/lib.ads35
-rw-r--r--gcc/ada/link.c9
-rw-r--r--gcc/ada/live.adb10
-rw-r--r--gcc/ada/make.adb4145
-rw-r--r--gcc/ada/make.ads7
-rw-r--r--gcc/ada/makeusg.adb32
-rw-r--r--gcc/ada/mdll-fil.adb2
-rw-r--r--gcc/ada/mdll-fil.ads2
-rw-r--r--gcc/ada/mdll-utl.adb62
-rw-r--r--gcc/ada/mdll-utl.ads2
-rw-r--r--gcc/ada/mdll.adb45
-rw-r--r--gcc/ada/memroot.adb286
-rw-r--r--gcc/ada/memroot.ads23
-rw-r--r--gcc/ada/memtrack.adb129
-rw-r--r--gcc/ada/misc.c220
-rw-r--r--gcc/ada/mkdir.c17
-rw-r--r--gcc/ada/mlib-fil.adb2
-rw-r--r--gcc/ada/mlib-fil.ads2
-rw-r--r--gcc/ada/mlib-prj.adb1801
-rw-r--r--gcc/ada/mlib-prj.ads26
-rw-r--r--gcc/ada/mlib-tgt.adb130
-rw-r--r--gcc/ada/mlib-tgt.ads109
-rw-r--r--gcc/ada/mlib-utl.adb154
-rw-r--r--gcc/ada/mlib-utl.ads24
-rw-r--r--gcc/ada/mlib.adb228
-rw-r--r--gcc/ada/mlib.ads33
-rw-r--r--gcc/ada/namet.adb108
-rw-r--r--gcc/ada/namet.ads44
-rw-r--r--gcc/ada/namet.h5
-rw-r--r--gcc/ada/nlists.ads2
-rw-r--r--gcc/ada/nlists.h1
-rw-r--r--gcc/ada/nmake.adb18
-rw-r--r--gcc/ada/nmake.ads15
-rw-r--r--gcc/ada/nmake.adt3
-rw-r--r--gcc/ada/opt.adb89
-rw-r--r--gcc/ada/opt.ads339
-rw-r--r--gcc/ada/osint-b.adb11
-rw-r--r--gcc/ada/osint-c.adb42
-rw-r--r--gcc/ada/osint.adb403
-rw-r--r--gcc/ada/osint.ads20
-rw-r--r--gcc/ada/par-ch10.adb46
-rw-r--r--gcc/ada/par-ch11.adb4
-rw-r--r--gcc/ada/par-ch2.adb17
-rw-r--r--gcc/ada/par-ch3.adb49
-rw-r--r--gcc/ada/par-ch4.adb24
-rw-r--r--gcc/ada/par-ch5.adb128
-rw-r--r--gcc/ada/par-ch6.adb16
-rw-r--r--gcc/ada/par-ch9.adb13
-rw-r--r--gcc/ada/par-endh.adb71
-rw-r--r--gcc/ada/par-labl.adb9
-rw-r--r--gcc/ada/par-load.adb4
-rw-r--r--gcc/ada/par-prag.adb655
-rw-r--r--gcc/ada/par-sync.adb44
-rw-r--r--gcc/ada/par-tchk.adb53
-rw-r--r--gcc/ada/par-util.adb27
-rw-r--r--gcc/ada/par.adb24
-rw-r--r--gcc/ada/prep.adb1446
-rw-r--r--gcc/ada/prep.ads130
-rw-r--r--gcc/ada/prepcomp.adb783
-rw-r--r--gcc/ada/prepcomp.ads67
-rw-r--r--gcc/ada/prj-attr.adb72
-rw-r--r--gcc/ada/prj-attr.ads14
-rw-r--r--gcc/ada/prj-com.adb2
-rw-r--r--gcc/ada/prj-com.ads14
-rw-r--r--gcc/ada/prj-dect.adb532
-rw-r--r--gcc/ada/prj-dect.ads2
-rw-r--r--gcc/ada/prj-env.adb1061
-rw-r--r--gcc/ada/prj-env.ads48
-rw-r--r--gcc/ada/prj-err.adb64
-rw-r--r--gcc/ada/prj-err.ads100
-rw-r--r--gcc/ada/prj-ext.adb65
-rw-r--r--gcc/ada/prj-ext.ads14
-rw-r--r--gcc/ada/prj-makr.adb765
-rw-r--r--gcc/ada/prj-makr.ads10
-rw-r--r--gcc/ada/prj-nmsc.adb2853
-rw-r--r--gcc/ada/prj-nmsc.ads6
-rw-r--r--gcc/ada/prj-pars.adb20
-rw-r--r--gcc/ada/prj-pars.ads12
-rw-r--r--gcc/ada/prj-part.adb961
-rw-r--r--gcc/ada/prj-part.ads20
-rw-r--r--gcc/ada/prj-pp.adb97
-rw-r--r--gcc/ada/prj-pp.ads12
-rw-r--r--gcc/ada/prj-proc.adb1088
-rw-r--r--gcc/ada/prj-proc.ads9
-rw-r--r--gcc/ada/prj-strt.adb778
-rw-r--r--gcc/ada/prj-strt.ads4
-rw-r--r--gcc/ada/prj-tree.adb270
-rw-r--r--gcc/ada/prj-tree.ads186
-rw-r--r--gcc/ada/prj-util.adb256
-rw-r--r--gcc/ada/prj-util.ads46
-rw-r--r--gcc/ada/prj.adb218
-rw-r--r--gcc/ada/prj.ads204
-rw-r--r--gcc/ada/raise.c1282
-rw-r--r--gcc/ada/raise.h10
-rw-r--r--gcc/ada/repinfo.adb430
-rw-r--r--gcc/ada/repinfo.h7
-rw-r--r--gcc/ada/restrict.adb215
-rw-r--r--gcc/ada/restrict.ads88
-rw-r--r--gcc/ada/rident.ads130
-rw-r--r--gcc/ada/rtsfind.adb494
-rw-r--r--gcc/ada/rtsfind.ads336
-rw-r--r--gcc/ada/s-addima.ads5
-rw-r--r--gcc/ada/s-arit64.adb2
-rw-r--r--gcc/ada/s-assert.adb2
-rw-r--r--gcc/ada/s-assert.ads7
-rw-r--r--gcc/ada/s-atacco.adb31
-rw-r--r--gcc/ada/s-atacco.ads17
-rw-r--r--gcc/ada/s-auxdec.adb4
-rw-r--r--gcc/ada/s-auxdec.ads42
-rw-r--r--gcc/ada/s-bitops.adb10
-rw-r--r--gcc/ada/s-boarop.ads65
-rw-r--r--gcc/ada/s-carsi8.adb141
-rw-r--r--gcc/ada/s-carsi8.ads66
-rw-r--r--gcc/ada/s-carun8.adb140
-rw-r--r--gcc/ada/s-carun8.ads66
-rw-r--r--gcc/ada/s-casi16.adb137
-rw-r--r--gcc/ada/s-casi16.ads56
-rw-r--r--gcc/ada/s-casi32.adb120
-rw-r--r--gcc/ada/s-casi32.ads55
-rw-r--r--gcc/ada/s-casi64.adb120
-rw-r--r--gcc/ada/s-casi64.ads55
-rw-r--r--gcc/ada/s-casuti.adb105
-rw-r--r--gcc/ada/s-casuti.ads66
-rw-r--r--gcc/ada/s-caun16.adb137
-rw-r--r--gcc/ada/s-caun16.ads56
-rw-r--r--gcc/ada/s-caun32.adb120
-rw-r--r--gcc/ada/s-caun32.ads55
-rw-r--r--gcc/ada/s-caun64.adb119
-rw-r--r--gcc/ada/s-caun64.ads55
-rw-r--r--gcc/ada/s-crc32.adb7
-rw-r--r--gcc/ada/s-crc32.ads3
-rw-r--r--gcc/ada/s-direio.adb20
-rw-r--r--gcc/ada/s-errrep.adb8
-rw-r--r--gcc/ada/s-errrep.ads8
-rw-r--r--gcc/ada/s-exctab.adb67
-rw-r--r--gcc/ada/s-exctab.ads34
-rw-r--r--gcc/ada/s-exnint.adb (renamed from gcc/ada/s-expgen.ads)64
-rw-r--r--gcc/ada/s-exnint.ads10
-rw-r--r--gcc/ada/s-exnllf.adb (renamed from gcc/ada/s-exngen.adb)99
-rw-r--r--gcc/ada/s-exnllf.ads10
-rw-r--r--gcc/ada/s-exnlli.adb76
-rw-r--r--gcc/ada/s-exnlli.ads10
-rw-r--r--gcc/ada/s-exnsin.ads44
-rw-r--r--gcc/ada/s-exnssi.ads44
-rw-r--r--gcc/ada/s-expgen.adb181
-rw-r--r--gcc/ada/s-expint.adb85
-rw-r--r--gcc/ada/s-expint.ads9
-rw-r--r--gcc/ada/s-expllf.ads44
-rw-r--r--gcc/ada/s-explli.adb85
-rw-r--r--gcc/ada/s-explli.ads10
-rw-r--r--gcc/ada/s-expsfl.ads44
-rw-r--r--gcc/ada/s-expsin.ads44
-rw-r--r--gcc/ada/s-expssi.ads44
-rw-r--r--gcc/ada/s-expuns.ads4
-rw-r--r--gcc/ada/s-fatflt.ads4
-rw-r--r--gcc/ada/s-fatgen.adb37
-rw-r--r--gcc/ada/s-fatgen.ads22
-rw-r--r--gcc/ada/s-fatlfl.ads4
-rw-r--r--gcc/ada/s-fatllf.ads4
-rw-r--r--gcc/ada/s-fatsfl.ads4
-rw-r--r--gcc/ada/s-fileio.adb97
-rw-r--r--gcc/ada/s-fileio.ads4
-rw-r--r--gcc/ada/s-finimp.adb191
-rw-r--r--gcc/ada/s-finimp.ads42
-rw-r--r--gcc/ada/s-finroo.adb4
-rw-r--r--gcc/ada/s-finroo.ads3
-rw-r--r--gcc/ada/s-geveop.adb123
-rw-r--r--gcc/ada/s-geveop.ads66
-rw-r--r--gcc/ada/s-gloloc.adb38
-rw-r--r--gcc/ada/s-gloloc.ads16
-rw-r--r--gcc/ada/s-hibaen.ads101
-rw-r--r--gcc/ada/s-htable.adb362
-rw-r--r--gcc/ada/s-htable.ads198
-rw-r--r--gcc/ada/s-imgdec.adb2
-rw-r--r--gcc/ada/s-imgenu.adb14
-rw-r--r--gcc/ada/s-imgrea.adb98
-rw-r--r--gcc/ada/s-imgwch.adb4
-rw-r--r--gcc/ada/s-inmaop.ads2
-rw-r--r--gcc/ada/s-interr.adb73
-rw-r--r--gcc/ada/s-interr.ads10
-rw-r--r--gcc/ada/s-intman.ads98
-rw-r--r--gcc/ada/s-maccod.ads2
-rw-r--r--gcc/ada/s-mastop.adb2
-rw-r--r--gcc/ada/s-mastop.ads2
-rw-r--r--gcc/ada/s-memcop.ads76
-rw-r--r--gcc/ada/s-memory.adb10
-rw-r--r--gcc/ada/s-memory.ads60
-rw-r--r--gcc/ada/s-osprim.ads12
-rw-r--r--gcc/ada/s-parame.ads19
-rw-r--r--gcc/ada/s-parint.ads5
-rw-r--r--gcc/ada/s-pooloc.adb13
-rw-r--r--gcc/ada/s-pooloc.ads2
-rw-r--r--gcc/ada/s-poosiz.adb53
-rw-r--r--gcc/ada/s-proinf.ads7
-rw-r--r--gcc/ada/s-purexc.ads77
-rw-r--r--gcc/ada/s-rident.ads156
-rw-r--r--gcc/ada/s-scaval.adb266
-rw-r--r--gcc/ada/s-scaval.ads61
-rw-r--r--gcc/ada/s-secsta.adb5
-rw-r--r--gcc/ada/s-secsta.ads11
-rw-r--r--gcc/ada/s-sequio.adb28
-rw-r--r--gcc/ada/s-shasto.adb94
-rw-r--r--gcc/ada/s-shasto.ads8
-rw-r--r--gcc/ada/s-soflin.ads7
-rw-r--r--gcc/ada/s-stache.adb17
-rw-r--r--gcc/ada/s-stache.ads7
-rw-r--r--gcc/ada/s-stalib.adb19
-rw-r--r--gcc/ada/s-stalib.ads32
-rw-r--r--gcc/ada/s-stoele.ads55
-rw-r--r--gcc/ada/s-stopoo.adb65
-rw-r--r--gcc/ada/s-stopoo.ads21
-rw-r--r--gcc/ada/s-stratt.adb9
-rw-r--r--gcc/ada/s-stratt.ads26
-rw-r--r--gcc/ada/s-strcom.adb140
-rw-r--r--gcc/ada/s-strcom.ads61
-rw-r--r--gcc/ada/s-strops.adb22
-rw-r--r--gcc/ada/s-strops.ads6
-rw-r--r--gcc/ada/s-strxdr.adb1811
-rw-r--r--gcc/ada/s-taasde.adb10
-rw-r--r--gcc/ada/s-taasde.ads5
-rw-r--r--gcc/ada/s-tadeca.adb5
-rw-r--r--gcc/ada/s-tadeca.ads5
-rw-r--r--gcc/ada/s-tadert.adb5
-rw-r--r--gcc/ada/s-tadert.ads5
-rw-r--r--gcc/ada/s-taenca.adb69
-rw-r--r--gcc/ada/s-taenca.ads4
-rw-r--r--gcc/ada/s-taprob.adb8
-rw-r--r--gcc/ada/s-taprob.ads28
-rw-r--r--gcc/ada/s-taprop.ads27
-rw-r--r--gcc/ada/s-tarest.adb22
-rw-r--r--gcc/ada/s-tarest.ads42
-rw-r--r--gcc/ada/s-tasdeb.adb563
-rw-r--r--gcc/ada/s-tasdeb.ads173
-rw-r--r--gcc/ada/s-tasinf.adb2
-rw-r--r--gcc/ada/s-tasinf.ads22
-rw-r--r--gcc/ada/s-tasini.adb70
-rw-r--r--gcc/ada/s-tasini.ads2
-rw-r--r--gcc/ada/s-taskin.adb21
-rw-r--r--gcc/ada/s-taskin.ads55
-rw-r--r--gcc/ada/s-tasque.adb21
-rw-r--r--gcc/ada/s-tasque.ads4
-rw-r--r--gcc/ada/s-tasren.adb129
-rw-r--r--gcc/ada/s-tasren.ads2
-rw-r--r--gcc/ada/s-tasres.ads2
-rw-r--r--gcc/ada/s-tassta.adb304
-rw-r--r--gcc/ada/s-tassta.ads51
-rw-r--r--gcc/ada/s-tasuti.adb29
-rw-r--r--gcc/ada/s-tasuti.ads4
-rw-r--r--gcc/ada/s-tataat.adb23
-rw-r--r--gcc/ada/s-tataat.ads12
-rw-r--r--gcc/ada/s-thread.adb101
-rw-r--r--gcc/ada/s-thread.ads93
-rw-r--r--gcc/ada/s-tpae65.adb87
-rw-r--r--gcc/ada/s-tpae65.ads (renamed from gcc/ada/5qosinte.adb)36
-rw-r--r--gcc/ada/s-tpinop.adb2
-rw-r--r--gcc/ada/s-tpinop.ads2
-rw-r--r--gcc/ada/s-tpoben.adb4
-rw-r--r--gcc/ada/s-tpoben.ads8
-rw-r--r--gcc/ada/s-tpobop.adb16
-rw-r--r--gcc/ada/s-tpobop.ads2
-rw-r--r--gcc/ada/s-tporft.adb104
-rw-r--r--gcc/ada/s-tposen.adb11
-rw-r--r--gcc/ada/s-tposen.ads37
-rw-r--r--gcc/ada/s-traceb.adb32
-rw-r--r--gcc/ada/s-traceb.ads11
-rw-r--r--gcc/ada/s-traent.adb59
-rw-r--r--gcc/ada/s-traent.ads62
-rw-r--r--gcc/ada/s-unstyp.ads5
-rw-r--r--gcc/ada/s-vaflop.ads2
-rw-r--r--gcc/ada/s-valrea.adb78
-rw-r--r--gcc/ada/s-valuti.adb4
-rw-r--r--gcc/ada/s-veboop.adb121
-rw-r--r--gcc/ada/s-veboop.ads68
-rw-r--r--gcc/ada/s-vector.ads51
-rw-r--r--gcc/ada/s-vercon.adb5
-rw-r--r--gcc/ada/s-vmexta.adb20
-rw-r--r--gcc/ada/s-wchcnv.ads5
-rw-r--r--gcc/ada/s-wchcon.ads5
-rw-r--r--gcc/ada/s-widcha.adb4
-rw-r--r--gcc/ada/s-wwdcha.adb4
-rw-r--r--gcc/ada/s-wwdwch.adb5
-rw-r--r--gcc/ada/scans.ads32
-rw-r--r--gcc/ada/scn-nlit.adb369
-rw-r--r--gcc/ada/scn-slit.adb371
-rw-r--r--gcc/ada/scn.adb1359
-rw-r--r--gcc/ada/scn.ads48
-rw-r--r--gcc/ada/scng.adb2175
-rw-r--r--gcc/ada/scng.ads102
-rw-r--r--gcc/ada/sem.adb330
-rw-r--r--gcc/ada/sem.ads233
-rw-r--r--gcc/ada/sem_aggr.adb178
-rw-r--r--gcc/ada/sem_attr.adb1160
-rw-r--r--gcc/ada/sem_attr.ads11
-rw-r--r--gcc/ada/sem_case.adb275
-rw-r--r--gcc/ada/sem_case.ads20
-rw-r--r--gcc/ada/sem_cat.adb187
-rw-r--r--gcc/ada/sem_cat.ads16
-rw-r--r--gcc/ada/sem_ch10.adb946
-rw-r--r--gcc/ada/sem_ch11.adb129
-rw-r--r--gcc/ada/sem_ch12.adb1175
-rw-r--r--gcc/ada/sem_ch12.ads27
-rw-r--r--gcc/ada/sem_ch13.adb565
-rw-r--r--gcc/ada/sem_ch13.ads13
-rw-r--r--gcc/ada/sem_ch3.adb1647
-rw-r--r--gcc/ada/sem_ch3.ads37
-rw-r--r--gcc/ada/sem_ch4.adb421
-rw-r--r--gcc/ada/sem_ch5.adb446
-rw-r--r--gcc/ada/sem_ch5.ads2
-rw-r--r--gcc/ada/sem_ch6.adb962
-rw-r--r--gcc/ada/sem_ch6.ads39
-rw-r--r--gcc/ada/sem_ch7.adb492
-rw-r--r--gcc/ada/sem_ch7.ads12
-rw-r--r--gcc/ada/sem_ch8.adb715
-rw-r--r--gcc/ada/sem_ch8.ads47
-rw-r--r--gcc/ada/sem_ch9.adb298
-rw-r--r--gcc/ada/sem_disp.adb97
-rw-r--r--gcc/ada/sem_disp.ads4
-rw-r--r--gcc/ada/sem_dist.adb30
-rw-r--r--gcc/ada/sem_elab.adb220
-rw-r--r--gcc/ada/sem_eval.adb649
-rw-r--r--gcc/ada/sem_eval.ads67
-rw-r--r--gcc/ada/sem_intr.adb9
-rw-r--r--gcc/ada/sem_maps.adb4
-rw-r--r--gcc/ada/sem_mech.adb25
-rw-r--r--gcc/ada/sem_prag.adb1887
-rw-r--r--gcc/ada/sem_prag.ads20
-rw-r--r--gcc/ada/sem_res.adb1013
-rw-r--r--gcc/ada/sem_res.ads17
-rw-r--r--gcc/ada/sem_type.adb512
-rw-r--r--gcc/ada/sem_type.ads54
-rw-r--r--gcc/ada/sem_util.adb1214
-rw-r--r--gcc/ada/sem_util.ads189
-rw-r--r--gcc/ada/sem_warn.adb681
-rw-r--r--gcc/ada/sfn_scan.adb26
-rw-r--r--gcc/ada/sinfo.adb210
-rw-r--r--gcc/ada/sinfo.ads251
-rw-r--r--gcc/ada/sinfo.h38
-rw-r--r--gcc/ada/sinput-c.adb200
-rw-r--r--gcc/ada/sinput-c.ads39
-rw-r--r--gcc/ada/sinput-d.adb18
-rw-r--r--gcc/ada/sinput-l.adb311
-rw-r--r--gcc/ada/sinput-l.ads26
-rw-r--r--gcc/ada/sinput-p.adb183
-rw-r--r--gcc/ada/sinput-p.ads11
-rw-r--r--gcc/ada/sinput.adb57
-rw-r--r--gcc/ada/sinput.ads138
-rw-r--r--gcc/ada/snames.adb83
-rw-r--r--gcc/ada/snames.ads1263
-rw-r--r--gcc/ada/snames.h409
-rw-r--r--gcc/ada/socket.c181
-rw-r--r--gcc/ada/sprint.adb60
-rw-r--r--gcc/ada/stringt.adb8
-rw-r--r--gcc/ada/stringt.ads3
-rw-r--r--gcc/ada/stringt.h1
-rw-r--r--gcc/ada/style.ads117
-rw-r--r--gcc/ada/styleg-c.adb225
-rw-r--r--gcc/ada/styleg-c.ads54
-rw-r--r--gcc/ada/styleg.adb (renamed from gcc/ada/style.adb)424
-rw-r--r--gcc/ada/styleg.ads159
-rw-r--r--gcc/ada/stylesw.adb15
-rw-r--r--gcc/ada/stylesw.ads15
-rw-r--r--gcc/ada/switch-b.adb48
-rw-r--r--gcc/ada/switch-c.adb380
-rw-r--r--gcc/ada/switch-m.adb127
-rw-r--r--gcc/ada/switch.adb10
-rw-r--r--gcc/ada/switch.ads4
-rw-r--r--gcc/ada/symbols.adb79
-rw-r--r--gcc/ada/symbols.ads84
-rw-r--r--gcc/ada/sysdep.c75
-rw-r--r--gcc/ada/system.ads22
-rw-r--r--gcc/ada/table.adb54
-rw-r--r--gcc/ada/table.ads17
-rw-r--r--gcc/ada/targparm.adb533
-rw-r--r--gcc/ada/targparm.ads397
-rw-r--r--gcc/ada/targtyps.c3
-rw-r--r--gcc/ada/tb-alvms.c263
-rw-r--r--gcc/ada/tb-alvxw.c965
-rw-r--r--gcc/ada/tbuild.adb30
-rw-r--r--gcc/ada/tbuild.ads18
-rw-r--r--gcc/ada/tempdir.adb123
-rw-r--r--gcc/ada/tempdir.ads47
-rw-r--r--gcc/ada/tracebak.c1225
-rw-r--r--gcc/ada/trans.c1064
-rw-r--r--gcc/ada/tree_io.adb3
-rw-r--r--gcc/ada/treepr.adb12
-rw-r--r--gcc/ada/treeprs.ads457
-rw-r--r--gcc/ada/treeprs.adt3
-rw-r--r--gcc/ada/ttypes.ads6
-rw-r--r--gcc/ada/types.ads71
-rw-r--r--gcc/ada/types.h17
-rw-r--r--gcc/ada/uintp.adb129
-rw-r--r--gcc/ada/uintp.ads10
-rw-r--r--gcc/ada/uintp.h11
-rw-r--r--gcc/ada/uname.adb6
-rw-r--r--gcc/ada/urealp.adb70
-rw-r--r--gcc/ada/urealp.ads14
-rw-r--r--gcc/ada/urealp.h16
-rw-r--r--gcc/ada/usage.adb100
-rw-r--r--gcc/ada/utils.c405
-rw-r--r--gcc/ada/utils2.c157
-rw-r--r--gcc/ada/validsw.adb12
-rw-r--r--gcc/ada/validsw.ads16
-rw-r--r--gcc/ada/vms_conv.adb1998
-rw-r--r--gcc/ada/vms_conv.ads296
-rw-r--r--gcc/ada/vms_data.ads4991
-rw-r--r--gcc/ada/vxaddr2line.adb456
-rw-r--r--gcc/ada/widechar.adb3
-rw-r--r--gcc/ada/xeinfo.adb13
-rw-r--r--gcc/ada/xnmake.adb7
-rw-r--r--gcc/ada/xr_tabls.adb1702
-rw-r--r--gcc/ada/xr_tabls.ads258
-rw-r--r--gcc/ada/xref_lib.adb1026
-rw-r--r--gcc/ada/xref_lib.ads75
-rw-r--r--gcc/ada/xsnames.adb9
-rw-r--r--gcc/ada/xtreeprs.adb2
987 files changed, 134279 insertions, 54496 deletions
diff --git a/gcc/ada/1ic.ads b/gcc/ada/1ic.ads
index e6caea3a6b1..bc1b7eb34ef 100644
--- a/gcc/ada/1ic.ads
+++ b/gcc/ada/1ic.ads
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
diff --git a/gcc/ada/31soccon.ads b/gcc/ada/31soccon.ads
index 05021803b30..9f7065f6ffe 100644
--- a/gcc/ada/31soccon.ads
+++ b/gcc/ada/31soccon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-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- --
@@ -26,88 +26,133 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+-- This package provides target dependent definitions of constant for use
+-- by the GNAT.Sockets package (g-socket.ads). This package should not be
+-- directly with'ed by an applications program.
+
-- This is the version for UnixWare
package GNAT.Sockets.Constants is
- -- Families
-
- AF_INET : constant := 2;
- AF_INET6 : constant := 27;
-
- -- Modes
-
- SOCK_STREAM : constant := 2;
- SOCK_DGRAM : constant := 1;
-
- -- Socket Errors
-
- EBADF : constant := 9;
- ENOTSOCK : constant := 95;
- ENOTCONN : constant := 134;
- ENOBUFS : constant := 132;
- EOPNOTSUPP : constant := 122;
- EFAULT : constant := 14;
- EWOULDBLOCK : constant := 11;
- EADDRNOTAVAIL : constant := 126;
- EMSGSIZE : constant := 97;
- EADDRINUSE : constant := 125;
- EINVAL : constant := 22;
- EACCES : constant := 13;
- EAFNOSUPPORT : constant := 124;
- EISCONN : constant := 133;
- ETIMEDOUT : constant := 145;
- ECONNREFUSED : constant := 146;
- ENETUNREACH : constant := 128;
- EALREADY : constant := 149;
- EINPROGRESS : constant := 150;
- ENOPROTOOPT : constant := 99;
- EPROTONOSUPPORT : constant := 120;
- EINTR : constant := 4;
- EIO : constant := 5;
- ESOCKTNOSUPPORT : constant := 121;
-
- -- Host Errors
-
- HOST_NOT_FOUND : constant := 1;
- TRY_AGAIN : constant := 2;
- NO_ADDRESS : constant := 4;
- NO_RECOVERY : constant := 3;
-
- -- Control Flags
-
- FIONBIO : constant := -2147195266;
- FIONREAD : constant := 1074030207;
-
- -- Shutdown Modes
-
- SHUT_RD : constant := 0;
- SHUT_WR : constant := 1;
- SHUT_RDWR : constant := 2;
-
- -- Protocol Levels
-
- SOL_SOCKET : constant := 65535;
- IPPROTO_IP : constant := 0;
- IPPROTO_UDP : constant := 17;
- IPPROTO_TCP : constant := 6;
-
- -- Socket Options
-
- TCP_NODELAY : constant := 1;
- SO_SNDBUF : constant := 4097;
- SO_RCVBUF : constant := 4098;
- SO_REUSEADDR : constant := 4;
- SO_KEEPALIVE : constant := 8;
- SO_LINGER : constant := 128;
- SO_ERROR : constant := 4103;
- SO_BROADCAST : constant := 32;
- IP_ADD_MEMBERSHIP : constant := 11;
- IP_DROP_MEMBERSHIP : constant := 12;
- IP_MULTICAST_TTL : constant := 16;
- IP_MULTICAST_LOOP : constant := 10;
+ --------------
+ -- Families --
+ --------------
+
+ AF_INET : constant := 2; -- IPv4 address family
+ AF_INET6 : constant := 27; -- IPv6 address family
+
+ -----------
+ -- Modes --
+ -----------
+
+ SOCK_STREAM : constant := 2; -- Stream socket
+ SOCK_DGRAM : constant := 1; -- Datagram socket
+
+ -------------------
+ -- Socket errors --
+ -------------------
+
+ EACCES : constant := 13; -- Permission denied
+ EADDRINUSE : constant := 125; -- Address already in use
+ EADDRNOTAVAIL : constant := 126; -- Cannot assign address
+ EAFNOSUPPORT : constant := 124; -- Addr family not supported
+ EALREADY : constant := 149; -- Operation in progress
+ EBADF : constant := 9; -- Bad file descriptor
+ ECONNABORTED : constant := 130; -- Connection aborted
+ ECONNREFUSED : constant := 146; -- Connection refused
+ ECONNRESET : constant := 131; -- Connection reset by peer
+ EDESTADDRREQ : constant := 96; -- Destination addr required
+ EFAULT : constant := 14; -- Bad address
+ EHOSTDOWN : constant := 147; -- Host is down
+ EHOSTUNREACH : constant := 148; -- No route to host
+ EINPROGRESS : constant := 150; -- Operation now in progress
+ EINTR : constant := 4; -- Interrupted system call
+ EINVAL : constant := 22; -- Invalid argument
+ EIO : constant := 5; -- Input output error
+ EISCONN : constant := 133; -- Socket already connected
+ ELOOP : constant := 90; -- Too many symbolic lynks
+ EMFILE : constant := 24; -- Too many open files
+ EMSGSIZE : constant := 97; -- Message too long
+ ENAMETOOLONG : constant := 78; -- Name too long
+ ENETDOWN : constant := 127; -- Network is down
+ ENETRESET : constant := 129; -- Disconn. on network reset
+ ENETUNREACH : constant := 128; -- Network is unreachable
+ ENOBUFS : constant := 132; -- No buffer space available
+ ENOPROTOOPT : constant := 99; -- Protocol not available
+ ENOTCONN : constant := 134; -- Socket not connected
+ ENOTSOCK : constant := 95; -- Operation on non socket
+ EOPNOTSUPP : constant := 122; -- Operation not supported
+ EPFNOSUPPORT : constant := 123; -- Unknown protocol family
+ EPROTONOSUPPORT : constant := 120; -- Unknown protocol
+ EPROTOTYPE : constant := 98; -- Unknown protocol type
+ ESHUTDOWN : constant := 143; -- Cannot send once shutdown
+ ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported
+ ETIMEDOUT : constant := 145; -- Connection timed out
+ ETOOMANYREFS : constant := 144; -- Too many references
+ EWOULDBLOCK : constant := 11; -- Operation would block
+
+ -----------------
+ -- Host errors --
+ -----------------
+
+ HOST_NOT_FOUND : constant := 1; -- Unknown host
+ TRY_AGAIN : constant := 2; -- Host name lookup failure
+ NO_DATA : constant := 4; -- No data record for name
+ NO_RECOVERY : constant := 3; -- Non recoverable errors
+
+ -------------------
+ -- Control flags --
+ -------------------
+
+ FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
+ FIONREAD : constant := 1074030207; -- How many bytes to read
+
+ --------------------
+ -- Shutdown modes --
+ --------------------
+
+ SHUT_RD : constant := 0; -- No more recv
+ SHUT_WR : constant := 1; -- No more send
+ SHUT_RDWR : constant := 2; -- No more recv/send
+
+ ---------------------
+ -- Protocol levels --
+ ---------------------
+
+ SOL_SOCKET : constant := 65535; -- Options for socket level
+ IPPROTO_IP : constant := 0; -- Dummy protocol for IP
+ IPPROTO_UDP : constant := 17; -- UDP
+ IPPROTO_TCP : constant := 6; -- TCP
+
+ -------------------
+ -- Request flags --
+ -------------------
+
+ MSG_OOB : constant := 1; -- Process out-of-band data
+ MSG_PEEK : constant := 2; -- Peek at incoming data
+ MSG_EOR : constant := 8; -- Send end of record
+ MSG_WAITALL : constant := 64; -- Wait for full reception
+
+ --------------------
+ -- Socket options --
+ --------------------
+
+ TCP_NODELAY : constant := 1; -- Do not coalesce packets
+ SO_SNDBUF : constant := 4097; -- Set/get send buffer size
+ SO_RCVBUF : constant := 4098; -- Set/get recv buffer size
+ SO_REUSEADDR : constant := 4; -- Bind reuse local address
+ SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs
+ SO_LINGER : constant := 128; -- Defer close to flush data
+ SO_ERROR : constant := 4103; -- Get/clear error status
+ SO_BROADCAST : constant := 32; -- Can send broadcast msgs
+ IP_ADD_MEMBERSHIP : constant := 11; -- Join a multicast group
+ IP_DROP_MEMBERSHIP : constant := 12; -- Leave a multicast group
+ IP_MULTICAST_TTL : constant := 16; -- Set/get multicast TTL
+ IP_MULTICAST_LOOP : constant := 10; -- Set/get mcast loopback
+
end GNAT.Sockets.Constants;
diff --git a/gcc/ada/31soliop.ads b/gcc/ada/31soliop.ads
index aa928b71511..754cafd6a1e 100644
--- a/gcc/ada/31soliop.ads
+++ b/gcc/ada/31soliop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,17 +26,18 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-package GNAT.Sockets.Linker_Options is
+-- This package is used to provide target specific linker_options for the
+-- support of scokets as required by the package GNAT.Sockets.
- -- This is the UnixWare version of this package.
+-- This is the UnixWare version of this package
+package GNAT.Sockets.Linker_Options is
private
-
pragma Linker_Options ("-lnsl");
pragma Linker_Options ("-lsocket");
-
end GNAT.Sockets.Linker_Options;
diff --git a/gcc/ada/3asoccon.ads b/gcc/ada/3asoccon.ads
index 0703268d164..ef3536e4bbc 100644
--- a/gcc/ada/3asoccon.ads
+++ b/gcc/ada/3asoccon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-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- --
@@ -26,88 +26,133 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+-- This package provides target dependent definitions of constant for use
+-- by the GNAT.Sockets package (g-socket.ads). This package should not be
+-- directly with'ed by an applications program.
+
-- This is the version for OSF
package GNAT.Sockets.Constants is
- -- Families
-
- AF_INET : constant := 2;
- AF_INET6 : constant := 26;
-
- -- Modes
-
- SOCK_STREAM : constant := 1;
- SOCK_DGRAM : constant := 2;
-
- -- Socket Errors
-
- EBADF : constant := 9;
- ENOTSOCK : constant := 38;
- ENOTCONN : constant := 57;
- ENOBUFS : constant := 55;
- EOPNOTSUPP : constant := 45;
- EFAULT : constant := 14;
- EWOULDBLOCK : constant := 35;
- EADDRNOTAVAIL : constant := 49;
- EMSGSIZE : constant := 40;
- EADDRINUSE : constant := 48;
- EINVAL : constant := 22;
- EACCES : constant := 13;
- EAFNOSUPPORT : constant := 47;
- EISCONN : constant := 56;
- ETIMEDOUT : constant := 60;
- ECONNREFUSED : constant := 61;
- ENETUNREACH : constant := 51;
- EALREADY : constant := 37;
- EINPROGRESS : constant := 36;
- ENOPROTOOPT : constant := 42;
- EPROTONOSUPPORT : constant := 43;
- EINTR : constant := 4;
- EIO : constant := 5;
- ESOCKTNOSUPPORT : constant := 44;
-
- -- Host Errors
-
- HOST_NOT_FOUND : constant := 1;
- TRY_AGAIN : constant := 2;
- NO_ADDRESS : constant := 4;
- NO_RECOVERY : constant := 3;
-
- -- Control Flags
-
- FIONBIO : constant := -2147195266;
- FIONREAD : constant := 1074030207;
-
- -- Shutdown Modes
-
- SHUT_RD : constant := 0;
- SHUT_WR : constant := 1;
- SHUT_RDWR : constant := 2;
-
- -- Protocol Levels
-
- SOL_SOCKET : constant := 65535;
- IPPROTO_IP : constant := 0;
- IPPROTO_UDP : constant := 17;
- IPPROTO_TCP : constant := 6;
-
- -- Socket Options
-
- TCP_NODELAY : constant := 1;
- SO_SNDBUF : constant := 4097;
- SO_RCVBUF : constant := 4098;
- SO_REUSEADDR : constant := 4;
- SO_KEEPALIVE : constant := 8;
- SO_LINGER : constant := 128;
- SO_ERROR : constant := 4103;
- SO_BROADCAST : constant := 32;
- IP_ADD_MEMBERSHIP : constant := 12;
- IP_DROP_MEMBERSHIP : constant := 13;
- IP_MULTICAST_TTL : constant := 10;
- IP_MULTICAST_LOOP : constant := 11;
+ --------------
+ -- Families --
+ --------------
+
+ AF_INET : constant := 2; -- IPv4 address family
+ AF_INET6 : constant := 26; -- IPv6 address family
+
+ -----------
+ -- Modes --
+ -----------
+
+ SOCK_STREAM : constant := 1; -- Stream socket
+ SOCK_DGRAM : constant := 2; -- Datagram socket
+
+ -------------------
+ -- Socket errors --
+ -------------------
+
+ EACCES : constant := 13; -- Permission denied
+ EADDRINUSE : constant := 48; -- Address already in use
+ EADDRNOTAVAIL : constant := 49; -- Cannot assign address
+ EAFNOSUPPORT : constant := 47; -- Addr family not supported
+ EALREADY : constant := 37; -- Operation in progress
+ EBADF : constant := 9; -- Bad file descriptor
+ ECONNABORTED : constant := 53; -- Connection aborted
+ ECONNREFUSED : constant := 61; -- Connection refused
+ ECONNRESET : constant := 54; -- Connection reset by peer
+ EDESTADDRREQ : constant := 39; -- Destination addr required
+ EFAULT : constant := 14; -- Bad address
+ EHOSTDOWN : constant := 64; -- Host is down
+ EHOSTUNREACH : constant := 65; -- No route to host
+ EINPROGRESS : constant := 36; -- Operation now in progress
+ EINTR : constant := 4; -- Interrupted system call
+ EINVAL : constant := 22; -- Invalid argument
+ EIO : constant := 5; -- Input output error
+ EISCONN : constant := 56; -- Socket already connected
+ ELOOP : constant := 62; -- Too many symbolic lynks
+ EMFILE : constant := 24; -- Too many open files
+ EMSGSIZE : constant := 40; -- Message too long
+ ENAMETOOLONG : constant := 63; -- Name too long
+ ENETDOWN : constant := 50; -- Network is down
+ ENETRESET : constant := 52; -- Disconn. on network reset
+ ENETUNREACH : constant := 51; -- Network is unreachable
+ ENOBUFS : constant := 55; -- No buffer space available
+ ENOPROTOOPT : constant := 42; -- Protocol not available
+ ENOTCONN : constant := 57; -- Socket not connected
+ ENOTSOCK : constant := 38; -- Operation on non socket
+ EOPNOTSUPP : constant := 45; -- Operation not supported
+ EPFNOSUPPORT : constant := 46; -- Unknown protocol family
+ EPROTONOSUPPORT : constant := 43; -- Unknown protocol
+ EPROTOTYPE : constant := 41; -- Unknown protocol type
+ ESHUTDOWN : constant := 58; -- Cannot send once shutdown
+ ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported
+ ETIMEDOUT : constant := 60; -- Connection timed out
+ ETOOMANYREFS : constant := 59; -- Too many references
+ EWOULDBLOCK : constant := 35; -- Operation would block
+
+ -----------------
+ -- Host errors --
+ -----------------
+
+ HOST_NOT_FOUND : constant := 1; -- Unknown host
+ TRY_AGAIN : constant := 2; -- Host name lookup failure
+ NO_DATA : constant := 4; -- No data record for name
+ NO_RECOVERY : constant := 3; -- Non recoverable errors
+
+ -------------------
+ -- Control flags --
+ -------------------
+
+ FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
+ FIONREAD : constant := 1074030207; -- How many bytes to read
+
+ --------------------
+ -- Shutdown modes --
+ --------------------
+
+ SHUT_RD : constant := 0; -- No more recv
+ SHUT_WR : constant := 1; -- No more send
+ SHUT_RDWR : constant := 2; -- No more recv/send
+
+ ---------------------
+ -- Protocol levels --
+ ---------------------
+
+ SOL_SOCKET : constant := 65535; -- Options for socket level
+ IPPROTO_IP : constant := 0; -- Dummy protocol for IP
+ IPPROTO_UDP : constant := 17; -- UDP
+ IPPROTO_TCP : constant := 6; -- TCP
+
+ -------------------
+ -- Request flags --
+ -------------------
+
+ MSG_OOB : constant := 1; -- Process out-of-band data
+ MSG_PEEK : constant := 2; -- Peek at incoming data
+ MSG_EOR : constant := 8; -- Send end of record
+ MSG_WAITALL : constant := 64; -- Wait for full reception
+
+ --------------------
+ -- Socket options --
+ --------------------
+
+ TCP_NODELAY : constant := 1; -- Do not coalesce packets
+ SO_SNDBUF : constant := 4097; -- Set/get send buffer size
+ SO_RCVBUF : constant := 4098; -- Set/get recv buffer size
+ SO_REUSEADDR : constant := 4; -- Bind reuse local address
+ SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs
+ SO_LINGER : constant := 128; -- Defer close to flush data
+ SO_ERROR : constant := 4103; -- Get/clear error status
+ SO_BROADCAST : constant := 32; -- Can send broadcast msgs
+ IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group
+ IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group
+ IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL
+ IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback
+
end GNAT.Sockets.Constants;
diff --git a/gcc/ada/3bsoccon.ads b/gcc/ada/3bsoccon.ads
index 4044c0134a5..0f5fe9d4c6b 100644
--- a/gcc/ada/3bsoccon.ads
+++ b/gcc/ada/3bsoccon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-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- --
@@ -26,88 +26,133 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+-- This package provides target dependent definitions of constant for use
+-- by the GNAT.Sockets package (g-socket.ads). This package should not be
+-- directly with'ed by an applications program.
+
-- This is the version for AIX
package GNAT.Sockets.Constants is
- -- Families
-
- AF_INET : constant := 2;
- AF_INET6 : constant := 24;
-
- -- Modes
-
- SOCK_STREAM : constant := 1;
- SOCK_DGRAM : constant := 2;
-
- -- Socket Errors
-
- EBADF : constant := 9;
- ENOTSOCK : constant := 57;
- ENOTCONN : constant := 76;
- ENOBUFS : constant := 74;
- EOPNOTSUPP : constant := 64;
- EFAULT : constant := 14;
- EWOULDBLOCK : constant := 11;
- EADDRNOTAVAIL : constant := 68;
- EMSGSIZE : constant := 59;
- EADDRINUSE : constant := 67;
- EINVAL : constant := 22;
- EACCES : constant := 13;
- EAFNOSUPPORT : constant := 66;
- EISCONN : constant := 75;
- ETIMEDOUT : constant := 78;
- ECONNREFUSED : constant := 79;
- ENETUNREACH : constant := 70;
- EALREADY : constant := 56;
- EINPROGRESS : constant := 55;
- ENOPROTOOPT : constant := 61;
- EPROTONOSUPPORT : constant := 62;
- EINTR : constant := 4;
- EIO : constant := 5;
- ESOCKTNOSUPPORT : constant := 63;
-
- -- Host Errors
-
- HOST_NOT_FOUND : constant := 1;
- TRY_AGAIN : constant := 2;
- NO_ADDRESS : constant := 4;
- NO_RECOVERY : constant := 3;
-
- -- Control Flags
-
- FIONBIO : constant := -2147195266;
- FIONREAD : constant := 1074030207;
-
- -- Shutdown Modes
-
- SHUT_RD : constant := 0;
- SHUT_WR : constant := 1;
- SHUT_RDWR : constant := 2;
-
- -- Protocol Levels
-
- SOL_SOCKET : constant := 65535;
- IPPROTO_IP : constant := 0;
- IPPROTO_UDP : constant := 17;
- IPPROTO_TCP : constant := 6;
-
- -- Socket Options
-
- TCP_NODELAY : constant := 1;
- SO_SNDBUF : constant := 4097;
- SO_RCVBUF : constant := 4098;
- SO_REUSEADDR : constant := 4;
- SO_KEEPALIVE : constant := 8;
- SO_LINGER : constant := 128;
- SO_ERROR : constant := 4103;
- SO_BROADCAST : constant := 32;
- IP_ADD_MEMBERSHIP : constant := 12;
- IP_DROP_MEMBERSHIP : constant := 13;
- IP_MULTICAST_TTL : constant := 10;
- IP_MULTICAST_LOOP : constant := 11;
+ --------------
+ -- Families --
+ --------------
+
+ AF_INET : constant := 2; -- IPv4 address family
+ AF_INET6 : constant := 24; -- IPv6 address family
+
+ -----------
+ -- Modes --
+ -----------
+
+ SOCK_STREAM : constant := 1; -- Stream socket
+ SOCK_DGRAM : constant := 2; -- Datagram socket
+
+ -------------------
+ -- Socket errors --
+ -------------------
+
+ EACCES : constant := 13; -- Permission denied
+ EADDRINUSE : constant := 67; -- Address already in use
+ EADDRNOTAVAIL : constant := 68; -- Cannot assign address
+ EAFNOSUPPORT : constant := 66; -- Addr family not supported
+ EALREADY : constant := 56; -- Operation in progress
+ EBADF : constant := 9; -- Bad file descriptor
+ ECONNABORTED : constant := 72; -- Connection aborted
+ ECONNREFUSED : constant := 79; -- Connection refused
+ ECONNRESET : constant := 73; -- Connection reset by peer
+ EDESTADDRREQ : constant := 58; -- Destination addr required
+ EFAULT : constant := 14; -- Bad address
+ EHOSTDOWN : constant := 80; -- Host is down
+ EHOSTUNREACH : constant := 81; -- No route to host
+ EINPROGRESS : constant := 55; -- Operation now in progress
+ EINTR : constant := 4; -- Interrupted system call
+ EINVAL : constant := 22; -- Invalid argument
+ EIO : constant := 5; -- Input output error
+ EISCONN : constant := 75; -- Socket already connected
+ ELOOP : constant := 85; -- Too many symbolic lynks
+ EMFILE : constant := 24; -- Too many open files
+ EMSGSIZE : constant := 59; -- Message too long
+ ENAMETOOLONG : constant := 86; -- Name too long
+ ENETDOWN : constant := 69; -- Network is down
+ ENETRESET : constant := 71; -- Disconn. on network reset
+ ENETUNREACH : constant := 70; -- Network is unreachable
+ ENOBUFS : constant := 74; -- No buffer space available
+ ENOPROTOOPT : constant := 61; -- Protocol not available
+ ENOTCONN : constant := 76; -- Socket not connected
+ ENOTSOCK : constant := 57; -- Operation on non socket
+ EOPNOTSUPP : constant := 64; -- Operation not supported
+ EPFNOSUPPORT : constant := 65; -- Unknown protocol family
+ EPROTONOSUPPORT : constant := 62; -- Unknown protocol
+ EPROTOTYPE : constant := 60; -- Unknown protocol type
+ ESHUTDOWN : constant := 77; -- Cannot send once shutdown
+ ESOCKTNOSUPPORT : constant := 63; -- Socket type not supported
+ ETIMEDOUT : constant := 78; -- Connection timed out
+ ETOOMANYREFS : constant := 115; -- Too many references
+ EWOULDBLOCK : constant := 11; -- Operation would block
+
+ -----------------
+ -- Host errors --
+ -----------------
+
+ HOST_NOT_FOUND : constant := 1; -- Unknown host
+ TRY_AGAIN : constant := 2; -- Host name lookup failure
+ NO_DATA : constant := 4; -- No data record for name
+ NO_RECOVERY : constant := 3; -- Non recoverable errors
+
+ -------------------
+ -- Control flags --
+ -------------------
+
+ FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
+ FIONREAD : constant := 1074030207; -- How many bytes to read
+
+ --------------------
+ -- Shutdown modes --
+ --------------------
+
+ SHUT_RD : constant := 0; -- No more recv
+ SHUT_WR : constant := 1; -- No more send
+ SHUT_RDWR : constant := 2; -- No more recv/send
+
+ ---------------------
+ -- Protocol levels --
+ ---------------------
+
+ SOL_SOCKET : constant := 65535; -- Options for socket level
+ IPPROTO_IP : constant := 0; -- Dummy protocol for IP
+ IPPROTO_UDP : constant := 17; -- UDP
+ IPPROTO_TCP : constant := 6; -- TCP
+
+ -------------------
+ -- Request flags --
+ -------------------
+
+ MSG_OOB : constant := 1; -- Process out-of-band data
+ MSG_PEEK : constant := 2; -- Peek at incoming data
+ MSG_EOR : constant := 8; -- Send end of record
+ MSG_WAITALL : constant := 64; -- Wait for full reception
+
+ --------------------
+ -- Socket options --
+ --------------------
+
+ TCP_NODELAY : constant := 1; -- Do not coalesce packets
+ SO_SNDBUF : constant := 4097; -- Set/get send buffer size
+ SO_RCVBUF : constant := 4098; -- Set/get recv buffer size
+ SO_REUSEADDR : constant := 4; -- Bind reuse local address
+ SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs
+ SO_LINGER : constant := 128; -- Defer close to flush data
+ SO_ERROR : constant := 4103; -- Get/clear error status
+ SO_BROADCAST : constant := 32; -- Can send broadcast msgs
+ IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group
+ IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group
+ IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL
+ IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback
+
end GNAT.Sockets.Constants;
diff --git a/gcc/ada/3gsoccon.ads b/gcc/ada/3gsoccon.ads
index 6bfacf70f1e..f19f3cde5f6 100644
--- a/gcc/ada/3gsoccon.ads
+++ b/gcc/ada/3gsoccon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-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- --
@@ -26,88 +26,133 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+-- This package provides target dependent definitions of constant for use
+-- by the GNAT.Sockets package (g-socket.ads). This package should not be
+-- directly with'ed by an applications program.
+
-- This is the version for SGI
package GNAT.Sockets.Constants is
- -- Families
-
- AF_INET : constant := 2;
- AF_INET6 : constant := 24;
-
- -- Modes
-
- SOCK_STREAM : constant := 2;
- SOCK_DGRAM : constant := 1;
-
- -- Socket Errors
-
- EBADF : constant := 9;
- ENOTSOCK : constant := 95;
- ENOTCONN : constant := 134;
- ENOBUFS : constant := 132;
- EOPNOTSUPP : constant := 122;
- EFAULT : constant := 14;
- EWOULDBLOCK : constant := 11;
- EADDRNOTAVAIL : constant := 126;
- EMSGSIZE : constant := 97;
- EADDRINUSE : constant := 125;
- EINVAL : constant := 22;
- EACCES : constant := 13;
- EAFNOSUPPORT : constant := 124;
- EISCONN : constant := 133;
- ETIMEDOUT : constant := 145;
- ECONNREFUSED : constant := 146;
- ENETUNREACH : constant := 128;
- EALREADY : constant := 149;
- EINPROGRESS : constant := 150;
- ENOPROTOOPT : constant := 99;
- EPROTONOSUPPORT : constant := 120;
- EINTR : constant := 4;
- EIO : constant := 5;
- ESOCKTNOSUPPORT : constant := 121;
-
- -- Host Errors
-
- HOST_NOT_FOUND : constant := 1;
- TRY_AGAIN : constant := 2;
- NO_ADDRESS : constant := 4;
- NO_RECOVERY : constant := 3;
-
- -- Control Flags
-
- FIONBIO : constant := -2147195266;
- FIONREAD : constant := 1074030207;
-
- -- Shutdown Modes
-
- SHUT_RD : constant := 0;
- SHUT_WR : constant := 1;
- SHUT_RDWR : constant := 2;
-
- -- Protocol Levels
-
- SOL_SOCKET : constant := 65535;
- IPPROTO_IP : constant := 0;
- IPPROTO_UDP : constant := 17;
- IPPROTO_TCP : constant := 6;
-
- -- Socket Options
-
- TCP_NODELAY : constant := 1;
- SO_SNDBUF : constant := 4097;
- SO_RCVBUF : constant := 4098;
- SO_REUSEADDR : constant := 4;
- SO_KEEPALIVE : constant := 8;
- SO_LINGER : constant := 128;
- SO_ERROR : constant := 4103;
- SO_BROADCAST : constant := 32;
- IP_ADD_MEMBERSHIP : constant := 23;
- IP_DROP_MEMBERSHIP : constant := 24;
- IP_MULTICAST_TTL : constant := 21;
- IP_MULTICAST_LOOP : constant := 22;
+ --------------
+ -- Families --
+ --------------
+
+ AF_INET : constant := 2; -- IPv4 address family
+ AF_INET6 : constant := 24; -- IPv6 address family
+
+ -----------
+ -- Modes --
+ -----------
+
+ SOCK_STREAM : constant := 2; -- Stream socket
+ SOCK_DGRAM : constant := 1; -- Datagram socket
+
+ -------------------
+ -- Socket errors --
+ -------------------
+
+ EACCES : constant := 13; -- Permission denied
+ EADDRINUSE : constant := 125; -- Address already in use
+ EADDRNOTAVAIL : constant := 126; -- Cannot assign address
+ EAFNOSUPPORT : constant := 124; -- Addr family not supported
+ EALREADY : constant := 149; -- Operation in progress
+ EBADF : constant := 9; -- Bad file descriptor
+ ECONNABORTED : constant := 130; -- Connection aborted
+ ECONNREFUSED : constant := 146; -- Connection refused
+ ECONNRESET : constant := 131; -- Connection reset by peer
+ EDESTADDRREQ : constant := 96; -- Destination addr required
+ EFAULT : constant := 14; -- Bad address
+ EHOSTDOWN : constant := 147; -- Host is down
+ EHOSTUNREACH : constant := 148; -- No route to host
+ EINPROGRESS : constant := 150; -- Operation now in progress
+ EINTR : constant := 4; -- Interrupted system call
+ EINVAL : constant := 22; -- Invalid argument
+ EIO : constant := 5; -- Input output error
+ EISCONN : constant := 133; -- Socket already connected
+ ELOOP : constant := 90; -- Too many symbolic lynks
+ EMFILE : constant := 24; -- Too many open files
+ EMSGSIZE : constant := 97; -- Message too long
+ ENAMETOOLONG : constant := 78; -- Name too long
+ ENETDOWN : constant := 127; -- Network is down
+ ENETRESET : constant := 129; -- Disconn. on network reset
+ ENETUNREACH : constant := 128; -- Network is unreachable
+ ENOBUFS : constant := 132; -- No buffer space available
+ ENOPROTOOPT : constant := 99; -- Protocol not available
+ ENOTCONN : constant := 134; -- Socket not connected
+ ENOTSOCK : constant := 95; -- Operation on non socket
+ EOPNOTSUPP : constant := 122; -- Operation not supported
+ EPFNOSUPPORT : constant := 123; -- Unknown protocol family
+ EPROTONOSUPPORT : constant := 120; -- Unknown protocol
+ EPROTOTYPE : constant := 98; -- Unknown protocol type
+ ESHUTDOWN : constant := 143; -- Cannot send once shutdown
+ ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported
+ ETIMEDOUT : constant := 145; -- Connection timed out
+ ETOOMANYREFS : constant := 144; -- Too many references
+ EWOULDBLOCK : constant := 11; -- Operation would block
+
+ -----------------
+ -- Host errors --
+ -----------------
+
+ HOST_NOT_FOUND : constant := 1; -- Unknown host
+ TRY_AGAIN : constant := 2; -- Host name lookup failure
+ NO_DATA : constant := 4; -- No data record for name
+ NO_RECOVERY : constant := 3; -- Non recoverable errors
+
+ -------------------
+ -- Control flags --
+ -------------------
+
+ FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
+ FIONREAD : constant := 1074030207; -- How many bytes to read
+
+ --------------------
+ -- Shutdown modes --
+ --------------------
+
+ SHUT_RD : constant := 0; -- No more recv
+ SHUT_WR : constant := 1; -- No more send
+ SHUT_RDWR : constant := 2; -- No more recv/send
+
+ ---------------------
+ -- Protocol levels --
+ ---------------------
+
+ SOL_SOCKET : constant := 65535; -- Options for socket level
+ IPPROTO_IP : constant := 0; -- Dummy protocol for IP
+ IPPROTO_UDP : constant := 17; -- UDP
+ IPPROTO_TCP : constant := 6; -- TCP
+
+ -------------------
+ -- Request flags --
+ -------------------
+
+ MSG_OOB : constant := 1; -- Process out-of-band data
+ MSG_PEEK : constant := 2; -- Peek at incoming data
+ MSG_EOR : constant := 8; -- Send end of record
+ MSG_WAITALL : constant := 64; -- Wait for full reception
+
+ --------------------
+ -- Socket options --
+ --------------------
+
+ TCP_NODELAY : constant := 1; -- Do not coalesce packets
+ SO_SNDBUF : constant := 4097; -- Set/get send buffer size
+ SO_RCVBUF : constant := 4098; -- Set/get recv buffer size
+ SO_REUSEADDR : constant := 4; -- Bind reuse local address
+ SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs
+ SO_LINGER : constant := 128; -- Defer close to flush data
+ SO_ERROR : constant := 4103; -- Get/clear error status
+ SO_BROADCAST : constant := 32; -- Can send broadcast msgs
+ IP_ADD_MEMBERSHIP : constant := 23; -- Join a multicast group
+ IP_DROP_MEMBERSHIP : constant := 24; -- Leave a multicast group
+ IP_MULTICAST_TTL : constant := 21; -- Set/get multicast TTL
+ IP_MULTICAST_LOOP : constant := 22; -- Set/get mcast loopback
+
end GNAT.Sockets.Constants;
diff --git a/gcc/ada/3hsoccon.ads b/gcc/ada/3hsoccon.ads
index e88cd53edac..cbca2bee7a5 100644
--- a/gcc/ada/3hsoccon.ads
+++ b/gcc/ada/3hsoccon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-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- --
@@ -26,88 +26,133 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+-- This package provides target dependent definitions of constant for use
+-- by the GNAT.Sockets package (g-socket.ads). This package should not be
+-- directly with'ed by an applications program.
+
-- This is the version for HP/UX
package GNAT.Sockets.Constants is
- -- Families
-
- AF_INET : constant := 2;
- AF_INET6 : constant := -1;
-
- -- Modes
-
- SOCK_STREAM : constant := 1;
- SOCK_DGRAM : constant := 2;
-
- -- Socket Errors
-
- EBADF : constant := 9;
- ENOTSOCK : constant := 216;
- ENOTCONN : constant := 235;
- ENOBUFS : constant := 233;
- EOPNOTSUPP : constant := 223;
- EFAULT : constant := 14;
- EWOULDBLOCK : constant := 246;
- EADDRNOTAVAIL : constant := 227;
- EMSGSIZE : constant := 218;
- EADDRINUSE : constant := 226;
- EINVAL : constant := 22;
- EACCES : constant := 13;
- EAFNOSUPPORT : constant := 225;
- EISCONN : constant := 234;
- ETIMEDOUT : constant := 238;
- ECONNREFUSED : constant := 239;
- ENETUNREACH : constant := 229;
- EALREADY : constant := 244;
- EINPROGRESS : constant := 245;
- ENOPROTOOPT : constant := 220;
- EPROTONOSUPPORT : constant := 221;
- EINTR : constant := 4;
- EIO : constant := 5;
- ESOCKTNOSUPPORT : constant := 222;
-
- -- Host Errors
-
- HOST_NOT_FOUND : constant := 1;
- TRY_AGAIN : constant := 2;
- NO_ADDRESS : constant := 4;
- NO_RECOVERY : constant := 3;
-
- -- Control Flags
-
- FIONBIO : constant := -2147195266;
- FIONREAD : constant := 1074030207;
-
- -- Shutdown Modes
-
- SHUT_RD : constant := 0;
- SHUT_WR : constant := 1;
- SHUT_RDWR : constant := 2;
-
- -- Protocol Levels
-
- SOL_SOCKET : constant := 65535;
- IPPROTO_IP : constant := 0;
- IPPROTO_UDP : constant := 17;
- IPPROTO_TCP : constant := 6;
-
- -- Socket Options
-
- TCP_NODELAY : constant := 1;
- SO_SNDBUF : constant := 4097;
- SO_RCVBUF : constant := 4098;
- SO_REUSEADDR : constant := 4;
- SO_KEEPALIVE : constant := 8;
- SO_LINGER : constant := 128;
- SO_ERROR : constant := 4103;
- SO_BROADCAST : constant := 32;
- IP_ADD_MEMBERSHIP : constant := 5;
- IP_DROP_MEMBERSHIP : constant := 6;
- IP_MULTICAST_TTL : constant := 3;
- IP_MULTICAST_LOOP : constant := 4;
+ --------------
+ -- Families --
+ --------------
+
+ AF_INET : constant := 2; -- IPv4 address family
+ AF_INET6 : constant := 26; -- IPv6 address family
+
+ -----------
+ -- Modes --
+ -----------
+
+ SOCK_STREAM : constant := 1; -- Stream socket
+ SOCK_DGRAM : constant := 2; -- Datagram socket
+
+ -------------------
+ -- Socket errors --
+ -------------------
+
+ EACCES : constant := 13; -- Permission denied
+ EADDRINUSE : constant := 226; -- Address already in use
+ EADDRNOTAVAIL : constant := 227; -- Cannot assign address
+ EAFNOSUPPORT : constant := 225; -- Addr family not supported
+ EALREADY : constant := 244; -- Operation in progress
+ EBADF : constant := 9; -- Bad file descriptor
+ ECONNABORTED : constant := 231; -- Connection aborted
+ ECONNREFUSED : constant := 239; -- Connection refused
+ ECONNRESET : constant := 232; -- Connection reset by peer
+ EDESTADDRREQ : constant := 217; -- Destination addr required
+ EFAULT : constant := 14; -- Bad address
+ EHOSTDOWN : constant := 241; -- Host is down
+ EHOSTUNREACH : constant := 242; -- No route to host
+ EINPROGRESS : constant := 245; -- Operation now in progress
+ EINTR : constant := 4; -- Interrupted system call
+ EINVAL : constant := 22; -- Invalid argument
+ EIO : constant := 5; -- Input output error
+ EISCONN : constant := 234; -- Socket already connected
+ ELOOP : constant := 249; -- Too many symbolic lynks
+ EMFILE : constant := 24; -- Too many open files
+ EMSGSIZE : constant := 218; -- Message too long
+ ENAMETOOLONG : constant := 248; -- Name too long
+ ENETDOWN : constant := 228; -- Network is down
+ ENETRESET : constant := 230; -- Disconn. on network reset
+ ENETUNREACH : constant := 229; -- Network is unreachable
+ ENOBUFS : constant := 233; -- No buffer space available
+ ENOPROTOOPT : constant := 220; -- Protocol not available
+ ENOTCONN : constant := 235; -- Socket not connected
+ ENOTSOCK : constant := 216; -- Operation on non socket
+ EOPNOTSUPP : constant := 223; -- Operation not supported
+ EPFNOSUPPORT : constant := 224; -- Unknown protocol family
+ EPROTONOSUPPORT : constant := 221; -- Unknown protocol
+ EPROTOTYPE : constant := 219; -- Unknown protocol type
+ ESHUTDOWN : constant := 236; -- Cannot send once shutdown
+ ESOCKTNOSUPPORT : constant := 222; -- Socket type not supported
+ ETIMEDOUT : constant := 238; -- Connection timed out
+ ETOOMANYREFS : constant := 237; -- Too many references
+ EWOULDBLOCK : constant := 246; -- Operation would block
+
+ -----------------
+ -- Host errors --
+ -----------------
+
+ HOST_NOT_FOUND : constant := 1; -- Unknown host
+ TRY_AGAIN : constant := 2; -- Host name lookup failure
+ NO_DATA : constant := 4; -- No data record for name
+ NO_RECOVERY : constant := 3; -- Non recoverable errors
+
+ -------------------
+ -- Control flags --
+ -------------------
+
+ FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
+ FIONREAD : constant := 1074030207; -- How many bytes to read
+
+ --------------------
+ -- Shutdown modes --
+ --------------------
+
+ SHUT_RD : constant := 0; -- No more recv
+ SHUT_WR : constant := 1; -- No more send
+ SHUT_RDWR : constant := 2; -- No more recv/send
+
+ ---------------------
+ -- Protocol levels --
+ ---------------------
+
+ SOL_SOCKET : constant := 65535; -- Options for socket level
+ IPPROTO_IP : constant := 0; -- Dummy protocol for IP
+ IPPROTO_UDP : constant := 17; -- UDP
+ IPPROTO_TCP : constant := 6; -- TCP
+
+ -------------------
+ -- Request flags --
+ -------------------
+
+ MSG_OOB : constant := 1; -- Process out-of-band data
+ MSG_PEEK : constant := 2; -- Peek at incoming data
+ MSG_EOR : constant := 8; -- Send end of record
+ MSG_WAITALL : constant := 64; -- Wait for full reception
+
+ --------------------
+ -- Socket options --
+ --------------------
+
+ TCP_NODELAY : constant := 1; -- Do not coalesce packets
+ SO_SNDBUF : constant := 4097; -- Set/get send buffer size
+ SO_RCVBUF : constant := 4098; -- Set/get recv buffer size
+ SO_REUSEADDR : constant := 4; -- Bind reuse local address
+ SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs
+ SO_LINGER : constant := 128; -- Defer close to flush data
+ SO_ERROR : constant := 4103; -- Get/clear error status
+ SO_BROADCAST : constant := 32; -- Can send broadcast msgs
+ IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group
+ IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group
+ IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL
+ IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback
+
end GNAT.Sockets.Constants;
diff --git a/gcc/ada/3psoccon.ads b/gcc/ada/3psoccon.ads
new file mode 100644
index 00000000000..61903079b82
--- /dev/null
+++ b/gcc/ada/3psoccon.ads
@@ -0,0 +1,158 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . C O N S T A N T S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2000-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides target dependent definitions of constant for use
+-- by the GNAT.Sockets package (g-socket.ads). This package should not be
+-- directly with'ed by an applications program.
+
+-- This is the version for Interix
+
+package GNAT.Sockets.Constants is
+
+ --------------
+ -- Families --
+ --------------
+
+ AF_INET : constant := 2; -- IPv4 address family
+ AF_INET6 : constant := -1; -- IPv6 address family
+
+ -----------
+ -- Modes --
+ -----------
+
+ SOCK_STREAM : constant := 1; -- Stream socket
+ SOCK_DGRAM : constant := 2; -- Datagram socket
+
+ -------------------
+ -- Socket errors --
+ -------------------
+
+ EACCES : constant := 13; -- Permission denied
+ EADDRINUSE : constant := 48; -- Address already in use
+ EADDRNOTAVAIL : constant := 49; -- Cannot assign address
+ EAFNOSUPPORT : constant := 47; -- Addr family not supported
+ EALREADY : constant := 37; -- Operation in progress
+ EBADF : constant := 9; -- Bad file descriptor
+ ECONNABORTED : constant := 53; -- Connection aborted
+ ECONNREFUSED : constant := 61; -- Connection refused
+ ECONNRESET : constant := 54; -- Connection reset by peer
+ EDESTADDRREQ : constant := 82; -- Destination addr required
+ EFAULT : constant := 14; -- Bad address
+ EHOSTDOWN : constant := 64; -- Host is down
+ EHOSTUNREACH : constant := 65; -- No route to host
+ EINPROGRESS : constant := 80; -- Operation now in progress
+ EINTR : constant := 4; -- Interrupted system call
+ EINVAL : constant := 22; -- Invalid argument
+ EIO : constant := 5; -- Input output error
+ EISCONN : constant := 56; -- Socket already connected
+ ELOOP : constant := 62; -- Too many symbolic lynks
+ EMFILE : constant := 24; -- Too many open files
+ EMSGSIZE : constant := 83; -- Message too long
+ ENAMETOOLONG : constant := 38; -- Name too long
+ ENETDOWN : constant := 50; -- Network is down
+ ENETRESET : constant := 52; -- Disconn. on network reset
+ ENETUNREACH : constant := 51; -- Network is unreachable
+ ENOBUFS : constant := 55; -- No buffer space available
+ ENOPROTOOPT : constant := 85; -- Protocol not available
+ ENOTCONN : constant := 57; -- Socket not connected
+ ENOTSOCK : constant := 81; -- Operation on non socket
+ EOPNOTSUPP : constant := 45; -- Operation not supported
+ EPFNOSUPPORT : constant := 46; -- Unknown protocol family
+ EPROTONOSUPPORT : constant := 43; -- Unknown protocol
+ EPROTOTYPE : constant := 84; -- Unknown protocol type
+ ESHUTDOWN : constant := 58; -- Cannot send once shutdown
+ ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported
+ ETIMEDOUT : constant := 60; -- Connection timed out
+ ETOOMANYREFS : constant := 59; -- Too many references
+ EWOULDBLOCK : constant := 11; -- Operation would block
+
+ -----------------
+ -- Host errors --
+ -----------------
+
+ HOST_NOT_FOUND : constant := 90; -- Unknown host
+ TRY_AGAIN : constant := 91; -- Host name lookup failure
+ NO_DATA : constant := 93; -- No data record for name
+ NO_RECOVERY : constant := 92; -- Non recoverable errors
+
+ -------------------
+ -- Control flags --
+ -------------------
+
+ FIONBIO : constant := -2147195390; -- Set/clear non-blocking io
+ FIONREAD : constant := 1074030081; -- How many bytes to read
+
+ --------------------
+ -- Shutdown modes --
+ --------------------
+
+ SHUT_RD : constant := 0; -- No more recv
+ SHUT_WR : constant := 1; -- No more send
+ SHUT_RDWR : constant := 2; -- No more recv/send
+
+ ---------------------
+ -- Protocol levels --
+ ---------------------
+
+ SOL_SOCKET : constant := 65535; -- Options for socket level
+ IPPROTO_IP : constant := 0; -- Dummy protocol for IP
+ IPPROTO_UDP : constant := 17; -- UDP
+ IPPROTO_TCP : constant := 6; -- TCP
+
+ -------------------
+ -- Request flags --
+ -------------------
+
+ MSG_OOB : constant := 1; -- Process out-of-band data
+ MSG_PEEK : constant := 2; -- Peek at incoming data
+ MSG_EOR : constant := 8; -- Send end of record
+ MSG_WAITALL : constant := 64; -- Wait for full reception
+
+ --------------------
+ -- Socket options --
+ --------------------
+
+ TCP_NODELAY : constant := 1; -- Do not coalesce packets
+ SO_SNDBUF : constant := 4097; -- Set/get send buffer size
+ SO_RCVBUF : constant := 4098; -- Set/get recv buffer size
+ SO_REUSEADDR : constant := 4; -- Bind reuse local address
+ SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs
+ SO_LINGER : constant := 128; -- Defer close to flush data
+ SO_ERROR : constant := 4103; -- Get/clear error status
+ SO_BROADCAST : constant := 32; -- Can send broadcast msgs
+ IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group
+ IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group
+ IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL
+ IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback
+
+end GNAT.Sockets.Constants;
diff --git a/gcc/ada/3ssoccon.ads b/gcc/ada/3ssoccon.ads
index 2af7a2a73b8..1ad58838ca9 100644
--- a/gcc/ada/3ssoccon.ads
+++ b/gcc/ada/3ssoccon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-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- --
@@ -26,88 +26,133 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+-- This package provides target dependent definitions of constant for use
+-- by the GNAT.Sockets package (g-socket.ads). This package should not be
+-- directly with'ed by an applications program.
+
-- This is the version for Solaris
package GNAT.Sockets.Constants is
- -- Families
-
- AF_INET : constant := 2;
- AF_INET6 : constant := 26;
-
- -- Modes
-
- SOCK_STREAM : constant := 2;
- SOCK_DGRAM : constant := 1;
-
- -- Socket Errors
-
- EBADF : constant := 9;
- ENOTSOCK : constant := 95;
- ENOTCONN : constant := 134;
- ENOBUFS : constant := 132;
- EOPNOTSUPP : constant := 122;
- EFAULT : constant := 14;
- EWOULDBLOCK : constant := 11;
- EADDRNOTAVAIL : constant := 126;
- EMSGSIZE : constant := 97;
- EADDRINUSE : constant := 125;
- EINVAL : constant := 22;
- EACCES : constant := 13;
- EAFNOSUPPORT : constant := 124;
- EISCONN : constant := 133;
- ETIMEDOUT : constant := 145;
- ECONNREFUSED : constant := 146;
- ENETUNREACH : constant := 128;
- EALREADY : constant := 149;
- EINPROGRESS : constant := 150;
- ENOPROTOOPT : constant := 99;
- EPROTONOSUPPORT : constant := 120;
- EINTR : constant := 4;
- EIO : constant := 5;
- ESOCKTNOSUPPORT : constant := 121;
-
- -- Host Errors
-
- HOST_NOT_FOUND : constant := 1;
- TRY_AGAIN : constant := 2;
- NO_ADDRESS : constant := 4;
- NO_RECOVERY : constant := 3;
-
- -- Control Flags
-
- FIONBIO : constant := -2147195266;
- FIONREAD : constant := 1074030207;
-
- -- Shutdown Modes
-
- SHUT_RD : constant := 0;
- SHUT_WR : constant := 1;
- SHUT_RDWR : constant := 2;
-
- -- Protocol Levels
-
- SOL_SOCKET : constant := 65535;
- IPPROTO_IP : constant := 0;
- IPPROTO_UDP : constant := 17;
- IPPROTO_TCP : constant := 6;
-
- -- Socket Options
-
- TCP_NODELAY : constant := 1;
- SO_SNDBUF : constant := 4097;
- SO_RCVBUF : constant := 4098;
- SO_REUSEADDR : constant := 4;
- SO_KEEPALIVE : constant := 8;
- SO_LINGER : constant := 128;
- SO_ERROR : constant := 4103;
- SO_BROADCAST : constant := 32;
- IP_ADD_MEMBERSHIP : constant := 19;
- IP_DROP_MEMBERSHIP : constant := 20;
- IP_MULTICAST_TTL : constant := 17;
- IP_MULTICAST_LOOP : constant := 18;
+ --------------
+ -- Families --
+ --------------
+
+ AF_INET : constant := 2; -- IPv4 address family
+ AF_INET6 : constant := 26; -- IPv6 address family
+
+ -----------
+ -- Modes --
+ -----------
+
+ SOCK_STREAM : constant := 2; -- Stream socket
+ SOCK_DGRAM : constant := 1; -- Datagram socket
+
+ -------------------
+ -- Socket errors --
+ -------------------
+
+ EACCES : constant := 13; -- Permission denied
+ EADDRINUSE : constant := 125; -- Address already in use
+ EADDRNOTAVAIL : constant := 126; -- Cannot assign address
+ EAFNOSUPPORT : constant := 124; -- Addr family not supported
+ EALREADY : constant := 149; -- Operation in progress
+ EBADF : constant := 9; -- Bad file descriptor
+ ECONNABORTED : constant := 130; -- Connection aborted
+ ECONNREFUSED : constant := 146; -- Connection refused
+ ECONNRESET : constant := 131; -- Connection reset by peer
+ EDESTADDRREQ : constant := 96; -- Destination addr required
+ EFAULT : constant := 14; -- Bad address
+ EHOSTDOWN : constant := 147; -- Host is down
+ EHOSTUNREACH : constant := 148; -- No route to host
+ EINPROGRESS : constant := 150; -- Operation now in progress
+ EINTR : constant := 4; -- Interrupted system call
+ EINVAL : constant := 22; -- Invalid argument
+ EIO : constant := 5; -- Input output error
+ EISCONN : constant := 133; -- Socket already connected
+ ELOOP : constant := 90; -- Too many symbolic lynks
+ EMFILE : constant := 24; -- Too many open files
+ EMSGSIZE : constant := 97; -- Message too long
+ ENAMETOOLONG : constant := 78; -- Name too long
+ ENETDOWN : constant := 127; -- Network is down
+ ENETRESET : constant := 129; -- Disconn. on network reset
+ ENETUNREACH : constant := 128; -- Network is unreachable
+ ENOBUFS : constant := 132; -- No buffer space available
+ ENOPROTOOPT : constant := 99; -- Protocol not available
+ ENOTCONN : constant := 134; -- Socket not connected
+ ENOTSOCK : constant := 95; -- Operation on non socket
+ EOPNOTSUPP : constant := 122; -- Operation not supported
+ EPFNOSUPPORT : constant := 123; -- Unknown protocol family
+ EPROTONOSUPPORT : constant := 120; -- Unknown protocol
+ EPROTOTYPE : constant := 98; -- Unknown protocol type
+ ESHUTDOWN : constant := 143; -- Cannot send once shutdown
+ ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported
+ ETIMEDOUT : constant := 145; -- Connection timed out
+ ETOOMANYREFS : constant := 144; -- Too many references
+ EWOULDBLOCK : constant := 11; -- Operation would block
+
+ -----------------
+ -- Host errors --
+ -----------------
+
+ HOST_NOT_FOUND : constant := 1; -- Unknown host
+ TRY_AGAIN : constant := 2; -- Host name lookup failure
+ NO_DATA : constant := 4; -- No data record for name
+ NO_RECOVERY : constant := 3; -- Non recoverable errors
+
+ -------------------
+ -- Control flags --
+ -------------------
+
+ FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
+ FIONREAD : constant := 1074030207; -- How many bytes to read
+
+ --------------------
+ -- Shutdown modes --
+ --------------------
+
+ SHUT_RD : constant := 0; -- No more recv
+ SHUT_WR : constant := 1; -- No more send
+ SHUT_RDWR : constant := 2; -- No more recv/send
+
+ ---------------------
+ -- Protocol levels --
+ ---------------------
+
+ SOL_SOCKET : constant := 65535; -- Options for socket level
+ IPPROTO_IP : constant := 0; -- Dummy protocol for IP
+ IPPROTO_UDP : constant := 17; -- UDP
+ IPPROTO_TCP : constant := 6; -- TCP
+
+ -------------------
+ -- Request flags --
+ -------------------
+
+ MSG_OOB : constant := 1; -- Process out-of-band data
+ MSG_PEEK : constant := 2; -- Peek at incoming data
+ MSG_EOR : constant := 8; -- Send end of record
+ MSG_WAITALL : constant := 64; -- Wait for full reception
+
+ --------------------
+ -- Socket options --
+ --------------------
+
+ TCP_NODELAY : constant := 1; -- Do not coalesce packets
+ SO_SNDBUF : constant := 4097; -- Set/get send buffer size
+ SO_RCVBUF : constant := 4098; -- Set/get recv buffer size
+ SO_REUSEADDR : constant := 4; -- Bind reuse local address
+ SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs
+ SO_LINGER : constant := 128; -- Defer close to flush data
+ SO_ERROR : constant := 4103; -- Get/clear error status
+ SO_BROADCAST : constant := 32; -- Can send broadcast msgs
+ IP_ADD_MEMBERSHIP : constant := 19; -- Join a multicast group
+ IP_DROP_MEMBERSHIP : constant := 20; -- Leave a multicast group
+ IP_MULTICAST_TTL : constant := 17; -- Set/get multicast TTL
+ IP_MULTICAST_LOOP : constant := 18; -- Set/get mcast loopback
+
end GNAT.Sockets.Constants;
diff --git a/gcc/ada/3ssoliop.ads b/gcc/ada/3ssoliop.ads
index 80de5201c75..18b7abb7e63 100644
--- a/gcc/ada/3ssoliop.ads
+++ b/gcc/ada/3ssoliop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,17 +26,18 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-package GNAT.Sockets.Linker_Options is
+-- This package is used to provide target specific linker_options for the
+-- support of scokets as required by the package GNAT.Sockets.
- -- This is the Solaris version of this package.
+-- This is the UnixWare version of this package
+package GNAT.Sockets.Linker_Options is
private
-
pragma Linker_Options ("-lnsl");
pragma Linker_Options ("-lsocket");
-
end GNAT.Sockets.Linker_Options;
diff --git a/gcc/ada/3veacodu.adb b/gcc/ada/3veacodu.adb
new file mode 100644
index 00000000000..2c31a28e299
--- /dev/null
+++ b/gcc/ada/3veacodu.adb
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . E X C E P T I O N _ A C T I O N S . C O R E _ D U M P --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VMS version.
+
+with System;
+with System.Aux_DEC;
+separate (GNAT.Exception_Actions)
+procedure Core_Dump (Occurrence : Exception_Occurrence) is
+
+ use System;
+ use System.Aux_DEC;
+
+ pragma Unreferenced (Occurrence);
+
+ SS_IMGDMP : constant := 1276;
+
+ subtype Cond_Value_Type is Unsigned_Longword;
+ subtype Access_Mode_Type is
+ Unsigned_Word range 0 .. 3;
+ Access_Mode_Zero : constant Access_Mode_Type := 0;
+
+ Status : Cond_Value_Type;
+
+ procedure Setexv (
+ Status : out Cond_Value_Type;
+ Vector : in Unsigned_Longword := 0;
+ Addres : in Address := Address_Zero;
+ Acmode : in Access_Mode_Type := Access_Mode_Zero;
+ Prvhnd : in Unsigned_Longword := 0);
+ pragma Interface (External, Setexv);
+ pragma Import_Valued_Procedure (Setexv, "SYS$SETEXV",
+ (Cond_Value_Type, Unsigned_Longword, Address, Access_Mode_Type,
+ Unsigned_Longword),
+ (Value, Value, Value, Value, Value));
+
+ procedure Lib_Signal (I : in Integer);
+ pragma Interface (C, Lib_Signal);
+ pragma Import_Procedure (Lib_Signal, "LIB$SIGNAL", Mechanism => (Value));
+begin
+ Setexv (Status, 1, Address_Zero, 3);
+ Lib_Signal (SS_IMGDMP);
+end Core_Dump;
diff --git a/gcc/ada/3vexpect.adb b/gcc/ada/3vexpect.adb
new file mode 100644
index 00000000000..fd239a5286c
--- /dev/null
+++ b/gcc/ada/3vexpect.adb
@@ -0,0 +1,1187 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- G N A T . E X P E C T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VMS version.
+
+with System; use System;
+with Ada.Calendar; use Ada.Calendar;
+
+with GNAT.IO;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Regpat; use GNAT.Regpat;
+
+with Unchecked_Deallocation;
+
+package body GNAT.Expect is
+
+ type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access;
+
+ Save_Input : File_Descriptor;
+ Save_Output : File_Descriptor;
+ Save_Error : File_Descriptor;
+
+ procedure Expect_Internal
+ (Descriptors : in out Array_Of_Pd;
+ Result : out Expect_Match;
+ Timeout : Integer;
+ Full_Buffer : Boolean);
+ -- Internal function used to read from the process Descriptor.
+ --
+ -- Three outputs are possible:
+ -- Result=Expect_Timeout, if no output was available before the timeout
+ -- expired.
+ -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters
+ -- had to be discarded from the internal buffer of Descriptor.
+ -- Result=<integer>, indicates how many characters were added to the
+ -- internal buffer. These characters are from indexes
+ -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index
+ -- Process_Died is raised if the process is no longer valid.
+
+ procedure Reinitialize_Buffer
+ (Descriptor : in out Process_Descriptor'Class);
+ -- Reinitialize the internal buffer.
+ -- The buffer is deleted up to the end of the last match.
+
+ procedure Free is new Unchecked_Deallocation
+ (Pattern_Matcher, Pattern_Matcher_Access);
+
+ procedure Call_Filters
+ (Pid : Process_Descriptor'Class;
+ Str : String;
+ Filter_On : Filter_Type);
+ -- Call all the filters that have the appropriate type.
+ -- This function does nothing if the filters are locked
+
+ ------------------------------
+ -- Target dependent section --
+ ------------------------------
+
+ function Dup (Fd : File_Descriptor) return File_Descriptor;
+ pragma Import (C, Dup);
+
+ procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
+ pragma Import (C, Dup2);
+
+ procedure Kill (Pid : Process_Id; Sig_Num : Integer);
+ pragma Import (C, Kill);
+
+ function Create_Pipe (Pipe : access Pipe_Type) return Integer;
+ pragma Import (C, Create_Pipe, "__gnat_pipe");
+
+ function Poll
+ (Fds : System.Address;
+ Num_Fds : Integer;
+ Timeout : Integer;
+ Is_Set : System.Address)
+ return Integer;
+ pragma Import (C, Poll, "__gnat_expect_poll");
+ -- Check whether there is any data waiting on the file descriptor
+ -- Out_fd, and wait if there is none, at most Timeout milliseconds
+ -- Returns -1 in case of error, 0 if the timeout expired before
+ -- data became available.
+ --
+ -- Out_Is_Set is set to 1 if data was available, 0 otherwise.
+
+ function Waitpid (Pid : Process_Id) return Integer;
+ pragma Import (C, Waitpid, "__gnat_waitpid");
+ -- Wait for a specific process id, and return its exit code.
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+" (S : String) return GNAT.OS_Lib.String_Access is
+ begin
+ return new String'(S);
+ end "+";
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+"
+ (P : GNAT.Regpat.Pattern_Matcher)
+ return Pattern_Matcher_Access
+ is
+ begin
+ return new GNAT.Regpat.Pattern_Matcher'(P);
+ end "+";
+
+ ----------------
+ -- Add_Filter --
+ ----------------
+
+ procedure Add_Filter
+ (Descriptor : in out Process_Descriptor;
+ Filter : Filter_Function;
+ Filter_On : Filter_Type := Output;
+ User_Data : System.Address := System.Null_Address;
+ After : Boolean := False)
+ is
+ Current : Filter_List := Descriptor.Filters;
+
+ begin
+ if After then
+ while Current /= null and then Current.Next /= null loop
+ Current := Current.Next;
+ end loop;
+
+ if Current = null then
+ Descriptor.Filters :=
+ new Filter_List_Elem'
+ (Filter => Filter, Filter_On => Filter_On,
+ User_Data => User_Data, Next => null);
+ else
+ Current.Next :=
+ new Filter_List_Elem'
+ (Filter => Filter, Filter_On => Filter_On,
+ User_Data => User_Data, Next => null);
+ end if;
+
+ else
+ Descriptor.Filters :=
+ new Filter_List_Elem'
+ (Filter => Filter, Filter_On => Filter_On,
+ User_Data => User_Data, Next => Descriptor.Filters);
+ end if;
+ end Add_Filter;
+
+ ------------------
+ -- Call_Filters --
+ ------------------
+
+ procedure Call_Filters
+ (Pid : Process_Descriptor'Class;
+ Str : String;
+ Filter_On : Filter_Type)
+ is
+ Current_Filter : Filter_List;
+
+ begin
+ if Pid.Filters_Lock = 0 then
+ Current_Filter := Pid.Filters;
+
+ while Current_Filter /= null loop
+ if Current_Filter.Filter_On = Filter_On then
+ Current_Filter.Filter
+ (Pid, Str, Current_Filter.User_Data);
+ end if;
+
+ Current_Filter := Current_Filter.Next;
+ end loop;
+ end if;
+ end Call_Filters;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close
+ (Descriptor : in out Process_Descriptor;
+ Status : out Integer)
+ is
+ begin
+ Close (Descriptor.Input_Fd);
+
+ if Descriptor.Error_Fd /= Descriptor.Output_Fd then
+ Close (Descriptor.Error_Fd);
+ end if;
+
+ Close (Descriptor.Output_Fd);
+
+ -- ??? Should have timeouts for different signals
+ Kill (Descriptor.Pid, 9);
+
+ GNAT.OS_Lib.Free (Descriptor.Buffer);
+ Descriptor.Buffer_Size := 0;
+
+ Status := Waitpid (Descriptor.Pid);
+ end Close;
+
+ procedure Close (Descriptor : in out Process_Descriptor) is
+ Status : Integer;
+ begin
+ Close (Descriptor, Status);
+ end Close;
+
+ ------------
+ -- Expect --
+ ------------
+
+ procedure Expect
+ (Descriptor : in out Process_Descriptor;
+ Result : out Expect_Match;
+ Regexp : String;
+ Timeout : Integer := 10000;
+ Full_Buffer : Boolean := False)
+ is
+ begin
+ if Regexp = "" then
+ Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer);
+ else
+ Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer);
+ end if;
+ end Expect;
+
+ procedure Expect
+ (Descriptor : in out Process_Descriptor;
+ Result : out Expect_Match;
+ Regexp : String;
+ Matched : out GNAT.Regpat.Match_Array;
+ Timeout : Integer := 10000;
+ Full_Buffer : Boolean := False)
+ is
+ begin
+ pragma Assert (Matched'First = 0);
+ if Regexp = "" then
+ Expect
+ (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer);
+ else
+ Expect
+ (Descriptor, Result, Compile (Regexp), Matched, Timeout,
+ Full_Buffer);
+ end if;
+ end Expect;
+
+ procedure Expect
+ (Descriptor : in out Process_Descriptor;
+ Result : out Expect_Match;
+ Regexp : GNAT.Regpat.Pattern_Matcher;
+ Timeout : Integer := 10000;
+ Full_Buffer : Boolean := False)
+ is
+ Matched : GNAT.Regpat.Match_Array (0 .. 0);
+
+ begin
+ Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer);
+ end Expect;
+
+ procedure Expect
+ (Descriptor : in out Process_Descriptor;
+ Result : out Expect_Match;
+ Regexp : GNAT.Regpat.Pattern_Matcher;
+ Matched : out GNAT.Regpat.Match_Array;
+ Timeout : Integer := 10000;
+ Full_Buffer : Boolean := False)
+ is
+ N : Expect_Match;
+ Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
+ Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0;
+ Timeout_Tmp : Integer := Timeout;
+
+ begin
+ pragma Assert (Matched'First = 0);
+ Reinitialize_Buffer (Descriptor);
+
+ loop
+ -- First, test if what is already in the buffer matches (This is
+ -- required if this package is used in multi-task mode, since one of
+ -- the tasks might have added something in the buffer, and we don't
+ -- want other tasks to wait for new input to be available before
+ -- checking the regexps).
+
+ Match
+ (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
+
+ if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then
+ Result := 1;
+ Descriptor.Last_Match_Start := Matched (0).First;
+ Descriptor.Last_Match_End := Matched (0).Last;
+ return;
+ end if;
+
+ -- Else try to read new input
+
+ Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer);
+
+ if N = Expect_Timeout or else N = Expect_Full_Buffer then
+ Result := N;
+ return;
+ end if;
+
+ -- Calculate the timeout for the next turn.
+ -- Note that Timeout is, from the caller's perspective, the maximum
+ -- time until a match, not the maximum time until some output is
+ -- read, and thus can not be reused as is for Expect_Internal.
+
+ if Timeout /= -1 then
+ Timeout_Tmp := Integer (Try_Until - Clock) * 1000;
+
+ if Timeout_Tmp < 0 then
+ Result := Expect_Timeout;
+ exit;
+ end if;
+ end if;
+ end loop;
+
+ -- Even if we had the general timeout above, we have to test that the
+ -- last test we read from the external process didn't match.
+
+ Match
+ (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched);
+
+ if Matched (0).First /= 0 then
+ Result := 1;
+ Descriptor.Last_Match_Start := Matched (0).First;
+ Descriptor.Last_Match_End := Matched (0).Last;
+ return;
+ end if;
+ end Expect;
+
+ procedure Expect
+ (Descriptor : in out Process_Descriptor;
+ Result : out Expect_Match;
+ Regexps : Regexp_Array;
+ Timeout : Integer := 10000;
+ Full_Buffer : Boolean := False)
+ is
+ Patterns : Compiled_Regexp_Array (Regexps'Range);
+ Matched : GNAT.Regpat.Match_Array (0 .. 0);
+
+ begin
+ for J in Regexps'Range loop
+ Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
+ end loop;
+
+ Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
+
+ for J in Regexps'Range loop
+ Free (Patterns (J));
+ end loop;
+ end Expect;
+
+ procedure Expect
+ (Descriptor : in out Process_Descriptor;
+ Result : out Expect_Match;
+ Regexps : Compiled_Regexp_Array;
+ Timeout : Integer := 10000;
+ Full_Buffer : Boolean := False)
+ is
+ Matched : GNAT.Regpat.Match_Array (0 .. 0);
+
+ begin
+ Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer);
+ end Expect;
+
+ procedure Expect
+ (Result : out Expect_Match;
+ Regexps : Multiprocess_Regexp_Array;
+ Timeout : Integer := 10000;
+ Full_Buffer : Boolean := False)
+ is
+ Matched : GNAT.Regpat.Match_Array (0 .. 0);
+
+ begin
+ Expect (Result, Regexps, Matched, Timeout, Full_Buffer);
+ end Expect;
+
+ procedure Expect
+ (Descriptor : in out Process_Descriptor;
+ Result : out Expect_Match;
+ Regexps : Regexp_Array;
+ Matched : out GNAT.Regpat.Match_Array;
+ Timeout : Integer := 10000;
+ Full_Buffer : Boolean := False)
+ is
+ Patterns : Compiled_Regexp_Array (Regexps'Range);
+
+ begin
+ pragma Assert (Matched'First = 0);
+
+ for J in Regexps'Range loop
+ Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all));
+ end loop;
+
+ Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer);
+
+ for J in Regexps'Range loop
+ Free (Patterns (J));
+ end loop;
+ end Expect;
+
+ procedure Expect
+ (Descriptor : in out Process_Descriptor;
+ Result : out Expect_Match;
+ Regexps : Compiled_Regexp_Array;
+ Matched : out GNAT.Regpat.Match_Array;
+ Timeout : Integer := 10000;
+ Full_Buffer : Boolean := False)
+ is
+ N : Expect_Match;
+ Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
+
+ begin
+ pragma Assert (Matched'First = 0);
+
+ Reinitialize_Buffer (Descriptor);
+
+ loop
+ -- First, test if what is already in the buffer matches (This is
+ -- required if this package is used in multi-task mode, since one of
+ -- the tasks might have added something in the buffer, and we don't
+ -- want other tasks to wait for new input to be available before
+ -- checking the regexps).
+
+ if Descriptor.Buffer /= null then
+ for J in Regexps'Range loop
+ Match
+ (Regexps (J).all,
+ Descriptor.Buffer (1 .. Descriptor.Buffer_Index),
+ Matched);
+
+ if Matched (0) /= No_Match then
+ Result := Expect_Match (J);
+ Descriptor.Last_Match_Start := Matched (0).First;
+ Descriptor.Last_Match_End := Matched (0).Last;
+ return;
+ end if;
+ end loop;
+ end if;
+
+ Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
+
+ if N = Expect_Timeout or else N = Expect_Full_Buffer then
+ Result := N;
+ return;
+ end if;
+ end loop;
+ end Expect;
+
+ procedure Expect
+ (Result : out Expect_Match;
+ Regexps : Multiprocess_Regexp_Array;
+ Matched : out GNAT.Regpat.Match_Array;
+ Timeout : Integer := 10000;
+ Full_Buffer : Boolean := False)
+ is
+ N : Expect_Match;
+ Descriptors : Array_Of_Pd (Regexps'Range);
+
+ begin
+ pragma Assert (Matched'First = 0);
+
+ for J in Descriptors'Range loop
+ Descriptors (J) := Regexps (J).Descriptor;
+ Reinitialize_Buffer (Regexps (J).Descriptor.all);
+ end loop;
+
+ loop
+ -- First, test if what is already in the buffer matches (This is
+ -- required if this package is used in multi-task mode, since one of
+ -- the tasks might have added something in the buffer, and we don't
+ -- want other tasks to wait for new input to be available before
+ -- checking the regexps).
+
+ for J in Regexps'Range loop
+ Match (Regexps (J).Regexp.all,
+ Regexps (J).Descriptor.Buffer
+ (1 .. Regexps (J).Descriptor.Buffer_Index),
+ Matched);
+
+ if Matched (0) /= No_Match then
+ Result := Expect_Match (J);
+ Regexps (J).Descriptor.Last_Match_Start := Matched (0).First;
+ Regexps (J).Descriptor.Last_Match_End := Matched (0).Last;
+ return;
+ end if;
+ end loop;
+
+ Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
+
+ if N = Expect_Timeout or else N = Expect_Full_Buffer then
+ Result := N;
+ return;
+ end if;
+ end loop;
+ end Expect;
+
+ ---------------------
+ -- Expect_Internal --
+ ---------------------
+
+ procedure Expect_Internal
+ (Descriptors : in out Array_Of_Pd;
+ Result : out Expect_Match;
+ Timeout : Integer;
+ Full_Buffer : Boolean)
+ is
+ Num_Descriptors : Integer;
+ Buffer_Size : Integer := 0;
+
+ N : Integer;
+
+ type File_Descriptor_Array is
+ array (Descriptors'Range) of File_Descriptor;
+ Fds : aliased File_Descriptor_Array;
+
+ type Integer_Array is array (Descriptors'Range) of Integer;
+ Is_Set : aliased Integer_Array;
+
+ begin
+ for J in Descriptors'Range loop
+ Fds (J) := Descriptors (J).Output_Fd;
+
+ if Descriptors (J).Buffer_Size = 0 then
+ Buffer_Size := Integer'Max (Buffer_Size, 4096);
+ else
+ Buffer_Size :=
+ Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size);
+ end if;
+ end loop;
+
+ declare
+ Buffer : aliased String (1 .. Buffer_Size);
+ -- Buffer used for input. This is allocated only once, not for
+ -- every iteration of the loop
+
+ begin
+ -- Loop until we match or we have a timeout
+
+ loop
+ Num_Descriptors :=
+ Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address);
+
+ case Num_Descriptors is
+
+ -- Error?
+
+ when -1 =>
+ raise Process_Died;
+
+ -- Timeout?
+
+ when 0 =>
+ Result := Expect_Timeout;
+ return;
+
+ -- Some input
+
+ when others =>
+ for J in Descriptors'Range loop
+ if Is_Set (J) = 1 then
+ Buffer_Size := Descriptors (J).Buffer_Size;
+
+ if Buffer_Size = 0 then
+ Buffer_Size := 4096;
+ end if;
+
+ N := Read (Descriptors (J).Output_Fd, Buffer'Address,
+ Buffer_Size);
+
+ -- Error or End of file
+
+ if N <= 0 then
+ -- ??? Note that ddd tries again up to three times
+ -- in that case. See LiterateA.C:174
+ raise Process_Died;
+
+ else
+ -- If there is no limit to the buffer size
+
+ if Descriptors (J).Buffer_Size = 0 then
+
+ declare
+ Tmp : String_Access := Descriptors (J).Buffer;
+
+ begin
+ if Tmp /= null then
+ Descriptors (J).Buffer :=
+ new String (1 .. Tmp'Length + N);
+ Descriptors (J).Buffer (1 .. Tmp'Length) :=
+ Tmp.all;
+ Descriptors (J).Buffer
+ (Tmp'Length + 1 .. Tmp'Length + N) :=
+ Buffer (1 .. N);
+ Free (Tmp);
+ Descriptors (J).Buffer_Index :=
+ Descriptors (J).Buffer'Last;
+
+ else
+ Descriptors (J).Buffer :=
+ new String (1 .. N);
+ Descriptors (J).Buffer.all :=
+ Buffer (1 .. N);
+ Descriptors (J).Buffer_Index := N;
+ end if;
+ end;
+
+ else
+ -- Add what we read to the buffer
+
+ if Descriptors (J).Buffer_Index + N - 1 >
+ Descriptors (J).Buffer_Size
+ then
+ -- If the user wants to know when we have
+ -- read more than the buffer can contain.
+
+ if Full_Buffer then
+ Result := Expect_Full_Buffer;
+ return;
+ end if;
+
+ -- Keep as much as possible from the buffer,
+ -- and forget old characters.
+
+ Descriptors (J).Buffer
+ (1 .. Descriptors (J).Buffer_Size - N) :=
+ Descriptors (J).Buffer
+ (N - Descriptors (J).Buffer_Size +
+ Descriptors (J).Buffer_Index + 1 ..
+ Descriptors (J).Buffer_Index);
+ Descriptors (J).Buffer_Index :=
+ Descriptors (J).Buffer_Size - N;
+ end if;
+
+ -- Keep what we read in the buffer.
+
+ Descriptors (J).Buffer
+ (Descriptors (J).Buffer_Index + 1 ..
+ Descriptors (J).Buffer_Index + N) :=
+ Buffer (1 .. N);
+ Descriptors (J).Buffer_Index :=
+ Descriptors (J).Buffer_Index + N;
+ end if;
+
+ -- Call each of the output filter with what we
+ -- read.
+
+ Call_Filters
+ (Descriptors (J).all, Buffer (1 .. N), Output);
+
+ Result := Expect_Match (N);
+ return;
+ end if;
+ end if;
+ end loop;
+ end case;
+ end loop;
+ end;
+ end Expect_Internal;
+
+ ----------------
+ -- Expect_Out --
+ ----------------
+
+ function Expect_Out (Descriptor : Process_Descriptor) return String is
+ begin
+ return Descriptor.Buffer (1 .. Descriptor.Last_Match_End);
+ end Expect_Out;
+
+ ----------------------
+ -- Expect_Out_Match --
+ ----------------------
+
+ function Expect_Out_Match (Descriptor : Process_Descriptor) return String is
+ begin
+ return Descriptor.Buffer
+ (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End);
+ end Expect_Out_Match;
+
+ -----------
+ -- Flush --
+ -----------
+
+ procedure Flush
+ (Descriptor : in out Process_Descriptor;
+ Timeout : Integer := 0)
+ is
+ Buffer_Size : constant Integer := 8192;
+ Num_Descriptors : Integer;
+ N : Integer;
+ Is_Set : aliased Integer;
+ Buffer : aliased String (1 .. Buffer_Size);
+
+ begin
+ -- Empty the current buffer
+
+ Descriptor.Last_Match_End := Descriptor.Buffer_Index;
+ Reinitialize_Buffer (Descriptor);
+
+ -- Read everything from the process to flush its output
+
+ loop
+ Num_Descriptors :=
+ Poll (Descriptor.Output_Fd'Address, 1, Timeout, Is_Set'Address);
+
+ case Num_Descriptors is
+
+ -- Error ?
+
+ when -1 =>
+ raise Process_Died;
+
+ -- Timeout => End of flush
+
+ when 0 =>
+ return;
+
+ -- Some input
+
+ when others =>
+ if Is_Set = 1 then
+ N := Read (Descriptor.Output_Fd, Buffer'Address,
+ Buffer_Size);
+
+ if N = -1 then
+ raise Process_Died;
+ elsif N = 0 then
+ return;
+ end if;
+ end if;
+ end case;
+ end loop;
+
+ end Flush;
+
+ ------------------
+ -- Get_Error_Fd --
+ ------------------
+
+ function Get_Error_Fd
+ (Descriptor : Process_Descriptor)
+ return GNAT.OS_Lib.File_Descriptor
+ is
+ begin
+ return Descriptor.Error_Fd;
+ end Get_Error_Fd;
+
+ ------------------
+ -- Get_Input_Fd --
+ ------------------
+
+ function Get_Input_Fd
+ (Descriptor : Process_Descriptor)
+ return GNAT.OS_Lib.File_Descriptor
+ is
+ begin
+ return Descriptor.Input_Fd;
+ end Get_Input_Fd;
+
+ -------------------
+ -- Get_Output_Fd --
+ -------------------
+
+ function Get_Output_Fd
+ (Descriptor : Process_Descriptor)
+ return GNAT.OS_Lib.File_Descriptor
+ is
+ begin
+ return Descriptor.Output_Fd;
+ end Get_Output_Fd;
+
+ -------------
+ -- Get_Pid --
+ -------------
+
+ function Get_Pid
+ (Descriptor : Process_Descriptor)
+ return Process_Id
+ is
+ begin
+ return Descriptor.Pid;
+ end Get_Pid;
+
+ ---------------
+ -- Interrupt --
+ ---------------
+
+ procedure Interrupt (Descriptor : in out Process_Descriptor) is
+ SIGINT : constant := 2;
+
+ begin
+ Send_Signal (Descriptor, SIGINT);
+ end Interrupt;
+
+ ------------------
+ -- Lock_Filters --
+ ------------------
+
+ procedure Lock_Filters (Descriptor : in out Process_Descriptor) is
+ begin
+ Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1;
+ end Lock_Filters;
+
+ ------------------------
+ -- Non_Blocking_Spawn --
+ ------------------------
+
+ procedure Non_Blocking_Spawn
+ (Descriptor : out Process_Descriptor'Class;
+ Command : String;
+ Args : GNAT.OS_Lib.Argument_List;
+ Buffer_Size : Natural := 4096;
+ Err_To_Out : Boolean := False)
+ is
+ function Alloc_Vfork_Blocks return Integer;
+ pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks");
+
+ function Get_Vfork_Jmpbuf return System.Address;
+ pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf");
+
+ function Get_Current_Invo_Context (Addr : System.Address)
+ return Process_Id;
+ pragma Import (C, Get_Current_Invo_Context,
+ "LIB$GET_CURRENT_INVO_CONTEXT");
+
+ Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
+
+ Arg : String_Access;
+ Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
+
+ Command_With_Path : String_Access;
+
+ begin
+ -- Create the rest of the pipes
+
+ Set_Up_Communications
+ (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
+
+ Command_With_Path := Locate_Exec_On_Path (Command);
+
+ if Command_With_Path = null then
+ raise Invalid_Process;
+ end if;
+
+ -- Fork a new process. It's not possible to do this in a subprogram.
+
+ if Alloc_Vfork_Blocks >= 0 then
+ Descriptor.Pid := Get_Current_Invo_Context (Get_Vfork_Jmpbuf);
+ else
+ Descriptor.Pid := -1;
+ end if;
+
+ -- Are we now in the child (or, for Windows, still in the common
+ -- process).
+
+ if Descriptor.Pid = Null_Pid then
+ -- Prepare an array of arguments to pass to C
+
+ Arg := new String (1 .. Command_With_Path'Length + 1);
+ Arg (1 .. Command_With_Path'Length) := Command_With_Path.all;
+ Arg (Arg'Last) := ASCII.Nul;
+ Arg_List (1) := Arg.all'Address;
+
+ for J in Args'Range loop
+ Arg := new String (1 .. Args (J)'Length + 1);
+ Arg (1 .. Args (J)'Length) := Args (J).all;
+ Arg (Arg'Last) := ASCII.Nul;
+ Arg_List (J + 2 - Args'First) := Arg.all'Address;
+ end loop;
+
+ Arg_List (Arg_List'Last) := System.Null_Address;
+
+ -- This does not return on Unix systems
+
+ Set_Up_Child_Communications
+ (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
+ Arg_List'Address);
+ end if;
+
+ Free (Command_With_Path);
+
+ -- Did we have an error when spawning the child ?
+
+ if Descriptor.Pid < Null_Pid then
+ raise Invalid_Process;
+ else
+ -- We are now in the parent process
+
+ Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3);
+ end if;
+
+ -- Create the buffer
+
+ Descriptor.Buffer_Size := Buffer_Size;
+
+ if Buffer_Size /= 0 then
+ Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
+ end if;
+ end Non_Blocking_Spawn;
+
+ -------------------------
+ -- Reinitialize_Buffer --
+ -------------------------
+
+ procedure Reinitialize_Buffer
+ (Descriptor : in out Process_Descriptor'Class)
+ is
+ begin
+ if Descriptor.Buffer_Size = 0 then
+ declare
+ Tmp : String_Access := Descriptor.Buffer;
+
+ begin
+ Descriptor.Buffer :=
+ new String
+ (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End);
+
+ if Tmp /= null then
+ Descriptor.Buffer.all := Tmp
+ (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
+ Free (Tmp);
+ end if;
+ end;
+
+ Descriptor.Buffer_Index := Descriptor.Buffer'Last;
+
+ else
+ Descriptor.Buffer
+ (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) :=
+ Descriptor.Buffer
+ (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index);
+
+ if Descriptor.Buffer_Index > Descriptor.Last_Match_End then
+ Descriptor.Buffer_Index :=
+ Descriptor.Buffer_Index - Descriptor.Last_Match_End;
+ else
+ Descriptor.Buffer_Index := 0;
+ end if;
+ end if;
+
+ Descriptor.Last_Match_Start := 0;
+ Descriptor.Last_Match_End := 0;
+ end Reinitialize_Buffer;
+
+ -------------------
+ -- Remove_Filter --
+ -------------------
+
+ procedure Remove_Filter
+ (Descriptor : in out Process_Descriptor;
+ Filter : Filter_Function)
+ is
+ Previous : Filter_List := null;
+ Current : Filter_List := Descriptor.Filters;
+
+ begin
+ while Current /= null loop
+ if Current.Filter = Filter then
+ if Previous = null then
+ Descriptor.Filters := Current.Next;
+ else
+ Previous.Next := Current.Next;
+ end if;
+ end if;
+
+ Previous := Current;
+ Current := Current.Next;
+ end loop;
+ end Remove_Filter;
+
+ ----------
+ -- Send --
+ ----------
+
+ procedure Send
+ (Descriptor : in out Process_Descriptor;
+ Str : String;
+ Add_LF : Boolean := True;
+ Empty_Buffer : Boolean := False)
+ is
+ N : Natural;
+ Full_Str : constant String := Str & ASCII.LF;
+ Last : Natural;
+ Result : Expect_Match;
+ Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
+
+ begin
+ if Empty_Buffer then
+
+ -- Force a read on the process if there is anything waiting.
+
+ Expect_Internal (Descriptors, Result,
+ Timeout => 0, Full_Buffer => False);
+ Descriptor.Last_Match_End := Descriptor.Buffer_Index;
+
+ -- Empty the buffer
+
+ Reinitialize_Buffer (Descriptor);
+ end if;
+
+ if Add_LF then
+ Last := Full_Str'Last;
+ else
+ Last := Full_Str'Last - 1;
+ end if;
+
+ Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input);
+
+ N := Write (Descriptor.Input_Fd,
+ Full_Str'Address,
+ Last - Full_Str'First + 1);
+ end Send;
+
+ -----------------
+ -- Send_Signal --
+ -----------------
+
+ procedure Send_Signal
+ (Descriptor : Process_Descriptor;
+ Signal : Integer)
+ is
+ begin
+ Kill (Descriptor.Pid, Signal);
+ -- ??? Need to check process status here.
+ end Send_Signal;
+
+ ---------------------------------
+ -- Set_Up_Child_Communications --
+ ---------------------------------
+
+ procedure Set_Up_Child_Communications
+ (Pid : in out Process_Descriptor;
+ Pipe1 : in out Pipe_Type;
+ Pipe2 : in out Pipe_Type;
+ Pipe3 : in out Pipe_Type;
+ Cmd : in String;
+ Args : in System.Address)
+ is
+ pragma Warnings (Off, Pid);
+
+ begin
+ -- Since the code between fork and exec on VMS executes
+ -- in the context of the parent process, we need to
+ -- perform the following actions:
+ -- - save stdin, stdout, stderr
+ -- - replace them by our pipes
+ -- - create the child with process handle inheritance
+ -- - revert to the previous stdin, stdout and stderr.
+
+ Save_Input := Dup (GNAT.OS_Lib.Standin);
+ Save_Output := Dup (GNAT.OS_Lib.Standout);
+ Save_Error := Dup (GNAT.OS_Lib.Standerr);
+
+ -- Since we are still called from the parent process, there is no way
+ -- currently we can cleanly close the unneeded ends of the pipes, but
+ -- this doesn't really matter.
+ -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input.
+
+ Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin);
+ Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout);
+ Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr);
+
+ Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.Nul, Args);
+
+ end Set_Up_Child_Communications;
+
+ ---------------------------
+ -- Set_Up_Communications --
+ ---------------------------
+
+ procedure Set_Up_Communications
+ (Pid : in out Process_Descriptor;
+ Err_To_Out : Boolean;
+ Pipe1 : access Pipe_Type;
+ Pipe2 : access Pipe_Type;
+ Pipe3 : access Pipe_Type)
+ is
+ begin
+ -- Create the pipes
+
+ if Create_Pipe (Pipe1) /= 0 then
+ return;
+ end if;
+
+ if Create_Pipe (Pipe2) /= 0 then
+ return;
+ end if;
+
+ Pid.Input_Fd := Pipe1.Output;
+ Pid.Output_Fd := Pipe2.Input;
+
+ if Err_To_Out then
+ Pipe3.all := Pipe2.all;
+ else
+ if Create_Pipe (Pipe3) /= 0 then
+ return;
+ end if;
+ end if;
+
+ Pid.Error_Fd := Pipe3.Input;
+ end Set_Up_Communications;
+
+ ----------------------------------
+ -- Set_Up_Parent_Communications --
+ ----------------------------------
+
+ procedure Set_Up_Parent_Communications
+ (Pid : in out Process_Descriptor;
+ Pipe1 : in out Pipe_Type;
+ Pipe2 : in out Pipe_Type;
+ Pipe3 : in out Pipe_Type)
+ is
+ pragma Warnings (Off, Pid);
+
+ begin
+
+ Dup2 (Save_Input, GNAT.OS_Lib.Standin);
+ Dup2 (Save_Output, GNAT.OS_Lib.Standout);
+ Dup2 (Save_Error, GNAT.OS_Lib.Standerr);
+
+ Close (Save_Input);
+ Close (Save_Output);
+ Close (Save_Error);
+
+ Close (Pipe1.Input);
+ Close (Pipe2.Output);
+ Close (Pipe3.Output);
+ end Set_Up_Parent_Communications;
+
+ ------------------
+ -- Trace_Filter --
+ ------------------
+
+ procedure Trace_Filter
+ (Descriptor : Process_Descriptor'Class;
+ Str : String;
+ User_Data : System.Address := System.Null_Address)
+ is
+ pragma Warnings (Off, Descriptor);
+ pragma Warnings (Off, User_Data);
+
+ begin
+ GNAT.IO.Put (Str);
+ end Trace_Filter;
+
+ --------------------
+ -- Unlock_Filters --
+ --------------------
+
+ procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is
+ begin
+ if Descriptor.Filters_Lock > 0 then
+ Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1;
+ end if;
+ end Unlock_Filters;
+
+end GNAT.Expect;
diff --git a/gcc/ada/3vsoccon.ads b/gcc/ada/3vsoccon.ads
new file mode 100644
index 00000000000..76b2051e07c
--- /dev/null
+++ b/gcc/ada/3vsoccon.ads
@@ -0,0 +1,158 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . C O N S T A N T S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2000-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides target dependent definitions of constant for use
+-- by the GNAT.Sockets package (g-socket.ads). This package should not be
+-- directly with'ed by an applications program.
+
+-- This is the version for Alpha/VMS
+
+package GNAT.Sockets.Constants is
+
+ --------------
+ -- Families --
+ --------------
+
+ AF_INET : constant := 2; -- IPv4 address family
+ AF_INET6 : constant := 26; -- IPv6 address family
+
+ -----------
+ -- Modes --
+ -----------
+
+ SOCK_STREAM : constant := 1; -- Stream socket
+ SOCK_DGRAM : constant := 2; -- Datagram socket
+
+ -------------------
+ -- Socket errors --
+ -------------------
+
+ EACCES : constant := 13; -- Permission denied
+ EADDRINUSE : constant := 48; -- Address already in use
+ EADDRNOTAVAIL : constant := 49; -- Cannot assign address
+ EAFNOSUPPORT : constant := 47; -- Addr family not supported
+ EALREADY : constant := 37; -- Operation in progress
+ EBADF : constant := 9; -- Bad file descriptor
+ ECONNABORTED : constant := 53; -- Connection aborted
+ ECONNREFUSED : constant := 61; -- Connection refused
+ ECONNRESET : constant := 54; -- Connection reset by peer
+ EDESTADDRREQ : constant := 39; -- Destination addr required
+ EFAULT : constant := 45; -- Bad address
+ EHOSTDOWN : constant := 64; -- Host is down
+ EHOSTUNREACH : constant := 65; -- No route to host
+ EINPROGRESS : constant := 36; -- Operation now in progress
+ EINTR : constant := 4; -- Interrupted system call
+ EINVAL : constant := 22; -- Invalid argument
+ EIO : constant := 5; -- Input output error
+ EISCONN : constant := 56; -- Socket already connected
+ ELOOP : constant := 62; -- Too many symbolic lynks
+ EMFILE : constant := 24; -- Too many open files
+ EMSGSIZE : constant := 40; -- Message too long
+ ENAMETOOLONG : constant := 63; -- Name too long
+ ENETDOWN : constant := 50; -- Network is down
+ ENETRESET : constant := 52; -- Disconn. on network reset
+ ENETUNREACH : constant := 51; -- Network is unreachable
+ ENOBUFS : constant := 55; -- No buffer space available
+ ENOPROTOOPT : constant := 42; -- Protocol not available
+ ENOTCONN : constant := 57; -- Socket not connected
+ ENOTSOCK : constant := 38; -- Operation on non socket
+ EOPNOTSUPP : constant := 95; -- Operation not supported
+ EPFNOSUPPORT : constant := 46; -- Unknown protocol family
+ EPROTONOSUPPORT : constant := 43; -- Unknown protocol
+ EPROTOTYPE : constant := 41; -- Unknown protocol type
+ ESHUTDOWN : constant := 58; -- Cannot send once shutdown
+ ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported
+ ETIMEDOUT : constant := 60; -- Connection timed out
+ ETOOMANYREFS : constant := 59; -- Too many references
+ EWOULDBLOCK : constant := 35; -- Operation would block
+
+ -----------------
+ -- Host errors --
+ -----------------
+
+ HOST_NOT_FOUND : constant := 1; -- Unknown host
+ TRY_AGAIN : constant := 2; -- Host name lookup failure
+ NO_DATA : constant := 4; -- No data record for name
+ NO_RECOVERY : constant := 3; -- Non recoverable errors
+
+ -------------------
+ -- Control flags --
+ -------------------
+
+ FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
+ FIONREAD : constant := 1074030207; -- How many bytes to read
+
+ --------------------
+ -- Shutdown modes --
+ --------------------
+
+ SHUT_RD : constant := 0; -- No more recv
+ SHUT_WR : constant := 1; -- No more send
+ SHUT_RDWR : constant := 2; -- No more recv/send
+
+ ---------------------
+ -- Protocol levels --
+ ---------------------
+
+ SOL_SOCKET : constant := 16#FFFF#; -- Options for socket level
+ IPPROTO_IP : constant := 0; -- Dummy protocol for IP
+ IPPROTO_UDP : constant := 17; -- UDP
+ IPPROTO_TCP : constant := 6; -- TCP
+
+ -------------------
+ -- Request flags --
+ -------------------
+
+ MSG_OOB : constant := 1; -- Process out-of-band data
+ MSG_PEEK : constant := 2; -- Peek at incoming data
+ MSG_EOR : constant := 8; -- Send end of record
+ MSG_WAITALL : constant := 64; -- Wait for full reception
+
+ --------------------
+ -- Socket options --
+ --------------------
+
+ TCP_NODELAY : constant := 1; -- Do not coalesce packets
+ SO_SNDBUF : constant := 16#1001#; -- Set/get send buffer size
+ SO_RCVBUF : constant := 16#1002#; -- Set/get recv buffer size
+ SO_REUSEADDR : constant := 16#0004#; -- Bind reuse local address
+ SO_KEEPALIVE : constant := 16#0008#; -- Enable keep-alive msgs
+ SO_LINGER : constant := 16#0080#; -- Defer close to flush data
+ SO_ERROR : constant := 16#1007#; -- Get/clear error status
+ SO_BROADCAST : constant := 16#0020#; -- Can send broadcast msgs
+ IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group
+ IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group
+ IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL
+ IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback
+
+end GNAT.Sockets.Constants;
diff --git a/gcc/ada/3vsocthi.adb b/gcc/ada/3vsocthi.adb
new file mode 100644
index 00000000000..94bfccb1b7a
--- /dev/null
+++ b/gcc/ada/3vsocthi.adb
@@ -0,0 +1,577 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Temporary version for Alpha/VMS.
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Task_Lock;
+
+with Interfaces.C; use Interfaces.C;
+
+package body GNAT.Sockets.Thin is
+
+ Non_Blocking_Sockets : constant Fd_Set_Access
+ := New_Socket_Set (No_Socket_Set);
+ -- When this package is initialized with Process_Blocking_IO set
+ -- to True, sockets are set in non-blocking mode to avoid blocking
+ -- the whole process when a thread wants to perform a blocking IO
+ -- operation. But the user can also set a socket in non-blocking
+ -- mode by purpose. In order to make a difference between these
+ -- two situations, we track the origin of non-blocking mode in
+ -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
+ -- been set in non-blocking mode by the user.
+
+ Quantum : constant Duration := 0.2;
+ -- When Thread_Blocking_IO is False, we set sockets in
+ -- non-blocking mode and we spend a period of time Quantum between
+ -- two attempts on a blocking operation.
+
+ Thread_Blocking_IO : Boolean := True;
+
+ function Syscall_Accept
+ (S : C.int;
+ Addr : System.Address;
+ Addrlen : access C.int)
+ return C.int;
+ pragma Import (C, Syscall_Accept, "accept");
+
+ function Syscall_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int)
+ return C.int;
+ pragma Import (C, Syscall_Connect, "connect");
+
+ function Syscall_Ioctl
+ (S : C.int;
+ Req : C.int;
+ Arg : Int_Access)
+ return C.int;
+ pragma Import (C, Syscall_Ioctl, "ioctl");
+
+ function Syscall_Recv
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int;
+ pragma Import (C, Syscall_Recv, "recv");
+
+ function Syscall_Recvfrom
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ From : Sockaddr_In_Access;
+ Fromlen : access C.int)
+ return C.int;
+ pragma Import (C, Syscall_Recvfrom, "recvfrom");
+
+ function Syscall_Send
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int;
+ pragma Import (C, Syscall_Send, "send");
+
+ function Syscall_Sendto
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ To : Sockaddr_In_Access;
+ Tolen : C.int)
+ return C.int;
+ pragma Import (C, Syscall_Sendto, "sendto");
+
+ function Syscall_Socket
+ (Domain, Typ, Protocol : C.int)
+ return C.int;
+ pragma Import (C, Syscall_Socket, "socket");
+
+ function Non_Blocking_Socket (S : C.int) return Boolean;
+ procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
+
+ --------------
+ -- C_Accept --
+ --------------
+
+ function C_Accept
+ (S : C.int;
+ Addr : System.Address;
+ Addrlen : access C.int)
+ return C.int
+ is
+ R : C.int;
+ Val : aliased C.int := 1;
+
+ Discard : C.int;
+ pragma Warnings (Off, Discard);
+
+ begin
+ loop
+ R := Syscall_Accept (S, Addr, Addrlen);
+ exit when Thread_Blocking_IO
+ or else R /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= Constants.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ if not Thread_Blocking_IO
+ and then R /= Failure
+ then
+ -- A socket inherits the properties ot its server especially
+ -- the FIONBIO flag. Do not use C_Ioctl as this subprogram
+ -- tracks sockets set in non-blocking mode by user.
+
+ Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
+ Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
+ end if;
+
+ return R;
+ end C_Accept;
+
+ ---------------
+ -- C_Connect --
+ ---------------
+
+ function C_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int)
+ return C.int
+ is
+ Res : C.int;
+
+ begin
+ Res := Syscall_Connect (S, Name, Namelen);
+
+ if Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= Constants.EINPROGRESS
+ then
+ return Res;
+ end if;
+
+ declare
+ WSet : Fd_Set_Access;
+ Now : aliased Timeval;
+
+ begin
+ WSet := New_Socket_Set (No_Socket_Set);
+ loop
+ Insert_Socket_In_Set (WSet, S);
+ Now := Immediat;
+ Res := C_Select
+ (S + 1,
+ No_Fd_Set,
+ WSet,
+ No_Fd_Set,
+ Now'Unchecked_Access);
+
+ exit when Res > 0;
+
+ if Res = Failure then
+ Free_Socket_Set (WSet);
+ return Res;
+ end if;
+
+ delay Quantum;
+ end loop;
+
+ Free_Socket_Set (WSet);
+ end;
+
+ Res := Syscall_Connect (S, Name, Namelen);
+
+ if Res = Failure
+ and then Errno = Constants.EISCONN
+ then
+ return Thin.Success;
+ else
+ return Res;
+ end if;
+ end C_Connect;
+
+ -------------
+ -- C_Ioctl --
+ -------------
+
+ function C_Ioctl
+ (S : C.int;
+ Req : C.int;
+ Arg : Int_Access)
+ return C.int
+ is
+ begin
+ if not Thread_Blocking_IO
+ and then Req = Constants.FIONBIO
+ then
+ if Arg.all /= 0 then
+ Set_Non_Blocking_Socket (S, True);
+ end if;
+ end if;
+
+ return Syscall_Ioctl (S, Req, Arg);
+ end C_Ioctl;
+
+ ------------
+ -- C_Recv --
+ ------------
+
+ function C_Recv
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int
+ is
+ Res : C.int;
+
+ begin
+ loop
+ Res := Syscall_Recv (S, Msg, Len, Flags);
+ exit when Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= Constants.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ return Res;
+ end C_Recv;
+
+ ----------------
+ -- C_Recvfrom --
+ ----------------
+
+ function C_Recvfrom
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ From : Sockaddr_In_Access;
+ Fromlen : access C.int)
+ return C.int
+ is
+ Res : C.int;
+
+ begin
+ loop
+ Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
+ exit when Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= Constants.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ return Res;
+ end C_Recvfrom;
+
+ ------------
+ -- C_Send --
+ ------------
+
+ function C_Send
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int
+ is
+ Res : C.int;
+
+ begin
+ loop
+ Res := Syscall_Send (S, Msg, Len, Flags);
+ exit when Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= Constants.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ return Res;
+ end C_Send;
+
+ --------------
+ -- C_Sendto --
+ --------------
+
+ function C_Sendto
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ To : Sockaddr_In_Access;
+ Tolen : C.int)
+ return C.int
+ is
+ Res : C.int;
+
+ begin
+ loop
+ Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
+ exit when Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= Constants.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ return Res;
+ end C_Sendto;
+
+ --------------
+ -- C_Socket --
+ --------------
+
+ function C_Socket
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int)
+ return C.int
+ is
+ R : C.int;
+ Val : aliased C.int := 1;
+
+ Discard : C.int;
+ pragma Unreferenced (Discard);
+
+ begin
+ R := Syscall_Socket (Domain, Typ, Protocol);
+
+ if not Thread_Blocking_IO
+ and then R /= Failure
+ then
+ -- Do not use C_Ioctl as this subprogram tracks sockets set
+ -- in non-blocking mode by user.
+
+ Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
+ Set_Non_Blocking_Socket (R, False);
+ end if;
+
+ return R;
+ end C_Socket;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize is
+ begin
+ null;
+ end Finalize;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Process_Blocking_IO : Boolean) is
+ begin
+ Thread_Blocking_IO := not Process_Blocking_IO;
+ end Initialize;
+
+ -------------------------
+ -- Non_Blocking_Socket --
+ -------------------------
+
+ function Non_Blocking_Socket (S : C.int) return Boolean is
+ R : Boolean;
+
+ begin
+ Task_Lock.Lock;
+ R := Is_Socket_In_Set (Non_Blocking_Sockets, S);
+ Task_Lock.Unlock;
+ return R;
+ end Non_Blocking_Socket;
+
+ -----------------
+ -- Set_Address --
+ -----------------
+
+ procedure Set_Address
+ (Sin : Sockaddr_In_Access;
+ Address : In_Addr)
+ is
+ begin
+ Sin.Sin_Addr := Address;
+ end Set_Address;
+
+ ----------------
+ -- Set_Family --
+ ----------------
+
+ procedure Set_Family
+ (Sin : Sockaddr_In_Access;
+ Family : C.int)
+ is
+ begin
+ Sin.Sin_Family := C.unsigned_short (Family);
+ end Set_Family;
+
+ ----------------
+ -- Set_Length --
+ ----------------
+
+ procedure Set_Length
+ (Sin : Sockaddr_In_Access;
+ Len : C.int)
+ is
+ pragma Unreferenced (Sin);
+ pragma Unreferenced (Len);
+
+ begin
+ null;
+ end Set_Length;
+
+ -----------------------------
+ -- Set_Non_Blocking_Socket --
+ -----------------------------
+
+ procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
+ begin
+ Task_Lock.Lock;
+
+ if V then
+ Insert_Socket_In_Set (Non_Blocking_Sockets, S);
+ else
+ Remove_Socket_From_Set (Non_Blocking_Sockets, S);
+ end if;
+
+ Task_Lock.Unlock;
+ end Set_Non_Blocking_Socket;
+
+ --------------
+ -- Set_Port --
+ --------------
+
+ procedure Set_Port
+ (Sin : Sockaddr_In_Access;
+ Port : C.unsigned_short)
+ is
+ begin
+ Sin.Sin_Port := Port;
+ end Set_Port;
+
+ --------------------------
+ -- Socket_Error_Message --
+ --------------------------
+
+ function Socket_Error_Message (Errno : Integer) return String is
+ use type Interfaces.C.Strings.chars_ptr;
+
+ C_Msg : C.Strings.chars_ptr;
+
+ begin
+ C_Msg := C_Strerror (C.int (Errno));
+
+ if C_Msg = C.Strings.Null_Ptr then
+ return "Unknown system error";
+
+ else
+ return C.Strings.Value (C_Msg);
+ end if;
+ end Socket_Error_Message;
+
+ -------------
+ -- C_Readv --
+ -------------
+
+ function C_Readv
+ (Fd : C.int;
+ Iov : System.Address;
+ Iovcnt : C.int)
+ return C.int
+ is
+ Res : C.int;
+ Count : C.int := 0;
+
+ Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
+ for Iovec'Address use Iov;
+ pragma Import (Ada, Iovec);
+
+ begin
+ for J in Iovec'Range loop
+ Res := C_Read
+ (Fd,
+ Iovec (J).Base.all'Address,
+ Interfaces.C.int (Iovec (J).Length));
+
+ if Res < 0 then
+ return Res;
+ else
+ Count := Count + Res;
+ end if;
+ end loop;
+ return Count;
+ end C_Readv;
+
+ --------------
+ -- C_Writev --
+ --------------
+
+ function C_Writev
+ (Fd : C.int;
+ Iov : System.Address;
+ Iovcnt : C.int)
+ return C.int
+ is
+ Res : C.int;
+ Count : C.int := 0;
+
+ Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
+ for Iovec'Address use Iov;
+ pragma Import (Ada, Iovec);
+
+ begin
+ for J in Iovec'Range loop
+ Res := C_Write
+ (Fd,
+ Iovec (J).Base.all'Address,
+ Interfaces.C.int (Iovec (J).Length));
+
+ if Res < 0 then
+ return Res;
+ else
+ Count := Count + Res;
+ end if;
+ end loop;
+ return Count;
+ end C_Writev;
+
+end GNAT.Sockets.Thin;
diff --git a/gcc/ada/3vsocthi.ads b/gcc/ada/3vsocthi.ads
new file mode 100644
index 00000000000..62a1d082564
--- /dev/null
+++ b/gcc/ada/3vsocthi.ads
@@ -0,0 +1,445 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a target dependent thin interface to the sockets
+-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
+-- should not be directly with'ed by an applications program.
+
+-- This is the Alpha/VMS version.
+
+with Interfaces.C.Pointers;
+
+with Interfaces.C.Strings;
+with GNAT.Sockets.Constants;
+with GNAT.OS_Lib;
+
+with System;
+
+package GNAT.Sockets.Thin is
+
+ -- ??? more comments needed ???
+
+ package C renames Interfaces.C;
+
+ use type C.int;
+ -- This is so we can declare the Failure constant below
+
+ Success : constant C.int := 0;
+ Failure : constant C.int := -1;
+
+ function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
+ -- Returns last socket error number.
+
+ function Socket_Error_Message (Errno : Integer) return String;
+ -- Returns the error message string for the error number Errno. If
+ -- Errno is not known it returns "Unknown system error".
+
+ subtype Fd_Set_Access is System.Address;
+ No_Fd_Set : constant Fd_Set_Access := System.Null_Address;
+
+ type Timeval_Unit is new C.int;
+ pragma Convention (C, Timeval_Unit);
+
+ type Timeval is record
+ Tv_Sec : Timeval_Unit;
+ Tv_Usec : Timeval_Unit;
+ end record;
+ pragma Convention (C, Timeval);
+
+ type Timeval_Access is access all Timeval;
+ pragma Convention (C, Timeval_Access);
+
+ Immediat : constant Timeval := (0, 0);
+
+ type Int_Access is access all C.int;
+ pragma Convention (C, Int_Access);
+ -- Access to C integers
+
+ type Chars_Ptr_Array is array (C.size_t range <>) of
+ aliased C.Strings.chars_ptr;
+
+ package Chars_Ptr_Pointers is
+ new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array,
+ C.Strings.Null_Ptr);
+ -- Arrays of C (char *)
+
+ type In_Addr is record
+ S_B1, S_B2, S_B3, S_B4 : C.unsigned_char;
+ end record;
+ pragma Convention (C, In_Addr);
+ -- Internet address
+
+ type In_Addr_Access is access all In_Addr;
+ pragma Convention (C, In_Addr_Access);
+ -- Access to internet address
+
+ Inaddr_Any : aliased constant In_Addr := (others => 0);
+ -- Any internet address (all the interfaces)
+
+ type In_Addr_Access_Array is array (C.size_t range <>)
+ of aliased In_Addr_Access;
+ pragma Convention (C, In_Addr_Access_Array);
+
+ package In_Addr_Access_Pointers is
+ new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null);
+ -- Array of internet addresses
+
+ type Sockaddr is record
+ Sa_Family : C.unsigned_short;
+ Sa_Data : C.char_array (1 .. 14);
+ end record;
+ pragma Convention (C, Sockaddr);
+ -- Socket address
+
+ type Sockaddr_Access is access all Sockaddr;
+ pragma Convention (C, Sockaddr_Access);
+ -- Access to socket address
+
+ type Sockaddr_In is record
+ Sin_Family : C.unsigned_short := Constants.AF_INET;
+ Sin_Port : C.unsigned_short := 0;
+ Sin_Addr : In_Addr := Inaddr_Any;
+ Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0));
+ end record;
+ pragma Convention (C, Sockaddr_In);
+ -- Internet socket address
+
+ type Sockaddr_In_Access is access all Sockaddr_In;
+ pragma Convention (C, Sockaddr_In_Access);
+ -- Access to internet socket address
+
+ procedure Set_Length
+ (Sin : Sockaddr_In_Access;
+ Len : C.int);
+ pragma Inline (Set_Length);
+ -- Set Sin.Sin_Length to Len.
+ -- On this platform, nothing is done as there is no such field.
+
+ procedure Set_Family
+ (Sin : Sockaddr_In_Access;
+ Family : C.int);
+ pragma Inline (Set_Family);
+ -- Set Sin.Sin_Family to Family
+
+ procedure Set_Port
+ (Sin : Sockaddr_In_Access;
+ Port : C.unsigned_short);
+ pragma Inline (Set_Port);
+ -- Set Sin.Sin_Port to Port
+
+ procedure Set_Address
+ (Sin : Sockaddr_In_Access;
+ Address : In_Addr);
+ pragma Inline (Set_Address);
+ -- Set Sin.Sin_Addr to Address
+
+ type Hostent is record
+ H_Name : C.Strings.chars_ptr;
+ H_Aliases : Chars_Ptr_Pointers.Pointer;
+ H_Addrtype : C.int;
+ H_Length : C.int;
+ H_Addr_List : In_Addr_Access_Pointers.Pointer;
+ end record;
+ pragma Convention (C, Hostent);
+ -- Host entry
+
+ type Hostent_Access is access all Hostent;
+ pragma Convention (C, Hostent_Access);
+ -- Access to host entry
+
+ type Servent is record
+ S_Name : C.Strings.chars_ptr;
+ S_Aliases : Chars_Ptr_Pointers.Pointer;
+ S_Port : C.int;
+ S_Proto : C.Strings.chars_ptr;
+ end record;
+ pragma Convention (C, Servent);
+ -- Service entry
+
+ type Servent_Access is access all Servent;
+ pragma Convention (C, Servent_Access);
+ -- Access to service entry
+
+ type Two_Int is array (0 .. 1) of C.int;
+ pragma Convention (C, Two_Int);
+ -- Used with pipe()
+
+ function C_Accept
+ (S : C.int;
+ Addr : System.Address;
+ Addrlen : access C.int)
+ return C.int;
+
+ function C_Bind
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int)
+ return C.int;
+
+ function C_Close
+ (Fd : C.int)
+ return C.int;
+
+ function C_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int)
+ return C.int;
+
+ function C_Gethostbyaddr
+ (Addr : System.Address;
+ Len : C.int;
+ Typ : C.int)
+ return Hostent_Access;
+
+ function C_Gethostbyname
+ (Name : C.char_array)
+ return Hostent_Access;
+
+ function C_Gethostname
+ (Name : System.Address;
+ Namelen : C.int)
+ return C.int;
+
+ function C_Getpeername
+ (S : C.int;
+ Name : System.Address;
+ Namelen : access C.int)
+ return C.int;
+
+ function C_Getservbyname
+ (Name : C.char_array;
+ Proto : C.char_array)
+ return Servent_Access;
+
+ function C_Getservbyport
+ (Port : C.int;
+ Proto : C.char_array)
+ return Servent_Access;
+
+ function C_Getsockname
+ (S : C.int;
+ Name : System.Address;
+ Namelen : access C.int)
+ return C.int;
+
+ function C_Getsockopt
+ (S : C.int;
+ Level : C.int;
+ Optname : C.int;
+ Optval : System.Address;
+ Optlen : access C.int)
+ return C.int;
+
+ function C_Inet_Addr
+ (Cp : C.Strings.chars_ptr)
+ return C.int;
+
+ function C_Ioctl
+ (S : C.int;
+ Req : C.int;
+ Arg : Int_Access)
+ return C.int;
+
+ function C_Listen (S, Backlog : C.int) return C.int;
+
+ function C_Read
+ (Fd : C.int;
+ Buf : System.Address;
+ Count : C.int)
+ return C.int;
+
+ function C_Readv
+ (Fd : C.int;
+ Iov : System.Address;
+ Iovcnt : C.int)
+ return C.int;
+
+ function C_Recv
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int;
+
+ function C_Recvfrom
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ From : Sockaddr_In_Access;
+ Fromlen : access C.int)
+ return C.int;
+
+ function C_Select
+ (Nfds : C.int;
+ Readfds : Fd_Set_Access;
+ Writefds : Fd_Set_Access;
+ Exceptfds : Fd_Set_Access;
+ Timeout : Timeval_Access)
+ return C.int;
+
+ function C_Send
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int;
+
+ function C_Sendto
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ To : Sockaddr_In_Access;
+ Tolen : C.int)
+ return C.int;
+
+ function C_Setsockopt
+ (S : C.int;
+ Level : C.int;
+ Optname : C.int;
+ Optval : System.Address;
+ Optlen : C.int)
+ return C.int;
+
+ function C_Shutdown
+ (S : C.int;
+ How : C.int)
+ return C.int;
+
+ function C_Socket
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int)
+ return C.int;
+
+ function C_Strerror
+ (Errnum : C.int)
+ return C.Strings.chars_ptr;
+
+ function C_System
+ (Command : System.Address)
+ return C.int;
+
+ function C_Write
+ (Fd : C.int;
+ Buf : System.Address;
+ Count : C.int)
+ return C.int;
+
+ function C_Writev
+ (Fd : C.int;
+ Iov : System.Address;
+ Iovcnt : C.int)
+ return C.int;
+
+ procedure Free_Socket_Set
+ (Set : Fd_Set_Access);
+ -- Free system-dependent socket set.
+
+ procedure Get_Socket_From_Set
+ (Set : Fd_Set_Access;
+ Socket : Int_Access;
+ Last : Int_Access);
+ -- Get last socket in Socket and remove it from the socket
+ -- set. The parameter Last is a maximum value of the largest
+ -- socket. This hint is used to avoid scanning very large socket
+ -- sets. After a call to Get_Socket_From_Set, Last is set back to
+ -- the real largest socket in the socket set.
+
+ procedure Insert_Socket_In_Set
+ (Set : Fd_Set_Access;
+ Socket : C.int);
+ -- Insert socket in the socket set.
+
+ function Is_Socket_In_Set
+ (Set : Fd_Set_Access;
+ Socket : C.int)
+ return Boolean;
+ -- Check whether Socket is in the socket set.
+
+ procedure Last_Socket_In_Set
+ (Set : Fd_Set_Access;
+ Last : Int_Access);
+ -- Find the largest socket in the socket set. This is needed for
+ -- select(). When Last_Socket_In_Set is called, parameter Last is
+ -- a maximum value of the largest socket. This hint is used to
+ -- avoid scanning very large socket sets. After the call, Last is
+ -- set back to the real largest socket in the socket set.
+
+ function New_Socket_Set
+ (Set : Fd_Set_Access)
+ return Fd_Set_Access;
+ -- Allocate a new socket set which is a system-dependent structure
+ -- and initialize by copying Set if it is non-null, by making it
+ -- empty otherwise.
+
+ procedure Remove_Socket_From_Set
+ (Set : Fd_Set_Access;
+ Socket : C.int);
+ -- Remove socket from the socket set.
+
+ procedure Finalize;
+ procedure Initialize (Process_Blocking_IO : Boolean);
+
+private
+
+ pragma Import (C, C_Bind, "DECC$BIND");
+ pragma Import (C, C_Close, "DECC$CLOSE");
+ pragma Import (C, C_Gethostbyaddr, "DECC$GETHOSTBYADDR");
+ pragma Import (C, C_Gethostbyname, "DECC$GETHOSTBYNAME");
+ pragma Import (C, C_Gethostname, "DECC$GETHOSTNAME");
+ pragma Import (C, C_Getpeername, "DECC$GETPEERNAME");
+ pragma Import (C, C_Getservbyname, "DECC$GETSERVBYNAME");
+ pragma Import (C, C_Getservbyport, "DECC$GETSERVBYPORT");
+ pragma Import (C, C_Getsockname, "DECC$GETSOCKNAME");
+ pragma Import (C, C_Getsockopt, "DECC$GETSOCKOPT");
+ pragma Import (C, C_Inet_Addr, "DECC$INET_ADDR");
+ pragma Import (C, C_Listen, "DECC$LISTEN");
+ pragma Import (C, C_Read, "DECC$READ");
+ pragma Import (C, C_Select, "DECC$SELECT");
+ pragma Import (C, C_Setsockopt, "DECC$SETSOCKOPT");
+ pragma Import (C, C_Shutdown, "DECC$SHUTDOWN");
+ pragma Import (C, C_Strerror, "DECC$STRERROR");
+ pragma Import (C, C_System, "DECC$SYSTEM");
+ pragma Import (C, C_Write, "DECC$WRITE");
+
+ pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set");
+ pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set");
+ pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set");
+ pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set");
+ pragma Import (C, New_Socket_Set, "__gnat_new_socket_set");
+ pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set");
+ pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set");
+end GNAT.Sockets.Thin;
diff --git a/gcc/ada/3vtrasym.adb b/gcc/ada/3vtrasym.adb
new file mode 100644
index 00000000000..26382c11130
--- /dev/null
+++ b/gcc/ada/3vtrasym.adb
@@ -0,0 +1,185 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- G N A T . T R A C E B A C K . S Y M B O L I C --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1999-2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- Run-time symbolic traceback support for VMS
+
+with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
+with Interfaces.C;
+with Interfaces.C.Strings;
+with System;
+with System.Aux_DEC;
+with System.Soft_Links;
+with System.Traceback_Entries;
+
+package body GNAT.Traceback.Symbolic is
+
+ pragma Warnings (Off);
+ pragma Linker_Options ("--for-linker=sys$library:trace.exe");
+
+ use Interfaces.C.Strings;
+ use System;
+ use System.Aux_DEC;
+ use System.Traceback_Entries;
+
+ type Dscdef1_Type is record
+ Maxstrlen : Unsigned_Word;
+ Dtype : Unsigned_Byte;
+ Class : Unsigned_Byte;
+ Pointer : chars_ptr;
+ end record;
+
+ for Dscdef1_Type use record
+ Maxstrlen at 0 range 0 .. 15;
+ Dtype at 2 range 0 .. 7;
+ Class at 3 range 0 .. 7;
+ Pointer at 4 range 0 .. 31;
+ end record;
+ for Dscdef1_Type'Size use 64;
+
+ Image_Buf : String (1 .. 10240);
+ Image_Len : Integer;
+ Image_Need_Hdr : Boolean := True;
+ Image_Do_Another_Line : Boolean;
+ Image_Xtra_Msg : Boolean;
+
+ procedure Traceback_Image (Out_Desc : access Dscdef1_Type);
+
+ procedure Traceback_Image (Out_Desc : access Dscdef1_Type) is
+ Image : String (1 .. Integer (Out_Desc.Maxstrlen));
+ begin
+ Image := Value (Out_Desc.Pointer,
+ Interfaces.C.size_t (Out_Desc.Maxstrlen));
+
+ if Image_Do_Another_Line and then
+ (Image_Need_Hdr or else
+ Image (Image'First .. Image'First + 27) /=
+ " image module routine")
+ then
+ declare
+ First : Integer := Image_Len + 1;
+ Last : Integer := First + Image'Length - 1;
+ begin
+ Image_Buf (First .. Last + 1) := Image & ASCII.LF;
+ Image_Len := Last + 1;
+ end;
+
+ Image_Need_Hdr := False;
+
+ if Image (Image'First .. Image'First + 3) = "----" then
+ if Image_Xtra_Msg = False then
+ Image_Xtra_Msg := True;
+ else
+ Image_Xtra_Msg := False;
+ end if;
+ end if;
+
+ if Out_Desc.Maxstrlen = 79 and then not Image_Xtra_Msg then
+ Image_Len := Image_Len - 1;
+ Image_Do_Another_Line := False;
+ end if;
+ end if;
+ end Traceback_Image;
+
+ subtype User_Arg_Type is Unsigned_Longword;
+ subtype Cond_Value_Type is Unsigned_Longword;
+
+ procedure Show_Traceback
+ (Status : out Cond_Value_Type;
+ Faulting_FP : Address;
+ Faulting_SP : Address;
+ Faulting_PC : Address;
+ Detail_Level : Integer := Integer'Null_Parameter;
+ User_Act_Proc : Address := Address'Null_Parameter;
+ User_Arg_Value : User_Arg_Type := User_Arg_Type'Null_Parameter;
+ Exceptionn : Unsigned_Longword := Unsigned_Longword'Null_Parameter);
+
+ pragma Interface (External, Show_Traceback);
+
+ pragma Import_Valued_Procedure
+ (Show_Traceback, "TBK$SHOW_TRACEBACK",
+ (Cond_Value_Type, Address, Address, Address, Integer, Address,
+ User_Arg_Type, Unsigned_Longword),
+ (Value, Value, Value, Value, Reference, Value, Value, Reference),
+ Detail_Level);
+
+
+ ------------------------
+ -- Symbolic_Traceback --
+ ------------------------
+
+ function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is
+ Res : String (1 .. 256 * Traceback'Length);
+ Len : Integer;
+ Status : Cond_Value_Type;
+
+ begin
+ if Traceback'Length > 0 then
+
+ Len := 0;
+
+ -- Since image computation is not thread-safe we need task lockout
+ System.Soft_Links.Lock_Task.all;
+ for I in Traceback'Range loop
+ Image_Len := 0;
+ Image_Do_Another_Line := True;
+ Image_Xtra_Msg := False;
+
+ Show_Traceback
+ (Status,
+ FP_For (Traceback (I)),
+ SP_For (Traceback (I)),
+ PC_For (Traceback (I)),
+ 0,
+ Traceback_Image'Address);
+
+ declare
+ First : Integer := Len + 1;
+ Last : Integer := First + Image_Len - 1;
+ begin
+ Res (First .. Last + 1) := Image_Buf & ASCII.LF;
+ Len := Last + 1;
+ end;
+ end loop;
+ System.Soft_Links.Unlock_Task.all;
+
+ return Res (1 .. Len);
+ else
+ return "";
+ end if;
+ end Symbolic_Traceback;
+
+ function Symbolic_Traceback (E : Exception_Occurrence) return String is
+ begin
+ return Symbolic_Traceback (Tracebacks (E));
+ end Symbolic_Traceback;
+
+end GNAT.Traceback.Symbolic;
diff --git a/gcc/ada/3wsoccon.ads b/gcc/ada/3wsoccon.ads
index 252801da5ce..b4bb31564dc 100644
--- a/gcc/ada/3wsoccon.ads
+++ b/gcc/ada/3wsoccon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-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- --
@@ -26,109 +26,133 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+-- This package provides target dependent definitions of constant for use
+-- by the GNAT.Sockets package (g-socket.ads). This package should not be
+-- directly with'ed by an applications program.
+
-- This is the version for MINGW32 NT
package GNAT.Sockets.Constants is
- -- Families
-
- AF_INET : constant := 2;
- AF_INET6 : constant := 3;
-
- -- Modes
-
- SOCK_STREAM : constant := 1;
- SOCK_DGRAM : constant := 2;
-
- -- Socket Errors
-
- EINTR : constant := 10004;
- EBADF : constant := 10009;
- EACCES : constant := 10013;
- EFAULT : constant := 10014;
- EINVAL : constant := 10022;
- EMFILE : constant := 10024;
- EWOULDBLOCK : constant := 10035;
- EINPROGRESS : constant := 10036;
- EALREADY : constant := 10037;
- ENOTSOCK : constant := 10038;
- EDESTADDRREQ : constant := 10039;
- EMSGSIZE : constant := 10040;
- EPROTOTYPE : constant := 10041;
- ENOPROTOOPT : constant := 10042;
- EPROTONOSUPPORT : constant := 10043;
- ESOCKTNOSUPPORT : constant := 10044;
- EOPNOTSUPP : constant := 10045;
- EPFNOSUPPORT : constant := 10046;
- EAFNOSUPPORT : constant := 10047;
- EADDRINUSE : constant := 10048;
- EADDRNOTAVAIL : constant := 10049;
- ENETDOWN : constant := 10050;
- ENETUNREACH : constant := 10051;
- ENETRESET : constant := 10052;
- ECONNABORTED : constant := 10053;
- ECONNRESET : constant := 10054;
- ENOBUFS : constant := 10055;
- EISCONN : constant := 10056;
- ENOTCONN : constant := 10057;
- ESHUTDOWN : constant := 10058;
- ETOOMANYREFS : constant := 10059;
- ETIMEDOUT : constant := 10060;
- ECONNREFUSED : constant := 10061;
- ELOOP : constant := 10062;
- ENAMETOOLONG : constant := 10063;
- EHOSTDOWN : constant := 10064;
- EHOSTUNREACH : constant := 10065;
- SYSNOTREADY : constant := 10091;
- VERNOTSUPPORTED : constant := 10092;
- NOTINITIALISED : constant := 10093;
- EDISCON : constant := 10101;
-
- -- Host Errors
-
- HOST_NOT_FOUND : constant := 11001;
- TRY_AGAIN : constant := 11002;
- NO_RECOVERY : constant := 11003;
- NO_ADDRESS : constant := 11004;
- NO_DATA : constant := 11004;
-
- EIO : constant := 10101;
-
- -- Control Flags
-
- FIONBIO : constant := -2147195266;
- FIONREAD : constant := 1074030207;
-
- -- Shutdown Modes
-
- SHUT_RD : constant := 0;
- SHUT_WR : constant := 1;
- SHUT_RDWR : constant := 2;
-
- -- Protocol Levels
-
- SOL_SOCKET : constant := 65535;
- IPPROTO_IP : constant := 0;
- IPPROTO_UDP : constant := 17;
- IPPROTO_TCP : constant := 6;
-
- -- Socket Options
-
- TCP_NODELAY : constant := 1;
- SO_SNDBUF : constant := 4097;
- SO_RCVBUF : constant := 4098;
- SO_REUSEADDR : constant := 4;
- SO_KEEPALIVE : constant := 8;
- SO_LINGER : constant := 128;
- SO_ERROR : constant := 4103;
- SO_BROADCAST : constant := 32;
- IP_ADD_MEMBERSHIP : constant := 5;
- IP_DROP_MEMBERSHIP : constant := 6;
- IP_MULTICAST_TTL : constant := 3;
- IP_MULTICAST_LOOP : constant := 4;
+ --------------
+ -- Families --
+ --------------
+
+ AF_INET : constant := 2; -- IPv4 address family
+ AF_INET6 : constant := 3; -- IPv6 address family
+
+ -----------
+ -- Modes --
+ -----------
+
+ SOCK_STREAM : constant := 1; -- Stream socket
+ SOCK_DGRAM : constant := 2; -- Datagram socket
+
+ -------------------
+ -- Socket errors --
+ -------------------
+
+ EACCES : constant := 10013; -- Permission denied
+ EADDRINUSE : constant := 10048; -- Address already in use
+ EADDRNOTAVAIL : constant := 10049; -- Cannot assign address
+ EAFNOSUPPORT : constant := 10047; -- Addr family not supported
+ EALREADY : constant := 10037; -- Operation in progress
+ EBADF : constant := 10009; -- Bad file descriptor
+ ECONNABORTED : constant := 10053; -- Connection aborted
+ ECONNREFUSED : constant := 10061; -- Connection refused
+ ECONNRESET : constant := 10054; -- Connection reset by peer
+ EDESTADDRREQ : constant := 10039; -- Destination addr required
+ EFAULT : constant := 10014; -- Bad address
+ EHOSTDOWN : constant := 10064; -- Host is down
+ EHOSTUNREACH : constant := 10065; -- No route to host
+ EINPROGRESS : constant := 10036; -- Operation now in progress
+ EINTR : constant := 10004; -- Interrupted system call
+ EINVAL : constant := 10022; -- Invalid argument
+ EIO : constant := 10101; -- Input output error
+ EISCONN : constant := 10056; -- Socket already connected
+ ELOOP : constant := 10062; -- Too many symbolic lynks
+ EMFILE : constant := 10024; -- Too many open files
+ EMSGSIZE : constant := 10040; -- Message too long
+ ENAMETOOLONG : constant := 10063; -- Name too long
+ ENETDOWN : constant := 10050; -- Network is down
+ ENETRESET : constant := 10052; -- Disconn. on network reset
+ ENETUNREACH : constant := 10051; -- Network is unreachable
+ ENOBUFS : constant := 10055; -- No buffer space available
+ ENOPROTOOPT : constant := 10042; -- Protocol not available
+ ENOTCONN : constant := 10057; -- Socket not connected
+ ENOTSOCK : constant := 10038; -- Operation on non socket
+ EOPNOTSUPP : constant := 10045; -- Operation not supported
+ EPFNOSUPPORT : constant := 10046; -- Unknown protocol family
+ EPROTONOSUPPORT : constant := 10043; -- Unknown protocol
+ EPROTOTYPE : constant := 10041; -- Unknown protocol type
+ ESHUTDOWN : constant := 10058; -- Cannot send once shutdown
+ ESOCKTNOSUPPORT : constant := 10044; -- Socket type not supported
+ ETIMEDOUT : constant := 10060; -- Connection timed out
+ ETOOMANYREFS : constant := 10059; -- Too many references
+ EWOULDBLOCK : constant := 10035; -- Operation would block
+
+ -----------------
+ -- Host errors --
+ -----------------
+
+ HOST_NOT_FOUND : constant := 11001; -- Unknown host
+ TRY_AGAIN : constant := 11002; -- Host name lookup failure
+ NO_DATA : constant := 11004; -- No data record for name
+ NO_RECOVERY : constant := 11003; -- Non recoverable errors
+
+ -------------------
+ -- Control flags --
+ -------------------
+
+ FIONBIO : constant := -2147195266; -- Set/clear non-blocking io
+ FIONREAD : constant := 1074030207; -- How many bytes to read
+
+ --------------------
+ -- Shutdown modes --
+ --------------------
+
+ SHUT_RD : constant := 0; -- No more recv
+ SHUT_WR : constant := 1; -- No more send
+ SHUT_RDWR : constant := 2; -- No more recv/send
+
+ ---------------------
+ -- Protocol levels --
+ ---------------------
+
+ SOL_SOCKET : constant := 65535; -- Options for socket level
+ IPPROTO_IP : constant := 0; -- Dummy protocol for IP
+ IPPROTO_UDP : constant := 17; -- UDP
+ IPPROTO_TCP : constant := 6; -- TCP
+
+ -------------------
+ -- Request flags --
+ -------------------
+
+ MSG_OOB : constant := 1; -- Process out-of-band data
+ MSG_PEEK : constant := 2; -- Peek at incoming data
+ MSG_EOR : constant := -1; -- Send end of record
+ MSG_WAITALL : constant := -1; -- Wait for full reception
+
+ --------------------
+ -- Socket options --
+ --------------------
+
+ TCP_NODELAY : constant := 1; -- Do not coalesce packets
+ SO_SNDBUF : constant := 4097; -- Set/get send buffer size
+ SO_RCVBUF : constant := 4098; -- Set/get recv buffer size
+ SO_REUSEADDR : constant := 4; -- Bind reuse local address
+ SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs
+ SO_LINGER : constant := 128; -- Defer close to flush data
+ SO_ERROR : constant := 4103; -- Get/clear error status
+ SO_BROADCAST : constant := 32; -- Can send broadcast msgs
+ IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group
+ IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group
+ IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL
+ IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback
end GNAT.Sockets.Constants;
diff --git a/gcc/ada/3wsocthi.adb b/gcc/ada/3wsocthi.adb
index 9782121d90b..0fb9731530f 100644
--- a/gcc/ada/3wsocthi.adb
+++ b/gcc/ada/3wsocthi.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,12 +26,21 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+-- This package provides a target dependent thin interface to the sockets
+-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
+-- should not be directly with'ed by an applications program.
+
-- This version is for NT.
+with GNAT.Sockets.Constants; use GNAT.Sockets.Constants;
+
+with System; use System;
+
package body GNAT.Sockets.Thin is
use type C.unsigned;
@@ -41,75 +50,257 @@ package body GNAT.Sockets.Thin is
WS_Version : constant := 16#0101#;
Initialized : Boolean := False;
- -----------
- -- Clear --
- -----------
-
- procedure Clear
- (Item : in out Fd_Set;
- Socket : C.int)
+ SYSNOTREADY : constant := 10091;
+ VERNOTSUPPORTED : constant := 10092;
+ NOTINITIALISED : constant := 10093;
+ EDISCON : constant := 10101;
+
+ function Standard_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int)
+ return C.int;
+ pragma Import (Stdcall, Standard_Connect, "connect");
+
+ function Standard_Select
+ (Nfds : C.int;
+ Readfds : Fd_Set_Access;
+ Writefds : Fd_Set_Access;
+ Exceptfds : Fd_Set_Access;
+ Timeout : Timeval_Access)
+ return C.int;
+ pragma Import (Stdcall, Standard_Select, "select");
+
+ ---------------
+ -- C_Connect --
+ ---------------
+
+ function C_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int)
+ return C.int
is
+ Res : C.int;
+
begin
- for J in 1 .. Item.fd_count loop
- if Item.fd_array (J) = Socket then
- Item.fd_array (J .. Item.fd_count - 1) :=
- Item.fd_array (J + 1 .. Item.fd_count);
- Item.fd_count := Item.fd_count - 1;
- exit;
+ Res := Standard_Connect (S, Name, Namelen);
+
+ if Res = -1 then
+ if Socket_Errno = EWOULDBLOCK then
+ Set_Socket_Errno (EINPROGRESS);
end if;
- end loop;
- end Clear;
+ end if;
- -----------
- -- Empty --
- -----------
+ return Res;
+ end C_Connect;
+
+ -------------
+ -- C_Readv --
+ -------------
+
+ function C_Readv
+ (Socket : C.int;
+ Iov : System.Address;
+ Iovcnt : C.int)
+ return C.int
+ is
+ Res : C.int;
+ Count : C.int := 0;
+
+ Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
+ for Iovec'Address use Iov;
+ pragma Import (Ada, Iovec);
- procedure Empty (Item : in out Fd_Set) is
begin
- Item := Null_Fd_Set;
- end Empty;
+ for J in Iovec'Range loop
+ Res := C_Recv
+ (Socket,
+ Iovec (J).Base.all'Address,
+ C.int (Iovec (J).Length),
+ 0);
+
+ if Res < 0 then
+ return Res;
+ else
+ Count := Count + Res;
+ end if;
+ end loop;
+ return Count;
+ end C_Readv;
--------------
- -- Finalize --
+ -- C_Select --
--------------
- procedure Finalize is
+ function C_Select
+ (Nfds : C.int;
+ Readfds : Fd_Set_Access;
+ Writefds : Fd_Set_Access;
+ Exceptfds : Fd_Set_Access;
+ Timeout : Timeval_Access)
+ return C.int
+ is
+ pragma Warnings (Off, Exceptfds);
+
+ RFS : Fd_Set_Access := Readfds;
+ WFS : Fd_Set_Access := Writefds;
+ WFSC : Fd_Set_Access := No_Fd_Set;
+ EFS : Fd_Set_Access := Exceptfds;
+ Res : C.int;
+ S : aliased C.int;
+ Last : aliased C.int;
+
begin
- if Initialized then
- WSACleanup;
- Initialized := False;
+ -- Asynchronous connection failures are notified in the
+ -- exception fd set instead of the write fd set. To ensure
+ -- POSIX compatitibility, copy write fd set into exception fd
+ -- set. Once select() returns, check any socket present in the
+ -- exception fd set and peek at incoming out-of-band data. If
+ -- the test is not successfull and if the socket is present in
+ -- the initial write fd set, then move the socket from the
+ -- exception fd set to the write fd set.
+
+ if WFS /= No_Fd_Set then
+ -- Add any socket present in write fd set into exception fd set
+
+ if EFS = No_Fd_Set then
+ EFS := New_Socket_Set (WFS);
+
+ else
+ WFSC := New_Socket_Set (WFS);
+
+ Last := Nfds - 1;
+ loop
+ Get_Socket_From_Set
+ (WFSC, S'Unchecked_Access, Last'Unchecked_Access);
+ exit when S = -1;
+ Insert_Socket_In_Set (EFS, S);
+ end loop;
+
+ Free_Socket_Set (WFSC);
+ end if;
+
+ -- Keep a copy of write fd set
+
+ WFSC := New_Socket_Set (WFS);
end if;
- end Finalize;
+
+ Res := Standard_Select (Nfds, RFS, WFS, EFS, Timeout);
+
+ if EFS /= No_Fd_Set then
+ declare
+ EFSC : Fd_Set_Access := New_Socket_Set (EFS);
+ Buffer : Character;
+ Length : C.int;
+ Flag : C.int := MSG_PEEK + MSG_OOB;
+ Fromlen : aliased C.int;
+
+ begin
+ Last := Nfds - 1;
+ loop
+ Get_Socket_From_Set
+ (EFSC, S'Unchecked_Access, Last'Unchecked_Access);
+
+ -- No more sockets in EFSC
+
+ exit when S = -1;
+
+ -- Check out-of-band data
+
+ Length := C_Recvfrom
+ (S, Buffer'Address, 1, Flag,
+ null, Fromlen'Unchecked_Access);
+
+ -- If the signal is not an out-of-band data, then it
+ -- is a connection failure notification.
+
+ if Length = -1 then
+ Remove_Socket_From_Set (EFS, S);
+
+ -- If S is present in the initial write fd set,
+ -- move it from exception fd set back to write fd
+ -- set. Otherwise, ignore this event since the user
+ -- is not watching for it.
+
+ if WFSC /= No_Fd_Set
+ and then Is_Socket_In_Set (WFSC, S)
+ then
+ Insert_Socket_In_Set (WFS, S);
+ end if;
+ end if;
+ end loop;
+
+ Free_Socket_Set (EFSC);
+ end;
+
+ if Exceptfds = No_Fd_Set then
+ Free_Socket_Set (EFS);
+ end if;
+ end if;
+
+ -- Free any copy of write fd set
+
+ if WFSC /= No_Fd_Set then
+ Free_Socket_Set (WFSC);
+ end if;
+
+ return Res;
+ end C_Select;
--------------
- -- Is_Empty --
+ -- C_Writev --
--------------
- function Is_Empty (Item : Fd_Set) return Boolean is
- begin
- return Item.fd_count = 0;
- end Is_Empty;
+ function C_Writev
+ (Socket : C.int;
+ Iov : System.Address;
+ Iovcnt : C.int)
+ return C.int
+ is
+ Res : C.int;
+ Count : C.int := 0;
- ------------
- -- Is_Set --
- ------------
+ Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
+ for Iovec'Address use Iov;
+ pragma Import (Ada, Iovec);
- function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean is
begin
- for J in 1 .. Item.fd_count loop
- if Item.fd_array (J) = Socket then
- return True;
+ for J in Iovec'Range loop
+ Res := C_Send
+ (Socket,
+ Iovec (J).Base.all'Address,
+ C.int (Iovec (J).Length),
+ 0);
+
+ if Res < 0 then
+ return Res;
+ else
+ Count := Count + Res;
end if;
end loop;
+ return Count;
+ end C_Writev;
- return False;
- end Is_Set;
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize is
+ begin
+ if Initialized then
+ WSACleanup;
+ Initialized := False;
+ end if;
+ end Finalize;
----------------
-- Initialize --
----------------
procedure Initialize (Process_Blocking_IO : Boolean := False) is
+ pragma Unreferenced (Process_Blocking_IO);
+
Return_Value : Interfaces.C.int;
begin
@@ -120,32 +311,56 @@ package body GNAT.Sockets.Thin is
end if;
end Initialize;
- ---------
- -- Max --
- ---------
+ -----------------
+ -- Set_Address --
+ -----------------
+
+ procedure Set_Address
+ (Sin : Sockaddr_In_Access;
+ Address : In_Addr)
+ is
+ begin
+ Sin.Sin_Addr := Address;
+ end Set_Address;
- function Max (Item : Fd_Set) return C.int is
- L : C.int := 0;
+ ----------------
+ -- Set_Family --
+ ----------------
+ procedure Set_Family
+ (Sin : Sockaddr_In_Access;
+ Family : C.int)
+ is
begin
- for J in 1 .. Item.fd_count loop
- if Item.fd_array (J) > L then
- L := Item.fd_array (J);
- end if;
- end loop;
+ Sin.Sin_Family := C.unsigned_short (Family);
+ end Set_Family;
- return L;
- end Max;
+ ----------------
+ -- Set_Length --
+ ----------------
- ---------
- -- Set --
- ---------
+ procedure Set_Length
+ (Sin : Sockaddr_In_Access;
+ Len : C.int)
+ is
+ pragma Unreferenced (Sin);
+ pragma Unreferenced (Len);
+
+ begin
+ null;
+ end Set_Length;
- procedure Set (Item : in out Fd_Set; Socket : in C.int) is
+ --------------
+ -- Set_Port --
+ --------------
+
+ procedure Set_Port
+ (Sin : Sockaddr_In_Access;
+ Port : C.unsigned_short)
+ is
begin
- Item.fd_count := Item.fd_count + 1;
- Item.fd_array (Item.fd_count) := Socket;
- end Set;
+ Sin.Sin_Port := Port;
+ end Set_Port;
--------------------------
-- Socket_Error_Message --
diff --git a/gcc/ada/3wsocthi.ads b/gcc/ada/3wsocthi.ads
index 63c8a5ea715..0fb5e4a798d 100644
--- a/gcc/ada/3wsocthi.ads
+++ b/gcc/ada/3wsocthi.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,11 +26,16 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
--- This version is for NT.
+-- This package provides a target dependent thin interface to the sockets
+-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
+-- should not be directly with'ed by an applications program.
+
+-- This version is for NT
with Interfaces.C.Pointers;
with Interfaces.C.Strings;
@@ -41,8 +46,6 @@ with System;
package GNAT.Sockets.Thin is
- -- ??? far more comments required ???
-
package C renames Interfaces.C;
use type C.int;
@@ -54,23 +57,15 @@ package GNAT.Sockets.Thin is
function Socket_Errno return Integer;
-- Returns last socket error number.
+ procedure Set_Socket_Errno (Errno : Integer);
+ -- Set last socket error number.
+
function Socket_Error_Message (Errno : Integer) return String;
-- Returns the error message string for the error number Errno. If
-- Errno is not known it returns "Unknown system error".
- type Socket_Fd_Array is array (C.unsigned range 1 .. 64) of C.int;
- pragma Convention (C, Socket_Fd_Array);
-
- type Fd_Set is record
- fd_count : C.unsigned;
- fd_array : Socket_Fd_Array;
- end record;
- pragma Convention (C, Fd_Set);
-
- Null_Fd_Set : constant Fd_Set := (0, (others => 0));
-
- type Fd_Set_Access is access all Fd_Set;
- pragma Convention (C, Fd_Set_Access);
+ subtype Fd_Set_Access is System.Address;
+ No_Fd_Set : constant Fd_Set_Access := System.Null_Address;
type Timeval_Unit is new C.long;
pragma Convention (C, Timeval_Unit);
@@ -142,6 +137,31 @@ package GNAT.Sockets.Thin is
pragma Convention (C, Sockaddr_In_Access);
-- Access to internet socket address
+ procedure Set_Length
+ (Sin : Sockaddr_In_Access;
+ Len : C.int);
+ pragma Inline (Set_Length);
+ -- Set Sin.Sin_Length to Len.
+ -- On this platform, nothing is done as there is no such field.
+
+ procedure Set_Family
+ (Sin : Sockaddr_In_Access;
+ Family : C.int);
+ pragma Inline (Set_Family);
+ -- Set Sin.Sin_Family to Family
+
+ procedure Set_Port
+ (Sin : Sockaddr_In_Access;
+ Port : C.unsigned_short);
+ pragma Inline (Set_Port);
+ -- Set Sin.Sin_Port to Port
+
+ procedure Set_Address
+ (Sin : Sockaddr_In_Access;
+ Address : In_Addr);
+ pragma Inline (Set_Address);
+ -- Set Sin.Sin_Addr to Address
+
type Hostent is record
H_Name : C.Strings.chars_ptr;
H_Aliases : Chars_Ptr_Pointers.Pointer;
@@ -156,6 +176,19 @@ package GNAT.Sockets.Thin is
pragma Convention (C, Hostent_Access);
-- Access to host entry
+ type Servent is record
+ S_Name : C.Strings.chars_ptr;
+ S_Aliases : Chars_Ptr_Pointers.Pointer;
+ S_Port : C.int;
+ S_Proto : C.Strings.chars_ptr;
+ end record;
+ pragma Convention (C, Servent);
+ -- Service entry
+
+ type Servent_Access is access all Servent;
+ pragma Convention (C, Servent_Access);
+ -- Access to service entry
+
type Two_Int is array (0 .. 1) of C.int;
pragma Convention (C, Two_Int);
-- Used with pipe()
@@ -173,8 +206,8 @@ package GNAT.Sockets.Thin is
return C.int;
function C_Close
- (Fd : C.int)
- return C.int;
+ (Fd : C.int)
+ return C.int;
function C_Connect
(S : C.int;
@@ -203,6 +236,16 @@ package GNAT.Sockets.Thin is
Namelen : access C.int)
return C.int;
+ function C_Getservbyname
+ (Name : C.char_array;
+ Proto : C.char_array)
+ return Servent_Access;
+
+ function C_Getservbyport
+ (Port : C.int;
+ Proto : C.char_array)
+ return Servent_Access;
+
function C_Getsockname
(S : C.int;
Name : System.Address;
@@ -237,6 +280,12 @@ package GNAT.Sockets.Thin is
Nbyte : C.int)
return C.int;
+ function C_Readv
+ (Socket : C.int;
+ Iov : System.Address;
+ Iovcnt : C.int)
+ return C.int;
+
function C_Recv
(S : C.int;
Buf : System.Address;
@@ -310,33 +359,78 @@ package GNAT.Sockets.Thin is
Nbyte : C.int)
return C.int;
+ function C_Writev
+ (Socket : C.int;
+ Iov : System.Address;
+ Iovcnt : C.int)
+ return C.int;
+
function WSAStartup
(WS_Version : Interfaces.C.int;
WSADataAddress : System.Address)
return Interfaces.C.int;
- procedure WSACleanup;
+ procedure Free_Socket_Set
+ (Set : Fd_Set_Access);
+ -- Free system-dependent socket set.
+
+ procedure Get_Socket_From_Set
+ (Set : Fd_Set_Access;
+ Socket : Int_Access;
+ Last : Int_Access);
+ -- Get last socket in Socket and remove it from the socket
+ -- set. The parameter Last is a maximum value of the largest
+ -- socket. This hint is used to avoid scanning very large socket
+ -- sets. After a call to Get_Socket_From_Set, Last is set back to
+ -- the real largest socket in the socket set.
+
+ procedure Insert_Socket_In_Set
+ (Set : Fd_Set_Access;
+ Socket : C.int);
+ -- Insert socket in the socket set
+
+ function Is_Socket_In_Set
+ (Set : Fd_Set_Access;
+ Socket : C.int)
+ return Boolean;
+ -- Check whether Socket is in the socket set
+
+ procedure Last_Socket_In_Set
+ (Set : Fd_Set_Access;
+ Last : Int_Access);
+ -- Find the largest socket in the socket set. This is needed for
+ -- select(). When Last_Socket_In_Set is called, parameter Last is
+ -- a maximum value of the largest socket. This hint is used to
+ -- avoid scanning very large socket sets. After the call, Last is
+ -- set back to the real largest socket in the socket set.
+
+ function New_Socket_Set
+ (Set : Fd_Set_Access)
+ return Fd_Set_Access;
+ -- Allocate a new socket set which is a system-dependent structure
+ -- and initialize by copying Set if it is non-null, by making it
+ -- empty otherwise.
+
+ procedure Remove_Socket_From_Set
+ (Set : Fd_Set_Access;
+ Socket : C.int);
+ -- Remove socket from the socket set
- procedure Clear (Item : in out Fd_Set; Socket : in C.int);
- procedure Empty (Item : in out Fd_Set);
- function Is_Empty (Item : Fd_Set) return Boolean;
- function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean;
- function Max (Item : Fd_Set) return C.int;
- procedure Set (Item : in out Fd_Set; Socket : in C.int);
+ procedure WSACleanup;
procedure Finalize;
procedure Initialize (Process_Blocking_IO : Boolean := False);
private
-
pragma Import (Stdcall, C_Accept, "accept");
pragma Import (Stdcall, C_Bind, "bind");
pragma Import (Stdcall, C_Close, "closesocket");
- pragma Import (Stdcall, C_Connect, "connect");
pragma Import (Stdcall, C_Gethostbyaddr, "gethostbyaddr");
pragma Import (Stdcall, C_Gethostbyname, "gethostbyname");
pragma Import (Stdcall, C_Gethostname, "gethostname");
pragma Import (Stdcall, C_Getpeername, "getpeername");
+ pragma Import (Stdcall, C_Getservbyname, "getservbyname");
+ pragma Import (Stdcall, C_Getservbyport, "getservbyport");
pragma Import (Stdcall, C_Getsockname, "getsockname");
pragma Import (Stdcall, C_Getsockopt, "getsockopt");
pragma Import (Stdcall, C_Inet_Addr, "inet_addr");
@@ -345,7 +439,6 @@ private
pragma Import (C, C_Read, "_read");
pragma Import (Stdcall, C_Recv, "recv");
pragma Import (Stdcall, C_Recvfrom, "recvfrom");
- pragma Import (Stdcall, C_Select, "select");
pragma Import (Stdcall, C_Send, "send");
pragma Import (Stdcall, C_Sendto, "sendto");
pragma Import (Stdcall, C_Setsockopt, "setsockopt");
@@ -355,7 +448,15 @@ private
pragma Import (C, C_System, "_system");
pragma Import (C, C_Write, "_write");
pragma Import (Stdcall, Socket_Errno, "WSAGetLastError");
+ pragma Import (Stdcall, Set_Socket_Errno, "WSASetLastError");
pragma Import (Stdcall, WSAStartup, "WSAStartup");
pragma Import (Stdcall, WSACleanup, "WSACleanup");
+ pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set");
+ pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set");
+ pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set");
+ pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set");
+ pragma Import (C, New_Socket_Set, "__gnat_new_socket_set");
+ pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set");
+ pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set");
end GNAT.Sockets.Thin;
diff --git a/gcc/ada/3wsoliop.ads b/gcc/ada/3wsoliop.ads
index 8c82f43223d..e930da934d5 100644
--- a/gcc/ada/3wsoliop.ads
+++ b/gcc/ada/3wsoliop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,16 +26,18 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-package GNAT.Sockets.Linker_Options is
+-- This package is used to provide target specific linker_options for the
+-- support of scokets as required by the package GNAT.Sockets.
- -- Windows NT version of this package
+-- This is the Windows/NT version of this package
-private
+package GNAT.Sockets.Linker_Options is
+private
pragma Linker_Options ("-lwsock32");
-
end GNAT.Sockets.Linker_Options;
diff --git a/gcc/ada/3zsoccon.ads b/gcc/ada/3zsoccon.ads
new file mode 100644
index 00000000000..ddf2485c4da
--- /dev/null
+++ b/gcc/ada/3zsoccon.ads
@@ -0,0 +1,158 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . C O N S T A N T S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2000-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides target dependent definitions of constant for use
+-- by the GNAT.Sockets package (g-socket.ads). This package should not be
+-- directly with'ed by an applications program.
+
+-- This is the version for VxWorks
+
+package GNAT.Sockets.Constants is
+
+ --------------
+ -- Families --
+ --------------
+
+ AF_INET : constant := 2; -- IPv4 address family
+ AF_INET6 : constant := -1; -- IPv6 address family
+
+ -----------
+ -- Modes --
+ -----------
+
+ SOCK_STREAM : constant := 1; -- Stream socket
+ SOCK_DGRAM : constant := 2; -- Datagram socket
+
+ -------------------
+ -- Socket errors --
+ -------------------
+
+ EACCES : constant := 13; -- Permission denied
+ EADDRINUSE : constant := 48; -- Address already in use
+ EADDRNOTAVAIL : constant := 49; -- Cannot assign address
+ EAFNOSUPPORT : constant := 47; -- Addr family not supported
+ EALREADY : constant := 69; -- Operation in progress
+ EBADF : constant := 9; -- Bad file descriptor
+ ECONNABORTED : constant := 53; -- Connection aborted
+ ECONNREFUSED : constant := 61; -- Connection refused
+ ECONNRESET : constant := 54; -- Connection reset by peer
+ EDESTADDRREQ : constant := 40; -- Destination addr required
+ EFAULT : constant := 14; -- Bad address
+ EHOSTDOWN : constant := 67; -- Host is down
+ EHOSTUNREACH : constant := 65; -- No route to host
+ EINPROGRESS : constant := 68; -- Operation now in progress
+ EINTR : constant := 4; -- Interrupted system call
+ EINVAL : constant := 22; -- Invalid argument
+ EIO : constant := 5; -- Input output error
+ EISCONN : constant := 56; -- Socket already connected
+ ELOOP : constant := 64; -- Too many symbolic lynks
+ EMFILE : constant := 24; -- Too many open files
+ EMSGSIZE : constant := 36; -- Message too long
+ ENAMETOOLONG : constant := 26; -- Name too long
+ ENETDOWN : constant := 62; -- Network is down
+ ENETRESET : constant := 52; -- Disconn. on network reset
+ ENETUNREACH : constant := 51; -- Network is unreachable
+ ENOBUFS : constant := 55; -- No buffer space available
+ ENOPROTOOPT : constant := 42; -- Protocol not available
+ ENOTCONN : constant := 57; -- Socket not connected
+ ENOTSOCK : constant := 50; -- Operation on non socket
+ EOPNOTSUPP : constant := 45; -- Operation not supported
+ EPFNOSUPPORT : constant := 46; -- Unknown protocol family
+ EPROTONOSUPPORT : constant := 43; -- Unknown protocol
+ EPROTOTYPE : constant := 41; -- Unknown protocol type
+ ESHUTDOWN : constant := 58; -- Cannot send once shutdown
+ ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported
+ ETIMEDOUT : constant := 60; -- Connection timed out
+ ETOOMANYREFS : constant := 59; -- Too many references
+ EWOULDBLOCK : constant := 70; -- Operation would block
+
+ -----------------
+ -- Host errors --
+ -----------------
+
+ HOST_NOT_FOUND : constant := 1; -- Unknown host
+ TRY_AGAIN : constant := 2; -- Host name lookup failure
+ NO_DATA : constant := 4; -- No data record for name
+ NO_RECOVERY : constant := 3; -- Non recoverable errors
+
+ -------------------
+ -- Control flags --
+ -------------------
+
+ FIONBIO : constant := 16; -- Set/clear non-blocking io
+ FIONREAD : constant := 1; -- How many bytes to read
+
+ --------------------
+ -- Shutdown modes --
+ --------------------
+
+ SHUT_RD : constant := 0; -- No more recv
+ SHUT_WR : constant := 1; -- No more send
+ SHUT_RDWR : constant := 2; -- No more recv/send
+
+ ---------------------
+ -- Protocol levels --
+ ---------------------
+
+ SOL_SOCKET : constant := 65535; -- Options for socket level
+ IPPROTO_IP : constant := 0; -- Dummy protocol for IP
+ IPPROTO_UDP : constant := 17; -- UDP
+ IPPROTO_TCP : constant := 6; -- TCP
+
+ -------------------
+ -- Request flags --
+ -------------------
+
+ MSG_OOB : constant := 1; -- Process out-of-band data
+ MSG_PEEK : constant := 2; -- Peek at incoming data
+ MSG_EOR : constant := 8; -- Send end of record
+ MSG_WAITALL : constant := 64; -- Wait for full reception
+
+ --------------------
+ -- Socket options --
+ --------------------
+
+ TCP_NODELAY : constant := 1; -- Do not coalesce packets
+ SO_SNDBUF : constant := 4097; -- Set/get send buffer size
+ SO_RCVBUF : constant := 4098; -- Set/get recv buffer size
+ SO_REUSEADDR : constant := 4; -- Bind reuse local address
+ SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs
+ SO_LINGER : constant := 128; -- Defer close to flush data
+ SO_ERROR : constant := 4103; -- Get/clear error status
+ SO_BROADCAST : constant := 32; -- Can send broadcast msgs
+ IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group
+ IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group
+ IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL
+ IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback
+
+end GNAT.Sockets.Constants;
diff --git a/gcc/ada/3zsocthi.adb b/gcc/ada/3zsocthi.adb
new file mode 100644
index 00000000000..c40e3520bd5
--- /dev/null
+++ b/gcc/ada/3zsocthi.adb
@@ -0,0 +1,632 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a target dependent thin interface to the sockets
+-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
+-- should not be directly with'ed by an applications program.
+
+-- This version is for VxWorks
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Task_Lock;
+
+with Interfaces.C; use Interfaces.C;
+with Unchecked_Conversion;
+
+package body GNAT.Sockets.Thin is
+
+ Non_Blocking_Sockets : Fd_Set_Access := New_Socket_Set (No_Socket_Set);
+ -- When this package is initialized with Process_Blocking_IO set
+ -- to True, sockets are set in non-blocking mode to avoid blocking
+ -- the whole process when a thread wants to perform a blocking IO
+ -- operation. But the user can also set a socket in non-blocking
+ -- mode by purpose. In order to make a difference between these
+ -- two situations, we track the origin of non-blocking mode in
+ -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
+ -- been set in non-blocking mode by the user.
+
+ Quantum : constant Duration := 0.2;
+ -- When Thread_Blocking_IO is False, we set sockets in
+ -- non-blocking mode and we spend a period of time Quantum between
+ -- two attempts on a blocking operation.
+ Thread_Blocking_IO : Boolean := True;
+
+ -- The following types and variables are required to create a Hostent
+ -- record "by hand".
+
+ type In_Addr_Access_Array_Access is access In_Addr_Access_Array;
+
+ Alias_Access : Chars_Ptr_Pointers.Pointer :=
+ new C.Strings.chars_ptr'(C.Strings.Null_Ptr);
+
+ In_Addr_Access_Array_A : In_Addr_Access_Array_Access :=
+ new In_Addr_Access_Array'(new In_Addr, null);
+
+ In_Addr_Access_Ptr : In_Addr_Access_Pointers.Pointer :=
+ In_Addr_Access_Array_A
+ (In_Addr_Access_Array_A'First)'Access;
+
+ Local_Hostent : Hostent_Access := new Hostent;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ -- All these require comments ???
+
+ function Syscall_Accept
+ (S : C.int;
+ Addr : System.Address;
+ Addrlen : access C.int)
+ return C.int;
+ pragma Import (C, Syscall_Accept, "accept");
+
+ function Syscall_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int)
+ return C.int;
+ pragma Import (C, Syscall_Connect, "connect");
+
+ function Syscall_Ioctl
+ (S : C.int;
+ Req : C.int;
+ Arg : Int_Access)
+ return C.int;
+ pragma Import (C, Syscall_Ioctl, "ioctl");
+
+ function Syscall_Recv
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int;
+ pragma Import (C, Syscall_Recv, "recv");
+
+ function Syscall_Recvfrom
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ From : Sockaddr_In_Access;
+ Fromlen : access C.int)
+ return C.int;
+ pragma Import (C, Syscall_Recvfrom, "recvfrom");
+
+ function Syscall_Send
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int;
+ pragma Import (C, Syscall_Send, "send");
+
+ function Syscall_Sendto
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ To : Sockaddr_In_Access;
+ Tolen : C.int)
+ return C.int;
+ pragma Import (C, Syscall_Sendto, "sendto");
+
+ function Syscall_Socket
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int)
+ return C.int;
+ pragma Import (C, Syscall_Socket, "socket");
+
+ function Non_Blocking_Socket (S : C.int) return Boolean;
+ procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
+
+ --------------
+ -- C_Accept --
+ --------------
+
+ function C_Accept
+ (S : C.int;
+ Addr : System.Address;
+ Addrlen : access C.int)
+ return C.int
+ is
+ R : C.int;
+ Val : aliased C.int := 1;
+ Res : C.int;
+
+ begin
+ loop
+ R := Syscall_Accept (S, Addr, Addrlen);
+ exit when Thread_Blocking_IO
+ or else R /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= Constants.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ if not Thread_Blocking_IO
+ and then R /= Failure
+ then
+ -- A socket inherits the properties ot its server especially
+ -- the FIONBIO flag. Do not use C_Ioctl as this subprogram
+ -- tracks sockets set in non-blocking mode by user.
+
+ Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
+ Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
+ end if;
+
+ return R;
+ end C_Accept;
+
+ ---------------
+ -- C_Connect --
+ ---------------
+
+ function C_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int)
+ return C.int
+ is
+ Res : C.int;
+
+ begin
+ Res := Syscall_Connect (S, Name, Namelen);
+
+ if Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= Constants.EINPROGRESS
+ then
+ return Res;
+ end if;
+
+ declare
+ WSet : Fd_Set_Access;
+ Now : aliased Timeval;
+
+ begin
+ WSet := New_Socket_Set (No_Socket_Set);
+
+ loop
+ Insert_Socket_In_Set (WSet, S);
+ Now := Immediat;
+ Res := C_Select
+ (S + 1,
+ No_Fd_Set,
+ WSet,
+ No_Fd_Set,
+ Now'Unchecked_Access);
+
+ exit when Res > 0;
+
+ if Res = Failure then
+ Free_Socket_Set (WSet);
+ return Res;
+ end if;
+
+ delay Quantum;
+ end loop;
+
+ Free_Socket_Set (WSet);
+ end;
+
+ Res := Syscall_Connect (S, Name, Namelen);
+
+ if Res = Failure
+ and then Errno = Constants.EISCONN
+ then
+ return Thin.Success;
+ else
+ return Res;
+ end if;
+ end C_Connect;
+
+ ---------------------
+ -- C_Gethostbyaddr --
+ ---------------------
+
+ function C_Gethostbyaddr
+ (Addr : System.Address;
+ Len : C.int;
+ Typ : C.int)
+ return Hostent_Access
+ is
+ pragma Warnings (Off, Len);
+ pragma Warnings (Off, Typ);
+
+ type int_Access is access int;
+ function To_Pointer is
+ new Unchecked_Conversion (System.Address, int_Access);
+
+ procedure VxWorks_Gethostbyaddr
+ (Addr : C.int; Buf : out C.char_array);
+ pragma Import (C, VxWorks_Gethostbyaddr, "hostGetByAddr");
+
+ Host_Name : C.char_array (1 .. Max_Name_Length);
+
+ begin
+ VxWorks_Gethostbyaddr (To_Pointer (Addr).all, Host_Name);
+
+ In_Addr_Access_Ptr.all.all := To_In_Addr (To_Pointer (Addr).all);
+ Local_Hostent.all.H_Name := C.Strings.New_Char_Array (Host_Name);
+
+ return Local_Hostent;
+ end C_Gethostbyaddr;
+
+ ---------------------
+ -- C_Gethostbyname --
+ ---------------------
+
+ function C_Gethostbyname
+ (Name : C.char_array)
+ return Hostent_Access
+ is
+ function VxWorks_Gethostbyname
+ (Name : C.char_array)
+ return C.int;
+ pragma Import (C, VxWorks_Gethostbyname, "hostGetByName");
+
+ Addr : C.int;
+
+ begin
+ Addr := VxWorks_Gethostbyname (Name);
+
+ In_Addr_Access_Ptr.all.all := To_In_Addr (Addr);
+ Local_Hostent.all.H_Name := C.Strings.New_Char_Array (To_C (Host_Name));
+
+ return Local_Hostent;
+ end C_Gethostbyname;
+
+ ---------------------
+ -- C_Getservbyname --
+ ---------------------
+
+ function C_Getservbyname
+ (Name : C.char_array;
+ Proto : C.char_array)
+ return Servent_Access
+ is
+ pragma Warnings (Off, Name);
+ pragma Warnings (Off, Proto);
+
+ begin
+ return null;
+ end C_Getservbyname;
+
+ ---------------------
+ -- C_Getservbyport --
+ ---------------------
+
+ function C_Getservbyport
+ (Port : C.int;
+ Proto : C.char_array)
+ return Servent_Access
+ is
+ pragma Warnings (Off, Port);
+ pragma Warnings (Off, Proto);
+
+ begin
+ return null;
+ end C_Getservbyport;
+
+ -------------
+ -- C_Ioctl --
+ -------------
+
+ function C_Ioctl
+ (S : C.int;
+ Req : C.int;
+ Arg : Int_Access)
+ return C.int
+ is
+ begin
+ if not Thread_Blocking_IO
+ and then Req = Constants.FIONBIO
+ then
+ if Arg.all /= 0 then
+ Set_Non_Blocking_Socket (S, True);
+ end if;
+ end if;
+
+ return Syscall_Ioctl (S, Req, Arg);
+ end C_Ioctl;
+
+ ------------
+ -- C_Recv --
+ ------------
+
+ function C_Recv
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int
+ is
+ Res : C.int;
+
+ begin
+ loop
+ Res := Syscall_Recv (S, Msg, Len, Flags);
+ exit when Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= Constants.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ return Res;
+ end C_Recv;
+
+ ----------------
+ -- C_Recvfrom --
+ ----------------
+
+ function C_Recvfrom
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ From : Sockaddr_In_Access;
+ Fromlen : access C.int)
+ return C.int
+ is
+ Res : C.int;
+
+ begin
+ loop
+ Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
+ exit when Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= Constants.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ return Res;
+ end C_Recvfrom;
+
+ ------------
+ -- C_Send --
+ ------------
+
+ function C_Send
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int
+ is
+ Res : C.int;
+
+ begin
+ loop
+ Res := Syscall_Send (S, Msg, Len, Flags);
+ exit when Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= Constants.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ return Res;
+ end C_Send;
+
+ --------------
+ -- C_Sendto --
+ --------------
+
+ function C_Sendto
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ To : Sockaddr_In_Access;
+ Tolen : C.int)
+ return C.int
+ is
+ Res : C.int;
+
+ begin
+ loop
+ Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
+ exit when Thread_Blocking_IO
+ or else Res /= Failure
+ or else Non_Blocking_Socket (S)
+ or else Errno /= Constants.EWOULDBLOCK;
+ delay Quantum;
+ end loop;
+
+ return Res;
+ end C_Sendto;
+
+ --------------
+ -- C_Socket --
+ --------------
+
+ function C_Socket
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int)
+ return C.int
+ is
+ R : C.int;
+ Val : aliased C.int := 1;
+ Res : C.int;
+
+ begin
+ R := Syscall_Socket (Domain, Typ, Protocol);
+
+ if not Thread_Blocking_IO
+ and then R /= Failure
+ then
+ -- Do not use C_Ioctl as this subprogram tracks sockets set
+ -- in non-blocking mode by user.
+
+ Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
+ Set_Non_Blocking_Socket (R, False);
+ end if;
+
+ return R;
+ end C_Socket;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize is
+ begin
+ null;
+ end Finalize;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Process_Blocking_IO : Boolean) is
+ begin
+ Thread_Blocking_IO := not Process_Blocking_IO;
+ end Initialize;
+
+ -------------------------
+ -- Non_Blocking_Socket --
+ -------------------------
+
+ function Non_Blocking_Socket (S : C.int) return Boolean is
+ R : Boolean;
+
+ begin
+ Task_Lock.Lock;
+ R := Is_Socket_In_Set (Non_Blocking_Sockets, S);
+ Task_Lock.Unlock;
+ return R;
+ end Non_Blocking_Socket;
+
+ -----------------
+ -- Set_Address --
+ -----------------
+
+ procedure Set_Address
+ (Sin : Sockaddr_In_Access;
+ Address : In_Addr)
+ is
+ begin
+ Sin.Sin_Addr := Address;
+ end Set_Address;
+
+ ----------------
+ -- Set_Family --
+ ----------------
+
+ procedure Set_Family
+ (Sin : Sockaddr_In_Access;
+ Family : C.int)
+ is
+ begin
+ Sin.Sin_Family := C.unsigned_char (Family);
+ end Set_Family;
+
+ ----------------
+ -- Set_Length --
+ ----------------
+
+ procedure Set_Length
+ (Sin : Sockaddr_In_Access;
+ Len : C.int)
+ is
+ begin
+ Sin.Sin_Length := C.unsigned_char (Len);
+ end Set_Length;
+
+ -----------------------------
+ -- Set_Non_Blocking_Socket --
+ -----------------------------
+
+ procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
+ begin
+ Task_Lock.Lock;
+ if V then
+ Insert_Socket_In_Set (Non_Blocking_Sockets, S);
+ else
+ Remove_Socket_From_Set (Non_Blocking_Sockets, S);
+ end if;
+
+ Task_Lock.Unlock;
+ end Set_Non_Blocking_Socket;
+
+ --------------
+ -- Set_Port --
+ --------------
+
+ procedure Set_Port
+ (Sin : Sockaddr_In_Access;
+ Port : C.unsigned_short)
+ is
+ begin
+ Sin.Sin_Port := Port;
+ end Set_Port;
+
+ --------------------------
+ -- Socket_Error_Message --
+ --------------------------
+
+ function Socket_Error_Message (Errno : Integer) return String is
+ use type Interfaces.C.Strings.chars_ptr;
+
+ C_Msg : C.Strings.chars_ptr;
+
+ begin
+ C_Msg := C_Strerror (C.int (Errno));
+
+ if C_Msg = C.Strings.Null_Ptr then
+ return "Unknown system error";
+
+ else
+ return C.Strings.Value (C_Msg);
+ end if;
+ end Socket_Error_Message;
+
+-- Package elaboration
+
+begin
+ Local_Hostent.all.H_Aliases := Alias_Access;
+
+ -- VxWorks currently only supports AF_INET
+
+ Local_Hostent.all.H_Addrtype := Constants.AF_INET;
+
+ Local_Hostent.all.H_Length := 1;
+ Local_Hostent.all.H_Addr_List := In_Addr_Access_Ptr;
+
+end GNAT.Sockets.Thin;
diff --git a/gcc/ada/3zsocthi.ads b/gcc/ada/3zsocthi.ads
new file mode 100644
index 00000000000..7ff589b5444
--- /dev/null
+++ b/gcc/ada/3zsocthi.ads
@@ -0,0 +1,446 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . S O C K E T S . T H I N --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a target dependent thin interface to the sockets
+-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
+-- should not be directly with'ed by an applications program.
+
+-- This is the version for VxWorks
+
+with Interfaces.C.Pointers;
+
+with Ada.Unchecked_Conversion;
+with Interfaces.C.Strings;
+with GNAT.Sockets.Constants;
+with GNAT.OS_Lib;
+
+with System;
+
+package GNAT.Sockets.Thin is
+
+ package C renames Interfaces.C;
+
+ use type C.int;
+ -- This is so we can declare the Failure constant below
+
+ Success : constant C.int := 0;
+ Failure : constant C.int := -1;
+
+ function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
+ -- Returns last socket error number.
+
+ function Socket_Error_Message (Errno : Integer) return String;
+ -- Returns the error message string for the error number Errno. If
+ -- Errno is not known it returns "Unknown system error".
+
+ subtype Fd_Set_Access is System.Address;
+ No_Fd_Set : constant Fd_Set_Access := System.Null_Address;
+
+ type Timeval_Unit is new C.int;
+ pragma Convention (C, Timeval_Unit);
+
+ type Timeval is record
+ Tv_Sec : Timeval_Unit;
+ Tv_Usec : Timeval_Unit;
+ end record;
+ pragma Convention (C, Timeval);
+
+ type Timeval_Access is access all Timeval;
+ pragma Convention (C, Timeval_Access);
+
+ Immediat : constant Timeval := (0, 0);
+
+ type Int_Access is access all C.int;
+ pragma Convention (C, Int_Access);
+ -- Access to C integers
+
+ type Chars_Ptr_Array is array (C.size_t range <>) of
+ aliased C.Strings.chars_ptr;
+
+ package Chars_Ptr_Pointers is
+ new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array,
+ C.Strings.Null_Ptr);
+ -- Arrays of C (char *)
+
+ type In_Addr is record
+ S_B1, S_B2, S_B3, S_B4 : C.unsigned_char;
+ end record;
+ pragma Convention (C, In_Addr);
+ -- Internet address
+
+ function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr);
+
+ type In_Addr_Access is access all In_Addr;
+ pragma Convention (C, In_Addr_Access);
+ -- Access to internet address
+
+ Inaddr_Any : aliased constant In_Addr := (others => 0);
+ -- Any internet address (all the interfaces)
+
+ type In_Addr_Access_Array is array (C.size_t range <>)
+ of aliased In_Addr_Access;
+ pragma Convention (C, In_Addr_Access_Array);
+
+ package In_Addr_Access_Pointers is
+ new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null);
+ -- Array of internet addresses
+
+ type Sockaddr is record
+ Sa_Length : C.unsigned_char;
+ Sa_Family : C.unsigned_char;
+ Sa_Data : C.char_array (1 .. 14);
+ end record;
+ pragma Convention (C, Sockaddr);
+ -- Socket address
+
+ type Sockaddr_Access is access all Sockaddr;
+ pragma Convention (C, Sockaddr_Access);
+ -- Access to socket address
+
+ type Sockaddr_In is record
+ Sin_Length : C.unsigned_char := 0;
+ Sin_Family : C.unsigned_char := Constants.AF_INET;
+ Sin_Port : C.unsigned_short := 0;
+ Sin_Addr : In_Addr := Inaddr_Any;
+ Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0));
+ end record;
+ pragma Convention (C, Sockaddr_In);
+ -- Internet socket address
+
+ type Sockaddr_In_Access is access all Sockaddr_In;
+ pragma Convention (C, Sockaddr_In_Access);
+ -- Access to internet socket address
+
+ procedure Set_Length
+ (Sin : Sockaddr_In_Access;
+ Len : C.int);
+ pragma Inline (Set_Length);
+ -- Set Sin.Sin_Length to Len.
+
+ procedure Set_Family
+ (Sin : Sockaddr_In_Access;
+ Family : C.int);
+ pragma Inline (Set_Family);
+ -- Set Sin.Sin_Family to Family.
+
+ procedure Set_Port
+ (Sin : Sockaddr_In_Access;
+ Port : C.unsigned_short);
+ pragma Inline (Set_Port);
+ -- Set Sin.Sin_Port to Port.
+
+ procedure Set_Address
+ (Sin : Sockaddr_In_Access;
+ Address : In_Addr);
+ pragma Inline (Set_Address);
+ -- Set Sin.Sin_Addr to Address.
+
+ type Hostent is record
+ H_Name : C.Strings.chars_ptr;
+ H_Aliases : Chars_Ptr_Pointers.Pointer;
+ H_Addrtype : C.int;
+ H_Length : C.int;
+ H_Addr_List : In_Addr_Access_Pointers.Pointer;
+ end record;
+ pragma Convention (C, Hostent);
+ -- Host entry
+
+ type Hostent_Access is access all Hostent;
+ pragma Convention (C, Hostent_Access);
+ -- Access to host entry
+
+ type Servent is record
+ S_Name : C.Strings.chars_ptr;
+ S_Aliases : Chars_Ptr_Pointers.Pointer;
+ S_Port : C.int;
+ S_Proto : C.Strings.chars_ptr;
+ end record;
+ pragma Convention (C, Servent);
+ -- Service entry
+
+ type Servent_Access is access all Servent;
+ pragma Convention (C, Servent_Access);
+ -- Access to service entry
+
+ type Two_Int is array (0 .. 1) of C.int;
+ pragma Convention (C, Two_Int);
+ -- Used with pipe()
+
+ function C_Accept
+ (S : C.int;
+ Addr : System.Address;
+ Addrlen : access C.int)
+ return C.int;
+
+ function C_Bind
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int)
+ return C.int;
+
+ function C_Close
+ (Fd : C.int)
+ return C.int;
+
+ function C_Connect
+ (S : C.int;
+ Name : System.Address;
+ Namelen : C.int)
+ return C.int;
+
+ function C_Gethostbyaddr
+ (Addr : System.Address;
+ Len : C.int;
+ Typ : C.int)
+ return Hostent_Access;
+
+ function C_Gethostbyname
+ (Name : C.char_array)
+ return Hostent_Access;
+
+ function C_Gethostname
+ (Name : System.Address;
+ Namelen : C.int)
+ return C.int;
+
+ function C_Getpeername
+ (S : C.int;
+ Name : System.Address;
+ Namelen : access C.int)
+ return C.int;
+
+ function C_Getservbyname
+ (Name : C.char_array;
+ Proto : C.char_array)
+ return Servent_Access;
+
+ function C_Getservbyport
+ (Port : C.int;
+ Proto : C.char_array)
+ return Servent_Access;
+
+ function C_Getsockname
+ (S : C.int;
+ Name : System.Address;
+ Namelen : access C.int)
+ return C.int;
+
+ function C_Getsockopt
+ (S : C.int;
+ Level : C.int;
+ Optname : C.int;
+ Optval : System.Address;
+ Optlen : access C.int)
+ return C.int;
+
+ function C_Inet_Addr
+ (Cp : C.Strings.chars_ptr)
+ return C.int;
+
+ function C_Ioctl
+ (S : C.int;
+ Req : C.int;
+ Arg : Int_Access)
+ return C.int;
+
+ function C_Listen (S, Backlog : C.int) return C.int;
+
+ function C_Read
+ (Fd : C.int;
+ Buf : System.Address;
+ Count : C.int)
+ return C.int;
+
+ function C_Readv
+ (Fd : C.int;
+ Iov : System.Address;
+ Iovcnt : C.int)
+ return C.int;
+
+ function C_Recv
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int;
+
+ function C_Recvfrom
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ From : Sockaddr_In_Access;
+ Fromlen : access C.int)
+ return C.int;
+
+ function C_Select
+ (Nfds : C.int;
+ Readfds : Fd_Set_Access;
+ Writefds : Fd_Set_Access;
+ Exceptfds : Fd_Set_Access;
+ Timeout : Timeval_Access)
+ return C.int;
+
+ function C_Send
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int)
+ return C.int;
+
+ function C_Sendto
+ (S : C.int;
+ Msg : System.Address;
+ Len : C.int;
+ Flags : C.int;
+ To : Sockaddr_In_Access;
+ Tolen : C.int)
+ return C.int;
+
+ function C_Setsockopt
+ (S : C.int;
+ Level : C.int;
+ Optname : C.int;
+ Optval : System.Address;
+ Optlen : C.int)
+ return C.int;
+
+ function C_Shutdown
+ (S : C.int;
+ How : C.int)
+ return C.int;
+
+ function C_Socket
+ (Domain : C.int;
+ Typ : C.int;
+ Protocol : C.int)
+ return C.int;
+
+ function C_Strerror
+ (Errnum : C.int)
+ return C.Strings.chars_ptr;
+
+ function C_System
+ (Command : System.Address)
+ return C.int;
+
+ function C_Write
+ (Fd : C.int;
+ Buf : System.Address;
+ Count : C.int)
+ return C.int;
+
+ function C_Writev
+ (Fd : C.int;
+ Iov : System.Address;
+ Iovcnt : C.int)
+ return C.int;
+
+ procedure Free_Socket_Set
+ (Set : Fd_Set_Access);
+ -- Free system-dependent socket set
+
+ procedure Get_Socket_From_Set
+ (Set : Fd_Set_Access;
+ Socket : Int_Access;
+ Last : Int_Access);
+ -- Get last socket in Socket and remove it from the socket
+ -- set. The parameter Last is a maximum value of the largest
+ -- socket. This hint is used to avoid scanning very large socket
+ -- sets. After a call to Get_Socket_From_Set, Last is set back to
+ -- the real largest socket in the socket set.
+
+ procedure Insert_Socket_In_Set
+ (Set : Fd_Set_Access;
+ Socket : C.int);
+ -- Insert socket in the socket set
+
+ function Is_Socket_In_Set
+ (Set : Fd_Set_Access;
+ Socket : C.int)
+ return Boolean;
+ -- Check whether Socket is in the socket set
+
+ procedure Last_Socket_In_Set
+ (Set : Fd_Set_Access;
+ Last : Int_Access);
+ -- Find the largest socket in the socket set. This is needed for
+ -- select(). When Last_Socket_In_Set is called, parameter Last is
+ -- a maximum value of the largest socket. This hint is used to
+ -- avoid scanning very large socket sets. After the call, Last is
+ -- set back to the real largest socket in the socket set.
+
+ function New_Socket_Set
+ (Set : Fd_Set_Access)
+ return Fd_Set_Access;
+ -- Allocate a new socket set which is a system-dependent structure
+ -- and initialize by copying Set if it is non-null, by making it
+ -- empty otherwise.
+
+ procedure Remove_Socket_From_Set
+ (Set : Fd_Set_Access;
+ Socket : C.int);
+ -- Remove socket from the socket set
+
+ procedure Finalize;
+ procedure Initialize (Process_Blocking_IO : Boolean);
+
+private
+
+ pragma Import (C, C_Bind, "bind");
+ pragma Import (C, C_Close, "close");
+ pragma Import (C, C_Gethostname, "gethostname");
+ pragma Import (C, C_Getpeername, "getpeername");
+ pragma Import (C, C_Getsockname, "getsockname");
+ pragma Import (C, C_Getsockopt, "getsockopt");
+ pragma Import (C, C_Inet_Addr, "inet_addr");
+ pragma Import (C, C_Listen, "listen");
+ pragma Import (C, C_Read, "read");
+ pragma Import (C, C_Readv, "readv");
+ pragma Import (C, C_Select, "select");
+ pragma Import (C, C_Setsockopt, "setsockopt");
+ pragma Import (C, C_Shutdown, "shutdown");
+ pragma Import (C, C_Strerror, "strerror");
+ pragma Import (C, C_System, "system");
+ pragma Import (C, C_Write, "write");
+ pragma Import (C, C_Writev, "writev");
+
+ pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set");
+ pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set");
+ pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set");
+ pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set");
+ pragma Import (C, New_Socket_Set, "__gnat_new_socket_set");
+ pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set");
+ pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set");
+
+end GNAT.Sockets.Thin;
diff --git a/gcc/ada/41intnam.ads b/gcc/ada/41intnam.ads
index 474649c472c..b7009ab569e 100644
--- a/gcc/ada/41intnam.ads
+++ b/gcc/ada/41intnam.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/42intnam.ads b/gcc/ada/42intnam.ads
index 111b01eee9c..edc91159690 100644
--- a/gcc/ada/42intnam.ads
+++ b/gcc/ada/42intnam.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/4aintnam.ads b/gcc/ada/4aintnam.ads
index ac7d0865e55..95509a89d94 100644
--- a/gcc/ada/4aintnam.ads
+++ b/gcc/ada/4aintnam.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/4cintnam.ads b/gcc/ada/4cintnam.ads
index 0f9678e29ae..fa56138b461 100644
--- a/gcc/ada/4cintnam.ads
+++ b/gcc/ada/4cintnam.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/4dintnam.ads b/gcc/ada/4dintnam.ads
deleted file mode 100644
index 37e77777c8e..00000000000
--- a/gcc/ada/4dintnam.ads
+++ /dev/null
@@ -1,97 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . I N T E R R U P T S . N A M E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2002 Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a DOS/DJGPPv2 (FSU THREAD) version of this package.
---
--- The following signals are reserved by the run time:
---
--- SIGFPE, SIGILL, SIGSEGV, SIGABRT, SIGTRAP, SIGINT, SIGALRM
--- SIGSTOP, SIGKILL
---
--- The pragma Unreserve_All_Interrupts affects the following signal(s):
---
--- SIGINT: Made available for Ada handler
-
--- This target-dependent package spec contains names of interrupts
--- supported by the local system.
-
-with System.OS_Interface;
--- used for names of interrupts
-
-package Ada.Interrupts.Names is
-
- -- Beware that the mapping of names to signals may be
- -- many-to-one. There may be aliases. Also, for all
- -- signal names that are not supported on the current system
- -- the value of the corresponding constant will be zero.
-
- SIGHUP : constant Interrupt_ID :=
- System.OS_Interface.SIGHUP; -- hangup
-
- SIGINT : constant Interrupt_ID :=
- System.OS_Interface.SIGINT; -- interrupt (rubout)
-
- SIGQUIT : constant Interrupt_ID :=
- System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
-
- SIGILL : constant Interrupt_ID :=
- System.OS_Interface.SIGILL; -- illegal instruction (not reset)
-
- SIGABRT : constant Interrupt_ID := -- used by abort,
- System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
-
- SIGFPE : constant Interrupt_ID :=
- System.OS_Interface.SIGFPE; -- floating point exception
-
- SIGKILL : constant Interrupt_ID :=
- System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
-
- SIGSEGV : constant Interrupt_ID :=
- System.OS_Interface.SIGSEGV; -- segmentation violation
-
- SIGPIPE : constant Interrupt_ID := -- write on a pipe with
- System.OS_Interface.SIGPIPE; -- no one to read it
-
- SIGALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGALRM; -- alarm clock
-
- SIGTERM : constant Interrupt_ID :=
- System.OS_Interface.SIGTERM; -- software termination signal from kill
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
-end Ada.Interrupts.Names;
diff --git a/gcc/ada/4gintnam.ads b/gcc/ada/4gintnam.ads
index c22d1393291..afd82f2bb6c 100644
--- a/gcc/ada/4gintnam.ads
+++ b/gcc/ada/4gintnam.ads
@@ -6,7 +6,8 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2002, Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU Library General Public License as published by the --
@@ -26,27 +27,26 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Irix version of this package
---
+
-- The following signals are reserved by the run time (Athread library):
---
+
-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGSTOP, SIGKILL
---
+
-- The following signals are reserved by the run time (Pthread library):
---
+
-- SIGTSTP, SIGILL, SIGTRAP, SIGEMT, SIGFPE, SIGBUS, SIGSTOP, SIGKILL,
-- SIGSEGV, SIGSYS, SIGXCPU, SIGXFSZ, SIGPROF, SIGPTINTR, SIGPTRESCHED,
-- SIGABRT, SIGINT
---
+
-- The pragma Unreserve_All_Interrupts affects the following signal
-- (Pthread library):
---
+
-- SIGINT: made available for Ada handler
-- This target-dependent package spec contains names of interrupts
diff --git a/gcc/ada/4hexcpol.adb b/gcc/ada/4hexcpol.adb
index 0162918ae3e..7deb26a8603 100644
--- a/gcc/ada/4hexcpol.adb
+++ b/gcc/ada/4hexcpol.adb
@@ -28,7 +28,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/4hintnam.ads b/gcc/ada/4hintnam.ads
index b275cab1a26..0e01a0fa74e 100644
--- a/gcc/ada/4hintnam.ads
+++ b/gcc/ada/4hintnam.ads
@@ -6,7 +6,8 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2002, Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,21 +27,20 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a HP-UX version of this package.
---
+
-- The following signals are reserved by the run time:
---
+
-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT,
-- SIGALRM, SIGSTOP, SIGKILL
---
+
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
---
+
-- SIGINT: made available for Ada handler
-- This target-dependent package spec contains names of interrupts
diff --git a/gcc/ada/4lintnam.ads b/gcc/ada/4lintnam.ads
index 048e18378fc..ce9ccc774db 100644
--- a/gcc/ada/4lintnam.ads
+++ b/gcc/ada/4lintnam.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/4mintnam.ads b/gcc/ada/4mintnam.ads
deleted file mode 100644
index f893e555189..00000000000
--- a/gcc/ada/4mintnam.ads
+++ /dev/null
@@ -1,145 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . I N T E R R U P T S . N A M E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a Machten version of this package.
---
--- The following signals are reserved by the run time:
---
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
--- SIGALRM, SIGEMT, SIGCHLD, SIGSTOP, SIGKILL
---
--- The pragma Unreserve_All_Interrupts affects the following signal(s):
---
--- SIGINT: made available for Ada handlers
-
--- This target-dependent package spec contains names of interrupts
--- supported by the local system.
-
-with System.OS_Interface;
--- used for names of interrupts
-
-package Ada.Interrupts.Names is
-
- -- Beware that the mapping of names to signals may be
- -- many-to-one. There may be aliases. Also, for all
- -- signal names that are not supported on the current system
- -- the value of the corresponding constant will be zero.
-
- SIGHUP : constant Interrupt_ID :=
- System.OS_Interface.SIGHUP; -- hangup
-
- SIGINT : constant Interrupt_ID :=
- System.OS_Interface.SIGINT; -- interrupt (rubout)
-
- SIGQUIT : constant Interrupt_ID :=
- System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
-
- SIGILL : constant Interrupt_ID :=
- System.OS_Interface.SIGILL; -- illegal instruction (not reset)
-
- SIGTRAP : constant Interrupt_ID :=
- System.OS_Interface.SIGTRAP; -- trace trap (not reset)
-
- SIGABRT : constant Interrupt_ID := -- used by abort,
- System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
-
- SIGIOT : constant Interrupt_ID :=
- System.OS_Interface.SIGIOT; -- IOT instruction
-
- SIGBUS : constant Interrupt_ID :=
- System.OS_Interface.SIGBUS; -- bus error
-
- SIGFPE : constant Interrupt_ID :=
- System.OS_Interface.SIGFPE; -- floating point exception
-
- SIGKILL : constant Interrupt_ID :=
- System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGSEGV : constant Interrupt_ID :=
- System.OS_Interface.SIGSEGV; -- segmentation violation
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
- SIGPIPE : constant Interrupt_ID := -- write on a pipe with
- System.OS_Interface.SIGPIPE; -- no one to read it
-
- SIGALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGALRM; -- alarm clock
-
- SIGTERM : constant Interrupt_ID :=
- System.OS_Interface.SIGTERM; -- software termination signal from kill
-
- SIGCHLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
-
- SIGCONT : constant Interrupt_ID :=
- System.OS_Interface.SIGCONT; -- stopped process has been continued
-
- SIGSTOP : constant Interrupt_ID :=
- System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
-
- SIGTSTP : constant Interrupt_ID :=
- System.OS_Interface.SIGTSTP; -- user stop requested from tty
-
- SIGTTIN : constant Interrupt_ID :=
- System.OS_Interface.SIGTTIN; -- background tty read attempted
-
- SIGTTOU : constant Interrupt_ID :=
- System.OS_Interface.SIGTTOU; -- background tty write attempted
-
- SIGURG : constant Interrupt_ID :=
- System.OS_Interface.SIGURG; -- urgent condition on IO channel
-
- SIGXCPU : constant Interrupt_ID :=
- System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
-
- SIGXFSZ : constant Interrupt_ID :=
- System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
-
- SIGVTALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGVTALRM; -- virtual timer expired
-
- SIGPROF : constant Interrupt_ID :=
- System.OS_Interface.SIGPROF; -- profiling timer expired
-
- SIGWINCH : constant Interrupt_ID :=
- System.OS_Interface.SIGWINCH; -- window size change
-
- SIGIO : constant Interrupt_ID := -- input/output possible,
- System.OS_Interface.SIGIO;
-
-end Ada.Interrupts.Names;
diff --git a/gcc/ada/4nintnam.ads b/gcc/ada/4nintnam.ads
index dc9bea2fe25..427ba5cc18a 100644
--- a/gcc/ada/4nintnam.ads
+++ b/gcc/ada/4nintnam.ads
@@ -28,7 +28,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/4ointnam.ads b/gcc/ada/4ointnam.ads
index efa1d3c6831..6733730b372 100644
--- a/gcc/ada/4ointnam.ads
+++ b/gcc/ada/4ointnam.ads
@@ -6,7 +6,8 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-1997 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/4onumaux.ads b/gcc/ada/4onumaux.ads
index fd208c1df14..1512401b785 100644
--- a/gcc/ada/4onumaux.ads
+++ b/gcc/ada/4onumaux.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (C Library Version for x86) --
-- --
--- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/4pintnam.ads b/gcc/ada/4pintnam.ads
index 3c1ee22175f..f9cac69dc99 100644
--- a/gcc/ada/4pintnam.ads
+++ b/gcc/ada/4pintnam.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/4sintnam.ads b/gcc/ada/4sintnam.ads
index 8217d3089f4..d6fc181ea9e 100644
--- a/gcc/ada/4sintnam.ads
+++ b/gcc/ada/4sintnam.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/4uintnam.ads b/gcc/ada/4uintnam.ads
deleted file mode 100644
index a5ddb4a5c81..00000000000
--- a/gcc/ada/4uintnam.ads
+++ /dev/null
@@ -1,154 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- A D A . I N T E R R U P T S . N A M E S --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2002 Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a Sun OS (FSU THREADS) version of this package.
---
--- The following signals are reserved by the run time:
---
--- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
--- SIGALRM, SIGEMT, SIGCHLD, SIGSTOP, SIGKILL
---
--- The pragma Unreserve_All_Interrupts affects the following signal(s):
---
--- SIGINT: made available for Ada handlers
-
-with System.OS_Interface;
--- used for names of interrupts
-
-package Ada.Interrupts.Names is
-
- -- Beware that the mapping of names to signals may be
- -- many-to-one. There may be aliases. Also, for all
- -- signal names that are not supported on the current system
- -- the value of the corresponding constant will be zero.
-
- SIGHUP : constant Interrupt_ID :=
- System.OS_Interface.SIGHUP; -- hangup
-
- SIGINT : constant Interrupt_ID :=
- System.OS_Interface.SIGINT; -- interrupt (rubout)
-
- SIGQUIT : constant Interrupt_ID :=
- System.OS_Interface.SIGQUIT; -- quit (ASCD FS)
-
- SIGILL : constant Interrupt_ID :=
- System.OS_Interface.SIGILL; -- illegal instruction (not reset)
-
- SIGTRAP : constant Interrupt_ID :=
- System.OS_Interface.SIGTRAP; -- trace trap (not reset)
-
- SIGIOT : constant Interrupt_ID :=
- System.OS_Interface.SIGIOT; -- IOT instruction
-
- SIGABRT : constant Interrupt_ID := -- used by abort,
- System.OS_Interface.SIGABRT; -- replace SIGIOT in the future
-
- SIGEMT : constant Interrupt_ID :=
- System.OS_Interface.SIGEMT; -- EMT instruction
-
- SIGFPE : constant Interrupt_ID :=
- System.OS_Interface.SIGFPE; -- floating point exception
-
- SIGKILL : constant Interrupt_ID :=
- System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored)
-
- SIGBUS : constant Interrupt_ID :=
- System.OS_Interface.SIGBUS; -- bus error
-
- SIGSEGV : constant Interrupt_ID :=
- System.OS_Interface.SIGSEGV; -- segmentation violation
-
- SIGSYS : constant Interrupt_ID :=
- System.OS_Interface.SIGSYS; -- bad argument to system call
-
- SIGPIPE : constant Interrupt_ID := -- write on a pipe with
- System.OS_Interface.SIGPIPE; -- no one to read it
-
- SIGALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGALRM; -- alarm clock
-
- SIGTERM : constant Interrupt_ID :=
- System.OS_Interface.SIGTERM; -- software termination signal from kill
-
- SIGUSR1 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR1; -- user defined signal 1
-
- SIGUSR2 : constant Interrupt_ID :=
- System.OS_Interface.SIGUSR2; -- user defined signal 2
-
- SIGCLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCLD; -- child status change
-
- SIGCHLD : constant Interrupt_ID :=
- System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD
-
- SIGWINCH : constant Interrupt_ID :=
- System.OS_Interface.SIGWINCH; -- window size change
-
- SIGURG : constant Interrupt_ID :=
- System.OS_Interface.SIGURG; -- urgent condition on IO channel
-
- SIGPOLL : constant Interrupt_ID :=
- System.OS_Interface.SIGPOLL; -- pollable event occurred
-
- SIGIO : constant Interrupt_ID := -- input/output possible,
- System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris)
-
- SIGSTOP : constant Interrupt_ID :=
- System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored)
-
- SIGTSTP : constant Interrupt_ID :=
- System.OS_Interface.SIGTSTP; -- user stop requested from tty
-
- SIGCONT : constant Interrupt_ID :=
- System.OS_Interface.SIGCONT; -- stopped process has been continued
-
- SIGTTIN : constant Interrupt_ID :=
- System.OS_Interface.SIGTTIN; -- background tty read attempted
-
- SIGTTOU : constant Interrupt_ID :=
- System.OS_Interface.SIGTTOU; -- background tty write attempted
-
- SIGVTALRM : constant Interrupt_ID :=
- System.OS_Interface.SIGVTALRM; -- virtual timer expired
-
- SIGPROF : constant Interrupt_ID :=
- System.OS_Interface.SIGPROF; -- profiling timer expired
-
- SIGXCPU : constant Interrupt_ID :=
- System.OS_Interface.SIGXCPU; -- CPU time limit exceeded
-
- SIGXFSZ : constant Interrupt_ID :=
- System.OS_Interface.SIGXFSZ; -- filesize limit exceeded
-
-end Ada.Interrupts.Names;
diff --git a/gcc/ada/4vcaldel.adb b/gcc/ada/4vcaldel.adb
index 8ffdb3ae645..a95eae657b8 100644
--- a/gcc/ada/4vcaldel.adb
+++ b/gcc/ada/4vcaldel.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2000 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/4vcalend.adb b/gcc/ada/4vcalend.adb
index 99b8dcafac1..74c2923cbf2 100644
--- a/gcc/ada/4vcalend.adb
+++ b/gcc/ada/4vcalend.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2000 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- --
@@ -235,8 +235,11 @@ package body Ada.Calendar is
Status : Unsigned_Longword;
Timbuf : Unsigned_Word_Array (1 .. 7);
+ Subsecs : constant Time := Date mod 10_000_000;
+ Date_Secs : constant Time := Date - Subsecs;
+
begin
- Numtim (Status, Timbuf, Date);
+ Numtim (Status, Timbuf, Date_Secs);
if Status mod 2 /= 1
or else Timbuf (1) not in Ada_Year_Min .. Ada_Year_Max
@@ -244,12 +247,13 @@ package body Ada.Calendar is
raise Time_Error;
end if;
- Seconds
- := Day_Duration (Timbuf (6) + 60 * (Timbuf (5) + 60 * Timbuf (4)))
- + Day_Duration (Timbuf (7)) / 100.0;
- Day := Integer (Timbuf (3));
- Month := Integer (Timbuf (2));
- Year := Integer (Timbuf (1));
+ Seconds := Day_Duration (Timbuf (6)
+ + 60 * (Timbuf (5) + 60 * Timbuf (4)))
+ + Duration (Subsecs) / 10_000_000.0;
+
+ Day := Integer (Timbuf (3));
+ Month := Integer (Timbuf (2));
+ Year := Integer (Timbuf (1));
end Split;
-------------
@@ -280,6 +284,8 @@ package body Ada.Calendar is
Date : Time;
Int_Secs : Integer;
Day_Hack : Boolean := False;
+ Subsecs : Day_Duration;
+
begin
-- The following checks are redundant with respect to the constraint
-- error checks that should normally be made on parameters, but we
@@ -305,30 +311,17 @@ package body Ada.Calendar is
Int_Secs := Integer (Seconds);
end if;
+ Subsecs := Seconds - Day_Duration (Int_Secs);
+
-- Cvt_Vectim barfs on the largest Day_Duration, so trick it by
-- setting it to zero and then adding the difference after conversion.
if Int_Secs = 86_400 then
Int_Secs := 0;
Day_Hack := True;
- Timbuf (7) := 0;
- else
- Timbuf (7) := Unsigned_Word
- (100.0 * Duration (Seconds - Day_Duration (Int_Secs)));
- -- Cvt_Vectim accurate only to within .01 seconds
- end if;
-
- -- Similar hack needed for 86399 and 100/100ths, since that gets
- -- treated as 86400 (largest Day_Duration). This can happen because
- -- Duration has more accuracy than VMS system time conversion calls
- -- can handle.
-
- if Int_Secs = 86_399 and then Timbuf (7) = 100 then
- Int_Secs := 0;
- Day_Hack := True;
- Timbuf (7) := 0;
end if;
+ Timbuf (7) := 0;
Timbuf (6) := Unsigned_Word (Int_Secs mod 60);
Timbuf (5) := Unsigned_Word ((Int_Secs / 60) mod 60);
Timbuf (4) := Unsigned_Word (Int_Secs / 3600);
@@ -346,8 +339,8 @@ package body Ada.Calendar is
Date := Date + 10_000_000 * 86_400;
end if;
+ Date := Date + Time (10_000_000.0 * Subsecs);
return Date;
-
end Time_Of;
----------
diff --git a/gcc/ada/4vintnam.ads b/gcc/ada/4vintnam.ads
index 5e4f58593e0..7eec58fbeb7 100644
--- a/gcc/ada/4vintnam.ads
+++ b/gcc/ada/4vintnam.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/4wexcpol.adb b/gcc/ada/4wexcpol.adb
index 0ee2dea057f..afa93c1d3f2 100644
--- a/gcc/ada/4wexcpol.adb
+++ b/gcc/ada/4wexcpol.adb
@@ -28,7 +28,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/4wintnam.ads b/gcc/ada/4wintnam.ads
index 834ff6b2959..4d02e17bf60 100644
--- a/gcc/ada/4wintnam.ads
+++ b/gcc/ada/4wintnam.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2002 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/4zintnam.ads b/gcc/ada/4zintnam.ads
index 8c67efff57e..757b15376fb 100644
--- a/gcc/ada/4zintnam.ads
+++ b/gcc/ada/4zintnam.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/50system.ads b/gcc/ada/50system.ads
new file mode 100644
index 00000000000..e3277e56789
--- /dev/null
+++ b/gcc/ada/50system.ads
@@ -0,0 +1,163 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (VxWorks/HIE Version PPC) --
+-- --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+pragma Restrictions (No_Exception_Handlers);
+pragma Restrictions (No_Implicit_Dynamic_Code);
+pragma Restrictions (No_Finalization);
+pragma Discard_Names;
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 1.0 / 60.0;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 32;
+ Memory_Size : constant := 2 ** 32;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := High_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ -- 256 is reserved for the VxWorks kernel
+ -- 248 - 255 correspond to hardware interrupt levels 0 .. 7
+ -- 247 is a catchall default "interrupt" priority for signals,
+ -- allowing higher priority than normal tasks, but lower than
+ -- hardware priority levels. Protected Object ceilings can
+ -- override these values.
+ -- 246 is used by the Interrupt_Manager task
+
+ Max_Priority : constant Positive := 245;
+ Max_Interrupt_Priority : constant Positive := 255;
+
+ subtype Any_Priority is Integer range 0 .. 255;
+ subtype Priority is Any_Priority range 0 .. 245;
+ subtype Interrupt_Priority is Any_Priority range 246 .. 255;
+
+ Default_Priority : constant Priority := 122;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := False;
+ Configurable_Run_Time : constant Boolean := True;
+ Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := True;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := False;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := True;
+ Use_Ada_Main_Program_Name : constant Boolean := True;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := True;
+ Long_Shifts_Inlined : constant Boolean := False;
+
+end System;
diff --git a/gcc/ada/51osinte.adb b/gcc/ada/51osinte.adb
index 8b159a899b8..9916e8846f4 100644
--- a/gcc/ada/51osinte.adb
+++ b/gcc/ada/51osinte.adb
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/51osinte.ads b/gcc/ada/51osinte.ads
index 63ab7beeefc..509aee8ccd0 100644
--- a/gcc/ada/51osinte.ads
+++ b/gcc/ada/51osinte.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/52system.ads b/gcc/ada/51system.ads
index 63485e177ee..01404ee32aa 100644
--- a/gcc/ada/52system.ads
+++ b/gcc/ada/51system.ads
@@ -5,9 +5,9 @@
-- S Y S T E M --
-- --
-- S p e c --
--- (LynxOS PPC/x86 Version)
+-- (SCO UnixWare Version) --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -58,7 +58,7 @@ pragma Pure (System);
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
- Tick : constant := 1.0;
+ Tick : constant := 0.01;
-- Storage-related Declarations
@@ -86,7 +86,7 @@ pragma Pure (System);
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := High_Order_First;
+ Default_Bit_Order : constant Bit_Order := Low_Order_First;
-- Priority-related Declarations (RM D.1)
@@ -118,21 +118,33 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := True;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
end System;
diff --git a/gcc/ada/52osinte.adb b/gcc/ada/52osinte.adb
index 0e03bd0607f..156601442b3 100644
--- a/gcc/ada/52osinte.adb
+++ b/gcc/ada/52osinte.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -424,6 +424,7 @@ package body System.OS_Interface is
protocol : int)
return int
is
+ pragma Unreferenced (attr, protocol);
begin
return 0;
end pthread_mutexattr_setprotocol;
@@ -433,6 +434,7 @@ package body System.OS_Interface is
prioceiling : int)
return int
is
+ pragma Unreferenced (attr, prioceiling);
begin
return 0;
end pthread_mutexattr_setprioceiling;
@@ -442,6 +444,7 @@ package body System.OS_Interface is
contentionscope : int)
return int
is
+ pragma Unreferenced (attr, contentionscope);
begin
return 0;
end pthread_attr_setscope;
@@ -464,6 +467,7 @@ package body System.OS_Interface is
detachstate : int)
return int
is
+ pragma Unreferenced (attr, detachstate);
begin
return 0;
end pthread_attr_setdetachstate;
diff --git a/gcc/ada/52osinte.ads b/gcc/ada/52osinte.ads
index 2f4431fdb0f..ba2e532cc24 100644
--- a/gcc/ada/52osinte.ads
+++ b/gcc/ada/52osinte.ads
@@ -6,7 +6,8 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- --
+-- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +28,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -457,6 +458,9 @@ package System.OS_Interface is
pragma Inline (pthread_create);
-- LynxOS has a non standard pthread_create
+ function pthread_detach (thread : pthread_t) return int;
+ pragma Inline (pthread_detach);
+
procedure pthread_exit (status : System.Address);
pragma Import (C, pthread_exit, "pthread_exit");
diff --git a/gcc/ada/53osinte.ads b/gcc/ada/53osinte.ads
index 3643653b5a2..b4934b464c5 100644
--- a/gcc/ada/53osinte.ads
+++ b/gcc/ada/53osinte.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/54osinte.ads b/gcc/ada/54osinte.ads
index d13eed4cc11..037fd09e829 100644
--- a/gcc/ada/54osinte.ads
+++ b/gcc/ada/54osinte.ads
@@ -26,9 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/55system.ads b/gcc/ada/55system.ads
new file mode 100644
index 00000000000..65bcc0ebd7f
--- /dev/null
+++ b/gcc/ada/55system.ads
@@ -0,0 +1,150 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (GNU-Linux/ia64 Version) --
+-- --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 0.01;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 64;
+ Memory_Size : constant := 2 ** 64;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := Low_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer range 0 .. 31;
+ subtype Priority is Any_Priority range 0 .. 30;
+ subtype Interrupt_Priority is Any_Priority range 31 .. 31;
+
+ Default_Priority : constant Priority := 15;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
+ Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
+end System;
diff --git a/gcc/ada/56osinte.adb b/gcc/ada/56osinte.adb
new file mode 100644
index 00000000000..0cb052632a3
--- /dev/null
+++ b/gcc/ada/56osinte.adb
@@ -0,0 +1,154 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001-2002 Ada Core Technologies, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a LynxOS (POSIX Threads) version of this package
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+with Interfaces.C;
+
+package body System.OS_Interface is
+
+ use Interfaces.C;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ function To_Duration (TV : struct_timeval) return Duration is
+ begin
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ end To_Duration;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ ----------------
+ -- To_Timeval --
+ ----------------
+
+ function To_Timeval (D : Duration) return struct_timeval is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return
+ struct_timeval'
+ (tv_sec => S,
+ tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
+ end To_Timeval;
+
+ -------------
+ -- sigwait --
+ -------------
+
+ function sigwait
+ (set : access sigset_t;
+ sig : access Signal)
+ return int
+ is
+ function sigwaitinfo
+ (set : access sigset_t;
+ info : System.Address) return Signal;
+ pragma Import (C, sigwaitinfo, "sigwaitinfo");
+
+ begin
+ sig.all := sigwaitinfo (set, Null_Address);
+
+ if sig.all = -1 then
+ return errno;
+ end if;
+
+ return 0;
+ end sigwait;
+
+ --------------------
+ -- Get_Stack_Base --
+ --------------------
+
+ function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+
+ begin
+ return Null_Address;
+ end Get_Stack_Base;
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+end System.OS_Interface;
diff --git a/gcc/ada/5mosinte.ads b/gcc/ada/56osinte.ads
index 17ed7f51025..c6bcbeb9ad4 100644
--- a/gcc/ada/5mosinte.ads
+++ b/gcc/ada/56osinte.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,11 +27,11 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
--- This is a MACOS (FSU THREAD) version of this package.
+-- This is a LynxOS (POSIX Threads) version of this package.
-- This package encapsulates all direct interfaces to OS services
-- that are needed by children of System.
@@ -44,7 +44,10 @@ with Interfaces.C;
package System.OS_Interface is
pragma Preelaborate;
- pragma Linker_Options ("-lgthreads");
+ pragma Linker_Options ("-mthreads");
+ -- Selects the POSIX 1.c runtime, rather than the non-threading runtime
+ -- or the deprecated legacy threads library. The -mthreads flag is
+ -- defined in patch.LynxOS and matches the definition for Lynx's gcc.
subtype int is Interfaces.C.int;
subtype short is Interfaces.C.short;
@@ -63,7 +66,7 @@ package System.OS_Interface is
function errno return int;
pragma Import (C, errno, "__get_errno");
- EAGAIN : constant := 35;
+ EAGAIN : constant := 11;
EINTR : constant := 4;
EINVAL : constant := 22;
ENOMEM : constant := 12;
@@ -73,49 +76,71 @@ package System.OS_Interface is
-- Signals --
-------------
- Max_Interrupt : constant := 31;
+ Max_Interrupt : constant := 63;
+
+ -- Max_Interrupt is the number of OS signals, as defined in:
+ --
+ -- /usr/include/sys/signal.h
+ --
+ --
+ -- The lowest numbered signal is 1, but 0 is a valid argument to some
+ -- library functions, eg. kill(2). However, 0 is not just another
+ -- signal: For instance 'I in Signal' and similar should be used with
+ -- caution.
+
type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGWINCH : constant := 28; -- window size change
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
+ for Signal'Size use int'Size;
+
+ SIGHUP : constant := 1; -- hangup
+ SIGINT : constant := 2; -- interrupt (rubout)
+ SIGQUIT : constant := 3; -- quit (ASCD FS)
+ SIGILL : constant := 4; -- illegal instruction (not reset)
+ SIGTRAP : constant := 5; -- trace trap (not reset)
+ SIGBRK : constant := 6; -- break
+ SIGIOT : constant := 6; -- IOT instruction
+ SIGABRT : constant := 6; -- used by abort, replace SIGIOT in future
+ SIGCORE : constant := 7; -- kill with core dump
+ SIGEMT : constant := 7; -- EMT instruction
+ SIGFPE : constant := 8; -- floating point exception
+ SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
+ SIGBUS : constant := 10; -- bus error
+ SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad argument to system call
+ SIGPIPE : constant := 13; -- write on a pipe with no one to read it
+ SIGALRM : constant := 14; -- alarm clock
+ SIGTERM : constant := 15; -- software termination signal from kill
+ SIGURG : constant := 16; -- urgent condition on IO channel
+ SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 18; -- user stop requested from tty
+ SIGCONT : constant := 19; -- stopped process has been continued
+ SIGCLD : constant := 20; -- alias for SIGCHLD
+ SIGCHLD : constant := 20; -- child status change
+ SIGTTIN : constant := 21; -- background tty read attempted
+ SIGTTOU : constant := 22; -- background tty write attempted
+ SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
+ SIGPOLL : constant := 23; -- pollable event occurred
+ SIGTHREADKILL : constant := 24; -- Reserved by LynxOS runtime
+ SIGXCPU : constant := 24; -- CPU time limit exceeded
+ SIGXFSZ : constant := 25; -- filesize limit exceeded
+ SIGVTALRM : constant := 26; -- virtual timer expired
+ SIGPROF : constant := 27; -- profiling timer expired
+ SIGWINCH : constant := 28; -- window size change
+ SIGLOST : constant := 29; -- SUN 4.1 compatibility
+ SIGUSR1 : constant := 30; -- user defined signal 1
+ SIGUSR2 : constant := 31; -- user defined signal 2
+
+ SIGPRIO : constant := 32;
+ -- sent to a process with its priority or group is changed
SIGADAABORT : constant := SIGABRT;
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
type Signal_Set is array (Natural range <>) of Signal;
- Unmasked : constant Signal_Set := (SIGTRAP, SIGALRM, SIGEMT, SIGCHLD);
- Reserved : constant Signal_Set := (SIGKILL, SIGSTOP);
+ Unmasked : constant Signal_Set :=
+ (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGTHREADKILL);
+ Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO);
type sigset_t is private;
@@ -135,16 +160,16 @@ package System.OS_Interface is
pragma Import (C, sigemptyset, "sigemptyset");
type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
+ sa_handler : System.Address;
+ sa_mask : sigset_t;
+ sa_flags : int;
end record;
pragma Convention (C, struct_sigaction);
type struct_sigaction_ptr is access all struct_sigaction;
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 3;
+ SIG_BLOCK : constant := 0;
+ SIG_UNBLOCK : constant := 1;
+ SIG_SETMASK : constant := 2;
SIG_DFL : constant := 0;
SIG_IGN : constant := 1;
@@ -159,9 +184,8 @@ package System.OS_Interface is
-- Time --
----------
- Time_Slice_Supported : constant Boolean := False;
- -- Indicates wether time slicing is supported (i.e FSU threads have been
- -- compiled with DEF_RR)
+ Time_Slice_Supported : constant Boolean := True;
+ -- Indicates whether time slicing is supported
type timespec is private;
@@ -174,13 +198,27 @@ package System.OS_Interface is
tp : access timespec) return int;
pragma Import (C, clock_gettime, "clock_gettime");
+ function clock_getres
+ (clock_id : clockid_t;
+ res : access timespec) return int;
+ pragma Import (C, clock_getres, "clock_getres");
+
function To_Duration (TS : timespec) return Duration;
pragma Inline (To_Duration);
function To_Timespec (D : Duration) return timespec;
pragma Inline (To_Timespec);
+ type struct_timezone is record
+ tz_minuteswest : int;
+ tz_dsttime : int;
+ end record;
+ pragma Convention (C, struct_timezone);
+ type struct_timezone_ptr is access all struct_timezone;
+
type struct_timeval is private;
+ -- This is needed on systems that do not have clock_gettime()
+ -- but do have gettimeofday().
function To_Duration (TV : struct_timeval) return Duration;
pragma Inline (To_Duration);
@@ -192,9 +230,9 @@ package System.OS_Interface is
-- Priority Scheduling --
-------------------------
- SCHED_FIFO : constant := 0;
- SCHED_RR : constant := 1;
- SCHED_OTHER : constant := 2;
+ SCHED_FIFO : constant := 16#200000#;
+ SCHED_RR : constant := 16#100000#;
+ SCHED_OTHER : constant := 16#400000#;
-------------
-- Process --
@@ -213,9 +251,6 @@ package System.OS_Interface is
---------
function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
pragma Import (C, lwp_self, "pthread_self");
-------------
@@ -224,7 +259,6 @@ package System.OS_Interface is
type Thread_Body is access
function (arg : System.Address) return System.Address;
-
type pthread_t is private;
subtype Thread_Id is pthread_t;
@@ -236,57 +270,54 @@ package System.OS_Interface is
type pthread_key_t is private;
PTHREAD_CREATE_DETACHED : constant := 1;
+ PTHREAD_CREATE_JOINABLE : constant := 0;
-----------
-- Stack --
-----------
Stack_Base_Available : constant Boolean := False;
- -- Indicates wether the stack base is available on this target.
- -- This allows us to share s-osinte.adb between all the FSU run time.
- -- Note that this value can only be true if pthread_t has a complete
- -- definition that corresponds exactly to the C header files.
+ -- Indicates whether the stack base is available on this target.
function Get_Stack_Base (thread : pthread_t) return Address;
pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread.
+ -- Returns the stack base of the specified thread.
-- Only call this function when Stack_Base_Available is True.
function Get_Page_Size return size_t;
function Get_Page_Size return Address;
pragma Import (C, Get_Page_Size, "getpagesize");
- -- returns the size of a page, or 0 if this is not relevant on this
+ -- Returns the size of a page, or 0 if this is not relevant on this
-- target
- PROT_NONE : constant := 0;
- PROT_READ : constant := 1;
- PROT_WRITE : constant := 2;
- PROT_EXEC : constant := 4;
+ PROT_NONE : constant := 1;
+ PROT_READ : constant := 2;
+ PROT_WRITE : constant := 4;
+ PROT_EXEC : constant := 8;
PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
- PROT_ON : constant := PROT_NONE;
+ PROT_ON : constant := PROT_READ;
PROT_OFF : constant := PROT_ALL;
function mprotect (addr : Address; len : size_t; prot : int) return int;
pragma Import (C, mprotect);
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
+ -----------------------------------------
+ -- Nonstandard Thread Initialization --
+ -----------------------------------------
procedure pthread_init;
- -- FSU_THREADS requires pthread_init, which is nonstandard
- -- and this should be invoked during the elaboration of s-taprop.adb
- pragma Import (C, pthread_init, "pthread_init");
+ -- This is a dummy procedure to share some GNULLI files
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
+ ---------------------------
+ -- POSIX.1c Section 3 --
+ ---------------------------
function sigwait
(set : access sigset_t;
sig : access Signal) return int;
- -- FSU_THREADS has a nonstandard sigwait
+ pragma Inline (sigwait);
+ -- LynxOS has non standard sigwait
function pthread_kill
(thread : pthread_t;
@@ -298,13 +329,14 @@ package System.OS_Interface is
function pthread_sigmask
(how : int;
set : sigset_t_ptr;
- oset : sigset_t_ptr)
- return int;
- pragma Import (C, pthread_sigmask, "sigprocmask");
+ oset : sigset_t_ptr) return int;
+ pragma Import (C, pthread_sigmask, "pthread_sigmask");
+ -- The behavior of pthread_sigmask on LynxOS requires
+ -- further investigation.
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
+ ----------------------------
+ -- POSIX.1c Section 11 --
+ ----------------------------
function pthread_mutexattr_init
(attr : access pthread_mutexattr_t) return int;
@@ -323,10 +355,10 @@ package System.OS_Interface is
pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- -- FSU_THREADS has nonstandard pthread_mutex_lock
+ pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock");
function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- -- FSU_THREADS has nonstandard pthread_mutex_lock
+ pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock");
function pthread_condattr_init
(attr : access pthread_condattr_t) return int;
@@ -350,13 +382,13 @@ package System.OS_Interface is
function pthread_cond_wait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t) return int;
- -- FSU_THREADS has a nonstandard pthread_cond_wait
+ pragma Import (C, pthread_cond_wait, "pthread_cond_wait");
function pthread_cond_timedwait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t;
abstime : access timespec) return int;
- -- FSU_THREADS has a nonstandard pthread_cond_timedwait
+ pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait");
Relative_Timed_Wait : constant Boolean := False;
-- pthread_cond_timedwait requires an absolute delay time
@@ -366,8 +398,8 @@ package System.OS_Interface is
--------------------------
PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 2;
PTHREAD_PRIO_INHERIT : constant := 1;
+ PTHREAD_PRIO_PROTECT : constant := 2;
function pthread_mutexattr_setprotocol
(attr : access pthread_mutexattr_t;
@@ -375,21 +407,19 @@ package System.OS_Interface is
pragma Import (C, pthread_mutexattr_setprotocol);
function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
+ (attr : access pthread_mutexattr_t;
prioceiling : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprioceiling,
- "pthread_mutexattr_setprio_ceiling");
+ pragma Import (C, pthread_mutexattr_setprioceiling);
type struct_sched_param is record
- sched_priority : int; -- scheduling priority
+ sched_priority : int;
end record;
function pthread_setschedparam
(thread : pthread_t;
policy : int;
param : access struct_sched_param) return int;
- -- FSU_THREADS does not have pthread_setschedparam
+ pragma Import (C, pthread_setschedparam, "pthread_setschedparam");
function pthread_attr_setscope
(attr : access pthread_attr_t;
@@ -397,22 +427,17 @@ package System.OS_Interface is
pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
+ (attr : access pthread_attr_t;
inheritsched : int) return int;
pragma Import (C, pthread_attr_setinheritsched);
function pthread_attr_setschedpolicy
(attr : access pthread_attr_t;
policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched");
-
- function pthread_attr_setschedparam
- (attr : access pthread_attr_t;
- sched_param : int) return int;
- pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
+ pragma Import (C, pthread_attr_setschedpolicy);
function sched_yield return int;
- -- FSU_THREADS does not have sched_yield;
+ pragma Import (C, sched_yield, "sched_yield");
---------------------------
-- P1003.1c - Section 16 --
@@ -428,7 +453,7 @@ package System.OS_Interface is
function pthread_attr_setdetachstate
(attr : access pthread_attr_t;
detachstate : int) return int;
- -- FSU_THREADS has a nonstandard pthread_attr_setdetachstate
+ pragma Import (C, pthread_attr_setdetachstate);
function pthread_attr_setstacksize
(attr : access pthread_attr_t;
@@ -452,26 +477,31 @@ package System.OS_Interface is
-- POSIX.1c Section 17 --
--------------------------
- function pthread_setspecific
+ function st_setspecific
(key : pthread_key_t;
value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
+ pragma Import (C, st_setspecific, "st_setspecific");
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- -- FSU_THREADS has a nonstandard pthread_getspecific
+ function st_getspecific
+ (key : pthread_key_t;
+ retval : System.Address) return int;
+ pragma Import (C, st_getspecific, "st_getspecific");
type destructor_pointer is access procedure (arg : System.Address);
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
+ function st_keycreate
+ (destructor : destructor_pointer;
+ key : access pthread_key_t) return int;
+ pragma Import (C, st_keycreate, "st_keycreate");
private
- type sigset_t is new int;
+ type sigset_t is record
+ X1, X2 : long;
+ end record;
+ pragma Convention (C, sigset_t);
- type pid_t is new int;
+ type pid_t is new long;
type time_t is new long;
@@ -481,76 +511,71 @@ private
end record;
pragma Convention (C, timespec);
- type clockid_t is new int;
+ type clockid_t is new unsigned_char;
CLOCK_REALTIME : constant clockid_t := 0;
type struct_timeval is record
- tv_sec : long;
- tv_usec : long;
+ tv_sec : time_t;
+ tv_usec : time_t;
end record;
pragma Convention (C, struct_timeval);
+ type st_attr_t is record
+ stksize : int;
+ prio : int;
+ inheritsched : int;
+ state : int;
+ sched : int;
+ detachstate : int;
+ guardsize : int;
+ end record;
+ pragma Convention (C, st_attr_t);
+
type pthread_attr_t is record
- flags : int;
- stacksize : int;
- contentionscope : int;
- inheritsched : int;
- detachstate : int;
- sched : int;
- prio : int;
- starttime : timespec;
- deadline : timespec;
- period : timespec;
+ pthread_attr_magic : unsigned;
+ st : st_attr_t;
+ pthread_attr_scope : int;
end record;
pragma Convention (C, pthread_attr_t);
type pthread_condattr_t is record
- flags : int;
+ cv_magic : unsigned;
+ cv_pshared : unsigned;
end record;
pragma Convention (C, pthread_condattr_t);
type pthread_mutexattr_t is record
- flags : int;
- prio_ceiling : int;
- protocol : int;
+ m_flags : unsigned;
+ m_prio_c : int;
+ m_pshared : int;
end record;
pragma Convention (C, pthread_mutexattr_t);
- type sigjmp_buf is array (Integer range 0 .. 9) of int;
-
- type pthread_t_struct is record
- context : sigjmp_buf;
- pbody : sigjmp_buf;
- errno : int;
- ret : int;
- stack_base : System.Address;
- end record;
- pragma Convention (C, pthread_t_struct);
-
- type pthread_t is access all pthread_t_struct;
+ type tid_t is new short;
+ type pthread_t is new tid_t;
- type queue_t is record
- head : System.Address;
- tail : System.Address;
- end record;
- pragma Convention (C, queue_t);
+ type block_obj_t is new System.Address;
+ -- typedef struct _block_obj_s {
+ -- struct st_entry *b_head;
+ -- } block_obj_t;
type pthread_mutex_t is record
- queue : queue_t;
- lock : plain_char;
- owner : System.Address;
- flags : int;
- prio_ceiling : int;
- protocol : int;
- prev_max_ceiling_prio : int;
+ m_flags : unsigned;
+ m_owner : tid_t;
+ m_wait : block_obj_t;
+ m_prio_c : int;
+ m_oldprio : int;
+ m_count : int;
+ m_referenced : int;
end record;
pragma Convention (C, pthread_mutex_t);
+ type pthread_mutex_t_ptr is access all pthread_mutex_t;
type pthread_cond_t is record
- queue : queue_t;
- flags : int;
- waiters : int;
- mutex : System.Address;
+ cv_magic : unsigned;
+ cv_wait : block_obj_t;
+ cv_mutex : pthread_mutex_t_ptr;
+ cv_refcnt : int;
end record;
pragma Convention (C, pthread_cond_t);
diff --git a/gcc/ada/56taprop.adb b/gcc/ada/56taprop.adb
new file mode 100644
index 00000000000..60e87f005a8
--- /dev/null
+++ b/gcc/ada/56taprop.adb
@@ -0,0 +1,1201 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a LynxOS version of this file, adapted to make
+-- SCHED_FIFO and ceiling locking (Annex D compliance) work properly
+
+-- This package contains all the GNULL primitives that interface directly
+-- with the underlying OS.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+with System.Tasking.Debug;
+-- used for Known_Tasks
+
+with System.Task_Info;
+-- used for Task_Info_Type
+
+with Interfaces.C;
+-- used for int
+-- size_t
+
+with System.Interrupt_Management;
+-- used for Keep_Unmasked
+-- Abort_Task_Interrupt
+-- Interrupt_ID
+
+with System.Interrupt_Management.Operations;
+-- used for Set_Interrupt_Mask
+-- All_Tasks_Mask
+pragma Elaborate_All (System.Interrupt_Management.Operations);
+
+with System.Parameters;
+-- used for Size_Type
+
+with System.Tasking;
+-- used for Ada_Task_Control_Block
+-- Task_ID
+
+with System.Soft_Links;
+-- used for Defer/Undefer_Abort
+
+-- Note that we do not use System.Tasking.Initialization directly since
+-- this is a higher level package that we shouldn't depend on. For example
+-- when using the restricted run time, it is replaced by
+-- System.Tasking.Restricted.Initialization
+
+with System.OS_Primitives;
+-- used for Delay_Modes
+
+with Unchecked_Conversion;
+with Unchecked_Deallocation;
+
+package body System.Task_Primitives.Operations is
+
+ use System.Tasking.Debug;
+ use System.Tasking;
+ use Interfaces.C;
+ use System.OS_Interface;
+ use System.Parameters;
+ use System.OS_Primitives;
+
+ package SSL renames System.Soft_Links;
+
+ ----------------
+ -- Local Data --
+ ----------------
+
+ -- The followings are logically constants, but need to be initialized
+ -- at run time.
+
+ Single_RTS_Lock : aliased RTS_Lock;
+ -- This is a lock to allow only one thread of control in the RTS at
+ -- a time; it is used to execute in mutual exclusion from all other tasks.
+ -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
+ Environment_Task_ID : Task_ID;
+ -- A variable to hold Task_ID for the environment task.
+
+ Locking_Policy : Character;
+ pragma Import (C, Locking_Policy, "__gl_locking_policy");
+ -- Value of the pragma Locking_Policy:
+ -- 'C' for Ceiling_Locking
+ -- 'I' for Inherit_Locking
+ -- ' ' for none.
+
+ Unblocked_Signal_Mask : aliased sigset_t;
+ -- The set of signals that should unblocked in all tasks
+
+ -- The followings are internal configuration constants needed.
+
+ Next_Serial_Number : Task_Serial_Number := 100;
+ -- We start at 100, to reserve some special values for
+ -- using in error checking.
+
+ Time_Slice_Val : Integer;
+ pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
+
+ Dispatching_Policy : Character;
+ pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+
+ FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
+ -- Indicates whether FIFO_Within_Priorities is set.
+
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads).
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ procedure Initialize (Environment_Task : Task_ID);
+ pragma Inline (Initialize);
+ -- Initialize various data needed by this package.
+
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does the current thread have an ATCB?
+
+ procedure Set (Self_Id : Task_ID);
+ pragma Inline (Set);
+ -- Set the self id for the current task.
+
+ function Self return Task_ID;
+ pragma Inline (Self);
+ -- Return a pointer to the Ada Task Control Block of the calling task.
+
+ end Specific;
+
+ package body Specific is separate;
+ -- The body of this package is target specific.
+
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
+ -- Allocate and Initialize a new ATCB for the current Thread.
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_ID is separate;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler (Sig : Signal);
+ -- Signal handler used to implement asynchronous abort.
+
+ procedure Set_OS_Priority (T : Task_ID; Prio : System.Any_Priority);
+ -- This procedure calls the scheduler of the OS to set thread's priority
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ -------------------
+ -- Abort_Handler --
+ -------------------
+
+ procedure Abort_Handler (Sig : Signal) is
+ pragma Unreferenced (Sig);
+
+ T : Task_ID := Self;
+ Result : Interfaces.C.int;
+ Old_Set : aliased sigset_t;
+
+ begin
+ -- It is not safe to raise an exception when using ZCX and the GCC
+ -- exception handling mechanism.
+
+ if ZCX_By_Default and then GCC_ZCX_Support then
+ return;
+ end if;
+
+ if T.Deferral_Level = 0
+ and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
+ not T.Aborting
+ then
+ T.Aborting := True;
+
+ -- Make sure signals used for RTS internal purpose are unmasked
+
+ Result := pthread_sigmask (SIG_UNBLOCK,
+ Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ raise Standard'Abort_Signal;
+ end if;
+ end Abort_Handler;
+
+ -----------------
+ -- Stack_Guard --
+ -----------------
+
+ procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread);
+ Guard_Page_Address : Address;
+
+ Res : Interfaces.C.int;
+
+ begin
+ if Stack_Base_Available then
+
+ -- Compute the guard page address
+
+ Guard_Page_Address :=
+ Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size;
+
+ if On then
+ Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON);
+ else
+ Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF);
+ end if;
+
+ pragma Assert (Res = 0);
+ end if;
+ end Stack_Guard;
+
+ --------------------
+ -- Get_Thread_Id --
+ --------------------
+
+ function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is
+ begin
+ return T.Common.LL.Thread;
+ end Get_Thread_Id;
+
+ ----------
+ -- Self --
+ ----------
+
+ function Self return Task_ID renames Specific.Self;
+
+ ---------------------
+ -- Initialize_Lock --
+ ---------------------
+
+ procedure Initialize_Lock
+ (Prio : System.Any_Priority;
+ L : access Lock)
+ is
+ Attributes : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutexattr_init (Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ if Locking_Policy = 'C' then
+ L.Ceiling := Prio;
+ end if;
+
+ Result := pthread_mutex_init (L.Mutex'Access, Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Initialize_Lock;
+
+ procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ pragma Unreferenced (Level);
+
+ Attributes : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutexattr_init (Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutex_init (L, Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = ENOMEM then
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ raise Storage_Error;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+ end Initialize_Lock;
+
+ -------------------
+ -- Finalize_Lock --
+ -------------------
+
+ procedure Finalize_Lock (L : access Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_destroy (L.Mutex'Access);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ procedure Finalize_Lock (L : access RTS_Lock) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_mutex_destroy (L);
+ pragma Assert (Result = 0);
+ end Finalize_Lock;
+
+ ----------------
+ -- Write_Lock --
+ ----------------
+
+ procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ Result : Interfaces.C.int;
+ T : constant Task_ID := Self;
+
+ begin
+ if Locking_Policy = 'C' then
+ if T.Common.Current_Priority > L.Ceiling then
+ Ceiling_Violation := True;
+ return;
+ end if;
+
+ L.Saved_Priority := T.Common.Current_Priority;
+
+ if T.Common.Current_Priority < L.Ceiling then
+ Set_OS_Priority (T, L.Ceiling);
+ end if;
+ end if;
+
+ Result := pthread_mutex_lock (L.Mutex'Access);
+
+ -- Assume that the cause of EINVAL is a priority ceiling violation
+
+ Ceiling_Violation := (Result = EINVAL);
+ pragma Assert (Result = 0 or else Result = EINVAL);
+ end Write_Lock;
+
+ -- No tricks on RTS_Locks
+
+ procedure Write_Lock
+ (L : access RTS_Lock; Global_Lock : Boolean := False)
+ is
+ Result : Interfaces.C.int;
+
+ begin
+ if not Single_Lock or else Global_Lock then
+ Result := pthread_mutex_lock (L);
+ pragma Assert (Result = 0);
+ end if;
+ end Write_Lock;
+
+ procedure Write_Lock (T : Task_ID) is
+ Result : Interfaces.C.int;
+ begin
+ if not Single_Lock then
+ Result := pthread_mutex_lock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Write_Lock;
+
+ ---------------
+ -- Read_Lock --
+ ---------------
+
+ procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
+ begin
+ Write_Lock (L, Ceiling_Violation);
+ end Read_Lock;
+
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock (L : access Lock) is
+ Result : Interfaces.C.int;
+ T : constant Task_ID := Self;
+
+ begin
+ Result := pthread_mutex_unlock (L.Mutex'Access);
+ pragma Assert (Result = 0);
+
+ if Locking_Policy = 'C' then
+ if T.Common.Current_Priority > L.Saved_Priority then
+ Set_OS_Priority (T, L.Saved_Priority);
+ end if;
+ end if;
+ end Unlock;
+
+ procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
+ Result : Interfaces.C.int;
+
+ begin
+ if not Single_Lock or else Global_Lock then
+ Result := pthread_mutex_unlock (L);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ procedure Unlock (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ if not Single_Lock then
+ Result := pthread_mutex_unlock (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+ end Unlock;
+
+ -----------
+ -- Sleep --
+ -----------
+
+ procedure Sleep
+ (Self_ID : Task_ID;
+ Reason : System.Tasking.Task_States)
+ is
+ pragma Unreferenced (Reason);
+
+ Result : Interfaces.C.int;
+
+ begin
+ if Single_Lock then
+ Result := pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ else
+ Result := pthread_cond_wait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ end if;
+
+ -- EINTR is not considered a failure.
+
+ pragma Assert (Result = 0 or else Result = EINTR);
+ end Sleep;
+
+ -----------------
+ -- Timed_Sleep --
+ -----------------
+
+ -- This is for use within the run-time system, so abort is
+ -- assumed to be already deferred, and the caller should be
+ -- holding its own ATCB lock.
+
+ procedure Timed_Sleep
+ (Self_ID : Task_ID;
+ Time : Duration;
+ Mode : ST.Delay_Modes;
+ Reason : Task_States;
+ Timedout : out Boolean;
+ Yielded : out Boolean)
+ is
+ pragma Unreferenced (Reason);
+
+ Check_Time : constant Duration := Monotonic_Clock;
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ Timedout := True;
+ Yielded := False;
+
+ if Mode = Relative then
+ Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
+
+ if Relative_Timed_Wait then
+ Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
+ end if;
+
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+
+ if Relative_Timed_Wait then
+ Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
+ end if;
+ end if;
+
+ if Abs_Time > Check_Time then
+ if Relative_Timed_Wait then
+ Request := To_Timespec (Rel_Time);
+ else
+ Request := To_Timespec (Abs_Time);
+ end if;
+
+ loop
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
+ or else Self_ID.Pending_Priority_Change;
+
+ if Single_Lock then
+ Result := pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
+ Request'Access);
+
+ else
+ Result := pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
+ Request'Access);
+ end if;
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ if Result = 0 or Result = EINTR then
+
+ -- Somebody may have called Wakeup for us
+
+ Timedout := False;
+ exit;
+ end if;
+
+ pragma Assert (Result = ETIMEDOUT);
+ end loop;
+ end if;
+ end Timed_Sleep;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ -- This is for use in implementing delay statements, so we assume
+ -- the caller is abort-deferred but is holding no locks.
+
+ procedure Timed_Delay
+ (Self_ID : Task_ID;
+ Time : Duration;
+ Mode : ST.Delay_Modes)
+ is
+ Check_Time : constant Duration := Monotonic_Clock;
+ Abs_Time : Duration;
+ Rel_Time : Duration;
+ Request : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ -- Only the little window between deferring abort and
+ -- locking Self_ID is the reason we need to
+ -- check for pending abort and priority change below!
+
+ SSL.Abort_Defer.all;
+
+ if Single_Lock then
+ Lock_RTS;
+ end if;
+
+ -- Comments needed in code below ???
+
+ Write_Lock (Self_ID);
+
+ if Mode = Relative then
+ Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time;
+
+ if Relative_Timed_Wait then
+ Rel_Time := Duration'Min (Max_Sensible_Delay, Time);
+ end if;
+
+ else
+ Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time);
+
+ if Relative_Timed_Wait then
+ Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time);
+ end if;
+ end if;
+
+ if Abs_Time > Check_Time then
+ if Relative_Timed_Wait then
+ Request := To_Timespec (Rel_Time);
+ else
+ Request := To_Timespec (Abs_Time);
+ end if;
+
+ Self_ID.Common.State := Delay_Sleep;
+
+ loop
+ if Self_ID.Pending_Priority_Change then
+ Self_ID.Pending_Priority_Change := False;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
+ end if;
+
+ exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+
+ if Single_Lock then
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access, Request'Access);
+ else
+ Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access, Request'Access);
+ end if;
+
+ exit when Abs_Time <= Monotonic_Clock;
+
+ pragma Assert (Result = 0
+ or else Result = ETIMEDOUT
+ or else Result = EINTR);
+ end loop;
+
+ Self_ID.Common.State := Runnable;
+ end if;
+
+ Unlock (Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ end if;
+
+ Result := sched_yield;
+ SSL.Abort_Undefer.all;
+ end Timed_Delay;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration is
+ TS : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := clock_gettime
+ (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Duration (TS);
+ end Monotonic_Clock;
+
+ -------------------
+ -- RT_Resolution --
+ -------------------
+
+ function RT_Resolution return Duration is
+ Res : aliased timespec;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := clock_getres
+ (clock_id => CLOCK_REALTIME, Res => Res'Unchecked_Access);
+ pragma Assert (Result = 0);
+ return To_Duration (Res);
+ end RT_Resolution;
+
+ ------------
+ -- Wakeup --
+ ------------
+
+ procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_cond_signal (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+ end Wakeup;
+
+ -----------
+ -- Yield --
+ -----------
+
+ procedure Yield (Do_Yield : Boolean := True) is
+ Result : Interfaces.C.int;
+
+ begin
+ if Do_Yield then
+ Result := sched_yield;
+ end if;
+ end Yield;
+
+ ------------------
+ -- Set_Priority --
+ ------------------
+
+ procedure Set_OS_Priority (T : Task_ID; Prio : System.Any_Priority) is
+ Result : Interfaces.C.int;
+ Param : aliased struct_sched_param;
+
+ begin
+ Param.sched_priority := Interfaces.C.int (Prio);
+
+ if Time_Slice_Supported and then Time_Slice_Val > 0 then
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
+
+ elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
+
+ else
+ Result := pthread_setschedparam
+ (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
+ end if;
+
+ pragma Assert (Result = 0);
+ end Set_OS_Priority;
+
+ type Prio_Array_Type is array (System.Any_Priority) of Integer;
+ pragma Atomic_Components (Prio_Array_Type);
+ Prio_Array : Prio_Array_Type;
+ -- Comments needed for these declarations ???
+
+ procedure Set_Priority
+ (T : Task_ID;
+ Prio : System.Any_Priority;
+ Loss_Of_Inheritance : Boolean := False)
+ is
+ Array_Item : Integer;
+
+ begin
+ Set_OS_Priority (T, Prio);
+
+ if Locking_Policy = 'C' then
+ -- Annex D requirements: loss of inheritance puts task at the
+ -- beginning of the queue for that prio; copied from 5ztaprop
+ -- (VxWorks)
+
+ if Loss_Of_Inheritance
+ and then Prio < T.Common.Current_Priority then
+
+ Array_Item := Prio_Array (T.Common.Base_Priority) + 1;
+ Prio_Array (T.Common.Base_Priority) := Array_Item;
+
+ loop
+ Yield;
+ exit when Array_Item = Prio_Array (T.Common.Base_Priority)
+ or else Prio_Array (T.Common.Base_Priority) = 1;
+ end loop;
+
+ Prio_Array (T.Common.Base_Priority) :=
+ Prio_Array (T.Common.Base_Priority) - 1;
+ end if;
+ end if;
+
+ T.Common.Current_Priority := Prio;
+ end Set_Priority;
+
+ ------------------
+ -- Get_Priority --
+ ------------------
+
+ function Get_Priority (T : Task_ID) return System.Any_Priority is
+ begin
+ return T.Common.Current_Priority;
+ end Get_Priority;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (Self_ID : Task_ID) is
+ begin
+ Self_ID.Common.LL.Thread := pthread_self;
+ Self_ID.Common.LL.LWP := lwp_self;
+
+ Specific.Set (Self_ID);
+
+ Lock_RTS;
+
+ for J in Known_Tasks'Range loop
+ if Known_Tasks (J) = null then
+ Known_Tasks (J) := Self_ID;
+ Self_ID.Known_Tasks_Index := J;
+ exit;
+ end if;
+ end loop;
+
+ Unlock_RTS;
+ end Enter_Task;
+
+ --------------
+ -- New_ATCB --
+ --------------
+
+ function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
+ begin
+ return new Ada_Task_Control_Block (Entry_Num);
+ end New_ATCB;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_ID is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (pthread_self);
+ end if;
+ end Register_Foreign_Thread;
+
+ ----------------------
+ -- Initialize_TCB --
+ ----------------------
+
+ procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
+ Mutex_Attr : aliased pthread_mutexattr_t;
+ Result : Interfaces.C.int;
+ Cond_Attr : aliased pthread_condattr_t;
+
+ begin
+ -- Give the task a unique serial number.
+
+ Self_ID.Serial_Number := Next_Serial_Number;
+ Next_Serial_Number := Next_Serial_Number + 1;
+ pragma Assert (Next_Serial_Number /= 0);
+
+ if not Single_Lock then
+ Result := pthread_mutexattr_init (Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
+ Mutex_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+ end if;
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := pthread_condattr_init (Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result = 0 then
+ Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
+ Cond_Attr'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+ end if;
+
+ if Result = 0 then
+ Succeeded := True;
+ else
+ if not Single_Lock then
+ Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Succeeded := False;
+ end if;
+
+ Result := pthread_condattr_destroy (Cond_Attr'Access);
+ pragma Assert (Result = 0);
+ end Initialize_TCB;
+
+ -----------------
+ -- Create_Task --
+ -----------------
+
+ procedure Create_Task
+ (T : Task_ID;
+ Wrapper : System.Address;
+ Stack_Size : System.Parameters.Size_Type;
+ Priority : System.Any_Priority;
+ Succeeded : out Boolean)
+ is
+ Attributes : aliased pthread_attr_t;
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+ Result : Interfaces.C.int;
+
+ function Thread_Body_Access is new
+ Unchecked_Conversion (System.Address, Thread_Body);
+
+ use System.Task_Info;
+
+ begin
+ if Stack_Size = Unspecified_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
+
+ elsif Stack_Size < Minimum_Stack_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
+
+ else
+ Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
+ end if;
+
+ if Stack_Base_Available then
+ -- If Stack Checking is supported then allocate 2 additional pages:
+ --
+ -- In the worst case, stack is allocated at something like
+ -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages
+ -- to be sure the effective stack size is greater than what
+ -- has been asked.
+
+ Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Get_Page_Size;
+ end if;
+
+ Result := pthread_attr_init (Attributes'Access);
+ pragma Assert (Result = 0 or else Result = ENOMEM);
+
+ if Result /= 0 then
+ Succeeded := False;
+ return;
+ end if;
+
+ Result := pthread_attr_setdetachstate
+ (Attributes'Access, PTHREAD_CREATE_DETACHED);
+ pragma Assert (Result = 0);
+
+ Result := pthread_attr_setstacksize
+ (Attributes'Access, Adjusted_Stack_Size);
+ pragma Assert (Result = 0);
+
+ if T.Common.Task_Info /= Default_Scope then
+
+ -- We are assuming that Scope_Type has the same values than the
+ -- corresponding C macros
+
+ Result := pthread_attr_setscope
+ (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info));
+ pragma Assert (Result = 0);
+ end if;
+
+ -- Since the initial signal mask of a thread is inherited from the
+ -- creator, and the Environment task has all its signals masked, we
+ -- do not need to manipulate caller's signal mask at this point.
+ -- All tasks in RTS will have All_Tasks_Mask initially.
+
+ Result := pthread_create
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
+ pragma Assert (Result = 0 or else Result = EAGAIN);
+
+ Succeeded := Result = 0;
+
+ Result := pthread_attr_destroy (Attributes'Access);
+ pragma Assert (Result = 0);
+
+ Set_Priority (T, Priority);
+ end Create_Task;
+
+ ------------------
+ -- Finalize_TCB --
+ ------------------
+
+ procedure Finalize_TCB (T : Task_ID) is
+ Result : Interfaces.C.int;
+ Tmp : Task_ID := T;
+ Is_Self : constant Boolean := T = Self;
+
+ procedure Free is new
+ Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
+
+ begin
+ if not Single_Lock then
+ Result := pthread_mutex_destroy (T.Common.LL.L'Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Result := pthread_cond_destroy (T.Common.LL.CV'Access);
+ pragma Assert (Result = 0);
+
+ if T.Known_Tasks_Index /= -1 then
+ Known_Tasks (T.Known_Tasks_Index) := null;
+ end if;
+
+ Free (Tmp);
+
+ if Is_Self then
+ Result := st_setspecific (ATCB_Key, System.Null_Address);
+ pragma Assert (Result = 0);
+ end if;
+
+ end Finalize_TCB;
+
+ ---------------
+ -- Exit_Task --
+ ---------------
+
+ procedure Exit_Task is
+ begin
+ Specific.Set (null);
+ end Exit_Task;
+
+ ----------------
+ -- Abort_Task --
+ ----------------
+
+ procedure Abort_Task (T : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := pthread_kill (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ pragma Assert (Result = 0);
+ end Abort_Task;
+
+ ----------------
+ -- Check_Exit --
+ ----------------
+
+ -- Dummy versions
+
+ function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
+ begin
+ return True;
+ end Check_Exit;
+
+ --------------------
+ -- Check_No_Locks --
+ --------------------
+
+ function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
+ begin
+ return True;
+ end Check_No_Locks;
+
+ ----------------------
+ -- Environment_Task --
+ ----------------------
+
+ function Environment_Task return Task_ID is
+ begin
+ return Environment_Task_ID;
+ end Environment_Task;
+
+ --------------
+ -- Lock_RTS --
+ --------------
+
+ procedure Lock_RTS is
+ begin
+ Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Lock_RTS;
+
+ ----------------
+ -- Unlock_RTS --
+ ----------------
+
+ procedure Unlock_RTS is
+ begin
+ Unlock (Single_RTS_Lock'Access, Global_Lock => True);
+ end Unlock_RTS;
+
+ ------------------
+ -- Suspend_Task --
+ ------------------
+
+ function Suspend_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
+ pragma Unreferenced (T);
+ pragma Unreferenced (Thread_Self);
+
+ begin
+ return False;
+ end Suspend_Task;
+
+ -----------------
+ -- Resume_Task --
+ -----------------
+
+ function Resume_Task
+ (T : ST.Task_ID;
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
+ pragma Unreferenced (T);
+ pragma Unreferenced (Thread_Self);
+
+ begin
+ return False;
+ end Resume_Task;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_ID) is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ function State
+ (Int : System.Interrupt_Management.Interrupt_ID)
+ return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
+ begin
+ Environment_Task_ID := Environment_Task;
+
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ Specific.Initialize (Environment_Task);
+
+ Enter_Task (Environment_Task);
+
+ -- Install the abort-signal handler
+
+ if State (System.Interrupt_Management.Abort_Task_Interrupt)
+ /= Default
+ then
+ act.sa_flags := 0;
+ act.sa_handler := Abort_Handler'Address;
+
+ Result := sigemptyset (Tmp_Set'Access);
+ pragma Assert (Result = 0);
+ act.sa_mask := Tmp_Set;
+
+ Result :=
+ sigaction
+ (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+
+ pragma Assert (Result = 0);
+ end if;
+ end Initialize;
+
+begin
+ declare
+ Result : Interfaces.C.int;
+
+ begin
+ -- Mask Environment task for all signals. The original mask of the
+ -- Environment task will be recovered by Interrupt_Server task
+ -- during the elaboration of s-interr.adb.
+
+ System.Interrupt_Management.Operations.Set_Interrupt_Mask
+ (System.Interrupt_Management.Operations.All_Tasks_Mask'Access);
+
+ -- Prepare the set of signals that should unblocked in all tasks
+
+ Result := sigemptyset (Unblocked_Signal_Mask'Access);
+ pragma Assert (Result = 0);
+
+ for J in Interrupt_Management.Interrupt_ID loop
+ if System.Interrupt_Management.Keep_Unmasked (J) then
+ Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J));
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
+ end;
+end System.Task_Primitives.Operations;
diff --git a/gcc/ada/5qtaspri.ads b/gcc/ada/56taspri.ads
index 0bd2d2fe6ad..bf079fd34a3 100644
--- a/gcc/ada/5qtaspri.ads
+++ b/gcc/ada/56taspri.ads
@@ -6,7 +6,8 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2001, Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,32 +27,33 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
--- RT_GNU/Linux version
+-- This is a LynxOS version of this package, derived from
+-- 7staspri.ads
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
with System.OS_Interface;
+-- used for pthread_mutex_t
+-- pthread_cond_t
+-- pthread_t
package System.Task_Primitives is
type Lock is limited private;
- -- Used for implementation of protected objects.
-
- type Lock_Ptr is limited private;
+ -- Should be used for implementation of protected objects.
type RTS_Lock is limited private;
- -- Used inside the runtime system. The difference between Lock and the
- -- RTS_Lock is that the later one serves only as a semaphore so that do
- -- not check for ceiling violations.
- type RTS_Lock_Ptr is limited private;
+ -- Should be used inside the runtime system.
+ -- The difference between Lock and the RTS_Lock is that the later
+ -- one serves only as a semaphore so that do not check for
+ -- ceiling violations.
type Task_Body_Access is access procedure;
-- Pointer to the task body's entry point (or possibly a wrapper
@@ -64,75 +66,32 @@ package System.Task_Primitives is
private
- type RT_GNU_Linux_Lock is record
- Ceiling_Priority : System.Any_Priority;
- Pre_Locking_Priority : System.Any_Priority;
- -- Used to store the task's active priority before it
- -- acquires the lock
-
- Owner : System.Address;
- -- This is really a Task_ID, but we can't use that type
- -- here because this System.Tasking is "with"
- -- the current package -- a circularity.
+ type Lock is record
+ Mutex : aliased System.OS_Interface.pthread_mutex_t;
+ Ceiling : System.Any_Priority;
+ Saved_Priority : System.Any_Priority;
end record;
- type Lock is new RT_GNU_Linux_Lock;
- type RTS_Lock is new RT_GNU_Linux_Lock;
-
- type RTS_Lock_Ptr is access all RTS_Lock;
- type Lock_Ptr is access all Lock;
+ type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
type Private_Data is record
- Stack : System.Address;
- -- A stack space needed for the task. the space is allocated
- -- when the task is being created and is deallocated when
- -- the TCB for the task is finalized
-
- Uses_Fp : Integer;
- -- A flag to indicate whether the task is going to use floating-
- -- point unit. It's set to 1, indicating FP unit is always going
- -- to be used. The reason is that it is in this private record and
- -- necessary operation has to be provided for a user to call so as
- -- to change its value
-
- Magic : Integer;
- -- A special value is going to be stored in it when a task is
- -- created. The value is RT_TASK_MAGIC (16#754d2774#) as declared
- -- in System.OS_Interface
-
- State : System.OS_Interface.Rt_Task_States;
- -- Shows whether the task is RT_TASK_READY, RT_TASK_DELAYED or
- -- RT_TASK_DORMANT to support suspend, wait, wakeup.
-
- Stack_Bottom : System.Address;
-
- Active_Priority : System.Any_Priority;
- -- Active priority of the task
-
- Period : System.OS_Interface.RTIME;
- -- Intended originally to store the period of the task, but not used
- -- in the current implementation
-
- Resume_Time : System.OS_Interface.RTIME;
- -- Store the time the task has to be awakened
-
- Next : System.Address;
- -- This really is a Task_ID, used to link the Available_TCBs.
-
- Succ : System.Address;
- pragma Volatile (Succ);
- Pred : System.Address;
- pragma Volatile (Pred);
- -- These really are Task_ID, used to implement a circular doubly
- -- linked list for task queue
-
- L : aliased RTS_Lock;
-
- Outer_Lock : RTS_Lock_Ptr := null;
- -- Used to track which Lock the task is holding is the outermost
- -- one in order to implement priority setting and inheritance
+ Thread : aliased System.OS_Interface.pthread_t;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ LWP : aliased System.Address;
+ -- The purpose of this field is to provide a better tasking support on
+ -- gdb. The order of the two first fields (Thread and LWP) is important.
+ -- On targets where lwp is not relevant, this is equivalent to Thread.
+
+ CV : aliased System.OS_Interface.pthread_cond_t;
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
end record;
- -- ???? May need to use pragma Atomic or Volatile on some
- -- components; may also need to specify aliased for some.
end System.Task_Primitives;
diff --git a/gcc/ada/56tpopsp.adb b/gcc/ada/56tpopsp.adb
new file mode 100644
index 00000000000..ece470e6366
--- /dev/null
+++ b/gcc/ada/56tpopsp.adb
@@ -0,0 +1,110 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a LynxOS version of this package.
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_ID) is
+ pragma Warnings (Off, Environment_Task);
+ Result : Interfaces.C.int;
+
+ begin
+ Result := st_keycreate (null, ATCB_Key'Access);
+ pragma Assert (Result = 0);
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ Result : Interfaces.C.int;
+ Value : aliased System.Address;
+ begin
+ Result := st_getspecific (ATCB_Key, Value'Address);
+ pragma Assert (Result = 0);
+ return (Value /= System.Null_Address);
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_ID) is
+ Result : Interfaces.C.int;
+
+ begin
+ Result := st_setspecific (ATCB_Key, To_Address (Self_Id));
+ pragma Assert (Result = 0);
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ -- To make Ada tasks and C threads interoperate better, we have added some
+ -- functionality to Self. Suppose a C main program (with threads) calls an
+ -- Ada procedure and the Ada procedure calls the tasking runtime system.
+ -- Eventually, a call will be made to self. Since the call is not coming
+ -- from an Ada task, there will be no corresponding ATCB.
+
+ -- What we do in Self is to catch references that do not come from
+ -- recognized Ada tasks, and create an ATCB for the calling thread.
+
+ -- The new ATCB will be "detached" from the normal Ada task master
+ -- hierarchy, much like the existing implicitly created signal-server
+ -- tasks.
+
+ function Self return Task_ID is
+ Result : Interfaces.C.int;
+ Value : aliased System.Address;
+
+ begin
+ Result := st_getspecific (ATCB_Key, Value'Address);
+
+ -- If the key value is Null, then it is a non-Ada task.
+
+ if Value /= System.Null_Address then
+ return To_Task_Id (Value);
+ else
+ return Register_Foreign_Thread;
+ end if;
+ end Self;
+
+end Specific;
diff --git a/gcc/ada/57system.ads b/gcc/ada/57system.ads
new file mode 100644
index 00000000000..caeae17a168
--- /dev/null
+++ b/gcc/ada/57system.ads
@@ -0,0 +1,150 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (LynxOS PPC Version) --
+-- --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 0.01;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 32;
+ Memory_Size : constant := 2 ** 32;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := High_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 254;
+ Max_Interrupt_Priority : constant Positive := 255;
+
+ subtype Any_Priority is Integer range 0 .. 255;
+ subtype Priority is Any_Priority range 0 .. 254;
+ subtype Interrupt_Priority is Any_Priority range 255 .. 255;
+
+ Default_Priority : constant Priority := 15;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
+ Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
+end System;
diff --git a/gcc/ada/58system.ads b/gcc/ada/58system.ads
new file mode 100644
index 00000000000..130b5f0d451
--- /dev/null
+++ b/gcc/ada/58system.ads
@@ -0,0 +1,150 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (LynxOS x86 Version) --
+-- --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 0.01;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 32;
+ Memory_Size : constant := 2 ** 32;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := Low_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 254;
+ Max_Interrupt_Priority : constant Positive := 255;
+
+ subtype Any_Priority is Integer range 0 .. 255;
+ subtype Priority is Any_Priority range 0 .. 254;
+ subtype Interrupt_Priority is Any_Priority range 255 .. 255;
+
+ Default_Priority : constant Priority := 15;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
+ Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
+end System;
diff --git a/gcc/ada/59system.ads b/gcc/ada/59system.ads
new file mode 100644
index 00000000000..f155af878b0
--- /dev/null
+++ b/gcc/ada/59system.ads
@@ -0,0 +1,164 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (PPC ELF Version) --
+-- --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+pragma Restrictions (No_Exception_Handlers);
+pragma Restrictions (No_Implicit_Dynamic_Code);
+pragma Restrictions (No_Finalization);
+pragma Discard_Names;
+-- Above pragmas need commenting ???
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 1.0 / 60.0;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 32;
+ Memory_Size : constant := 2 ** 32;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := High_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ -- 256 is reserved for the VxWorks kernel
+ -- 248 - 255 correspond to hardware interrupt levels 0 .. 7
+ -- 247 is a catchall default "interrupt" priority for signals,
+ -- allowing higher priority than normal tasks, but lower than
+ -- hardware priority levels. Protected Object ceilings can
+ -- override these values.
+ -- 246 is used by the Interrupt_Manager task
+
+ Max_Priority : constant Positive := 245;
+ Max_Interrupt_Priority : constant Positive := 255;
+
+ subtype Any_Priority is Integer range 0 .. 255;
+ subtype Priority is Any_Priority range 0 .. 245;
+ subtype Interrupt_Priority is Any_Priority range 246 .. 255;
+
+ Default_Priority : constant Priority := 122;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := False;
+ Configurable_Run_Time : constant Boolean := True;
+ Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := True;
+ Exit_Status_Supported : constant Boolean := False;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := False;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := True;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := True;
+ Long_Shifts_Inlined : constant Boolean := False;
+
+end System;
diff --git a/gcc/ada/5aml-tgt.adb b/gcc/ada/5aml-tgt.adb
new file mode 100644
index 00000000000..60e998e024d
--- /dev/null
+++ b/gcc/ada/5aml-tgt.adb
@@ -0,0 +1,385 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T --
+-- (True64 Version) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a set of target dependent routines to build
+-- static, dynamic and shared libraries.
+
+-- This is the True64 version of the body.
+
+with MLib.Fil;
+with MLib.Utl;
+with Namet; use Namet;
+with Opt;
+with Output; use Output;
+with Prj.Com;
+with System;
+
+package body MLib.Tgt is
+
+ use GNAT;
+ use MLib;
+
+ Expect_Unresolved : aliased String := "-Wl,-expect_unresolved,*";
+
+ No_Arguments : aliased Argument_List := (1 .. 0 => null);
+ Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access;
+
+ Wl_Init_String : aliased String := "-Wl,-init";
+ Wl_Init : constant String_Access := Wl_Init_String'Access;
+ Wl_Fini_String : aliased String := "-Wl,-fini";
+ Wl_Fini : constant String_Access := Wl_Fini_String'Access;
+
+ Init_Fini_List : constant Argument_List_Access :=
+ new Argument_List'(1 => Wl_Init,
+ 2 => null,
+ 3 => Wl_Fini,
+ 4 => null);
+ -- Used to put switches for automatic elaboration/finalization
+
+ ---------------------
+ -- Archive_Builder --
+ ---------------------
+
+ function Archive_Builder return String is
+ begin
+ return "ar";
+ end Archive_Builder;
+
+ -----------------------------
+ -- Archive_Builder_Options --
+ -----------------------------
+
+ function Archive_Builder_Options return String_List_Access is
+ begin
+ return new String_List'(1 => new String'("cr"));
+ end Archive_Builder_Options;
+
+ -----------------
+ -- Archive_Ext --
+ -----------------
+
+ function Archive_Ext return String is
+ begin
+ return "a";
+ end Archive_Ext;
+
+ ---------------------
+ -- Archive_Indexer --
+ ---------------------
+
+ function Archive_Indexer return String is
+ begin
+ return "ranlib";
+ end Archive_Indexer;
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Foreign : Argument_List;
+ Afiles : Argument_List;
+ Options : Argument_List;
+ Interfaces : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Driver_Name : Name_Id := No_Name;
+ Lib_Address : String := "";
+ Lib_Version : String := "";
+ Relocatable : Boolean := False;
+ Auto_Init : Boolean := False)
+ is
+ pragma Unreferenced (Foreign);
+ pragma Unreferenced (Afiles);
+ pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Lib_Address);
+ pragma Unreferenced (Relocatable);
+
+ Lib_File : constant String :=
+ Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Filename, DLL_Ext);
+
+ Version_Arg : String_Access;
+ Symbolic_Link_Needed : Boolean := False;
+
+ Init_Fini : Argument_List_Access := Empty_Argument_List;
+
+ begin
+ if Opt.Verbose_Mode then
+ Write_Str ("building relocatable shared library ");
+ Write_Line (Lib_File);
+ end if;
+
+ -- If specified, add automatic elaboration/finalization
+
+ if Auto_Init then
+ Init_Fini := Init_Fini_List;
+ Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init");
+ Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final");
+ end if;
+
+ if Lib_Version = "" then
+ Utl.Gcc
+ (Output_File => Lib_File,
+ Objects => Ofiles,
+ Options =>
+ Options &
+ Expect_Unresolved'Access &
+ Init_Fini.all,
+ Driver_Name => Driver_Name);
+
+ else
+ Version_Arg := new String'("-Wl,-soname," & Lib_Version);
+
+ if Is_Absolute_Path (Lib_Version) then
+ Utl.Gcc
+ (Output_File => Lib_Version,
+ Objects => Ofiles,
+ Options =>
+ Options &
+ Version_Arg &
+ Expect_Unresolved'Access &
+ Init_Fini.all,
+ Driver_Name => Driver_Name);
+ Symbolic_Link_Needed := Lib_Version /= Lib_File;
+
+ else
+ Utl.Gcc
+ (Output_File => Lib_Dir & Directory_Separator & Lib_Version,
+ Objects => Ofiles,
+ Options =>
+ Options &
+ Version_Arg &
+ Expect_Unresolved'Access &
+ Init_Fini.all,
+ Driver_Name => Driver_Name);
+ Symbolic_Link_Needed :=
+ Lib_Dir & Directory_Separator & Lib_Version /= Lib_File;
+ end if;
+
+ if Symbolic_Link_Needed then
+ declare
+ Success : Boolean;
+ Oldpath : String (1 .. Lib_Version'Length + 1);
+ Newpath : String (1 .. Lib_File'Length + 1);
+ Result : Integer;
+
+ function Symlink
+ (Oldpath : System.Address;
+ Newpath : System.Address)
+ return Integer;
+ pragma Import (C, Symlink, "__gnat_symlink");
+
+ begin
+ Oldpath (1 .. Lib_Version'Length) := Lib_Version;
+ Oldpath (Oldpath'Last) := ASCII.NUL;
+ Newpath (1 .. Lib_File'Length) := Lib_File;
+ Newpath (Newpath'Last) := ASCII.NUL;
+
+ Delete_File (Lib_File, Success);
+
+ Result := Symlink (Oldpath'Address, Newpath'Address);
+ end;
+ end if;
+ end if;
+ end Build_Dynamic_Library;
+
+ -------------------------
+ -- Default_DLL_Address --
+ -------------------------
+
+ function Default_DLL_Address return String is
+ begin
+ return "";
+ end Default_DLL_Address;
+
+ -------------
+ -- DLL_Ext --
+ -------------
+
+ function DLL_Ext return String is
+ begin
+ return "so";
+ end DLL_Ext;
+
+ --------------------
+ -- Dynamic_Option --
+ --------------------
+
+ function Dynamic_Option return String is
+ begin
+ return "-shared";
+ end Dynamic_Option;
+
+ -------------------
+ -- Is_Object_Ext --
+ -------------------
+
+ function Is_Object_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".o";
+ end Is_Object_Ext;
+
+ --------------
+ -- Is_C_Ext --
+ --------------
+
+ function Is_C_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".c";
+ end Is_C_Ext;
+
+ --------------------
+ -- Is_Archive_Ext --
+ --------------------
+
+ function Is_Archive_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".a" or else Ext = ".so";
+ end Is_Archive_Ext;
+
+ -------------
+ -- Libgnat --
+ -------------
+
+ function Libgnat return String is
+ begin
+ return "libgnat.a";
+ end Libgnat;
+
+ ------------------------
+ -- Library_Exists_For --
+ ------------------------
+
+ function Library_Exists_For (Project : Project_Id) return Boolean is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
+ "for non library project");
+ return False;
+
+ else
+ declare
+ Lib_Dir : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Dir);
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ if Projects.Table (Project).Library_Kind = Static then
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+ end;
+ end if;
+ end Library_Exists_For;
+
+ ---------------------------
+ -- Library_File_Name_For --
+ ---------------------------
+
+ function Library_File_Name_For (Project : Project_Id) return Name_Id is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
+ "for non library project");
+ return No_Name;
+
+ else
+ declare
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "lib";
+
+ if Projects.Table (Project).Library_Kind = Static then
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+
+ return Name_Find;
+ end;
+ end if;
+ end Library_File_Name_For;
+
+ --------------------------------
+ -- Linker_Library_Path_Option --
+ --------------------------------
+
+ function Linker_Library_Path_Option return String_Access is
+ begin
+ return new String'("-Wl,-rpath,");
+ end Linker_Library_Path_Option;
+
+ ----------------
+ -- Object_Ext --
+ ----------------
+
+ function Object_Ext return String is
+ begin
+ return "o";
+ end Object_Ext;
+
+ ----------------
+ -- PIC_Option --
+ ----------------
+
+ function PIC_Option return String is
+ begin
+ return "";
+ end PIC_Option;
+
+ -----------------------------------------------
+ -- Standalone_Library_Auto_Init_Is_Supported --
+ -----------------------------------------------
+
+ function Standalone_Library_Auto_Init_Is_Supported return Boolean is
+ begin
+ return True;
+ end Standalone_Library_Auto_Init_Is_Supported;
+
+ ---------------------------
+ -- Support_For_Libraries --
+ ---------------------------
+
+ function Support_For_Libraries return Library_Support is
+ begin
+ return Full;
+ end Support_For_Libraries;
+
+end MLib.Tgt;
diff --git a/gcc/ada/5aosinte.adb b/gcc/ada/5aosinte.adb
index bcf7d453440..e0b683e52cd 100644
--- a/gcc/ada/5aosinte.adb
+++ b/gcc/ada/5aosinte.adb
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5aosinte.ads b/gcc/ada/5aosinte.ads
index 25733820e19..f84484ccb63 100644
--- a/gcc/ada/5aosinte.ads
+++ b/gcc/ada/5aosinte.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5asystem.ads b/gcc/ada/5asystem.ads
index ee49d717632..3e445d90b27 100644
--- a/gcc/ada/5asystem.ads
+++ b/gcc/ada/5asystem.ads
@@ -118,24 +118,35 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := False;
+ Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := True;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := True;
Stack_Check_Probes : constant Boolean := True;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
-- Note: Denorm is False because denormals are only handled properly
-- if the -mieee switch is set, and we do not require this usage.
diff --git a/gcc/ada/5ataprop.adb b/gcc/ada/5ataprop.adb
index fbadd9b6aa1..259790b46f1 100644
--- a/gcc/ada/5ataprop.adb
+++ b/gcc/ada/5ataprop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -108,6 +108,9 @@ package body System.Task_Primitives.Operations is
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
@@ -128,15 +131,8 @@ package body System.Task_Primitives.Operations is
Curpid : pid_t;
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Abort_Handler (Sig : Signal);
-
- function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
-
- function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads).
--------------------
-- Local Packages --
@@ -148,6 +144,10 @@ package body System.Task_Primitives.Operations is
pragma Inline (Initialize);
-- Initialize various data needed by this package.
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does executing thread have a TCB?
+
procedure Set (Self_Id : Task_ID);
pragma Inline (Set);
-- Set the self id for the current task.
@@ -161,16 +161,44 @@ package body System.Task_Primitives.Operations is
package body Specific is separate;
-- The body of this package is target specific.
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
+ -- Allocate and Initialize a new ATCB for the current Thread.
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_ID is separate;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler (Sig : Signal);
+ -- Signal handler used to implement asynchronous abortion.
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
-------------------
-- Abort_Handler --
-------------------
procedure Abort_Handler (Sig : Signal) is
+ pragma Unreferenced (Sig);
+
T : constant Task_ID := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
begin
+ -- It is not safe to raise an exception when using ZCX and the GCC
+ -- exception handling mechanism.
+
+ if ZCX_By_Default and then GCC_ZCX_Support then
+ return;
+ end if;
+
if T.Deferral_Level = 0
and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
not T.Aborting
@@ -195,6 +223,9 @@ package body System.Task_Primitives.Operations is
-- bottom of a thread stack, so nothing is needed.
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ pragma Unreferenced (T);
+ pragma Unreferenced (On);
+
begin
null;
end Stack_Guard;
@@ -257,6 +288,8 @@ package body System.Task_Primitives.Operations is
end Initialize_Lock;
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ pragma Unreferenced (Level);
+
Attributes : aliased pthread_mutexattr_t;
Result : Interfaces.C.int;
@@ -398,14 +431,17 @@ package body System.Task_Primitives.Operations is
(Self_ID : Task_ID;
Reason : System.Tasking.Task_States)
is
+ pragma Unreferenced (Reason);
+
Result : Interfaces.C.int;
+
begin
if Single_Lock then
Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
+ (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access);
else
Result := pthread_cond_wait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
+ (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
end if;
-- EINTR is not considered a failure.
@@ -429,6 +465,8 @@ package body System.Task_Primitives.Operations is
Timedout : out Boolean;
Yielded : out Boolean)
is
+ pragma Unreferenced (Reason);
+
Check_Time : constant Duration := Monotonic_Clock;
Abs_Time : Duration;
Request : aliased timespec;
@@ -453,19 +491,23 @@ package body System.Task_Primitives.Operations is
if Single_Lock then
Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access,
- Request'Access);
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Request'Access);
else
Result := pthread_cond_timedwait
- (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
- Request'Access);
+ (Self_ID.Common.LL.CV'Access,
+ Self_ID.Common.LL.L'Access,
+ Request'Access);
end if;
exit when Abs_Time <= Monotonic_Clock;
if Result = 0 or Result = EINTR then
- -- somebody may have called Wakeup for us
+
+ -- Somebody may have called Wakeup for us
+
Timedout := False;
exit;
end if;
@@ -526,8 +568,10 @@ package body System.Task_Primitives.Operations is
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
if Single_Lock then
- Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
- Single_RTS_Lock'Access, Request'Access);
+ Result := pthread_cond_timedwait
+ (Self_ID.Common.LL.CV'Access,
+ Single_RTS_Lock'Access,
+ Request'Access);
else
Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
Self_ID.Common.LL.L'Access, Request'Access);
@@ -581,7 +625,10 @@ package body System.Task_Primitives.Operations is
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+
Result : Interfaces.C.int;
+
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -604,10 +651,12 @@ package body System.Task_Primitives.Operations is
------------------
procedure Set_Priority
- (T : Task_ID;
- Prio : System.Any_Priority;
+ (T : Task_ID;
+ Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
+ pragma Unreferenced (Loss_Of_Inheritance);
+
Result : Interfaces.C.int;
Param : aliased struct_sched_param;
@@ -617,15 +666,15 @@ package body System.Task_Primitives.Operations is
if Time_Slice_Val > 0 then
Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_RR, Param'Access);
+ (T.Common.LL.Thread, SCHED_RR, Param'Access);
elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
+ (T.Common.LL.Thread, SCHED_FIFO, Param'Access);
else
Result := pthread_setschedparam
- (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
+ (T.Common.LL.Thread, SCHED_OTHER, Param'Access);
end if;
pragma Assert (Result = 0);
@@ -671,6 +720,25 @@ package body System.Task_Primitives.Operations is
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_ID is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (pthread_self);
+ end if;
+ end Register_Foreign_Thread;
+
--------------------
-- Initialize_TCB --
--------------------
@@ -686,8 +754,8 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
- Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
- Mutex_Attr'Access);
+ Result := pthread_mutex_init
+ (Self_ID.Common.LL.L'Access, Mutex_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
@@ -704,8 +772,8 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
- Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
- Cond_Attr'Access);
+ Result := pthread_cond_init
+ (Self_ID.Common.LL.CV'Access, Cond_Attr'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
end if;
@@ -765,52 +833,53 @@ package body System.Task_Primitives.Operations is
end if;
Result := pthread_attr_setdetachstate
- (Attributes'Access, PTHREAD_CREATE_DETACHED);
+ (Attributes'Access, PTHREAD_CREATE_DETACHED);
pragma Assert (Result = 0);
Result := pthread_attr_setstacksize
- (Attributes'Access, Adjusted_Stack_Size);
- pragma Assert (Result = 0);
-
- -- Set the scheduling parameters explicitly, since this is the only
- -- way to force the OS to take the scope attribute into account
-
- Result := pthread_attr_setinheritsched
- (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
+ (Attributes'Access, Adjusted_Stack_Size);
pragma Assert (Result = 0);
Param.sched_priority :=
Interfaces.C.int (Underlying_Priorities (Priority));
Result := pthread_attr_setschedparam
- (Attributes'Access, Param'Access);
+ (Attributes'Access, Param'Access);
pragma Assert (Result = 0);
if Time_Slice_Val > 0 then
Result := pthread_attr_setschedpolicy
- (Attributes'Access, System.OS_Interface.SCHED_RR);
+ (Attributes'Access, System.OS_Interface.SCHED_RR);
elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then
Result := pthread_attr_setschedpolicy
- (Attributes'Access, System.OS_Interface.SCHED_FIFO);
+ (Attributes'Access, System.OS_Interface.SCHED_FIFO);
else
Result := pthread_attr_setschedpolicy
- (Attributes'Access, System.OS_Interface.SCHED_OTHER);
+ (Attributes'Access, System.OS_Interface.SCHED_OTHER);
end if;
pragma Assert (Result = 0);
+ -- Set the scheduling parameters explicitly, since this is the
+ -- only way to force the OS to take e.g. the sched policy and scope
+ -- attributes into account.
+
+ Result := pthread_attr_setinheritsched
+ (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
+ pragma Assert (Result = 0);
+
T.Common.Current_Priority := Priority;
if T.Common.Task_Info /= null then
case T.Common.Task_Info.Contention_Scope is
when System.Task_Info.Process_Scope =>
Result := pthread_attr_setscope
- (Attributes'Access, PTHREAD_SCOPE_PROCESS);
+ (Attributes'Access, PTHREAD_SCOPE_PROCESS);
when System.Task_Info.System_Scope =>
Result := pthread_attr_setscope
- (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
+ (Attributes'Access, PTHREAD_SCOPE_SYSTEM);
when System.Task_Info.Default_Scope =>
Result := 0;
@@ -825,10 +894,10 @@ package body System.Task_Primitives.Operations is
-- All tasks in RTS will have All_Tasks_Mask initially.
Result := pthread_create
- (T.Common.LL.Thread'Access,
- Attributes'Access,
- Thread_Body_Access (Wrapper),
- To_Address (T));
+ (T.Common.LL.Thread'Access,
+ Attributes'Access,
+ Thread_Body_Access (Wrapper),
+ To_Address (T));
pragma Assert (Result = 0 or else Result = EAGAIN);
Succeeded := Result = 0;
@@ -837,6 +906,9 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
if T.Common.Task_Info /= null then
+ -- ??? We're using a process-wide function to implement a task
+ -- specific characteristic.
+
if T.Common.Task_Info.Bind_To_Cpu_Number = 0 then
Result := bind_to_cpu (Curpid, 0);
elsif T.Common.Task_Info.Bind_To_Cpu_Number > 0 then
@@ -858,6 +930,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_TCB (T : Task_ID) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
+ Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
@@ -876,6 +949,12 @@ package body System.Task_Primitives.Operations is
end if;
Free (Tmp);
+
+ if Is_Self then
+ Result := pthread_setspecific (ATCB_Key, System.Null_Address);
+ pragma Assert (Result = 0);
+ end if;
+
end Finalize_TCB;
---------------
@@ -884,7 +963,7 @@ package body System.Task_Primitives.Operations is
procedure Exit_Task is
begin
- pthread_exit (System.Null_Address);
+ Specific.Set (null);
end Exit_Task;
----------------
@@ -895,8 +974,10 @@ package body System.Task_Primitives.Operations is
Result : Interfaces.C.int;
begin
- Result := pthread_kill (T.Common.LL.Thread,
- Signal (System.Interrupt_Management.Abort_Task_Interrupt));
+ Result :=
+ pthread_kill
+ (T.Common.LL.Thread,
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt));
pragma Assert (Result = 0);
end Abort_Task;
@@ -904,10 +985,11 @@ package body System.Task_Primitives.Operations is
-- Check_Exit --
----------------
- -- Dummy versions. The only currently working versions is for solaris
- -- (native).
+ -- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
+
begin
return True;
end Check_Exit;
@@ -917,6 +999,8 @@ package body System.Task_Primitives.Operations is
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
+
begin
return True;
end Check_No_Locks;
@@ -954,7 +1038,12 @@ package body System.Task_Primitives.Operations is
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
+ pragma Warnings (Off, T);
+ pragma Warnings (Off, Thread_Self);
+
begin
return False;
end Suspend_Task;
@@ -965,7 +1054,12 @@ package body System.Task_Primitives.Operations is
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
+ pragma Warnings (Off, T);
+ pragma Warnings (Off, Thread_Self);
+
begin
return False;
end Resume_Task;
@@ -975,41 +1069,61 @@ package body System.Task_Primitives.Operations is
----------------
procedure Initialize (Environment_Task : Task_ID) is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Tmp_Set : aliased sigset_t;
- Result : Interfaces.C.int;
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ function State (Int : System.Interrupt_Management.Interrupt_ID)
+ return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
begin
Environment_Task_ID := Environment_Task;
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-- Initialize the lock used to synchronize chain of all ATCBs.
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
Specific.Initialize (Environment_Task);
Enter_Task (Environment_Task);
-- Install the abort-signal handler
- act.sa_flags := 0;
- act.sa_handler := Abort_Handler'Address;
+ if State (System.Interrupt_Management.Abort_Task_Interrupt)
+ /= Default
+ then
+ act.sa_flags := 0;
+ act.sa_handler := Abort_Handler'Address;
- Result := sigemptyset (Tmp_Set'Access);
- pragma Assert (Result = 0);
- act.sa_mask := Tmp_Set;
+ Result := sigemptyset (Tmp_Set'Access);
+ pragma Assert (Result = 0);
+ act.sa_mask := Tmp_Set;
- Result :=
- sigaction
- (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
+ Result :=
+ sigaction
+ (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
end Initialize;
begin
declare
Result : Interfaces.C.int;
+
begin
-- Mask Environment task for all signals. The original mask of the
-- Environment task will be recovered by Interrupt_Server task
diff --git a/gcc/ada/5atasinf.ads b/gcc/ada/5atasinf.ads
index e70ee352408..179f469c37c 100644
--- a/gcc/ada/5atasinf.ads
+++ b/gcc/ada/5atasinf.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Compiler Interface) --
-- --
--- Copyright (C) 1998-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,18 +32,21 @@
-- --
------------------------------------------------------------------------------
--- This is a DEC Unix 4.0d version of this package.
-
-- This package contains the definitions and routines associated with the
--- implementation of the Task_Info pragma.
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
-- Note: the compiler generates direct calls to this interface, via Rtsfind.
-- Any changes to this interface may require corresponding compiler changes.
-with Unchecked_Deallocation;
+-- This unit may be used directly from an application program by providing
+-- an appropriate WITH, and the interface can be expected to remain stable.
+
+-- This is a DEC Unix 4.0d version of this package.
+
package System.Task_Info is
-pragma Elaborate_Body;
--- To ensure that a body is allowed
+ pragma Elaborate_Body;
+ -- To ensure that a body is allowed
-----------------------------------------
-- Implementation of Task_Info Feature --
@@ -96,13 +99,6 @@ pragma Elaborate_Body;
-- implementations, but it must be a type that can be used as a
-- discriminant (i.e. a scalar or access type).
- type Task_Image_Type is access String;
- -- Used to generate a meaningful identifier for tasks that are variables
- -- and components of variables.
-
- procedure Free_Task_Image is new
- Unchecked_Deallocation (String, Task_Image_Type);
-
Unspecified_Thread_Attribute : aliased Thread_Attributes :=
Thread_Attributes'(-1, Default_Scope);
diff --git a/gcc/ada/5ataspri.ads b/gcc/ada/5ataspri.ads
index b0cb9beef5c..2caf54b5f25 100644
--- a/gcc/ada/5ataspri.ads
+++ b/gcc/ada/5ataspri.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5atpopsp.adb b/gcc/ada/5atpopsp.adb
index 937041e22c1..dc4c0135f50 100644
--- a/gcc/ada/5atpopsp.adb
+++ b/gcc/ada/5atpopsp.adb
@@ -2,12 +2,11 @@
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S . --
--- S P E C I F I C --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,194 +33,42 @@
-- This is a POSIX version of this package where foreign threads are
-- recognized.
--- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread,
--- GNU/Linux threads and RTEMS use this version.
-
-with System.Task_Info;
--- Use for Unspecified_Task_Info
-with System.Soft_Links;
--- used to initialize TSD for a C thread, in function Self
+-- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread,
+-- GNU/Linux threads, and RTEMS use this version.
separate (System.Task_Primitives.Operations)
package body Specific is
- ------------------
- -- Local Data --
- ------------------
-
- -- The followings are logically constants, but need to be initialized
- -- at run time.
-
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_ID associated with a thread
-
- -- The following are used to allow the Self function to
- -- automatically generate ATCB's for C threads that happen to call
- -- Ada procedure, which in turn happen to call the Ada runtime system.
-
- type Fake_ATCB;
- type Fake_ATCB_Ptr is access Fake_ATCB;
- type Fake_ATCB is record
- Stack_Base : Interfaces.C.unsigned := 0;
- -- A value of zero indicates the node is not in use.
- Next : Fake_ATCB_Ptr;
- Real_ATCB : aliased Ada_Task_Control_Block (0);
- end record;
-
- Fake_ATCB_List : Fake_ATCB_Ptr;
- -- A linear linked list.
- -- The list is protected by Single_RTS_Lock;
- -- Nodes are added to this list from the front.
- -- Once a node is added to this list, it is never removed.
-
- Fake_Task_Elaborated : aliased Boolean := True;
- -- Used to identified fake tasks (i.e., non-Ada Threads).
-
- Next_Fake_ATCB : Fake_ATCB_Ptr;
- -- Used to allocate one Fake_ATCB in advance. See comment in New_Fake_ATCB
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- ---------------------------------
- -- Support for New_Fake_ATCB --
- ---------------------------------
-
- function New_Fake_ATCB return Task_ID;
- -- Allocate and Initialize a new ATCB. This code can safely be called from
- -- a foreign thread, as it doesn't access implicitly or explicitly
- -- "self" before having initialized the new ATCB.
-
- -------------------
- -- New_Fake_ATCB --
- -------------------
-
- function New_Fake_ATCB return Task_ID is
- Self_ID : Task_ID;
- P, Q : Fake_ATCB_Ptr;
- Succeeded : Boolean;
- Result : Interfaces.C.int;
-
- begin
- -- This section is ticklish.
- -- We dare not call anything that might require an ATCB, until
- -- we have the new ATCB in place.
-
- Lock_RTS;
- Q := null;
- P := Fake_ATCB_List;
-
- while P /= null loop
- if P.Stack_Base = 0 then
- Q := P;
- end if;
-
- P := P.Next;
- end loop;
-
- if Q = null then
-
- -- Create a new ATCB with zero entries.
-
- Self_ID := Next_Fake_ATCB.Real_ATCB'Access;
- Next_Fake_ATCB.Stack_Base := 1;
- Next_Fake_ATCB.Next := Fake_ATCB_List;
- Fake_ATCB_List := Next_Fake_ATCB;
- Next_Fake_ATCB := null;
-
- else
- -- Reuse an existing fake ATCB.
-
- Self_ID := Q.Real_ATCB'Access;
- Q.Stack_Base := 1;
- end if;
-
- -- Record this as the Task_ID for the current thread.
-
- Self_ID.Common.LL.Thread := pthread_self;
- Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
- pragma Assert (Result = 0);
-
- -- Do the standard initializations
-
- System.Tasking.Initialize_ATCB
- (Self_ID, null, Null_Address, Null_Task, Fake_Task_Elaborated'Access,
- System.Priority'First, Task_Info.Unspecified_Task_Info, 0, Self_ID,
- Succeeded);
- pragma Assert (Succeeded);
-
- -- Finally, it is safe to use an allocator in this thread.
-
- if Next_Fake_ATCB = null then
- Next_Fake_ATCB := new Fake_ATCB;
- end if;
-
- Self_ID.Master_of_Task := 0;
- Self_ID.Master_Within := Self_ID.Master_of_Task + 1;
-
- for L in Self_ID.Entry_Calls'Range loop
- Self_ID.Entry_Calls (L).Self := Self_ID;
- Self_ID.Entry_Calls (L).Level := L;
- end loop;
-
- Self_ID.Common.State := Runnable;
- Self_ID.Awake_Count := 1;
-
- -- Since this is not an ordinary Ada task, we will start out undeferred
-
- Self_ID.Deferral_Level := 0;
-
- System.Soft_Links.Create_TSD (Self_ID.Common.Compiler_Data);
-
- -- ????
- -- The following call is commented out to avoid dependence on
- -- the System.Tasking.Initialization package.
- -- It seems that if we want Ada.Task_Attributes to work correctly
- -- for C threads we will need to raise the visibility of this soft
- -- link to System.Soft_Links.
- -- We are putting that off until this new functionality is otherwise
- -- stable.
- -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T);
-
- for J in Known_Tasks'Range loop
- if Known_Tasks (J) = null then
- Known_Tasks (J) := Self_ID;
- Self_ID.Known_Tasks_Index := J;
- exit;
- end if;
- end loop;
-
- -- Must not unlock until Next_ATCB is again allocated.
-
- Unlock_RTS;
- return Self_ID;
- end New_Fake_ATCB;
-
----------------
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
+ pragma Warnings (Off, Environment_Task);
Result : Interfaces.C.int;
+
begin
Result := pthread_key_create (ATCB_Key'Access, null);
pragma Assert (Result = 0);
- Result := pthread_setspecific (ATCB_Key, To_Address (Environment_Task));
- pragma Assert (Result = 0);
+ end Initialize;
- -- Create a free ATCB for use on the Fake_ATCB_List.
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
- Next_Fake_ATCB := new Fake_ATCB;
- end Initialize;
+ function Is_Valid_Task return Boolean is
+ begin
+ return pthread_getspecific (ATCB_Key) /= System.Null_Address;
+ end Is_Valid_Task;
---------
-- Set --
---------
procedure Set (Self_Id : Task_ID) is
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
+
begin
Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
pragma Assert (Result = 0);
@@ -246,16 +93,17 @@ package body Specific is
function Self return Task_ID is
Result : System.Address;
+
begin
Result := pthread_getspecific (ATCB_Key);
-- If the key value is Null, then it is a non-Ada task.
- if Result = System.Null_Address then
- return New_Fake_ATCB;
+ if Result /= System.Null_Address then
+ return To_Task_Id (Result);
+ else
+ return Register_Foreign_Thread;
end if;
-
- return To_Task_ID (Result);
end Self;
end Specific;
diff --git a/gcc/ada/5avxwork.ads b/gcc/ada/5avxwork.ads
index c7894932796..6d5e424a33c 100644
--- a/gcc/ada/5avxwork.ads
+++ b/gcc/ada/5avxwork.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5bml-tgt.adb b/gcc/ada/5bml-tgt.adb
new file mode 100644
index 00000000000..2f18936c5db
--- /dev/null
+++ b/gcc/ada/5bml-tgt.adb
@@ -0,0 +1,398 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T --
+-- (AIX Version) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003, Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a set of target dependent routines to build
+-- static, dynamic or relocatable libraries.
+
+-- This is the AIX version of the body.
+
+with Ada.Strings.Fixed; use Ada.Strings.Fixed;
+with Ada.Text_IO; use Ada.Text_IO;
+with MLib.Fil;
+with MLib.Utl;
+with Namet; use Namet;
+with Opt;
+with Output; use Output;
+with Prj.Com;
+with Sdefault;
+
+package body MLib.Tgt is
+
+ No_Arguments : aliased Argument_List := (1 .. 0 => null);
+ Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access;
+
+ Wl_Initfini_String : constant String := "-Wl,-binitfini:";
+
+ Init_Fini_List : constant Argument_List_Access :=
+ new Argument_List'(1 => null);
+ -- Used to put switch for automatic elaboration/finalization
+
+ Bexpall : aliased String := "-Wl,-bexpall";
+ Bexpall_Option : constant String_Access := Bexpall'Access;
+ -- The switch to export all symbols
+
+ Lpthreads : aliased String := "-lpthreads";
+ Native_Thread_Options : aliased Argument_List := (1 => Lpthreads'Access);
+ -- The switch to use when linking a library against libgnarl when using
+ -- Native threads.
+
+ Lgthreads : aliased String := "-lgthreads";
+ Lmalloc : aliased String := "-lmalloc";
+ FSU_Thread_Options : aliased Argument_List :=
+ (1 => Lgthreads'Access, 2 => Lmalloc'Access);
+ -- The switches to use when linking a library against libgnarl when using
+ -- FSU threads.
+
+ Thread_Options : Argument_List_Access := null;
+ -- Designate the thread switches to used when linking a library against
+ -- libgnarl. Depends on the thread library (Native or FSU). Resolved for
+ -- the first library linked against libgnarl.
+
+ ---------------------
+ -- Archive_Builder --
+ ---------------------
+
+ function Archive_Builder return String is
+ begin
+ return "ar";
+ end Archive_Builder;
+
+ -----------------------------
+ -- Archive_Builder_Options --
+ -----------------------------
+
+ function Archive_Builder_Options return String_List_Access is
+ begin
+ return new String_List'(1 => new String'("cr"));
+ end Archive_Builder_Options;
+
+ -----------------
+ -- Archive_Ext --
+ -----------------
+
+ function Archive_Ext return String is
+ begin
+ return "a";
+ end Archive_Ext;
+
+ ---------------------
+ -- Archive_Indexer --
+ ---------------------
+
+ function Archive_Indexer return String is
+ begin
+ return "ranlib";
+ end Archive_Indexer;
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Foreign : Argument_List;
+ Afiles : Argument_List;
+ Options : Argument_List;
+ Interfaces : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Driver_Name : Name_Id := No_Name;
+ Lib_Address : String := "";
+ Lib_Version : String := "";
+ Relocatable : Boolean := False;
+ Auto_Init : Boolean := False)
+ is
+ pragma Unreferenced (Foreign);
+ pragma Unreferenced (Afiles);
+ pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Lib_Address);
+ pragma Unreferenced (Lib_Version);
+ pragma Unreferenced (Relocatable);
+
+ Lib_File : constant String :=
+ Lib_Dir & Directory_Separator & "lib" &
+ MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
+ -- The file name of the library
+
+ Init_Fini : Argument_List_Access := Empty_Argument_List;
+ -- The switch for automatic initialization of Stand-Alone Libraries.
+ -- Changed to a real switch when Auto_Init is True.
+
+ Options_2 : Argument_List_Access := Empty_Argument_List;
+ -- Changed to the thread options, if -lgnarl is specified
+
+ begin
+ if Opt.Verbose_Mode then
+ Write_Str ("building relocatable shared library ");
+ Write_Line (Lib_File);
+ end if;
+
+ -- If specified, add automatic elaboration/finalization
+
+ if Auto_Init then
+ Init_Fini := Init_Fini_List;
+ Init_Fini (1) :=
+ new String'(Wl_Initfini_String & Lib_Filename & "init:" &
+ Lib_Filename & "final");
+ end if;
+
+ -- Look for -lgnarl in Options. If found, set the thread options.
+
+ for J in Options'Range loop
+ if Options (J).all = "-lgnarl" then
+
+ -- If Thread_Options is null, read s-osinte.ads to discover the
+ -- thread library and set Thread_Options accordingly.
+
+ if Thread_Options = null then
+ declare
+ File : Ada.Text_IO.File_Type;
+ Line : String (1 .. 100);
+ Last : Natural;
+
+ begin
+ Open (File, In_File,
+ Sdefault.Include_Dir_Default_Name.all &
+ "/s-osinte.ads");
+
+ while not End_Of_File (File) loop
+ Get_Line (File, Line, Last);
+
+ if Index (Line (1 .. Last), "-lpthreads") /= 0 then
+ Thread_Options := Native_Thread_Options'Access;
+ exit;
+
+ elsif Index (Line (1 .. Last), "-lgthreads") /= 0 then
+ Thread_Options := FSU_Thread_Options'Access;
+ exit;
+ end if;
+ end loop;
+
+ Close (File);
+
+ if Thread_Options = null then
+ Prj.Com.Fail ("cannot find the thread library in use");
+ end if;
+
+ exception
+ when others =>
+ Prj.Com.Fail ("cannot open s-osinte.ads");
+ end;
+ end if;
+
+ Options_2 := Thread_Options;
+ exit;
+ end if;
+ end loop;
+
+ -- Finally, call GCC (or the driver specified) to build the library
+
+ MLib.Utl.Gcc
+ (Output_File => Lib_File,
+ Objects => Ofiles,
+ Options => Options & Bexpall_Option & Init_Fini.all,
+ Driver_Name => Driver_Name,
+ Options_2 => Options_2.all);
+ end Build_Dynamic_Library;
+
+ -------------------------
+ -- Default_DLL_Address --
+ -------------------------
+
+ function Default_DLL_Address return String is
+ begin
+ return "";
+ end Default_DLL_Address;
+
+ -------------
+ -- DLL_Ext --
+ -------------
+
+ function DLL_Ext return String is
+ begin
+ return "a";
+ end DLL_Ext;
+
+ --------------------
+ -- Dynamic_Option --
+ --------------------
+
+ function Dynamic_Option return String is
+ begin
+ return "-shared";
+ end Dynamic_Option;
+
+ -------------------
+ -- Is_Object_Ext --
+ -------------------
+
+ function Is_Object_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".o";
+ end Is_Object_Ext;
+
+ --------------
+ -- Is_C_Ext --
+ --------------
+
+ function Is_C_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".c";
+ end Is_C_Ext;
+
+ --------------------
+ -- Is_Archive_Ext --
+ --------------------
+
+ function Is_Archive_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".a";
+ end Is_Archive_Ext;
+
+ -------------
+ -- Libgnat --
+ -------------
+
+ function Libgnat return String is
+ begin
+ return "libgnat.a";
+ end Libgnat;
+
+ ------------------------
+ -- Library_Exists_For --
+ ------------------------
+
+ function Library_Exists_For (Project : Project_Id) return Boolean is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
+ "for non library project");
+ return False;
+
+ else
+ declare
+ Lib_Dir : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Dir);
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ if Projects.Table (Project).Library_Kind = Static then
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+ end;
+ end if;
+ end Library_Exists_For;
+
+ ---------------------------
+ -- Library_File_Name_For --
+ ---------------------------
+
+ function Library_File_Name_For (Project : Project_Id) return Name_Id is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
+ "for non library project");
+ return No_Name;
+
+ else
+ declare
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "lib";
+
+ if Projects.Table (Project).Library_Kind = Static then
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+
+ return Name_Find;
+ end;
+ end if;
+ end Library_File_Name_For;
+
+ --------------------------------
+ -- Linker_Library_Path_Option --
+ --------------------------------
+
+ function Linker_Library_Path_Option return String_Access is
+ begin
+ -- On AIX, any path specify with an -L switch is automatically added
+ -- to the library path. So, nothing is needed here.
+
+ return null;
+ end Linker_Library_Path_Option;
+
+ ----------------
+ -- Object_Ext --
+ ----------------
+
+ function Object_Ext return String is
+ begin
+ return "o";
+ end Object_Ext;
+
+ ----------------
+ -- PIC_Option --
+ ----------------
+
+ function PIC_Option return String is
+ begin
+ return "-fPIC";
+ end PIC_Option;
+
+ -----------------------------------------------
+ -- Standalone_Library_Auto_Init_Is_Supported --
+ -----------------------------------------------
+
+ function Standalone_Library_Auto_Init_Is_Supported return Boolean is
+ begin
+ return True;
+ end Standalone_Library_Auto_Init_Is_Supported;
+
+ ---------------------------
+ -- Support_For_Libraries --
+ ---------------------------
+
+ function Support_For_Libraries return Library_Support is
+ begin
+ return Full;
+ end Support_For_Libraries;
+
+end MLib.Tgt;
diff --git a/gcc/ada/5bosinte.adb b/gcc/ada/5bosinte.adb
index 6c90fade486..5fe86b1d606 100644
--- a/gcc/ada/5bosinte.adb
+++ b/gcc/ada/5bosinte.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2001, Free Software Fundation, Inc. --
+-- Copyright (C) 1997-2002, Free Software Fundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -77,8 +77,8 @@ package body System.OS_Interface is
F := F + 1.0;
end if;
- return timespec' (tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
----------------
@@ -101,8 +101,10 @@ package body System.OS_Interface is
F := F + 1.0;
end if;
- return struct_timeval' (tv_sec => S,
- tv_usec => long (Long_Long_Integer (F * 10#1#E6)));
+ return
+ struct_timeval'
+ (tv_sec => S,
+ tv_usec => long (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
-------------------
@@ -112,14 +114,17 @@ package body System.OS_Interface is
function clock_gettime
(clock_id : clockid_t;
tp : access timespec)
- return int
+ return int
is
+ pragma Warnings (Off, clock_id);
+
Result : int;
tv : aliased struct_timeval;
function gettimeofday
- (tv : access struct_timeval;
- tz : System.Address := System.Null_Address) return int;
+ (tv : access struct_timeval;
+ tz : System.Address := System.Null_Address)
+ return int;
pragma Import (C, gettimeofday, "gettimeofday");
begin
@@ -145,6 +150,8 @@ package body System.OS_Interface is
end sched_yield;
function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+
begin
return Null_Address;
end Get_Stack_Base;
diff --git a/gcc/ada/5bosinte.ads b/gcc/ada/5bosinte.ads
index 4f471d816c4..ab144c0f4d6 100644
--- a/gcc/ada/5bosinte.ads
+++ b/gcc/ada/5bosinte.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5bsystem.ads b/gcc/ada/5bsystem.ads
index 539b8df0afd..fa28445a423 100644
--- a/gcc/ada/5bsystem.ads
+++ b/gcc/ada/5bsystem.ads
@@ -118,22 +118,33 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := True;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
end System;
diff --git a/gcc/ada/5cosinte.ads b/gcc/ada/5cosinte.ads
index 88dab8b2143..86c507e0251 100644
--- a/gcc/ada/5cosinte.ads
+++ b/gcc/ada/5cosinte.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5csystem.ads b/gcc/ada/5csystem.ads
new file mode 100644
index 00000000000..8ddf3b06a6a
--- /dev/null
+++ b/gcc/ada/5csystem.ads
@@ -0,0 +1,160 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (VxWorks Version Sparc/64) --
+-- --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 1.0 / 60.0;
+
+ -- Storage-related Declarations
+
+ -- VxWorks for UltraSparc uses 64bit words but 32bit pointers
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 64;
+ Memory_Size : constant := 2 ** 32;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := High_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ -- 256 is reserved for the VxWorks kernel
+ -- 248 - 255 correspond to hardware interrupt levels 0 .. 7
+ -- 247 is a catchall default "interrupt" priority for signals,
+ -- allowing higher priority than normal tasks, but lower than
+ -- hardware priority levels. Protected Object ceilings can
+ -- override these values.
+ -- 246 is used by the Interrupt_Manager task
+
+ Max_Priority : constant Positive := 245;
+ Max_Interrupt_Priority : constant Positive := 255;
+
+ subtype Any_Priority is Integer range 0 .. 255;
+ subtype Priority is Any_Priority range 0 .. 245;
+ subtype Interrupt_Priority is Any_Priority range 246 .. 255;
+
+ Default_Priority : constant Priority := 122;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := False;
+ Configurable_Run_Time : constant Boolean := False;
+ Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := True;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+
+end System;
diff --git a/gcc/ada/5dosinte.ads b/gcc/ada/5dosinte.ads
deleted file mode 100644
index b76c1233c49..00000000000
--- a/gcc/ada/5dosinte.ads
+++ /dev/null
@@ -1,536 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a DOS/DJGPPv2 (FSU THREAD) version of this package.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
--- PLEASE DO NOT add any with-clauses to this package
--- or remove the pragma Elaborate_Body.
--- It is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-package System.OS_Interface is
- pragma Preelaborate;
-
- --
- -- A short name for libgthreads.a to keep Mike Feldman happy.
- --
- pragma Linker_Options ("-lgthre");
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 5;
- EINTR : constant := 13;
- EINVAL : constant := 14;
- ENOMEM : constant := 25;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 319;
- type Signal is new int range 0 .. Max_Interrupt;
-
- SIGHUP : constant := 294; -- hangup
- SIGINT : constant := 295; -- interrupt (rubout)
- SIGQUIT : constant := 298; -- quit (ASCD FS)
- SIGILL : constant := 290; -- illegal instruction (not reset)
- SIGABRT : constant := 288; -- used by abort
- SIGFPE : constant := 289; -- floating point exception
- SIGKILL : constant := 296; -- kill (cannot be caught or ignored)
- SIGSEGV : constant := 291; -- segmentation violation
- SIGPIPE : constant := 297; -- write on a pipe with no one to read it
- SIGALRM : constant := 293; -- alarm clock
- SIGTERM : constant := 292; -- software termination signal from kill
- SIGUSR1 : constant := 299; -- user defined signal 1
- SIGUSR2 : constant := 300; -- user defined signal 2
- SIGBUS : constant := 0;
-
- SIGADAABORT : constant := SIGABRT;
-
- type Signal_Set is array (Natural range <>) of Signal;
-
- Unmasked : constant Signal_Set := (SIGTRAP, SIGALRM);
- Reserved : constant Signal_Set := (0 .. 0 => SIGSTOP);
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type struct_sigaction is record
- sa_flags : int;
- sa_handler : System.Address;
- sa_mask : sigset_t;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 3;
- SIG_SETMASK : constant := 2;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := -1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := False;
- -- Indicates wether time slicing is supported (i.e FSU threads have been
- -- compiled with DEF_RR)
-
- type timespec is private;
-
- function nanosleep (rqtp, rmtp : access timespec) return int;
- -- FSU_THREADS has nonstandard nanosleep
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec) return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- type struct_timeval is private;
-
- function To_Duration (TV : struct_timeval) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timeval (D : Duration) return struct_timeval;
- pragma Inline (To_Timeval);
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 0;
- SCHED_RR : constant := 1;
- SCHED_OTHER : constant := 2;
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
-
- type pthread_t is private;
- subtype Thread_Id is pthread_t;
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- PTHREAD_CREATE_DETACHED : constant := 1;
-
- -----------
- -- Stack --
- -----------
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates wether the stack base is available on this target.
- -- This allows us to share s-osinte.adb between all the FSU run time.
- -- Note that this value can only be true if pthread_t has a complete
- -- definition that corresponds exactly to the C header files.
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread.
- -- Only call this function when Stack_Base_Available is True.
-
- function Get_Page_Size return size_t;
- function Get_Page_Size return Address;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- returns the size of a page, or 0 if this is not relevant on this
- -- target
-
- PROT_NONE : constant := 0;
- PROT_READ : constant := 1;
- PROT_WRITE : constant := 2;
- PROT_EXEC : constant := 4;
- PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
-
- PROT_ON : constant := PROT_NONE;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect
- (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
-
- procedure pthread_init;
- -- FSU_THREADS requires pthread_init, which is nonstandard
- -- and this should be invoked during the elaboration of s-taprop.adb
- pragma Import (C, pthread_init, "pthread_init");
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- -- FSU_THREADS has a nonstandard sigwait
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- type sigset_t_ptr is access all sigset_t;
-
- function pthread_sigmask
- (how : int;
- set : sigset_t_ptr;
- oset : sigset_t_ptr) return int;
- pragma Import (C, pthread_sigmask, "sigprocmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- -- FSU_THREADS has nonstandard pthread_mutex_lock
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- -- FSU_THREADS has nonstandard pthread_mutex_lock
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- -- FSU_THREADS has a nonstandard pthread_cond_wait
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- -- FSU_THREADS has a nonstandard pthread_cond_timedwait
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 2;
- PTHREAD_PRIO_INHERIT : constant := 1;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol);
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import (C, pthread_mutexattr_setprioceiling);
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- end record;
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- -- FSU_THREADS does not have pthread_setschedparam
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import (C, pthread_attr_setinheritsched);
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched");
-
- function sched_yield return int;
- -- FSU_THREADS does not have sched_yield;
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init);
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy);
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- -- FSU_THREADS has a nonstandard pthread_attr_setdetachstate
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize);
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create);
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- -- FSU_THREADS has a nonstandard pthread_getspecific
-
- type destructor_pointer is access procedure (arg : System.Address);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer) return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
-private
-
- type bits_arr_t is array (Integer range 1 .. 10) of long;
- type sigset_t is record
- bits : bits_arr_t;
- end record;
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 0;
-
- type struct_timeval is record
- tv_sec : long;
- tv_usec : long;
- end record;
- pragma Convention (C, struct_timeval);
-
- type pthread_attr_t is record
- flags : int;
- stacksize : int;
- contentionscope : int;
- inheritsched : int;
- detachstate : int;
- sched : int;
- prio : int;
- starttime : timespec;
- deadline : timespec;
- period : timespec;
- end record;
- pragma Convention (C, pthread_attr_t);
-
- type pthread_condattr_t is record
- flags : int;
- end record;
- pragma Convention (C, pthread_condattr_t);
-
- type pthread_mutexattr_t is record
- flags : int;
- prio_ceiling : int;
- protocol : int;
- end record;
- pragma Convention (C, pthread_mutexattr_t);
-
- type sigjmp_buf is array (Integer range 0 .. 43) of int;
-
- type pthread_t_struct is record
- context : sigjmp_buf;
- pbody : sigjmp_buf;
- errno : int;
- ret : int;
- stack_base : System.Address;
- end record;
- pragma Convention (C, pthread_t_struct);
-
- type pthread_t is access all pthread_t_struct;
-
- type queue_t is record
- head : System.Address;
- tail : System.Address;
- end record;
- pragma Convention (C, queue_t);
-
- type pthread_mutex_t is record
- queue : queue_t;
- lock : plain_char;
- owner : System.Address;
- flags : int;
- prio_ceiling : int;
- protocol : int;
- prev_max_ceiling_prio : int;
- end record;
- pragma Convention (C, pthread_mutex_t);
-
- type pthread_cond_t is record
- queue : queue_t;
- flags : int;
- waiters : int;
- mutex : System.Address;
- end record;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_key_t is new int;
-
-end System.OS_Interface;
diff --git a/gcc/ada/5dsystem.ads b/gcc/ada/5dsystem.ads
new file mode 100644
index 00000000000..1fa021d5187
--- /dev/null
+++ b/gcc/ada/5dsystem.ads
@@ -0,0 +1,158 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (VxWorks Version Xscale) --
+-- --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 1.0 / 60.0;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 32;
+ Memory_Size : constant := 2 ** 32;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := Low_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ -- 256 is reserved for the VxWorks kernel
+ -- 248 - 255 correspond to hardware interrupt levels 0 .. 7
+ -- 247 is a catchall default "interrupt" priority for signals,
+ -- allowing higher priority than normal tasks, but lower than
+ -- hardware priority levels. Protected Object ceilings can
+ -- override these values.
+ -- 246 is used by the Interrupt_Manager task
+
+ Max_Priority : constant Positive := 245;
+ Max_Interrupt_Priority : constant Positive := 255;
+
+ subtype Any_Priority is Integer range 0 .. 255;
+ subtype Priority is Any_Priority range 0 .. 245;
+ subtype Interrupt_Priority is Any_Priority range 246 .. 255;
+
+ Default_Priority : constant Priority := 122;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := False;
+ Configurable_Run_Time : constant Boolean := False;
+ Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := True;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+
+end System;
diff --git a/gcc/ada/5esystem.ads b/gcc/ada/5esystem.ads
index 1d997840cfe..d48b684f84c 100644
--- a/gcc/ada/5esystem.ads
+++ b/gcc/ada/5esystem.ads
@@ -118,22 +118,33 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := True;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := True;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := True;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
end System;
diff --git a/gcc/ada/5fintman.adb b/gcc/ada/5fintman.adb
index 183544838a3..2a290e105da 100644
--- a/gcc/ada/5fintman.adb
+++ b/gcc/ada/5fintman.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2001, Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -63,7 +63,7 @@ package body System.Interrupt_Management is
-- Initialize_Interrupts --
---------------------------
- -- Nothing needs to be done on this platform.
+ -- Nothing needs to be done on this platform
procedure Initialize_Interrupts is
begin
@@ -77,26 +77,76 @@ package body System.Interrupt_Management is
use type Interfaces.C.int;
begin
- Abort_Task_Interrupt := SIGABRT;
- -- Change this if you want to use another signal for task abort.
- -- SIGTERM might be a good one.
+ declare
+ function State (Int : Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ User : constant Character := 'u';
+ Runtime : constant Character := 'r';
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
- for I in Exception_Interrupts'Range loop
- Keep_Unmasked (Exception_Interrupts (I)) := True;
- end loop;
+ begin
+ Abort_Task_Interrupt := SIGABRT;
+
+ -- Change this if you want to use another signal for task abort.
+ -- SIGTERM might be a good one.
+
+ pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
+
+ -- Process state of exception signals
+
+ for J in Exception_Interrupts'Range loop
+ if State (Exception_Interrupts (J)) /= User then
+ Keep_Unmasked (Exception_Interrupts (J)) := True;
+ Reserve (Exception_Interrupts (J)) := True;
+ end if;
+ end loop;
+
+ if State (Abort_Task_Interrupt) /= User then
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+ Reserve (Abort_Task_Interrupt) := True;
+ end if;
+
+ -- Set SIGINT to unmasked state as long as it's
+ -- not in "User" state. Check for Unreserve_All_Interrupts last
+
+ if State (SIGINT) /= User then
+ Keep_Unmasked (SIGINT) := True;
+ end if;
+
+ -- Check all signals for state that requires keeping them
+ -- unmasked and reserved
+
+ for J in Interrupt_ID'Range loop
+ if State (J) = Default or else State (J) = Runtime then
+ Keep_Unmasked (J) := True;
+ Reserve (J) := True;
+ end if;
+ end loop;
- -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the
- -- same time, disable the ability of handling this signal via
- -- Ada.Interrupts.
- -- The pragma Unreserve_All_Interrupts let the user the ability to
- -- change this behavior.
+ -- Process pragma Unreserve_All_Interrupts. This overrides any
+ -- settings due to pragma Interrupt_State:
- if Unreserve_All_Interrupts = 0 then
- Keep_Unmasked (SIGINT) := True;
- end if;
+ if Unreserve_All_Interrupts /= 0 then
+ Keep_Unmasked (SIGINT) := False;
+ Reserve (SIGINT) := False;
+ end if;
- Keep_Unmasked (Abort_Task_Interrupt) := True;
+ -- We do not have Signal 0 in reality. We just use this value
+ -- to identify not existing signals (see s-intnam.ads). Therefore,
+ -- Signal 0 should not be used in all signal related operations hence
+ -- mark it as reserved.
- Reserve := Keep_Unmasked or Keep_Masked;
- Reserve (0) := True;
+ Reserve (0) := True;
+ end;
end System.Interrupt_Management;
diff --git a/gcc/ada/5fosinte.adb b/gcc/ada/5fosinte.adb
new file mode 100644
index 00000000000..9c4c616dfa2
--- /dev/null
+++ b/gcc/ada/5fosinte.adb
@@ -0,0 +1,120 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the IRIX version of this package.
+
+-- This package encapsulates all direct interfaces to OS services
+-- that are needed by children of System.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+with Interfaces.C; use Interfaces.C;
+
+package body System.OS_Interface is
+
+ ------------------
+ -- pthread_init --
+ ------------------
+
+ procedure pthread_init is
+ begin
+ null;
+ end pthread_init;
+
+ -----------------
+ -- To_Duration --
+ -----------------
+
+ function To_Duration (TS : timespec) return Duration is
+ begin
+ return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
+ end To_Duration;
+
+ function To_Duration (TV : struct_timeval) return Duration is
+ begin
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ end To_Duration;
+
+ -----------------
+ -- To_Timespec --
+ -----------------
+
+ function To_Timespec (D : Duration) return timespec is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ end To_Timespec;
+
+ ----------------
+ -- To_Timeval --
+ ----------------
+
+ function To_Timeval (D : Duration) return struct_timeval is
+ S : time_t;
+ F : Duration;
+
+ begin
+ S := time_t (Long_Long_Integer (D));
+ F := D - Duration (S);
+
+ -- If F has negative value due to a round-up, adjust for positive F
+ -- value.
+
+ if F < 0.0 then
+ S := S - 1;
+ F := F + 1.0;
+ end if;
+
+ return
+ struct_timeval'
+ (tv_sec => S,
+ tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
+ end To_Timeval;
+
+end System.OS_Interface;
diff --git a/gcc/ada/5fosinte.ads b/gcc/ada/5fosinte.ads
index 5a52148c48e..ef3f9941d0a 100644
--- a/gcc/ada/5fosinte.ads
+++ b/gcc/ada/5fosinte.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5fsystem.ads b/gcc/ada/5fsystem.ads
index 9da53a748e5..05351d8e932 100644
--- a/gcc/ada/5fsystem.ads
+++ b/gcc/ada/5fsystem.ads
@@ -118,24 +118,35 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := False;
+ Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := True;
- Long_Shifts_Inlined : constant Boolean := True;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := True;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := True;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := True;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
-- Note: Denorm is False because denormals are not supported on the
-- R10000, and we want the code to be valid for this processor.
diff --git a/gcc/ada/5ftaprop.adb b/gcc/ada/5ftaprop.adb
index 179f351eb7f..af9ecb59c22 100644
--- a/gcc/ada/5ftaprop.adb
+++ b/gcc/ada/5ftaprop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -111,14 +111,14 @@ package body System.Task_Primitives.Operations is
-- The followings are logically constants, but need to be initialized
-- at run time.
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_ID associated with a thread
-
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
@@ -129,26 +129,74 @@ package body System.Task_Primitives.Operations is
Unblocked_Signal_Mask : aliased sigset_t;
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads).
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ procedure Initialize (Environment_Task : Task_ID);
+ pragma Inline (Initialize);
+ -- Initialize various data needed by this package.
+
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does executing thread have a TCB?
+
+ procedure Set (Self_Id : Task_ID);
+ pragma Inline (Set);
+ -- Set the self id for the current task.
+
+ function Self return Task_ID;
+ pragma Inline (Self);
+ -- Return a pointer to the Ada Task Control Block of the calling task.
+
+ end Specific;
+
+ package body Specific is separate;
+ -- The body of this package is target specific.
+
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
+ -- Allocate and Initialize a new ATCB for the current Thread.
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_ID is separate;
+
-----------------------
-- Local Subprograms --
-----------------------
- function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
-
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
procedure Abort_Handler (Sig : Signal);
+ -- Signal handler used to implement asynchronous abort.
-------------------
-- Abort_Handler --
-------------------
procedure Abort_Handler (Sig : Signal) is
- T : Task_ID := Self;
+ pragma Unreferenced (Sig);
+
+ T : constant Task_ID := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
begin
+ -- It is not safe to raise an exception when using ZCX and the GCC
+ -- exception handling mechanism.
+
+ if ZCX_By_Default and then GCC_ZCX_Support then
+ return;
+ end if;
+
if T.Deferral_Level = 0
and then T.Pending_ATC_Level < T.ATC_Nesting_Level
then
@@ -172,6 +220,9 @@ package body System.Task_Primitives.Operations is
-- bottom of a thread stack, so nothing is needed.
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ pragma Unreferenced (On);
+ pragma Unreferenced (T);
+
begin
null;
end Stack_Guard;
@@ -189,15 +240,7 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
- function Self return Task_ID is
- Result : System.Address;
-
- begin
- Result := pthread_getspecific (ATCB_Key);
- pragma Assert (Result /= System.Null_Address);
-
- return To_Task_ID (Result);
- end Self;
+ function Self return Task_ID renames Specific.Self;
---------------------
-- Initialize_Lock --
@@ -248,6 +291,8 @@ package body System.Task_Primitives.Operations is
end Initialize_Lock;
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ pragma Unreferenced (Level);
+
Attributes : aliased pthread_mutexattr_t;
Result : Interfaces.C.int;
@@ -351,6 +396,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
+
begin
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
@@ -358,6 +404,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
@@ -367,6 +414,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (T : Task_ID) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
@@ -382,7 +430,10 @@ package body System.Task_Primitives.Operations is
(Self_ID : ST.Task_ID;
Reason : System.Tasking.Task_States)
is
+ pragma Unreferenced (Reason);
+
Result : Interfaces.C.int;
+
begin
if Single_Lock then
Result := pthread_cond_wait
@@ -409,6 +460,8 @@ package body System.Task_Primitives.Operations is
Timedout : out Boolean;
Yielded : out Boolean)
is
+ pragma Unreferenced (Reason);
+
Check_Time : constant Duration := Monotonic_Clock;
Abs_Time : Duration;
Request : aliased timespec;
@@ -560,7 +613,10 @@ package body System.Task_Primitives.Operations is
------------
procedure Wakeup (T : ST.Task_ID; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+
Result : Interfaces.C.int;
+
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -572,6 +628,7 @@ package body System.Task_Primitives.Operations is
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
+
begin
if Do_Yield then
Result := sched_yield;
@@ -587,6 +644,8 @@ package body System.Task_Primitives.Operations is
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
+ pragma Unreferenced (Loss_Of_Inheritance);
+
Result : Interfaces.C.int;
Param : aliased struct_sched_param;
Sched_Policy : Interfaces.C.int;
@@ -634,8 +693,7 @@ package body System.Task_Primitives.Operations is
begin
Self_ID.Common.LL.Thread := pthread_self;
- Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
- pragma Assert (Result = 0);
+ Specific.Set (Self_ID);
if Self_ID.Common.Task_Info /= null
and then Self_ID.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM
@@ -668,6 +726,25 @@ package body System.Task_Primitives.Operations is
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_ID is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (pthread_self);
+ end if;
+ end Register_Foreign_Thread;
+
--------------------
-- Initialize_TCB --
--------------------
@@ -759,7 +836,7 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
Result := pthread_attr_setstacksize
- (Attributes'Access, Interfaces.C.size_t (Adjusted_Stack_Size));
+ (Attributes'Access, Adjusted_Stack_Size);
pragma Assert (Result = 0);
if T.Common.Task_Info /= null then
@@ -807,7 +884,7 @@ package body System.Task_Primitives.Operations is
System.IO.Put_Line
("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task");
System.IO.Put ("""");
- System.IO.Put (T.Common.Task_Image.all);
+ System.IO.Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len));
System.IO.Put_Line (""" could not be honored. ");
System.IO.Put_Line ("Scope changed to PTHREAD_SCOPE_PROCESS");
@@ -827,7 +904,14 @@ package body System.Task_Primitives.Operations is
Succeeded := Result = 0;
- Set_Priority (T, Priority);
+ -- The following needs significant commenting ???
+
+ if T.Common.Task_Info /= null then
+ T.Common.Base_Priority := T.Common.Task_Info.Priority;
+ Set_Priority (T, T.Common.Task_Info.Priority);
+ else
+ Set_Priority (T, Priority);
+ end if;
Result := pthread_attr_destroy (Attributes'Access);
pragma Assert (Result = 0);
@@ -840,6 +924,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_TCB (T : Task_ID) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
+ Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
@@ -858,6 +943,12 @@ package body System.Task_Primitives.Operations is
end if;
Free (Tmp);
+
+ if Is_Self then
+ Result := pthread_setspecific (ATCB_Key, System.Null_Address);
+ pragma Assert (Result = 0);
+ end if;
+
end Finalize_TCB;
---------------
@@ -866,7 +957,7 @@ package body System.Task_Primitives.Operations is
procedure Exit_Task is
begin
- pthread_exit (System.Null_Address);
+ Specific.Set (null);
end Exit_Task;
----------------
@@ -875,6 +966,7 @@ package body System.Task_Primitives.Operations is
procedure Abort_Task (T : Task_ID) is
Result : Interfaces.C.int;
+
begin
Result := pthread_kill (T.Common.LL.Thread,
Signal (System.Interrupt_Management.Abort_Task_Interrupt));
@@ -885,10 +977,11 @@ package body System.Task_Primitives.Operations is
-- Check_Exit --
----------------
- -- Dummy versions. The only currently working versions is for solaris
- -- (native).
+ -- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
+
begin
return True;
end Check_Exit;
@@ -898,6 +991,8 @@ package body System.Task_Primitives.Operations is
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
+
begin
return True;
end Check_No_Locks;
@@ -935,7 +1030,12 @@ package body System.Task_Primitives.Operations is
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
+ pragma Unreferenced (T);
+ pragma Unreferenced (Thread_Self);
+
begin
return False;
end Suspend_Task;
@@ -946,7 +1046,12 @@ package body System.Task_Primitives.Operations is
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
+ pragma Unreferenced (T);
+ pragma Unreferenced (Thread_Self);
+
begin
return False;
end Resume_Task;
@@ -961,34 +1066,56 @@ package body System.Task_Primitives.Operations is
Tmp_Set : aliased sigset_t;
Result : Interfaces.C.int;
+ function State (Int : System.Interrupt_Management.Interrupt_ID)
+ return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
begin
Environment_Task_ID := Environment_Task;
-- Initialize the lock used to synchronize chain of all ATCBs.
+
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+ Specific.Initialize (Environment_Task);
+
Enter_Task (Environment_Task);
-- Install the abort-signal handler
- act.sa_flags := 0;
- act.sa_handler := Abort_Handler'Address;
+ if State (System.Interrupt_Management.Abort_Task_Interrupt)
+ /= Default
+ then
+ act.sa_flags := 0;
+ act.sa_handler := Abort_Handler'Address;
- Result := sigemptyset (Tmp_Set'Access);
- pragma Assert (Result = 0);
- act.sa_mask := Tmp_Set;
+ Result := sigemptyset (Tmp_Set'Access);
+ pragma Assert (Result = 0);
+ act.sa_mask := Tmp_Set;
- Result :=
- sigaction (
- Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
+ Result :=
+ sigaction (
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
end Initialize;
begin
declare
Result : Interfaces.C.int;
+
begin
-- Mask Environment task for all signals. The original mask of the
-- Environment task will be recovered by Interrupt_Server task
@@ -1009,9 +1136,6 @@ begin
end if;
end loop;
- Result := pthread_key_create (ATCB_Key'Access, null);
- pragma Assert (Result = 0);
-
-- Pick the highest resolution Clock for Clock_Realtime
-- ??? This code currently doesn't work (see c94007[ab] for example)
--
diff --git a/gcc/ada/5ftasinf.ads b/gcc/ada/5ftasinf.ads
index 0438b7664d3..2954f8ee66c 100644
--- a/gcc/ada/5ftasinf.ads
+++ b/gcc/ada/5ftasinf.ads
@@ -5,9 +5,8 @@
-- S Y S T E M . T A S K _ I N F O --
-- --
-- S p e c --
--- (Compiler Interface) --
-- --
--- Copyright (C) 1992-2000 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- --
@@ -33,19 +32,23 @@
------------------------------------------------------------------------------
-- This package contains the definitions and routines associated with the
--- implementation of the Task_Info pragma. It is specialized appropriately
--- for targets that make use of this pragma.
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
-- Note: the compiler generates direct calls to this interface, via Rtsfind.
-- Any changes to this interface may require corresponding compiler changes.
+-- This unit may be used directly from an application program by providing
+-- an appropriate WITH, and the interface can be expected to remain stable.
+
+-- This is the IRIX (kernel threads) version of this package
+
with Interfaces.C;
with System.OS_Interface;
-with Unchecked_Deallocation;
package System.Task_Info is
-pragma Elaborate_Body;
--- To ensure that a body is allowed
+ pragma Elaborate_Body;
+ -- To ensure that a body is allowed
package OSI renames System.OS_Interface;
@@ -127,13 +130,6 @@ pragma Elaborate_Body;
type Task_Info_Type is access all Thread_Attributes;
- type Task_Image_Type is access String;
- -- Used to generate a meaningful identifier for tasks that are variables
- -- and components of variables.
-
- procedure Free_Task_Image is new
- Unchecked_Deallocation (String, Task_Image_Type);
-
Unspecified_Task_Info : constant Task_Info_Type := null;
-- Value passed to task in the absence of a Task_Info pragma
diff --git a/gcc/ada/5ginterr.adb b/gcc/ada/5ginterr.adb
index 2365dc1dac0..b2a861ae029 100644
--- a/gcc/ada/5ginterr.adb
+++ b/gcc/ada/5ginterr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2001 Free Software Fundation --
+-- Copyright (C) 1998-2002 Free Software Fundation --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -244,7 +244,11 @@ package body System.Interrupts is
-------------------------------------
function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection) return Boolean is
+ (Object : access Dynamic_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Unreferenced (Object);
+
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
@@ -278,6 +282,8 @@ package body System.Interrupts is
(Object : access Static_Interrupt_Protection)
return Boolean
is
+ pragma Unreferenced (Object);
+
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
@@ -288,7 +294,7 @@ package body System.Interrupts is
procedure Install_Handlers
(Object : access Static_Interrupt_Protection;
- New_Handlers : in New_Handler_Array)
+ New_Handlers : New_Handler_Array)
is
begin
for N in New_Handlers'Range loop
diff --git a/gcc/ada/5gintman.adb b/gcc/ada/5gintman.adb
index 8868a8479dc..57771303f16 100644
--- a/gcc/ada/5gintman.adb
+++ b/gcc/ada/5gintman.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-1998, Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -40,12 +40,15 @@
-- Make a careful study of all signals available under the OS,
-- to see which need to be reserved, kept always unmasked,
-- or kept always unmasked.
+
-- Be on the lookout for special signals that
-- may be used by the thread library.
with System.OS_Interface;
-- used for various Constants, Signal and types
+with Interfaces.C;
+-- used for "int"
package body System.Interrupt_Management is
use System.OS_Interface;
@@ -75,6 +78,10 @@ package body System.Interrupt_Management is
-- unnamed signal number 48 for pthread_kill!
--
+ Unreserve_All_Interrupts : Interfaces.C.int;
+ pragma Import
+ (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
+
----------------------
-- Notify_Exception --
----------------------
@@ -98,16 +105,80 @@ package body System.Interrupt_Management is
end Initialize_Interrupts;
begin
- Abort_Task_Interrupt := Abort_Signal;
+ declare
+ function State (Int : Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ User : constant Character := 'u';
+ Runtime : constant Character := 'r';
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
+ use Interfaces.C;
+
+ begin
+ Abort_Task_Interrupt := Abort_Signal;
+
+ pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
+
+ -- Process state of exception signals
+
+ for J in Exception_Interrupts'Range loop
+ if State (Exception_Interrupts (J)) /= User then
+ Keep_Unmasked (Exception_Interrupts (J)) := True;
+ Reserve (Exception_Interrupts (J)) := True;
+ end if;
+ end loop;
+
+ if State (Abort_Task_Interrupt) /= User then
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+ Reserve (Abort_Task_Interrupt) := True;
+ end if;
+
+ -- Set SIGINT to unmasked state as long as it's
+ -- not in "User" state. Check for Unreserve_All_Interrupts last
+
+ if State (SIGINT) /= User then
+ Keep_Unmasked (SIGINT) := True;
+ end if;
+
+ -- Check all signals for state that requires keeping them
+ -- unmasked and reserved
+
+ for J in Interrupt_ID'Range loop
+ if State (J) = Default or else State (J) = Runtime then
+ Keep_Unmasked (J) := True;
+ Reserve (J) := True;
+ end if;
+ end loop;
+
+ -- Add target-specific reserved signals
+
+ for J in Reserved_Interrupts'Range loop
+ Reserve (Interrupt_ID (Reserved_Interrupts (J))) := True;
+ end loop;
+
+ -- Process pragma Unreserve_All_Interrupts. This overrides any
+ -- settings due to pragma Interrupt_State:
- for I in Reserved_Interrupts'Range loop
- Keep_Unmasked (Reserved_Interrupts (I)) := True;
- Reserve (Reserved_Interrupts (I)) := True;
- end loop;
+ if Unreserve_All_Interrupts /= 0 then
+ Keep_Unmasked (SIGINT) := False;
+ Reserve (SIGINT) := False;
+ end if;
- for I in Exception_Interrupts'Range loop
- Keep_Unmasked (Exception_Interrupts (I)) := True;
- Reserve (Reserved_Interrupts (I)) := True;
- end loop;
+ -- We do not have Signal 0 in reality. We just use this value
+ -- to identify not existing signals (see s-intnam.ads). Therefore,
+ -- Signal 0 should not be used in all signal related operations hence
+ -- mark it as reserved.
+ Reserve (0) := True;
+ end;
end System.Interrupt_Management;
diff --git a/gcc/ada/5gmastop.adb b/gcc/ada/5gmastop.adb
index 01e6381cadd..7f6785cba12 100644
--- a/gcc/ada/5gmastop.adb
+++ b/gcc/ada/5gmastop.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (Version for IRIX/MIPS) --
-- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-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- --
@@ -183,6 +183,8 @@ package body System.Machine_State_Operations is
-------------------
procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
+ pragma Warnings (Off, M);
+ pragma Warnings (Off, Handler);
LOADI : constant String (1 .. 2) := 'l' & LSC;
-- This is "lw" in o32 mode, and "ld" in n32/n64 mode
@@ -282,6 +284,8 @@ package body System.Machine_State_Operations is
(M : Machine_State;
Info : Subprogram_Info_Type)
is
+ pragma Warnings (Off, Info);
+
Scp : Sigcontext_Ptr := To_Sigcontext_Ptr (M);
procedure Exc_Unwind (Scp : Sigcontext_Ptr; Fde : Long_Integer := 0);
@@ -406,7 +410,11 @@ package body System.Machine_State_Operations is
procedure Set_Signal_Machine_State
(M : Machine_State;
- Context : System.Address) is
+ Context : System.Address)
+ is
+ pragma Warnings (Off, M);
+ pragma Warnings (Off, Context);
+
begin
null;
end Set_Signal_Machine_State;
diff --git a/gcc/ada/5gml-tgt.adb b/gcc/ada/5gml-tgt.adb
new file mode 100644
index 00000000000..027ae8a8684
--- /dev/null
+++ b/gcc/ada/5gml-tgt.adb
@@ -0,0 +1,368 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T --
+-- (IRIX Version) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003, Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a set of target dependent routines to build
+-- static, dynamic and shared libraries.
+
+-- This is the IRIX version of the body.
+
+with MLib.Fil;
+with MLib.Utl;
+with Namet; use Namet;
+with Opt;
+with Output; use Output;
+with Prj.Com;
+with System;
+
+package body MLib.Tgt is
+
+ No_Arguments : aliased Argument_List := (1 .. 0 => null);
+ Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access;
+
+ Wl_Init_String : aliased String := "-Wl,-init";
+ Wl_Init : constant String_Access := Wl_Init_String'Access;
+ Wl_Fini_String : aliased String := "-Wl,-fini";
+ Wl_Fini : constant String_Access := Wl_Fini_String'Access;
+
+ Init_Fini_List : constant Argument_List_Access :=
+ new Argument_List'(1 => Wl_Init,
+ 2 => null,
+ 3 => Wl_Fini,
+ 4 => null);
+ -- Used to put switches for automatic elaboration/finalization
+
+ ---------------------
+ -- Archive_Builder --
+ ---------------------
+
+ function Archive_Builder return String is
+ begin
+ return "ar";
+ end Archive_Builder;
+
+ -----------------------------
+ -- Archive_Builder_Options --
+ -----------------------------
+
+ function Archive_Builder_Options return String_List_Access is
+ begin
+ return new String_List'(1 => new String'("cr"));
+ end Archive_Builder_Options;
+
+ -----------------
+ -- Archive_Ext --
+ -----------------
+
+ function Archive_Ext return String is
+ begin
+ return "a";
+ end Archive_Ext;
+
+ ---------------------
+ -- Archive_Indexer --
+ ---------------------
+
+ function Archive_Indexer return String is
+ begin
+ return "ranlib";
+ end Archive_Indexer;
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Foreign : Argument_List;
+ Afiles : Argument_List;
+ Options : Argument_List;
+ Interfaces : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Driver_Name : Name_Id := No_Name;
+ Lib_Address : String := "";
+ Lib_Version : String := "";
+ Relocatable : Boolean := False;
+ Auto_Init : Boolean := False)
+ is
+ pragma Unreferenced (Foreign);
+ pragma Unreferenced (Afiles);
+ pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Lib_Address);
+ pragma Unreferenced (Relocatable);
+
+ Lib_File : constant String :=
+ Lib_Dir & Directory_Separator & "lib" &
+ MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
+
+ Version_Arg : String_Access;
+ Symbolic_Link_Needed : Boolean := False;
+
+ Init_Fini : Argument_List_Access := Empty_Argument_List;
+
+ begin
+ if Opt.Verbose_Mode then
+ Write_Str ("building relocatable shared library ");
+ Write_Line (Lib_File);
+ end if;
+
+ -- If specified, add automatic elaboration/finalization
+ if Auto_Init then
+ Init_Fini := Init_Fini_List;
+ Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init");
+ Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final");
+ end if;
+
+ if Lib_Version = "" then
+ MLib.Utl.Gcc
+ (Output_File => Lib_File,
+ Objects => Ofiles,
+ Options => Options & Init_Fini.all,
+ Driver_Name => Driver_Name);
+
+ else
+ Version_Arg := new String'("-Wl,-soname," & Lib_Version);
+
+ if Is_Absolute_Path (Lib_Version) then
+ MLib.Utl.Gcc
+ (Output_File => Lib_Version,
+ Objects => Ofiles,
+ Options => Options & Version_Arg & Init_Fini.all,
+ Driver_Name => Driver_Name);
+ Symbolic_Link_Needed := Lib_Version /= Lib_File;
+
+ else
+ MLib.Utl.Gcc
+ (Output_File => Lib_Dir & Directory_Separator & Lib_Version,
+ Objects => Ofiles,
+ Options => Options & Version_Arg & Init_Fini.all,
+ Driver_Name => Driver_Name);
+ Symbolic_Link_Needed :=
+ Lib_Dir & Directory_Separator & Lib_Version /= Lib_File;
+ end if;
+
+ if Symbolic_Link_Needed then
+ declare
+ Success : Boolean;
+ Oldpath : String (1 .. Lib_Version'Length + 1);
+ Newpath : String (1 .. Lib_File'Length + 1);
+ Result : Integer;
+
+ function Symlink
+ (Oldpath : System.Address;
+ Newpath : System.Address)
+ return Integer;
+ pragma Import (C, Symlink, "__gnat_symlink");
+
+ begin
+ Oldpath (1 .. Lib_Version'Length) := Lib_Version;
+ Oldpath (Oldpath'Last) := ASCII.NUL;
+ Newpath (1 .. Lib_File'Length) := Lib_File;
+ Newpath (Newpath'Last) := ASCII.NUL;
+
+ Delete_File (Lib_File, Success);
+
+ Result := Symlink (Oldpath'Address, Newpath'Address);
+ end;
+ end if;
+ end if;
+ end Build_Dynamic_Library;
+
+ -------------------------
+ -- Default_DLL_Address --
+ -------------------------
+
+ function Default_DLL_Address return String is
+ begin
+ return "";
+ end Default_DLL_Address;
+
+ -------------
+ -- DLL_Ext --
+ -------------
+
+ function DLL_Ext return String is
+ begin
+ return "so";
+ end DLL_Ext;
+
+ --------------------
+ -- Dynamic_Option --
+ --------------------
+
+ function Dynamic_Option return String is
+ begin
+ return "-shared";
+ end Dynamic_Option;
+
+ -------------------
+ -- Is_Object_Ext --
+ -------------------
+
+ function Is_Object_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".o";
+ end Is_Object_Ext;
+
+ --------------
+ -- Is_C_Ext --
+ --------------
+
+ function Is_C_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".c";
+ end Is_C_Ext;
+
+ --------------------
+ -- Is_Archive_Ext --
+ --------------------
+
+ function Is_Archive_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".a" or else Ext = ".so";
+ end Is_Archive_Ext;
+
+ -------------
+ -- Libgnat --
+ -------------
+
+ function Libgnat return String is
+ begin
+ return "libgnat.a";
+ end Libgnat;
+
+ ------------------------
+ -- Library_Exists_For --
+ ------------------------
+
+ function Library_Exists_For (Project : Project_Id) return Boolean is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
+ "for non library project");
+ return False;
+
+ else
+ declare
+ Lib_Dir : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Dir);
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ if Projects.Table (Project).Library_Kind = Static then
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+ end;
+ end if;
+ end Library_Exists_For;
+
+ ---------------------------
+ -- Library_File_Name_For --
+ ---------------------------
+
+ function Library_File_Name_For (Project : Project_Id) return Name_Id is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
+ "for non library project");
+ return No_Name;
+
+ else
+ declare
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "lib";
+
+ if Projects.Table (Project).Library_Kind = Static then
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+
+ return Name_Find;
+ end;
+ end if;
+ end Library_File_Name_For;
+
+ --------------------------------
+ -- Linker_Library_Path_Option --
+ --------------------------------
+
+ function Linker_Library_Path_Option return String_Access is
+ begin
+ return new String'("-Wl,-rpath,");
+ end Linker_Library_Path_Option;
+
+ ----------------
+ -- Object_Ext --
+ ----------------
+
+ function Object_Ext return String is
+ begin
+ return "o";
+ end Object_Ext;
+
+ ----------------
+ -- PIC_Option --
+ ----------------
+
+ function PIC_Option return String is
+ begin
+ return "-fPIC";
+ end PIC_Option;
+
+ -----------------------------------------------
+ -- Standalone_Library_Auto_Init_Is_Supported --
+ -----------------------------------------------
+
+ function Standalone_Library_Auto_Init_Is_Supported return Boolean is
+ begin
+ return True;
+ end Standalone_Library_Auto_Init_Is_Supported;
+
+ ---------------------------
+ -- Support_For_Libraries --
+ ---------------------------
+
+ function Support_For_Libraries return Library_Support is
+ begin
+ return Full;
+ end Support_For_Libraries;
+
+end MLib.Tgt;
diff --git a/gcc/ada/5gosinte.ads b/gcc/ada/5gosinte.ads
index ab83d462f83..17cf4505965 100644
--- a/gcc/ada/5gosinte.ads
+++ b/gcc/ada/5gosinte.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5gproinf.ads b/gcc/ada/5gproinf.ads
index f185e81c0ae..a4259c3c916 100644
--- a/gcc/ada/5gproinf.ads
+++ b/gcc/ada/5gproinf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-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- --
@@ -30,6 +30,7 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+
-- This package contains the definitions and routines used as parameters
-- to the run-time system at program startup for the SGI implementation.
diff --git a/gcc/ada/5gsystem.ads b/gcc/ada/5gsystem.ads
index 315724e1972..c18318ca364 100644
--- a/gcc/ada/5gsystem.ads
+++ b/gcc/ada/5gsystem.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (SGI Irix, n32 ABI) --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -58,7 +58,7 @@ pragma Pure (System);
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
- Tick : constant := 1.0;
+ Tick : constant := 0.01;
-- Storage-related Declarations
@@ -118,22 +118,34 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := False;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := True;
- Long_Shifts_Inlined : constant Boolean := True;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := True;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
- ZCX_By_Default : constant Boolean := True;
+ ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
- Front_End_ZCX_Support : constant Boolean := True;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
-- Note: Denorm is False because denormals are not supported on the
-- R10000, and we want the code to be valid for this processor.
diff --git a/gcc/ada/5gtaprop.adb b/gcc/ada/5gtaprop.adb
index ae3ce107d1e..b9b88c3fb5d 100644
--- a/gcc/ada/5gtaprop.adb
+++ b/gcc/ada/5gtaprop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -96,9 +96,9 @@ package body System.Task_Primitives.Operations is
package SSL renames System.Soft_Links;
- ------------------
- -- Local Data --
- ------------------
+ -----------------
+ -- Local Data --
+ -----------------
-- The followings are logically constants, but need to be initialized
-- at run time.
@@ -212,6 +212,7 @@ package body System.Task_Primitives.Operations is
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
Attributes : aliased pthread_mutexattr_t;
Result : Interfaces.C.int;
+
begin
Result := pthread_mutexattr_init (Attributes'Access);
@@ -265,6 +266,7 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Result : Interfaces.C.int;
+
begin
Result := pthread_mutex_lock (L);
@@ -276,6 +278,7 @@ package body System.Task_Primitives.Operations is
(L : access RTS_Lock; Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
+
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
@@ -285,6 +288,7 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (T : Task_ID) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
@@ -307,6 +311,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
+
begin
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
@@ -314,6 +319,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
@@ -323,6 +329,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (T : Task_ID) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
@@ -339,6 +346,7 @@ package body System.Task_Primitives.Operations is
Reason : System.Tasking.Task_States)
is
Result : Interfaces.C.int;
+
begin
if Single_Lock then
Result := pthread_cond_wait
@@ -349,6 +357,7 @@ package body System.Task_Primitives.Operations is
end if;
-- EINTR is not considered a failure.
+
pragma Assert (Result = 0 or else Result = EINTR);
end Sleep;
@@ -368,6 +377,7 @@ package body System.Task_Primitives.Operations is
Abs_Time : Duration;
Request : aliased struct_timeval;
Result : Interfaces.C.int;
+
begin
Timedout := True;
Yielded := False;
@@ -427,7 +437,7 @@ package body System.Task_Primitives.Operations is
begin
-- Only the little window between deferring abort and
-- locking Self_ID is the reason we need to
- -- check for pending abort and priority change below! :(
+ -- check for pending abort and priority change below!
SSL.Abort_Defer.all;
@@ -524,6 +534,7 @@ package body System.Task_Primitives.Operations is
Reason : System.Tasking.Task_States)
is
Result : Interfaces.C.int;
+
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -545,11 +556,14 @@ package body System.Task_Primitives.Operations is
------------------
procedure Set_Priority
- (T : Task_ID;
- Prio : System.Any_Priority;
+ (T : Task_ID;
+ Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
+ pragma Unreferenced (Loss_Of_Inheritance);
+
Result : Interfaces.C.int;
+
begin
T.Common.Current_Priority := Prio;
Result := pthread_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
@@ -572,6 +586,7 @@ package body System.Task_Primitives.Operations is
procedure Enter_Task (Self_ID : Task_ID) is
Result : Interfaces.C.int;
+
begin
Self_ID.Common.LL.Thread := pthread_self;
Self_ID.Common.LL.LWP := sproc_self;
@@ -603,6 +618,24 @@ package body System.Task_Primitives.Operations is
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return False;
+ end Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_ID is
+ begin
+ return null;
+ end Register_Foreign_Thread;
+
----------------------
-- Initialize_TCB --
----------------------
@@ -769,8 +802,10 @@ package body System.Task_Primitives.Operations is
---------------
procedure Exit_Task is
+ Result : Interfaces.C.int;
+
begin
- pthread_exit (System.Null_Address);
+ Result := pthread_set_ada_tcb (pthread_self, System.Null_Address);
end Exit_Task;
----------------
@@ -779,9 +814,12 @@ package body System.Task_Primitives.Operations is
procedure Abort_Task (T : Task_ID) is
Result : Interfaces.C.int;
+
begin
- Result := pthread_kill (T.Common.LL.Thread,
- Interfaces.C.int (System.Interrupt_Management.Abort_Task_Interrupt));
+ Result :=
+ pthread_kill (T.Common.LL.Thread,
+ Interfaces.C.int
+ (System.Interrupt_Management.Abort_Task_Interrupt));
pragma Assert (Result = 0);
end Abort_Task;
@@ -789,10 +827,11 @@ package body System.Task_Primitives.Operations is
-- Check_Exit --
----------------
- -- Dummy versions. The only currently working versions is for solaris
- -- (native).
+ -- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
+
begin
return True;
end Check_Exit;
@@ -839,7 +878,9 @@ package body System.Task_Primitives.Operations is
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
begin
if T.Common.LL.Thread /= Thread_Self then
return pthread_suspend (T.Common.LL.Thread) = 0;
@@ -854,7 +895,9 @@ package body System.Task_Primitives.Operations is
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
begin
if T.Common.LL.Thread /= Thread_Self then
return pthread_resume (T.Common.LL.Thread) = 0;
@@ -880,6 +923,10 @@ package body System.Task_Primitives.Operations is
Environment_Task.Common.Current_Priority);
end Initialize;
+ --------------------------------
+ -- Initialize_Athread_Library --
+ --------------------------------
+
procedure Initialize_Athread_Library is
Result : Interfaces.C.int;
Init : aliased pthread_init_struct;
diff --git a/gcc/ada/5gtasinf.ads b/gcc/ada/5gtasinf.ads
index 31d2760c7dc..8cb4f232d7f 100644
--- a/gcc/ada/5gtasinf.ads
+++ b/gcc/ada/5gtasinf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,16 +32,22 @@
------------------------------------------------------------------------------
-- This package contains the definitions and routines associated with the
--- implementation of the Task_Info pragma.
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+-- This unit may be used directly from an application program by providing
+-- an appropriate WITH, and the interface can be expected to remain stable.
-- This is the SGI (libathread) specific version of this module.
with System.OS_Interface;
-with Unchecked_Deallocation;
package System.Task_Info is
-pragma Elaborate_Body;
--- To ensure that a body is allowed
+ pragma Elaborate_Body;
+ -- To ensure that a body is allowed
---------------------------------------------------------
-- Binding of Tasks to sprocs and sprocs to processors --
@@ -273,13 +279,6 @@ pragma Elaborate_Body;
NDPRI : Non_Degrading_Priority := NDP_NONE)
return Task_Info_Type;
- type Task_Image_Type is access String;
- -- Used to generate a meaningful identifier for tasks that are variables
- -- and components of variables.
-
- procedure Free_Task_Image is new
- Unchecked_Deallocation (String, Task_Image_Type);
-
Unspecified_Task_Info : constant Task_Info_Type := null;
end System.Task_Info;
diff --git a/gcc/ada/5gtpgetc.adb b/gcc/ada/5gtpgetc.adb
index 2754ae4a169..6b36c9d54f8 100644
--- a/gcc/ada/5gtpgetc.adb
+++ b/gcc/ada/5gtpgetc.adb
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5hml-tgt.adb b/gcc/ada/5hml-tgt.adb
new file mode 100644
index 00000000000..5398d563990
--- /dev/null
+++ b/gcc/ada/5hml-tgt.adb
@@ -0,0 +1,373 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T --
+-- (HP-UX Version) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003, Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a set of target dependent routines to build
+-- libraries (static only on HP-UX).
+
+-- This is the HP-UX version of the body.
+
+with MLib.Fil;
+with MLib.Utl;
+with Namet; use Namet;
+with Opt;
+with Output; use Output;
+with Prj.Com;
+with System;
+
+package body MLib.Tgt is
+
+ No_Arguments : aliased Argument_List := (1 .. 0 => null);
+ Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access;
+
+ Wl_Init_String : aliased String := "-Wl,+init";
+ Wl_Init : constant String_Access := Wl_Init_String'Access;
+ Wl_Fini_String : aliased String := "-Wl,+fini";
+ Wl_Fini : constant String_Access := Wl_Fini_String'Access;
+
+ Init_Fini_List : constant Argument_List_Access :=
+ new Argument_List'(1 => Wl_Init,
+ 2 => null,
+ 3 => Wl_Fini,
+ 4 => null);
+ -- Used to put switches for automatic elaboration/finalization
+ ---------------------
+ -- Archive_Builder --
+ ---------------------
+
+ function Archive_Builder return String is
+ begin
+ return "ar";
+ end Archive_Builder;
+
+ -----------------------------
+ -- Archive_Builder_Options --
+ -----------------------------
+
+ function Archive_Builder_Options return String_List_Access is
+ begin
+ return new String_List'(1 => new String'("cr"));
+ end Archive_Builder_Options;
+
+ -----------------
+ -- Archive_Ext --
+ -----------------
+
+ function Archive_Ext return String is
+ begin
+ return "a";
+ end Archive_Ext;
+
+ ---------------------
+ -- Archive_Indexer --
+ ---------------------
+
+ function Archive_Indexer return String is
+ begin
+ return "ranlib";
+ end Archive_Indexer;
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Foreign : Argument_List;
+ Afiles : Argument_List;
+ Options : Argument_List;
+ Interfaces : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Driver_Name : Name_Id := No_Name;
+ Lib_Address : String := "";
+ Lib_Version : String := "";
+ Relocatable : Boolean := False;
+ Auto_Init : Boolean := False)
+ is
+ pragma Unreferenced (Foreign);
+ pragma Unreferenced (Afiles);
+ pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Lib_Address);
+ pragma Unreferenced (Relocatable);
+
+ Lib_File : constant String :=
+ Lib_Dir & Directory_Separator & "lib" &
+ MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
+
+ Version_Arg : String_Access;
+ Symbolic_Link_Needed : Boolean := False;
+
+ Init_Fini : Argument_List_Access := Empty_Argument_List;
+
+ Common_Options : Argument_List := Options & new String'(PIC_Option);
+ -- Common set of options to the gcc command performing the link.
+ -- On HPUX, this command eventually resorts to collect2, which may
+ -- generate a C file and compile it on the fly. This compilation shall
+ -- also generate position independant code for the final link to
+ -- succeed.
+ begin
+ if Opt.Verbose_Mode then
+ Write_Str ("building relocatable shared library ");
+ Write_Line (Lib_File);
+ end if;
+
+ -- If specified, add automatic elaboration/finalization
+ if Auto_Init then
+ Init_Fini := Init_Fini_List;
+ Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init");
+ Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final");
+ end if;
+
+ if Lib_Version = "" then
+ MLib.Utl.Gcc
+ (Output_File => Lib_File,
+ Objects => Ofiles,
+ Options => Common_Options & Init_Fini.all,
+ Driver_Name => Driver_Name);
+
+ else
+ Version_Arg := new String'("-Wl,+h," & Lib_Version);
+
+ if Is_Absolute_Path (Lib_Version) then
+ MLib.Utl.Gcc
+ (Output_File => Lib_Version,
+ Objects => Ofiles,
+ Options => Common_Options & Version_Arg & Init_Fini.all,
+ Driver_Name => Driver_Name);
+ Symbolic_Link_Needed := Lib_Version /= Lib_File;
+
+ else
+ MLib.Utl.Gcc
+ (Output_File => Lib_Dir & Directory_Separator & Lib_Version,
+ Objects => Ofiles,
+ Options => Common_Options & Version_Arg & Init_Fini.all,
+ Driver_Name => Driver_Name);
+ Symbolic_Link_Needed :=
+ Lib_Dir & Directory_Separator & Lib_Version /= Lib_File;
+ end if;
+
+ if Symbolic_Link_Needed then
+ declare
+ Success : Boolean;
+ Oldpath : String (1 .. Lib_Version'Length + 1);
+ Newpath : String (1 .. Lib_File'Length + 1);
+ Result : Integer;
+
+ function Symlink
+ (Oldpath : System.Address;
+ Newpath : System.Address)
+ return Integer;
+ pragma Import (C, Symlink, "__gnat_symlink");
+
+ begin
+ Oldpath (1 .. Lib_Version'Length) := Lib_Version;
+ Oldpath (Oldpath'Last) := ASCII.NUL;
+ Newpath (1 .. Lib_File'Length) := Lib_File;
+ Newpath (Newpath'Last) := ASCII.NUL;
+
+ Delete_File (Lib_File, Success);
+
+ Result := Symlink (Oldpath'Address, Newpath'Address);
+ end;
+ end if;
+ end if;
+ end Build_Dynamic_Library;
+
+ -------------------------
+ -- Default_DLL_Address --
+ -------------------------
+
+ function Default_DLL_Address return String is
+ begin
+ return "";
+ end Default_DLL_Address;
+
+ -------------
+ -- DLL_Ext --
+ -------------
+
+ function DLL_Ext return String is
+ begin
+ return "sl";
+ end DLL_Ext;
+
+ --------------------
+ -- Dynamic_Option --
+ --------------------
+
+ function Dynamic_Option return String is
+ begin
+ return "-shared";
+ end Dynamic_Option;
+
+ -------------------
+ -- Is_Object_Ext --
+ -------------------
+
+ function Is_Object_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".o";
+ end Is_Object_Ext;
+
+ --------------
+ -- Is_C_Ext --
+ --------------
+
+ function Is_C_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".c";
+ end Is_C_Ext;
+
+ --------------------
+ -- Is_Archive_Ext --
+ --------------------
+
+ function Is_Archive_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".a" or else Ext = ".so";
+ end Is_Archive_Ext;
+
+ -------------
+ -- Libgnat --
+ -------------
+
+ function Libgnat return String is
+ begin
+ return "libgnat.a";
+ end Libgnat;
+
+ ------------------------
+ -- Library_Exists_For --
+ ------------------------
+
+ function Library_Exists_For (Project : Project_Id) return Boolean is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
+ "for non library project");
+ return False;
+
+ else
+ declare
+ Lib_Dir : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Dir);
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ if Projects.Table (Project).Library_Kind = Static then
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+ end;
+ end if;
+ end Library_Exists_For;
+
+ ---------------------------
+ -- Library_File_Name_For --
+ ---------------------------
+
+ function Library_File_Name_For (Project : Project_Id) return Name_Id is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
+ "for non library project");
+ return No_Name;
+
+ else
+ declare
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "lib";
+
+ if Projects.Table (Project).Library_Kind = Static then
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+
+ return Name_Find;
+ end;
+ end if;
+ end Library_File_Name_For;
+
+ --------------------------------
+ -- Linker_Library_Path_Option --
+ --------------------------------
+
+ function Linker_Library_Path_Option return String_Access is
+ begin
+ return new String'("-Wl,+b,");
+ end Linker_Library_Path_Option;
+
+ ----------------
+ -- Object_Ext --
+ ----------------
+
+ function Object_Ext return String is
+ begin
+ return "o";
+ end Object_Ext;
+
+ ----------------
+ -- PIC_Option --
+ ----------------
+
+ function PIC_Option return String is
+ begin
+ return "-fPIC";
+ end PIC_Option;
+
+ -----------------------------------------------
+ -- Standalone_Library_Auto_Init_Is_Supported --
+ -----------------------------------------------
+
+ function Standalone_Library_Auto_Init_Is_Supported return Boolean is
+ begin
+ return True;
+ end Standalone_Library_Auto_Init_Is_Supported;
+
+ ---------------------------
+ -- Support_For_Libraries --
+ ---------------------------
+
+ function Support_For_Libraries return Library_Support is
+ begin
+ return Full;
+ end Support_For_Libraries;
+
+end MLib.Tgt;
diff --git a/gcc/ada/5hosinte.adb b/gcc/ada/5hosinte.adb
index 51a288ab531..dcd169ccf62 100644
--- a/gcc/ada/5hosinte.adb
+++ b/gcc/ada/5hosinte.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2001, Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -74,8 +74,8 @@ package body System.OS_Interface is
F := F + 1.0;
end if;
- return timespec' (tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
function To_Duration (TV : struct_timeval) return Duration is
@@ -98,8 +98,10 @@ package body System.OS_Interface is
F := F + 1.0;
end if;
- return struct_timeval' (tv_sec => S,
- tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
+ return
+ struct_timeval'
+ (tv_sec => S,
+ tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
---------------------------
@@ -128,6 +130,7 @@ package body System.OS_Interface is
-- DCE_THREADS does not have pthread_kill. Instead, we just ignore it.
function pthread_kill (thread : pthread_t; sig : Signal) return int is
+ pragma Unreferenced (thread, sig);
begin
return 0;
end pthread_kill;
@@ -539,6 +542,8 @@ package body System.OS_Interface is
end pthread_key_create;
function Get_Stack_Base (thread : pthread_t) return Address is
+ pragma Warnings (Off, thread);
+
begin
return Null_Address;
end Get_Stack_Base;
diff --git a/gcc/ada/5hosinte.ads b/gcc/ada/5hosinte.ads
index 117b2b4247e..1e51907f1af 100644
--- a/gcc/ada/5hosinte.ads
+++ b/gcc/ada/5hosinte.ads
@@ -6,7 +6,8 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2001, Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5hparame.ads b/gcc/ada/5hparame.ads
index ed5d8ac1a6e..8be952a18c2 100644
--- a/gcc/ada/5hparame.ads
+++ b/gcc/ada/5hparame.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -141,8 +141,8 @@ pragma Pure (Parameters);
---------------------
-- In the following sections, constant parameters are defined to
- -- allow some optimizations within the tasking run time based on
- -- restrictions on the tasking features.
+ -- allow some optimizations and fine tuning within the tasking run time
+ -- based on restrictions on the tasking features.
----------------------
-- Locking Strategy --
@@ -182,6 +182,14 @@ pragma Pure (Parameters);
-- point. A value of False for Dynamic_Priority_Support corresponds
-- to pragma Restrictions (No_Dynamic_Priorities);
+ ---------------------
+ -- Task Attributes --
+ ---------------------
+
+ Default_Attribute_Count : constant := 4;
+ -- Number of pre-allocated Address-sized task attributes stored in the
+ -- task control block.
+
--------------------
-- Runtime Traces --
--------------------
diff --git a/gcc/ada/5hsystem.ads b/gcc/ada/5hsystem.ads
index 8b72d167960..43e22cbaabc 100644
--- a/gcc/ada/5hsystem.ads
+++ b/gcc/ada/5hsystem.ads
@@ -118,24 +118,35 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := False;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := False;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := True;
Front_End_ZCX_Support : constant Boolean := False;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+
--------------------------
-- Underlying Priorities --
---------------------------
diff --git a/gcc/ada/5htaprop.adb b/gcc/ada/5htaprop.adb
index 0d6a3d2b19f..434806c426e 100644
--- a/gcc/ada/5htaprop.adb
+++ b/gcc/ada/5htaprop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
--- This is a HP-UX DCE threads version of this package
+-- This is a HP-UX DCE threads (HPUX 10) version of this package
-- This package contains all the GNULL primitives that interface directly
-- with the underlying OS.
@@ -100,14 +100,14 @@ package body System.Task_Primitives.Operations is
-- The followings are logically constants, but need to be initialized
-- at run time.
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_ID associated with a thread
-
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
@@ -117,16 +117,55 @@ package body System.Task_Primitives.Operations is
Time_Slice_Val : Integer;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
- Locking_Policy : Character;
- pragma Import (C, Locking_Policy, "__gl_locking_policy");
-
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
+ -- Note: the reason that Locking_Policy is not needed is that this
+ -- is not implemented for DCE threads. The HPUX 10 port is at this
+ -- stage considered dead, and no further work is planned on it.
+
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set.
- -- The followings are internal configuration constants needed.
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads).
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ procedure Initialize (Environment_Task : Task_ID);
+ pragma Inline (Initialize);
+ -- Initialize various data needed by this package.
+
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does the executing thread have a TCB?
+
+ procedure Set (Self_Id : Task_ID);
+ pragma Inline (Set);
+ -- Set the self id for the current task.
+
+ function Self return Task_ID;
+ pragma Inline (Self);
+ -- Return a pointer to the Ada Task Control Block of the calling task.
+
+ end Specific;
+
+ package body Specific is separate;
+ -- The body of this package is target specific.
+
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
+ -- Allocate and Initialize a new ATCB for the current Thread.
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_ID is separate;
-----------------------
-- Local Subprograms --
@@ -134,8 +173,6 @@ package body System.Task_Primitives.Operations is
procedure Abort_Handler (Sig : Signal);
- function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
-
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
-------------------
@@ -143,6 +180,8 @@ package body System.Task_Primitives.Operations is
-------------------
procedure Abort_Handler (Sig : Signal) is
+ pragma Unreferenced (Sig);
+
Self_Id : constant Task_ID := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
@@ -173,6 +212,7 @@ package body System.Task_Primitives.Operations is
-- ??? Check the comment above
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ pragma Unreferenced (T, On);
begin
null;
end Stack_Guard;
@@ -190,13 +230,7 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
- function Self return Task_ID is
- Result : System.Address;
- begin
- Result := pthread_getspecific (ATCB_Key);
- pragma Assert (Result /= System.Null_Address);
- return To_Task_ID (Result);
- end Self;
+ function Self return Task_ID renames Specific.Self;
---------------------
-- Initialize_Lock --
@@ -238,6 +272,8 @@ package body System.Task_Primitives.Operations is
end Initialize_Lock;
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ pragma Unreferenced (Level);
+
Attributes : aliased pthread_mutexattr_t;
Result : Interfaces.C.int;
@@ -285,6 +321,7 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Result : Interfaces.C.int;
+
begin
L.Owner_Priority := Get_Priority (Self);
@@ -302,6 +339,7 @@ package body System.Task_Primitives.Operations is
(L : access RTS_Lock; Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
+
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
@@ -311,6 +349,7 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (T : Task_ID) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
@@ -333,6 +372,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
+
begin
Result := pthread_mutex_unlock (L.L'Access);
pragma Assert (Result = 0);
@@ -349,6 +389,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (T : Task_ID) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
@@ -364,6 +405,8 @@ package body System.Task_Primitives.Operations is
(Self_ID : Task_ID;
Reason : System.Tasking.Task_States)
is
+ pragma Unreferenced (Reason);
+
Result : Interfaces.C.int;
begin
if Single_Lock then
@@ -390,6 +433,8 @@ package body System.Task_Primitives.Operations is
Timedout : out Boolean;
Yielded : out Boolean)
is
+ pragma Unreferenced (Reason);
+
Check_Time : constant Duration := Monotonic_Clock;
Abs_Time : Duration;
Request : aliased timespec;
@@ -426,7 +471,9 @@ package body System.Task_Primitives.Operations is
exit when Abs_Time <= Monotonic_Clock;
if Result = 0 or Result = EINTR then
- -- somebody may have called Wakeup for us
+
+ -- Somebody may have called Wakeup for us
+
Timedout := False;
exit;
end if;
@@ -538,7 +585,10 @@ package body System.Task_Primitives.Operations is
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+
Result : Interfaces.C.int;
+
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -550,6 +600,7 @@ package body System.Task_Primitives.Operations is
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
+
begin
if Do_Yield then
Result := sched_yield;
@@ -571,8 +622,8 @@ package body System.Task_Primitives.Operations is
-- scheduling.
procedure Set_Priority
- (T : Task_ID;
- Prio : System.Any_Priority;
+ (T : Task_ID;
+ Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
Result : Interfaces.C.int;
@@ -643,13 +694,9 @@ package body System.Task_Primitives.Operations is
----------------
procedure Enter_Task (Self_ID : Task_ID) is
- Result : Interfaces.C.int;
-
begin
Self_ID.Common.LL.Thread := pthread_self;
-
- Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
- pragma Assert (Result = 0);
+ Specific.Set (Self_ID);
Lock_RTS;
@@ -673,6 +720,25 @@ package body System.Task_Primitives.Operations is
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_ID is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (pthread_self);
+ end if;
+ end Register_Foreign_Thread;
+
--------------------
-- Initialize_TCB --
--------------------
@@ -798,6 +864,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_TCB (T : Task_ID) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
+ Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
@@ -816,6 +883,12 @@ package body System.Task_Primitives.Operations is
end if;
Free (Tmp);
+
+ if Is_Self then
+ Result := pthread_setspecific (ATCB_Key, System.Null_Address);
+ pragma Assert (Result = 0);
+ end if;
+
end Finalize_TCB;
---------------
@@ -824,7 +897,7 @@ package body System.Task_Primitives.Operations is
procedure Exit_Task is
begin
- pthread_exit (System.Null_Address);
+ Specific.Set (null);
end Exit_Task;
----------------
@@ -851,6 +924,7 @@ package body System.Task_Primitives.Operations is
-- (native).
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
begin
return True;
end Check_Exit;
@@ -860,6 +934,7 @@ package body System.Task_Primitives.Operations is
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
begin
return True;
end Check_No_Locks;
@@ -897,7 +972,12 @@ package body System.Task_Primitives.Operations is
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
+ pragma Unreferenced (T);
+ pragma Unreferenced (Thread_Self);
+
begin
return False;
end Suspend_Task;
@@ -908,7 +988,12 @@ package body System.Task_Primitives.Operations is
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
+ pragma Unreferenced (T);
+ pragma Unreferenced (Thread_Self);
+
begin
return False;
end Resume_Task;
@@ -923,50 +1008,56 @@ package body System.Task_Primitives.Operations is
Tmp_Set : aliased sigset_t;
Result : Interfaces.C.int;
- begin
+ function State (Int : System.Interrupt_Management.Interrupt_ID)
+ return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
+ begin
Environment_Task_ID := Environment_Task;
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-- Initialize the lock used to synchronize chain of all ATCBs.
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ Specific.Initialize (Environment_Task);
+
Enter_Task (Environment_Task);
-- Install the abort-signal handler
- act.sa_flags := 0;
- act.sa_handler := Abort_Handler'Address;
+ if State (System.Interrupt_Management.Abort_Task_Interrupt)
+ /= Default
+ then
+ act.sa_flags := 0;
+ act.sa_handler := Abort_Handler'Address;
- Result := sigemptyset (Tmp_Set'Access);
- pragma Assert (Result = 0);
- act.sa_mask := Tmp_Set;
+ Result := sigemptyset (Tmp_Set'Access);
+ pragma Assert (Result = 0);
+ act.sa_mask := Tmp_Set;
- Result :=
- sigaction (
- Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
+ Result :=
+ sigaction (
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
end Initialize;
- procedure do_nothing (arg : System.Address);
-
- procedure do_nothing (arg : System.Address) is
- begin
- null;
- end do_nothing;
+ -- NOTE: Unlike other pthread implementations, we do *not* mask all
+ -- signals here since we handle signals using the process-wide primitive
+ -- signal, rather than using sigthreadmask and sigwait. The reason of
+ -- this difference is that sigwait doesn't work when some critical
+ -- signals (SIGABRT, SIGPIPE) are masked.
-begin
- declare
- Result : Interfaces.C.int;
- begin
- -- NOTE: Unlike other pthread implementations, we do *not* mask all
- -- signals here since we handle signals using the process-wide primitive
- -- signal, rather than using sigthreadmask and sigwait. The reason of
- -- this difference is that sigwait doesn't work when some critical
- -- signals (SIGABRT, SIGPIPE) are masked.
-
- Result := pthread_key_create (ATCB_Key'Access, do_nothing'Access);
- pragma Assert (Result = 0);
- end;
end System.Task_Primitives.Operations;
diff --git a/gcc/ada/5htaspri.ads b/gcc/ada/5htaspri.ads
index ae5c014764c..4f422c24271 100644
--- a/gcc/ada/5htaspri.ads
+++ b/gcc/ada/5htaspri.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5htraceb.adb b/gcc/ada/5htraceb.adb
index 9a59aa612b3..67cb6d33eb4 100644
--- a/gcc/ada/5htraceb.adb
+++ b/gcc/ada/5htraceb.adb
@@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -290,7 +290,8 @@ package body System.Traceback is
Max_Len : Natural;
Len : out Natural;
Exclude_Min : System.Address := System.Null_Address;
- Exclude_Max : System.Address := System.Null_Address)
+ Exclude_Max : System.Address := System.Null_Address;
+ Skip_Frames : Natural := 1)
is
type Tracebacks_Array is array (1 .. Max_Len) of System.Address;
pragma Suppress_Initialization (Tracebacks_Array);
@@ -551,9 +552,8 @@ package body System.Traceback is
-- Start of processing for Call_Chain
begin
- -- Fetch the state for this subprogram's frame and pop it so that the
- -- backtrace starts at the right point for our caller, that is at its
- -- own frame.
+ -- Fetch the state for this subprogram's frame and pop it so that we
+ -- start with an initial out_rlo "here".
U_init_frame_record (Frame'Access);
Frame.top_sr0 := 0;
@@ -563,6 +563,12 @@ package body System.Traceback is
Pop_Success := Pop_Frame (Frame'Access);
+ -- Skip the requested number of frames.
+
+ for I in 1 .. Skip_Frames loop
+ Pop_Success := Pop_Frame (Frame'Access);
+ end loop;
+
-- Loop popping frames and storing locations until either a problem
-- occurs, or the top of the call chain is reached, or the provided
-- array is full.
diff --git a/gcc/ada/5iosinte.adb b/gcc/ada/5iosinte.adb
index fd3371887c0..36c082c86aa 100644
--- a/gcc/ada/5iosinte.adb
+++ b/gcc/ada/5iosinte.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2002 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5isystem.ads b/gcc/ada/5isystem.ads
new file mode 100644
index 00000000000..b418fd2e834
--- /dev/null
+++ b/gcc/ada/5isystem.ads
@@ -0,0 +1,166 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (VxWorks/LEVEL B Version PPC) --
+-- --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Level B certifiable VxWorks version
+
+pragma Restrictions (No_Finalization);
+pragma Restrictions (No_Exception_Registration);
+pragma Restrictions (No_Abort_Statements);
+
+pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 1.0 / 60.0;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 32;
+ Memory_Size : constant := 2 ** 32;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := High_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ -- 256 is reserved for the VxWorks kernel
+ -- 248 - 255 correspond to hardware interrupt levels 0 .. 7
+ -- 247 is a catchall default "interrupt" priority for signals,
+ -- allowing higher priority than normal tasks, but lower than
+ -- hardware priority levels. Protected Object ceilings can
+ -- override these values.
+ -- 246 is used by the Interrupt_Manager task
+
+ Max_Priority : constant Positive := 245;
+ Max_Interrupt_Priority : constant Positive := 255;
+
+ subtype Any_Priority is Integer range 0 .. 255;
+ subtype Priority is Any_Priority range 0 .. 245;
+ subtype Interrupt_Priority is Any_Priority range 246 .. 255;
+
+ Default_Priority : constant Priority := 122;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := False;
+ Configurable_Run_Time : constant Boolean := True;
+ Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := True;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := True;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := True;
+ Long_Shifts_Inlined : constant Boolean := False;
+
+end System;
diff --git a/gcc/ada/5itaprop.adb b/gcc/ada/5itaprop.adb
index 13d5361a905..2f086408561 100644
--- a/gcc/ada/5itaprop.adb
+++ b/gcc/ada/5itaprop.adb
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -101,11 +101,6 @@ package body System.Task_Primitives.Operations is
-- Local Data --
------------------
- Max_Stack_Size : constant := 2000 * 1024;
- -- GNU/LinuxThreads does not return an error value when requesting
- -- a task stack size which is too large, so we have to check this
- -- ourselves.
-
-- The followings are logically constants, but need to be initialized
-- at run time.
@@ -114,6 +109,9 @@ package body System.Task_Primitives.Operations is
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
@@ -143,44 +141,8 @@ package body System.Task_Primitives.Operations is
Mutex_Attr : aliased pthread_mutexattr_t;
Cond_Attr : aliased pthread_condattr_t;
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
-
- procedure Abort_Handler
- (signo : Signal;
- gs : unsigned_short;
- fs : unsigned_short;
- es : unsigned_short;
- ds : unsigned_short;
- edi : unsigned_long;
- esi : unsigned_long;
- ebp : unsigned_long;
- esp : unsigned_long;
- ebx : unsigned_long;
- edx : unsigned_long;
- ecx : unsigned_long;
- eax : unsigned_long;
- trapno : unsigned_long;
- err : unsigned_long;
- eip : unsigned_long;
- cs : unsigned_short;
- eflags : unsigned_long;
- esp_at_signal : unsigned_long;
- ss : unsigned_short;
- fpstate : System.Address;
- oldmask : unsigned_long;
- cr2 : unsigned_long);
-
- function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
-
- function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
-
- function To_pthread_t is new Unchecked_Conversion
- (Integer, System.OS_Interface.pthread_t);
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads).
--------------------
-- Local Packages --
@@ -192,6 +154,10 @@ package body System.Task_Primitives.Operations is
pragma Inline (Initialize);
-- Initialize various data needed by this package.
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does executing thread have a TCB?
+
procedure Set (Self_Id : Task_ID);
pragma Inline (Set);
-- Set the self id for the current task.
@@ -205,92 +171,45 @@ package body System.Task_Primitives.Operations is
package body Specific is separate;
-- The body of this package is target specific.
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
+ -- Allocate and Initialize a new ATCB for the current Thread.
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_ID is separate;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ subtype unsigned_long is Interfaces.C.unsigned_long;
+
+ procedure Abort_Handler (signo : Signal);
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
+ function To_pthread_t is new Unchecked_Conversion
+ (unsigned_long, System.OS_Interface.pthread_t);
+
-------------------
-- Abort_Handler --
-------------------
- -- Target-dependent binding of inter-thread Abort signal to
- -- the raising of the Abort_Signal exception.
-
- -- The technical issues and alternatives here are essentially
- -- the same as for raising exceptions in response to other
- -- signals (e.g. Storage_Error). See code and comments in
- -- the package body System.Interrupt_Management.
-
- -- Some implementations may not allow an exception to be propagated
- -- out of a handler, and others might leave the signal or
- -- interrupt that invoked this handler masked after the exceptional
- -- return to the application code.
-
- -- GNAT exceptions are originally implemented using setjmp()/longjmp().
- -- On most UNIX systems, this will allow transfer out of a signal handler,
- -- which is usually the only mechanism available for implementing
- -- asynchronous handlers of this kind. However, some
- -- systems do not restore the signal mask on longjmp(), leaving the
- -- abort signal masked.
-
- -- Alternative solutions include:
-
- -- 1. Change the PC saved in the system-dependent Context
- -- parameter to point to code that raises the exception.
- -- Normal return from this handler will then raise
- -- the exception after the mask and other system state has
- -- been restored (see example below).
- -- 2. Use siglongjmp()/sigsetjmp() to implement exceptions.
- -- 3. Unmask the signal in the Abortion_Signal exception handler
- -- (in the RTS).
-
- -- Note that with the new exception mechanism, it is not correct to
- -- simply "raise" an exception from a signal handler, that's why we
- -- use Raise_From_Signal_Handler
-
- procedure Abort_Handler
- (signo : Signal;
- gs : unsigned_short;
- fs : unsigned_short;
- es : unsigned_short;
- ds : unsigned_short;
- edi : unsigned_long;
- esi : unsigned_long;
- ebp : unsigned_long;
- esp : unsigned_long;
- ebx : unsigned_long;
- edx : unsigned_long;
- ecx : unsigned_long;
- eax : unsigned_long;
- trapno : unsigned_long;
- err : unsigned_long;
- eip : unsigned_long;
- cs : unsigned_short;
- eflags : unsigned_long;
- esp_at_signal : unsigned_long;
- ss : unsigned_short;
- fpstate : System.Address;
- oldmask : unsigned_long;
- cr2 : unsigned_long)
- is
+ procedure Abort_Handler (signo : Signal) is
+ pragma Unreferenced (signo);
+
Self_Id : Task_ID := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
- function To_Machine_State_Ptr is new
- Unchecked_Conversion (Address, Machine_State_Ptr);
-
- -- These are not directly visible
-
- procedure Raise_From_Signal_Handler
- (E : Ada.Exceptions.Exception_Id;
- M : System.Address);
- pragma Import
- (Ada, Raise_From_Signal_Handler,
- "ada__exceptions__raise_from_signal_handler");
- pragma No_Return (Raise_From_Signal_Handler);
-
- mstate : Machine_State_Ptr;
- message : aliased constant String := "" & ASCII.Nul;
- -- a null terminated String.
-
begin
+ if ZCX_By_Default and then GCC_ZCX_Support then
+ return;
+ end if;
+
if Self_Id.Deferral_Level = 0
and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level
and then not Self_Id.Aborting
@@ -303,16 +222,7 @@ package body System.Task_Primitives.Operations is
Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access);
pragma Assert (Result = 0);
- mstate := To_Machine_State_Ptr (SSL.Get_Machine_State_Addr.all);
- mstate.eip := eip;
- mstate.ebx := ebx;
- mstate.esp := esp_at_signal;
- mstate.ebp := ebp;
- mstate.esi := esi;
- mstate.edi := edi;
-
- Raise_From_Signal_Handler
- (Standard'Abort_Signal'Identity, message'Address);
+ raise Standard'Abort_Signal;
end if;
end Abort_Handler;
@@ -760,6 +670,7 @@ package body System.Task_Primitives.Operations is
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
+ pragma Unreferenced (Result);
begin
if Do_Yield then
@@ -852,6 +763,25 @@ package body System.Task_Primitives.Operations is
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_ID is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (pthread_self);
+ end if;
+ end Register_Foreign_Thread;
+
--------------------
-- Initialize_TCB --
--------------------
@@ -906,6 +836,8 @@ package body System.Task_Primitives.Operations is
Priority : System.Any_Priority;
Succeeded : out Boolean)
is
+ Adjusted_Stack_Size : Interfaces.C.size_t;
+
Attributes : aliased pthread_attr_t;
Result : Interfaces.C.int;
@@ -913,16 +845,32 @@ package body System.Task_Primitives.Operations is
Unchecked_Conversion (System.Address, Thread_Body);
begin
+ if Stack_Size = Unspecified_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size);
+
+ elsif Stack_Size < Minimum_Stack_Size then
+ Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size);
+
+ else
+ Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size);
+ end if;
+
Result := pthread_attr_init (Attributes'Access);
pragma Assert (Result = 0 or else Result = ENOMEM);
- if Result /= 0 or else Stack_Size > Max_Stack_Size then
+ if Result /= 0 then
Succeeded := False;
return;
end if;
- Result := pthread_attr_setdetachstate
- (Attributes'Access, PTHREAD_CREATE_DETACHED);
+ Result :=
+ pthread_attr_setstacksize
+ (Attributes'Access, Adjusted_Stack_Size);
+ pragma Assert (Result = 0);
+
+ Result :=
+ pthread_attr_setdetachstate
+ (Attributes'Access, PTHREAD_CREATE_DETACHED);
pragma Assert (Result = 0);
-- Since the initial signal mask of a thread is inherited from the
@@ -952,6 +900,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_TCB (T : Task_ID) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
+ Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
@@ -970,6 +919,12 @@ package body System.Task_Primitives.Operations is
end if;
Free (Tmp);
+
+ if Is_Self then
+ Result := pthread_setspecific (ATCB_Key, System.Null_Address);
+ pragma Assert (Result = 0);
+ end if;
+
end Finalize_TCB;
---------------
@@ -978,7 +933,7 @@ package body System.Task_Primitives.Operations is
procedure Exit_Task is
begin
- pthread_exit (System.Null_Address);
+ Specific.Set (null);
end Exit_Task;
----------------
@@ -1066,10 +1021,24 @@ package body System.Task_Primitives.Operations is
----------------
procedure Initialize (Environment_Task : Task_ID) is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Tmp_Set : aliased sigset_t;
- Result : Interfaces.C.int;
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ function State (Int : System.Interrupt_Management.Interrupt_ID)
+ return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
begin
Environment_Task_ID := Environment_Task;
@@ -1090,19 +1059,23 @@ package body System.Task_Primitives.Operations is
-- Install the abort-signal handler
- act.sa_flags := 0;
- act.sa_handler := Abort_Handler'Address;
+ if State (System.Interrupt_Management.Abort_Task_Interrupt)
+ /= Default
+ then
+ act.sa_flags := 0;
+ act.sa_handler := Abort_Handler'Address;
- Result := sigemptyset (Tmp_Set'Access);
- pragma Assert (Result = 0);
- act.sa_mask := Tmp_Set;
+ Result := sigemptyset (Tmp_Set'Access);
+ pragma Assert (Result = 0);
+ act.sa_mask := Tmp_Set;
- Result :=
- sigaction
- (Signal (Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
+ Result :=
+ sigaction
+ (Signal (Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
end Initialize;
begin
diff --git a/gcc/ada/5itaspri.ads b/gcc/ada/5itaspri.ads
index c26def9fb42..078ef3e0e8a 100644
--- a/gcc/ada/5itaspri.ads
+++ b/gcc/ada/5itaspri.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5ksystem.ads b/gcc/ada/5ksystem.ads
index afef59ee014..3e1e3cf9895 100644
--- a/gcc/ada/5ksystem.ads
+++ b/gcc/ada/5ksystem.ads
@@ -126,22 +126,33 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := False;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := False;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := False;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := True;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+
end System;
diff --git a/gcc/ada/5kvxwork.ads b/gcc/ada/5kvxwork.ads
index 47a4e4bb5ef..a0f10be72a0 100644
--- a/gcc/ada/5kvxwork.ads
+++ b/gcc/ada/5kvxwork.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5lintman.adb b/gcc/ada/5lintman.adb
index 4db8c763c9f..56871f3d9ec 100644
--- a/gcc/ada/5lintman.adb
+++ b/gcc/ada/5lintman.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2002 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -133,6 +133,9 @@ package body System.Interrupt_Management is
-- Notify_Exception --
----------------------
+ pragma Warnings (Off);
+ -- Because many unaccessed arguments
+
Signal_Mask : aliased sigset_t;
-- The set of signals handled by Notify_Exception
@@ -191,6 +194,7 @@ package body System.Interrupt_Management is
oldmask : unsigned_long;
cr2 : unsigned_long)
is
+ pragma Warnings (On);
function To_Machine_State_Ptr is new
Unchecked_Conversion (Address, Machine_State_Ptr);
@@ -207,7 +211,7 @@ package body System.Interrupt_Management is
mstate : Machine_State_Ptr;
message : aliased constant String := "" & ASCII.Nul;
- -- a null terminated String.
+ -- A null terminated String.
Result : int;
@@ -218,7 +222,7 @@ package body System.Interrupt_Management is
-- ??? The original signal mask (the one we had before coming into this
-- signal catching function) should be restored by
- -- Raise_From_Signal_Handler. For now, restore it explicitly
+ -- Raise_From_Signal_Handler. For now, restore it explicitely
Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
pragma Assert (Result = 0);
@@ -269,8 +273,22 @@ begin
old_act : aliased struct_sigaction;
Result : int;
- begin
+ function State (Int : Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ User : constant Character := 'u';
+ Runtime : constant Character := 'r';
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+ begin
-- Need to call pthread_init very early because it is doing signal
-- initializations.
@@ -281,64 +299,103 @@ begin
act.sa_handler := Notify_Exception'Address;
act.sa_flags := 0;
+
-- On some targets, we set sa_flags to SA_NODEFER so that during the
-- handler execution we do not change the Signal_Mask to be masked for
-- the Signal.
+
-- This is a temporary fix to the problem that the Signal_Mask is
-- not restored after the exception (longjmp) from the handler.
-- The right fix should be made in sigsetjmp so that we save
-- the Signal_Set and restore it after a longjmp.
- -- Since SA_NODEFER is obsolete, instead we reset explicitly
+
+ -- Since SA_NODEFER is obsolete, instead we reset explicitely
-- the mask in the exception handler.
Result := sigemptyset (Signal_Mask'Access);
pragma Assert (Result = 0);
+ -- Add signals that map to Ada exceptions to the mask.
+
for J in Exception_Interrupts'Range loop
- Result :=
- sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
- pragma Assert (Result = 0);
+ if State (Exception_Interrupts (J)) /= Default then
+ Result :=
+ sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
+ pragma Assert (Result = 0);
+ end if;
end loop;
act.sa_mask := Signal_Mask;
+ pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
+
+ -- Process state of exception signals
+
for J in Exception_Interrupts'Range loop
- Keep_Unmasked (Exception_Interrupts (J)) := True;
- Result :=
- sigaction
- (Signal (Exception_Interrupts (J)),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
+ if State (Exception_Interrupts (J)) /= User then
+ Keep_Unmasked (Exception_Interrupts (J)) := True;
+ Reserve (Exception_Interrupts (J)) := True;
+
+ if State (Exception_Interrupts (J)) /= Default then
+ Result :=
+ sigaction
+ (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
end loop;
- Keep_Unmasked (Abort_Task_Interrupt) := True;
+ if State (Abort_Task_Interrupt) /= User then
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+ Reserve (Abort_Task_Interrupt) := True;
+ end if;
- -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the
- -- same time, disable the ability of handling this signal
- -- via Ada.Interrupts.
- -- The pragma Unreserve_All_Interrupts allows the user to
- -- change this behavior.
+ -- Set SIGINT to unmasked state as long as it's
+ -- not in "User" state. Check for Unreserve_All_Interrupts last
- if Unreserve_All_Interrupts = 0 then
+ if State (SIGINT) /= User then
Keep_Unmasked (SIGINT) := True;
+ Reserve (SIGINT) := True;
end if;
+ -- Check all signals for state that requires keeping them
+ -- unmasked and reserved
+
+ for J in Interrupt_ID'Range loop
+ if State (J) = Default or else State (J) = Runtime then
+ Keep_Unmasked (J) := True;
+ Reserve (J) := True;
+ end if;
+ end loop;
+
+ -- Add the set of signals that must always be unmasked for this target
+
for J in Unmasked'Range loop
Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
+ Reserve (Interrupt_ID (Unmasked (J))) := True;
end loop;
- Reserve := Keep_Unmasked or Keep_Masked;
+ -- Add target-specific reserved signals
for J in Reserved'Range loop
Reserve (Interrupt_ID (Reserved (J))) := True;
end loop;
- Reserve (0) := True;
+ -- Process pragma Unreserve_All_Interrupts. This overrides any
+ -- settings due to pragma Interrupt_State:
+
+ if Unreserve_All_Interrupts /= 0 then
+ Keep_Unmasked (SIGINT) := False;
+ Reserve (SIGINT) := False;
+ end if;
+
-- We do not have Signal 0 in reality. We just use this value
-- to identify non-existent signals (see s-intnam.ads). Therefore,
-- Signal 0 should not be used in all signal related operations hence
-- mark it as reserved.
+ Reserve (0) := True;
end;
end System.Interrupt_Management;
diff --git a/gcc/ada/5lml-tgt.adb b/gcc/ada/5lml-tgt.adb
index f884381d5ef..ad40c10b0df 100644
--- a/gcc/ada/5lml-tgt.adb
+++ b/gcc/ada/5lml-tgt.adb
@@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001, Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-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- --
@@ -21,7 +21,7 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -30,14 +30,12 @@
-- This is the GNU/Linux version of the body.
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with MLib.Fil;
with MLib.Utl;
-with Namet; use Namet;
+with Namet; use Namet;
with Opt;
-with Osint; use Osint;
-with Output; use Output;
+with Output; use Output;
+with Prj.Com;
with System;
package body MLib.Tgt is
@@ -45,40 +43,38 @@ package body MLib.Tgt is
use GNAT;
use MLib;
- -- ??? serious lack of comments below, all these declarations need to
- -- be commented, none are:
+ No_Arguments : aliased Argument_List := (1 .. 0 => null);
+ Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access;
- package Files renames MLib.Fil;
- package Tools renames MLib.Utl;
+ Wl_Init_String : aliased String := "-Wl,-init";
+ Wl_Init : constant String_Access := Wl_Init_String'Access;
+ Wl_Fini_String : aliased String := "-Wl,-fini";
+ Wl_Fini : constant String_Access := Wl_Fini_String'Access;
- Args : Argument_List_Access := new Argument_List (1 .. 20);
- Last_Arg : Natural := 0;
+ Init_Fini_List : constant Argument_List_Access :=
+ new Argument_List'(1 => Wl_Init,
+ 2 => null,
+ 3 => Wl_Fini,
+ 4 => null);
+ -- Used to put switches for automatic elaboration/finalization
- Cp : constant String_Access := Locate_Exec_On_Path ("cp");
- Force : constant String_Access := new String'("-f");
+ ---------------------
+ -- Archive_Builder --
+ ---------------------
- procedure Add_Arg (Arg : String);
-
- -------------
- -- Add_Arg --
- -------------
-
- procedure Add_Arg (Arg : String) is
+ function Archive_Builder return String is
begin
- if Last_Arg = Args'Last then
- declare
- New_Args : constant Argument_List_Access :=
- new Argument_List (1 .. Args'Last * 2);
+ return "ar";
+ end Archive_Builder;
- begin
- New_Args (Args'Range) := Args.all;
- Args := New_Args;
- end;
- end if;
+ -----------------------------
+ -- Archive_Builder_Options --
+ -----------------------------
- Last_Arg := Last_Arg + 1;
- Args (Last_Arg) := new String'(Arg);
- end Add_Arg;
+ function Archive_Builder_Options return String_List_Access is
+ begin
+ return new String_List'(1 => new String'("cr"));
+ end Archive_Builder_Options;
-----------------
-- Archive_Ext --
@@ -86,17 +82,17 @@ package body MLib.Tgt is
function Archive_Ext return String is
begin
- return "a";
+ return "a";
end Archive_Ext;
- -----------------
- -- Base_Option --
- -----------------
+ ---------------------
+ -- Archive_Indexer --
+ ---------------------
- function Base_Option return String is
+ function Archive_Indexer return String is
begin
- return "";
- end Base_Option;
+ return "ranlib";
+ end Archive_Indexer;
---------------------------
-- Build_Dynamic_Library --
@@ -107,50 +103,67 @@ package body MLib.Tgt is
Foreign : Argument_List;
Afiles : Argument_List;
Options : Argument_List;
+ Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
- Relocatable : Boolean := False)
+ Relocatable : Boolean := False;
+ Auto_Init : Boolean := False)
is
+ pragma Unreferenced (Foreign);
+ pragma Unreferenced (Afiles);
+ pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Lib_Address);
+ pragma Unreferenced (Relocatable);
+
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
- Files.Ext_To (Lib_Filename, DLL_Ext);
-
- use type Argument_List;
- use type String_Access;
-
- Version_Arg : String_Access;
+ Fil.Ext_To (Lib_Filename, DLL_Ext);
+ Version_Arg : String_Access;
Symbolic_Link_Needed : Boolean := False;
+ Init_Fini : Argument_List_Access := Empty_Argument_List;
+
begin
if Opt.Verbose_Mode then
Write_Str ("building relocatable shared library ");
Write_Line (Lib_File);
end if;
+ -- If specified, add automatic elaboration/finalization
+ if Auto_Init then
+ Init_Fini := Init_Fini_List;
+ Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init");
+ Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final");
+ end if;
+
if Lib_Version = "" then
- Tools.Gcc
+ Utl.Gcc
(Output_File => Lib_File,
Objects => Ofiles,
- Options => Options);
+ Options => Options & Init_Fini.all,
+ Driver_Name => Driver_Name);
else
Version_Arg := new String'("-Wl,-soname," & Lib_Version);
if Is_Absolute_Path (Lib_Version) then
- Tools.Gcc
+ Utl.Gcc
(Output_File => Lib_Version,
Objects => Ofiles,
- Options => Options & Version_Arg);
+ Options => Options & Version_Arg & Init_Fini.all,
+ Driver_Name => Driver_Name);
Symbolic_Link_Needed := Lib_Version /= Lib_File;
else
- Tools.Gcc
+ Utl.Gcc
(Output_File => Lib_Dir & Directory_Separator & Lib_Version,
Objects => Ofiles,
- Options => Options & Version_Arg);
+ Options => Options & Version_Arg & Init_Fini.all,
+ Driver_Name => Driver_Name);
Symbolic_Link_Needed :=
Lib_Dir & Directory_Separator & Lib_Version /= Lib_File;
end if;
@@ -182,60 +195,6 @@ package body MLib.Tgt is
end if;
end Build_Dynamic_Library;
- --------------------
- -- Copy_ALI_Files --
- --------------------
-
- procedure Copy_ALI_Files
- (From : Name_Id;
- To : Name_Id)
- is
- Dir : Dir_Type;
- Name : String (1 .. 1_000);
- Last : Natural;
- Success : Boolean;
- From_Dir : constant String := Get_Name_String (From);
- To_Dir : constant String_Access :=
- new String'(Get_Name_String (To));
-
- begin
- Last_Arg := 0;
- Open (Dir, From_Dir);
-
- loop
- Read (Dir, Name, Last);
- exit when Last = 0;
- if Last > 4
-
- and then
- To_Lower (Name (Last - 3 .. Last)) = ".ali"
- then
- Add_Arg (From_Dir & Directory_Separator & Name (1 .. Last));
- end if;
- end loop;
-
- if Last_Arg /= 0 then
- if not Opt.Quiet_Output then
- Write_Str ("cp -f ");
-
- for J in 1 .. Last_Arg loop
- Write_Str (Args (J).all);
- Write_Char (' ');
- end loop;
-
- Write_Line (To_Dir.all);
- end if;
-
- Spawn (Cp.all,
- Force & Args (1 .. Last_Arg) & To_Dir,
- Success);
-
- if not Success then
- Fail ("could not copy ALI files to library dir");
- end if;
- end if;
- end Copy_ALI_Files;
-
-------------------------
-- Default_DLL_Address --
-------------------------
@@ -260,7 +219,7 @@ package body MLib.Tgt is
function Dynamic_Option return String is
begin
- return "-shared";
+ return "-shared";
end Dynamic_Option;
-------------------
@@ -299,25 +258,78 @@ package body MLib.Tgt is
return "libgnat.a";
end Libgnat;
- -----------------------------
- -- Libraries_Are_Supported --
- -----------------------------
+ ------------------------
+ -- Library_Exists_For --
+ ------------------------
- function Libraries_Are_Supported return Boolean is
+ function Library_Exists_For (Project : Project_Id) return Boolean is
begin
- return True;
- end Libraries_Are_Supported;
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
+ "for non library project");
+ return False;
+
+ else
+ declare
+ Lib_Dir : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Dir);
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ if Projects.Table (Project).Library_Kind = Static then
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+ end;
+ end if;
+ end Library_Exists_For;
+
+ ---------------------------
+ -- Library_File_Name_For --
+ ---------------------------
+
+ function Library_File_Name_For (Project : Project_Id) return Name_Id is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
+ "for non library project");
+ return No_Name;
+
+ else
+ declare
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "lib";
+
+ if Projects.Table (Project).Library_Kind = Static then
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+
+ return Name_Find;
+ end;
+ end if;
+ end Library_File_Name_For;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
- function Linker_Library_Path_Option
- (Directory : String)
- return String_Access
- is
+ function Linker_Library_Path_Option return String_Access is
begin
- return new String'("-Wl,-rpath," & Directory);
+ return new String'("-Wl,-rpath,");
end Linker_Library_Path_Option;
----------------
@@ -326,7 +338,7 @@ package body MLib.Tgt is
function Object_Ext return String is
begin
- return "o";
+ return "o";
end Object_Ext;
----------------
@@ -335,7 +347,25 @@ package body MLib.Tgt is
function PIC_Option return String is
begin
- return "-fPIC";
+ return "-fPIC";
end PIC_Option;
+ -----------------------------------------------
+ -- Standalone_Library_Auto_Init_Is_Supported --
+ -----------------------------------------------
+
+ function Standalone_Library_Auto_Init_Is_Supported return Boolean is
+ begin
+ return True;
+ end Standalone_Library_Auto_Init_Is_Supported;
+
+ ---------------------------
+ -- Support_For_Libraries --
+ ---------------------------
+
+ function Support_For_Libraries return Library_Support is
+ begin
+ return Full;
+ end Support_For_Libraries;
+
end MLib.Tgt;
diff --git a/gcc/ada/5losinte.ads b/gcc/ada/5losinte.ads
index 2de2e91617d..498fa62574e 100644
--- a/gcc/ada/5losinte.ads
+++ b/gcc/ada/5losinte.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5lparame.adb b/gcc/ada/5lparame.adb
new file mode 100644
index 00000000000..9b17c158733
--- /dev/null
+++ b/gcc/ada/5lparame.adb
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1995-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Linux (native) specific version
+
+package body System.Parameters is
+
+ -------------------------
+ -- Adjust_Storage_Size --
+ -------------------------
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type is
+ begin
+ if Size = Unspecified_Size then
+ return Default_Stack_Size;
+
+ elsif Size < Minimum_Stack_Size then
+ return Minimum_Stack_Size;
+
+ else
+ return Size;
+ end if;
+ end Adjust_Storage_Size;
+
+ ------------------------
+ -- Default_Stack_Size --
+ ------------------------
+
+ function Default_Stack_Size return Size_Type is
+ begin
+ return 2 * 1024 * 1024;
+ end Default_Stack_Size;
+
+ ------------------------
+ -- Minimum_Stack_Size --
+ ------------------------
+
+ function Minimum_Stack_Size return Size_Type is
+ begin
+ return 8 * 1024;
+ end Minimum_Stack_Size;
+
+end System.Parameters;
diff --git a/gcc/ada/5lsystem.ads b/gcc/ada/5lsystem.ads
index c39e7c61d93..8bcf7808221 100644
--- a/gcc/ada/5lsystem.ads
+++ b/gcc/ada/5lsystem.ads
@@ -58,7 +58,7 @@ pragma Pure (System);
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
- Tick : constant := 0.01;
+ Tick : constant := 0.000_001;
-- Storage-related Declarations
@@ -118,22 +118,33 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := True;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
- ZCX_By_Default : constant Boolean := False;
- GCC_ZCX_Support : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := True;
+ GCC_ZCX_Support : constant Boolean := True;
Front_End_ZCX_Support : constant Boolean := False;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
end System;
diff --git a/gcc/ada/5msystem.ads b/gcc/ada/5msystem.ads
new file mode 100644
index 00000000000..19c96d0d6ea
--- /dev/null
+++ b/gcc/ada/5msystem.ads
@@ -0,0 +1,158 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (VxWorks Version Mips) --
+-- --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 1.0 / 60.0;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 32;
+ Memory_Size : constant := 2 ** 32;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := High_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ -- 256 is reserved for the VxWorks kernel
+ -- 248 - 255 correspond to hardware interrupt levels 0 .. 7
+ -- 247 is a catchall default "interrupt" priority for signals,
+ -- allowing higher priority than normal tasks, but lower than
+ -- hardware priority levels. Protected Object ceilings can
+ -- override these values.
+ -- 246 is used by the Interrupt_Manager task
+
+ Max_Priority : constant Positive := 245;
+ Max_Interrupt_Priority : constant Positive := 255;
+
+ subtype Any_Priority is Integer range 0 .. 255;
+ subtype Priority is Any_Priority range 0 .. 245;
+ subtype Interrupt_Priority is Any_Priority range 246 .. 255;
+
+ Default_Priority : constant Priority := 122;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := False;
+ Configurable_Run_Time : constant Boolean := False;
+ Denorm : constant Boolean := False;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := True;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+
+end System;
diff --git a/gcc/ada/5mvxwork.ads b/gcc/ada/5mvxwork.ads
index 468d6505440..2e31d728aed 100644
--- a/gcc/ada/5mvxwork.ads
+++ b/gcc/ada/5mvxwork.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5ninmaop.adb b/gcc/ada/5ninmaop.adb
index c977fec01a2..f99a104f671 100644
--- a/gcc/ada/5ninmaop.adb
+++ b/gcc/ada/5ninmaop.adb
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5nintman.adb b/gcc/ada/5nintman.adb
index a335add09a6..9ef33ab5a15 100644
--- a/gcc/ada/5nintman.adb
+++ b/gcc/ada/5nintman.adb
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5nosinte.ads b/gcc/ada/5nosinte.ads
index d85b13770b7..20b4d9de1fc 100644
--- a/gcc/ada/5nosinte.ads
+++ b/gcc/ada/5nosinte.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5ntaprop.adb b/gcc/ada/5ntaprop.adb
index 0562c9c7640..365b0d911d3 100644
--- a/gcc/ada/5ntaprop.adb
+++ b/gcc/ada/5ntaprop.adb
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -266,6 +266,24 @@ package body System.Task_Primitives.Operations is
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return False;
+ end Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_ID is
+ begin
+ return null;
+ end Register_Foreign_Thread;
+
----------------------
-- Initialize_TCB --
----------------------
diff --git a/gcc/ada/5ntaspri.ads b/gcc/ada/5ntaspri.ads
index 78b51236471..6e6025c589d 100644
--- a/gcc/ada/5ntaspri.ads
+++ b/gcc/ada/5ntaspri.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5ointerr.adb b/gcc/ada/5ointerr.adb
index 4d46c8ef63d..7dbe33f26a7 100644
--- a/gcc/ada/5ointerr.adb
+++ b/gcc/ada/5ointerr.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2002 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5omastop.adb b/gcc/ada/5omastop.adb
index 7fa6fb6560b..aa704d3a187 100644
--- a/gcc/ada/5omastop.adb
+++ b/gcc/ada/5omastop.adb
@@ -463,7 +463,7 @@ package body System.Machine_State_Operations is
return To_Address (MS.eip);
else
-- When doing a call the return address is pushed to the stack.
- -- We want to return the call point address, so we subtract
+ -- We want to return the call point address, so we substract
-- Asm_Call_Size from the return address. This value is set
-- to 5 as an asm call takes 5 bytes on x86 architectures.
diff --git a/gcc/ada/5oosinte.adb b/gcc/ada/5oosinte.adb
index 538b3fa95fe..e2a241118d5 100644
--- a/gcc/ada/5oosinte.adb
+++ b/gcc/ada/5oosinte.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2002 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5oosinte.ads b/gcc/ada/5oosinte.ads
index b2b4b2987eb..450a6064bfa 100644
--- a/gcc/ada/5oosinte.ads
+++ b/gcc/ada/5oosinte.ads
@@ -6,7 +6,8 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2001 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5oosprim.adb b/gcc/ada/5oosprim.adb
index b56c35ded94..42e414cde44 100644
--- a/gcc/ada/5oosprim.adb
+++ b/gcc/ada/5oosprim.adb
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5oparame.adb b/gcc/ada/5oparame.adb
index 697c5959f82..1ae7463618b 100644
--- a/gcc/ada/5oparame.adb
+++ b/gcc/ada/5oparame.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/5osystem.ads b/gcc/ada/5osystem.ads
index 404da6601f1..17acb5bc21e 100644
--- a/gcc/ada/5osystem.ads
+++ b/gcc/ada/5osystem.ads
@@ -118,22 +118,33 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := True;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := True;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
end System;
diff --git a/gcc/ada/5otaprop.adb b/gcc/ada/5otaprop.adb
index 297a48cc6fc..924f477bb67 100644
--- a/gcc/ada/5otaprop.adb
+++ b/gcc/ada/5otaprop.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. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -200,8 +200,8 @@ package body System.Task_Primitives.Operations is
-- ??? Check the comment above
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
- pragma Warnings (Off, T);
- pragma Warnings (Off, On);
+ pragma Unreferenced (T);
+ pragma Unreferenced (On);
begin
null;
@@ -253,7 +253,7 @@ package body System.Task_Primitives.Operations is
end Initialize_Lock;
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
- pragma Warnings (Off, Level);
+ pragma Unreferenced (Level);
begin
if DosCreateMutexSem
@@ -289,7 +289,7 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID;
Old_Priority : constant Any_Priority :=
- Self_ID.Common.LL.Current_Priority;
+ Self_ID.Common.LL.Current_Priority;
begin
if L.Priority < Old_Priority then
@@ -316,7 +316,8 @@ package body System.Task_Primitives.Operations is
end Write_Lock;
procedure Write_Lock
- (L : access RTS_Lock; Global_Lock : Boolean := False)
+ (L : access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Self_ID : Task_ID;
Old_Priority : Any_Priority;
@@ -347,6 +348,7 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (T : Task_ID) is
begin
if not Single_Lock then
+
-- Request the lock and then update the lock owner data
Must_Not_Fail
@@ -417,6 +419,7 @@ package body System.Task_Primitives.Operations is
Must_Not_Fail (DosReleaseMutexSem (L.Mutex));
-- Reset priority after unlocking to avoid priority inversion
+
Thread_Local_Data_Ptr.Lock_Prio_Level :=
Thread_Local_Data_Ptr.Lock_Prio_Level - 1;
@@ -429,6 +432,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (T : Task_ID) is
begin
if not Single_Lock then
+
-- Check the owner data
pragma Assert (Suppress_Owner_Check
@@ -449,7 +453,7 @@ package body System.Task_Primitives.Operations is
(Self_ID : Task_ID;
Reason : System.Tasking.Task_States)
is
- pragma Warnings (Off, Reason);
+ pragma Unreferenced (Reason);
Count : aliased ULONG; -- Used to store dummy result
@@ -502,7 +506,7 @@ package body System.Task_Primitives.Operations is
Timedout : out Boolean;
Yielded : out Boolean)
is
- pragma Warnings (Off, Reason);
+ pragma Unreferenced (Reason);
Check_Time : constant Duration := OSP.Monotonic_Clock;
Rel_Time : Duration;
@@ -676,7 +680,8 @@ package body System.Task_Primitives.Operations is
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
- pragma Warnings (Off, Reason);
+ pragma Unreferenced (Reason);
+
begin
Sem_Must_Not_Fail (DosPostEventSem (T.Common.LL.CV));
end Wakeup;
@@ -742,7 +747,7 @@ package body System.Task_Primitives.Operations is
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
- pragma Warnings (Off, Loss_Of_Inheritance);
+ pragma Unreferenced (Loss_Of_Inheritance);
begin
T.Common.Current_Priority := Prio;
@@ -799,9 +804,27 @@ package body System.Task_Primitives.Operations is
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
- ----------------------
- -- Initialize_TCB --
- ----------------------
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return False;
+ end Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_ID is
+ begin
+ return null;
+ end Register_Foreign_Thread;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
begin
@@ -879,7 +902,7 @@ package body System.Task_Primitives.Operations is
-- recommend a minimum size of 32 kB. (The original was 4 kB)
-- Systems that use many tasks (say > 30) and require much
-- memory may run out of virtual address space, since OS/2
- -- has a per-process limit of 512 MB, of which max. 300 MB is
+ -- has a per-proces limit of 512 MB, of which max. 300 MB is
-- usable in practise.
if Stack_Size = Unspecified_Size then
@@ -973,11 +996,7 @@ package body System.Task_Primitives.Operations is
procedure Exit_Task is
begin
- DosExit (EXIT_THREAD, 0);
-
- -- Do not finalize TCB here.
- -- GNARL layer is responsible for that.
-
+ Thread_Local_Data_Ptr := null;
end Exit_Task;
----------------
@@ -985,7 +1004,7 @@ package body System.Task_Primitives.Operations is
----------------
procedure Abort_Task (T : Task_ID) is
- pragma Warnings (Off, T);
+ pragma Unreferenced (T);
begin
null;
@@ -999,8 +1018,7 @@ package body System.Task_Primitives.Operations is
-- Check_Exit --
----------------
- -- Dummy versions. The only currently working versions is for solaris
- -- (native).
+ -- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
begin
@@ -1013,6 +1031,7 @@ package body System.Task_Primitives.Operations is
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
TLD : constant Access_Thread_Local_Data := Thread_Local_Data_Ptr;
+
begin
return Self_ID = TLD.Self_ID
and then TLD.Lock_Prio_Level = 0;
@@ -1051,7 +1070,9 @@ package body System.Task_Primitives.Operations is
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
begin
if Thread_Id (T.Common.LL.Thread) /= Thread_Self then
return DosSuspendThread (T.Common.LL.Thread) = NO_ERROR;
@@ -1066,7 +1087,9 @@ package body System.Task_Primitives.Operations is
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
begin
if Thread_Id (T.Common.LL.Thread) /= Thread_Self then
return DosResumeThread (T.Common.LL.Thread) = NO_ERROR;
diff --git a/gcc/ada/5otaspri.ads b/gcc/ada/5otaspri.ads
index 9dd412cf421..cb5b0295b13 100644
--- a/gcc/ada/5otaspri.ads
+++ b/gcc/ada/5otaspri.ads
@@ -6,7 +6,8 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2001 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5posinte.ads b/gcc/ada/5posinte.ads
index 1db503934b9..fa94ad21feb 100644
--- a/gcc/ada/5posinte.ads
+++ b/gcc/ada/5posinte.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5posprim.adb b/gcc/ada/5posprim.adb
index 1dfb37110ce..ed8a6f40f55 100644
--- a/gcc/ada/5posprim.adb
+++ b/gcc/ada/5posprim.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,7 +32,7 @@
------------------------------------------------------------------------------
-- This version uses gettimeofday and select
--- Currently OpenNT, Dec Unix, Solaris and SCO UnixWare use this file.
+-- This file is suitable for OpenNT, Dec Unix and SCO UnixWare.
package body System.OS_Primitives is
@@ -41,33 +41,23 @@ package body System.OS_Primitives is
-- these declarations in System.OS_Interface and move these ones in
-- the spec.
- type struct_timezone is record
- tz_minuteswest : Integer;
- tz_dsttime : Integer;
- end record;
- pragma Convention (C, struct_timezone);
- type struct_timezone_ptr is access all struct_timezone;
-
type struct_timeval is record
- tv_sec : Integer;
- tv_usec : Integer;
+ tv_sec : Integer;
+ tv_usec : Integer;
end record;
pragma Convention (C, struct_timeval);
- function gettimeofday
+ procedure gettimeofday
(tv : access struct_timeval;
- tz : struct_timezone_ptr) return Integer;
+ tz : Address := Null_Address);
pragma Import (C, gettimeofday, "gettimeofday");
- type fd_set is null record;
- type fd_set_ptr is access all fd_set;
-
- function C_select
- (n : Integer := 0;
+ procedure C_select
+ (n : Integer := 0;
readfds,
writefds,
- exceptfds : fd_set_ptr := null;
- timeout : access struct_timeval) return Integer;
+ exceptfds : Address := Null_Address;
+ timeout : access struct_timeval);
pragma Import (C, C_select, "select");
-----------
@@ -75,11 +65,10 @@ package body System.OS_Primitives is
-----------
function Clock return Duration is
- TV : aliased struct_timeval;
- Result : Integer;
+ TV : aliased struct_timeval;
begin
- Result := gettimeofday (TV'Access, null);
+ gettimeofday (TV'Access);
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
end Clock;
@@ -97,7 +86,6 @@ package body System.OS_Primitives is
(Time : Duration;
Mode : Integer)
is
- Result : Integer;
Rel_Time : Duration;
Abs_Time : Duration;
Check_Time : Duration := Clock;
@@ -123,7 +111,7 @@ package body System.OS_Primitives is
timeval.tv_usec :=
Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6);
- Result := C_select (timeout => timeval'Unchecked_Access);
+ C_select (timeout => timeval'Unchecked_Access);
Check_Time := Clock;
exit when Abs_Time <= Check_Time;
diff --git a/gcc/ada/5psystem.ads b/gcc/ada/5psystem.ads
new file mode 100644
index 00000000000..11058290e59
--- /dev/null
+++ b/gcc/ada/5psystem.ads
@@ -0,0 +1,150 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (OpenNT/Interix Version) --
+-- --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 0.01;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 32;
+ Memory_Size : constant := 2 ** 32;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := Low_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer range 0 .. 31;
+ subtype Priority is Any_Priority range 0 .. 30;
+ subtype Interrupt_Priority is Any_Priority range 31 .. 31;
+
+ Default_Priority : constant Priority := 15;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
+ Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
+end System;
diff --git a/gcc/ada/5pvxwork.ads b/gcc/ada/5pvxwork.ads
index 829daa23944..17118681fc3 100644
--- a/gcc/ada/5pvxwork.ads
+++ b/gcc/ada/5pvxwork.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5qosinte.ads b/gcc/ada/5qosinte.ads
deleted file mode 100644
index 06f0e6cfc96..00000000000
--- a/gcc/ada/5qosinte.ads
+++ /dev/null
@@ -1,186 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1991-2001 Florida State University --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
--- RT GNU/Linux version.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
--- PLEASE DO NOT add any with-clauses to this package
--- or remove the pragma Elaborate_Body.
--- It is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-
-package System.OS_Interface is
-
- pragma Preelaborate;
-
- subtype int is Interfaces.C.int;
- subtype unsigned_long is Interfaces.C.unsigned_long;
-
- -- RT GNU/Linux kernel threads should not use the
- -- OS signal interfaces.
-
- Max_Interrupt : constant := 2;
- type Signal is new int range 0 .. Max_Interrupt;
- type sigset_t is new Integer;
-
- ----------
- -- Time --
- ----------
-
- RT_TICKS_PER_SEC : constant := 1193180;
- -- the amount of time units in one second.
-
- RT_TIME_END : constant := 16#7fffFfffFfffFfff#;
-
- type RTIME is range -2 ** 63 .. 2 ** 63 - 1;
- -- the introduction of type RTIME is due to the fact that RT-GNU/Linux
- -- uses this type to represent time. In RT-GNU/Linux, it's a long long
- -- integer that takes 64 bits for storage
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- RT_LOWEST_PRIORITY : constant System.Any_Priority :=
- System.Any_Priority'First;
- -- for the lowest priority task in RT-GNU/Linux. By the design, this
- -- task is the regular GNU/Linux kernel.
-
- RT_TASK_MAGIC : constant := 16#754d2774#;
- -- a special constant used as a label for a task that has been created
-
- ----------------------------
- -- RT constants and types --
- ----------------------------
-
- SFIF : Integer;
- pragma Import (C, SFIF, "SFIF");
- -- Interrupt emulation flag used by RT-GNU/Linux. If it's 0, the regular
- -- GNU/Linux kernel is preempted. Otherwise, the regular Linux kernel is
- -- running
-
- GFP_ATOMIC : constant := 16#1#;
- GFP_KERNEL : constant := 16#3#;
- -- constants to indicate the priority of a call to kmalloc.
- -- GFP_KERNEL is used in the current implementation to allocate
- -- stack space for a task. Since GFP_ATOMIC has higher priority,
- -- if necessary, replace GFP_KERNEL with GFP_ATOMIC
-
- type Rt_Task_States is (RT_TASK_READY, RT_TASK_DELAYED, RT_TASK_DORMANT);
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
-
- -- ??? need to define a type for references to (IDs of)
- -- RT GNU/Linux lock objects, and implement the lock objects.
-
- subtype Thread_Id is System.Address;
-
- -------------------------------
- -- Useful imported functions --
- -------------------------------
-
- -------------------------------------
- -- Functions from GNU/Linux kernel --
- -------------------------------------
-
- function Kmalloc (size : Integer; Priority : Integer) return System.Address;
- pragma Import (C, Kmalloc, "kmalloc");
-
- procedure Kfree (Ptr : System.Address);
- pragma Import (C, Kfree, "kfree");
-
- procedure Printk (Msg : String);
- pragma Import (C, Printk, "printk");
-
- ---------------------
- -- RT time related --
- ---------------------
-
- function Rt_Get_Time return RTIME;
- pragma Import (C, Rt_Get_Time, "rt_get_time");
-
- function Rt_Request_Timer (Fn : System.Address) return Integer;
- procedure Rt_Request_Timer (Fn : System.Address);
- pragma Import (C, Rt_Request_Timer, "rt_request_timer");
-
- procedure Rt_Free_Timer;
- pragma Import (C, Rt_Free_Timer, "rt_free_timer");
-
- procedure Rt_Set_Timer (T : RTIME);
- pragma Import (C, Rt_Set_Timer, "rt_set_timer");
-
- procedure Rt_No_Timer;
- pragma Import (C, Rt_No_Timer, "rt_no_timer");
-
- ---------------------
- -- RT FIFO related --
- ---------------------
-
- function Rtf_Create (Fifo : Integer; Size : Integer) return Integer;
- pragma Import (C, Rtf_Create, "rtf_create");
-
- function Rtf_Destroy (Fifo : Integer) return Integer;
- pragma Import (C, Rtf_Destroy, "rtf_destroy");
-
- function Rtf_Resize (Minor : Integer; Size : Integer) return Integer;
- pragma Import (C, Rtf_Resize, "rtf_resize");
-
- function Rtf_Put
- (Fifo : Integer;
- Buf : System.Address;
- Count : Integer) return Integer;
- pragma Import (C, Rtf_Put, "rtf_put");
-
- function Rtf_Get
- (Fifo : Integer;
- Buf : System.Address;
- Count : Integer) return Integer;
- pragma Import (C, Rtf_Get, "rtf_get");
-
- function Rtf_Create_Handler
- (Fifo : Integer;
- Handler : System.Address) return Integer;
- pragma Import (C, Rtf_Create_Handler, "rtf_create_handler");
-
-private
- type Require_Body;
-end System.OS_Interface;
diff --git a/gcc/ada/5qtaprop.adb b/gcc/ada/5qtaprop.adb
deleted file mode 100644
index aa1e97be694..00000000000
--- a/gcc/ada/5qtaprop.adb
+++ /dev/null
@@ -1,1776 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
--- RT GNU/Linux version
-
--- ???? Later, look at what we might want to provide for interrupt
--- management.
-
-pragma Suppress (All_Checks);
-
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
-
-with System.Machine_Code;
--- used for Asm
-
-with System.OS_Interface;
--- used for various types, constants, and operations
-
-with System.OS_Primitives;
--- used for Delay_Modes
-
-with System.Parameters;
--- used for Size_Type
-
-with System.Storage_Elements;
-
-with System.Tasking;
--- used for Ada_Task_Control_Block
--- Task_ID
-
-with Ada.Unchecked_Conversion;
-
-package body System.Task_Primitives.Operations is
-
- use System.Machine_Code,
- System.OS_Interface,
- System.OS_Primitives,
- System.Parameters,
- System.Tasking,
- System.Storage_Elements;
-
- --------------------------------
- -- RT GNU/Linux specific Data --
- --------------------------------
-
- -- Define two important parameters necessary for a GNU/Linux kernel module.
- -- Any module that is going to be loaded into the kernel space needs these
- -- parameters.
-
- Mod_Use_Count : Integer;
- pragma Export (C, Mod_Use_Count, "mod_use_count_");
- -- for module usage tracking by the kernel
-
- type Aliased_String is array (Positive range <>) of aliased Character;
- pragma Convention (C, Aliased_String);
-
- Kernel_Version : constant Aliased_String := "2.0.33" & ASCII.Nul;
- pragma Export (C, Kernel_Version, "kernel_version");
- -- So that insmod can find the version number.
-
- -- The following procedures have their name specified by the GNU/Linux
- -- module loader. Note that they simply correspond to adainit/adafinal.
-
- function Init_Module return Integer;
- pragma Export (C, Init_Module, "init_module");
-
- procedure Cleanup_Module;
- pragma Export (C, Cleanup_Module, "cleanup_module");
-
- ----------------
- -- Local Data --
- ----------------
-
- LF : constant String := ASCII.LF & ASCII.Nul;
-
- LFHT : constant String := ASCII.LF & ASCII.HT;
- -- used in inserted assembly code
-
- Max_Tasks : constant := 10;
- -- ??? Eventually, this should probably be in System.Parameters.
-
- Known_Tasks : array (0 .. Max_Tasks) of Task_ID;
- -- Global array of tasks read by gdb, and updated by Create_Task and
- -- Finalize_TCB. It's from System.Tasking.Debug. We moved it here to
- -- cut the dependence on that package. Consider moving it here or to
- -- this package specification, permanently????
-
- Max_Sensible_Delay : constant RTIME :=
- 365 * 24 * 60 * 60 * RT_TICKS_PER_SEC;
- -- Max of one year delay, needed to prevent exceptions for large
- -- delay values. It seems unlikely that any test will notice this
- -- restriction.
- -- ??? This is really declared in System.OS_Primitives,
- -- and the type is Duration, here its type is RTIME.
-
- Tick_Count : constant := RT_TICKS_PER_SEC / 20;
- Nano_Count : constant := 50_000_000;
- -- two constants used in conversions between RTIME and Duration.
-
- Addr_Bytes : constant Storage_Offset :=
- System.Address'Max_Size_In_Storage_Elements;
- -- number of bytes needed for storing an address.
-
- Guess : constant RTIME := 10;
- -- an approximate amount of RTIME used in scheduler to awake a task having
- -- its resume time within 'current time + Guess'
- -- The value of 10 is estimated here and may need further refinement
-
- TCB_Array : array (0 .. Max_Tasks)
- of aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0);
- pragma Volatile_Components (TCB_Array);
-
- Available_TCBs : Task_ID;
- pragma Atomic (Available_TCBs);
- -- Head of linear linked list of available TCB's, linked using TCB's
- -- LL.Next. This list is Initialized to contain a fixed number of tasks,
- -- when the runtime system starts up.
-
- Current_Task : Task_ID;
- pragma Export (C, Current_Task, "current_task");
- pragma Atomic (Current_Task);
- -- This is the task currently running. We need the pragma here to specify
- -- the link-name for Current_Task is "current_task", rather than the long
- -- name (including the package name) that the Ada compiler would normally
- -- generate. "current_task" is referenced in procedure Rt_Switch_To below
-
- Idle_Task : aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0);
- -- Tail of the circular queue of ready to run tasks.
-
- Scheduler_Idle : Boolean := False;
- -- True when the scheduler is idle (no task other than the idle task
- -- is on the ready queue).
-
- In_Elab_Code : Boolean := True;
- -- True when we are elaborating our application.
- -- Init_Module will set this flag to false and never revert it.
-
- Timer_Queue : aliased Restricted_Ada_Task_Control_Block (Entry_Num => 0);
- -- Header of the queue of delayed real-time tasks.
- -- Timer_Queue.LL has to be initialized properly before being used
-
- Timer_Expired : Boolean := False;
- -- flag to show whether the Timer_Queue needs to be checked
- -- when it becomes true, it means there is a task in the
- -- Timer_Queue having to be awakened and be moved to ready queue
-
- Environment_Task_ID : Task_ID;
- -- A variable to hold Task_ID for the environment task.
- -- Once initialized, this behaves as a constant.
- -- In the current implementation, this is the task assigned permanently
- -- as the regular GNU/Linux kernel.
-
- Single_RTS_Lock : aliased RTS_Lock;
- -- This is a lock to allow only one thread of control in the RTS at
- -- a time; it is used to execute in mutual exclusion from all other tasks.
- -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
-
- -- The followings are internal configuration constants needed.
- Next_Serial_Number : Task_Serial_Number := 100;
- pragma Volatile (Next_Serial_Number);
- -- We start at 100, to reserve some special values for
- -- using in error checking.
-
- GNU_Linux_Irq_State : Integer := 0;
- -- This needs comments ???
-
- type Duration_As_Integer is delta 1.0
- range -2.0**(Duration'Size - 1) .. 2.0**(Duration'Size - 1) - 1.0;
- -- used for output RTIME value during debugging
-
- type Address_Ptr is access all System.Address;
- pragma Convention (C, Address_Ptr);
-
- --------------------------------
- -- Local conversion functions --
- --------------------------------
-
- function To_Task_ID is new
- Ada.Unchecked_Conversion (System.Address, Task_ID);
-
- function To_Address is new
- Ada.Unchecked_Conversion (Task_ID, System.Address);
-
- function RTIME_To_D_Int is new
- Ada.Unchecked_Conversion (RTIME, Duration_As_Integer);
-
- function Raw_RTIME is new
- Ada.Unchecked_Conversion (Duration, RTIME);
-
- function Raw_Duration is new
- Ada.Unchecked_Conversion (RTIME, Duration);
-
- function To_Duration (T : RTIME) return Duration;
- pragma Inline (To_Duration);
-
- function To_RTIME (D : Duration) return RTIME;
- pragma Inline (To_RTIME);
-
- function To_Integer is new
- Ada.Unchecked_Conversion (System.Parameters.Size_Type, Integer);
-
- function To_Address_Ptr is
- new Ada.Unchecked_Conversion (System.Address, Address_Ptr);
-
- function To_RTS_Lock_Ptr is new
- Ada.Unchecked_Conversion (Lock_Ptr, RTS_Lock_Ptr);
-
- -----------------------------------
- -- Local Subprogram Declarations --
- -----------------------------------
-
- procedure Rt_Switch_To (Tsk : Task_ID);
- pragma Inline (Rt_Switch_To);
- -- switch from the 'current_task' to 'Tsk'
- -- and 'Tsk' then becomes 'current_task'
-
- procedure R_Save_Flags (F : out Integer);
- pragma Inline (R_Save_Flags);
- -- save EFLAGS register to 'F'
-
- procedure R_Restore_Flags (F : Integer);
- pragma Inline (R_Restore_Flags);
- -- restore EFLAGS register from 'F'
-
- procedure R_Cli;
- pragma Inline (R_Cli);
- -- disable interrupts
-
- procedure R_Sti;
- pragma Inline (R_Sti);
- -- enable interrupts
-
- procedure Timer_Wrapper;
- -- the timer handler. It sets Timer_Expired flag to True and
- -- then calls Rt_Schedule
-
- procedure Rt_Schedule;
- -- the scheduler
-
- procedure Insert_R (T : Task_ID);
- pragma Inline (Insert_R);
- -- insert 'T' into the tail of the ready queue for its active
- -- priority
- -- if original queue is 6 5 4 4 3 2 and T has priority of 4
- -- then after T is inserted the queue becomes 6 5 4 4 T 3 2
-
- procedure Insert_RF (T : Task_ID);
- pragma Inline (Insert_RF);
- -- insert 'T' into the front of the ready queue for its active
- -- priority
- -- if original queue is 6 5 4 4 3 2 and T has priority of 4
- -- then after T is inserted the queue becomes 6 5 T 4 4 3 2
-
- procedure Delete_R (T : Task_ID);
- pragma Inline (Delete_R);
- -- delete 'T' from the ready queue. If 'T' is not in any queue
- -- the operation has no effect
-
- procedure Insert_T (T : Task_ID);
- pragma Inline (Insert_T);
- -- insert 'T' into the waiting queue according to its Resume_Time.
- -- If there are tasks in the waiting queue that have the same
- -- Resume_Time as 'T', 'T' is then inserted into the queue for
- -- its active priority
-
- procedure Delete_T (T : Task_ID);
- pragma Inline (Delete_T);
- -- delete 'T' from the waiting queue.
-
- procedure Move_Top_Task_From_Timer_Queue_To_Ready_Queue;
- pragma Inline (Move_Top_Task_From_Timer_Queue_To_Ready_Queue);
- -- remove the task in the front of the waiting queue and insert it
- -- into the tail of the ready queue for its active priority
-
- -------------------------
- -- Local Subprograms --
- -------------------------
-
- procedure Rt_Switch_To (Tsk : Task_ID) is
- begin
- pragma Debug (Printk ("procedure Rt_Switch_To called" & LF));
-
- Asm (
- "pushl %%eax" & LFHT &
- "pushl %%ebp" & LFHT &
- "pushl %%edi" & LFHT &
- "pushl %%esi" & LFHT &
- "pushl %%edx" & LFHT &
- "pushl %%ecx" & LFHT &
- "pushl %%ebx" & LFHT &
-
- "movl current_task, %%edx" & LFHT &
- "cmpl $0, 36(%%edx)" & LFHT &
- -- 36 is hard-coded, 36(%%edx) is actually
- -- Current_Task.Common.LL.Uses_Fp
-
- "jz 25f" & LFHT &
- "sub $108,%%esp" & LFHT &
- "fsave (%%esp)" & LFHT &
- "25: pushl $1f" & LFHT &
- "movl %%esp, 32(%%edx)" & LFHT &
- -- 32 is hard-coded, 32(%%edx) is actually
- -- Current_Task.Common.LL.Stack
-
- "movl 32(%%ecx), %%esp" & LFHT &
- -- 32 is hard-coded, 32(%%ecx) is actually Tsk.Common.LL.Stack.
- -- Tsk is the task to be switched to
-
- "movl %%ecx, current_task" & LFHT &
- "ret" & LFHT &
- "1: cmpl $0, 36(%%ecx)" & LFHT &
- -- 36(%%exc) is Tsk.Common.LL.Stack (hard coded)
- "jz 26f" & LFHT &
- "frstor (%%esp)" & LFHT &
- "add $108,%%esp" & LFHT &
- "26: popl %%ebx" & LFHT &
- "popl %%ecx" & LFHT &
- "popl %%edx" & LFHT &
- "popl %%esi" & LFHT &
- "popl %%edi" & LFHT &
- "popl %%ebp" & LFHT &
- "popl %%eax",
- Outputs => No_Output_Operands,
- Inputs => Task_ID'Asm_Input ("c", Tsk),
- Clobber => "cx",
- Volatile => True);
- end Rt_Switch_To;
-
- procedure R_Save_Flags (F : out Integer) is
- begin
- Asm (
- "pushfl" & LFHT &
- "popl %0",
- Outputs => Integer'Asm_Output ("=g", F),
- Inputs => No_Input_Operands,
- Clobber => "memory",
- Volatile => True);
- end R_Save_Flags;
-
- procedure R_Restore_Flags (F : Integer) is
- begin
- Asm (
- "pushl %0" & LFHT &
- "popfl",
- Outputs => No_Output_Operands,
- Inputs => Integer'Asm_Input ("g", F),
- Clobber => "memory",
- Volatile => True);
- end R_Restore_Flags;
-
- procedure R_Sti is
- begin
- Asm (
- "sti",
- Outputs => No_Output_Operands,
- Inputs => No_Input_Operands,
- Clobber => "memory",
- Volatile => True);
- end R_Sti;
-
- procedure R_Cli is
- begin
- Asm (
- "cli",
- Outputs => No_Output_Operands,
- Inputs => No_Input_Operands,
- Clobber => "memory",
- Volatile => True);
- end R_Cli;
-
- -- A wrapper for Rt_Schedule, works as the timer handler
-
- procedure Timer_Wrapper is
- begin
- pragma Debug (Printk ("procedure Timer_Wrapper called" & LF));
-
- Timer_Expired := True;
- Rt_Schedule;
- end Timer_Wrapper;
-
- procedure Rt_Schedule is
- Now : RTIME;
- Top_Task : Task_ID;
- Flags : Integer;
-
- procedure Debug_Timer_Queue;
- -- Check the state of the Timer Queue.
-
- procedure Debug_Timer_Queue is
- begin
- if Timer_Queue.Common.LL.Succ /= Timer_Queue'Address then
- Printk ("Timer_Queue not empty" & LF);
- end if;
-
- if To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time <
- Now + Guess
- then
- Printk ("and need to move top task to ready queue" & LF);
- end if;
- end Debug_Timer_Queue;
-
- begin
- pragma Debug (Printk ("procedure Rt_Schedule called" & LF));
-
- -- Scheduler_Idle means that this call comes from an interrupt
- -- handler (e.g timer) that interrupted the idle loop below.
-
- if Scheduler_Idle then
- return;
- end if;
-
- <<Idle>>
- R_Save_Flags (Flags);
- R_Cli;
-
- Scheduler_Idle := False;
-
- if Timer_Expired then
- pragma Debug (Printk ("Timer expired" & LF));
- Timer_Expired := False;
-
- -- Check for expired time delays.
- Now := Rt_Get_Time;
-
- -- Need another (circular) queue for delayed tasks, this one ordered
- -- by wakeup time, so the one at the front has the earliest resume
- -- time. Wake up all the tasks sleeping on time delays that should
- -- be awakened at this time.
-
- -- ??? This is not very good, since we may waste time here waking
- -- up a bunch of lower priority tasks, adding to the blocking time
- -- of higher priority ready tasks, but we don't see how to get
- -- around this without adding more wasted time elsewhere.
-
- pragma Debug (Debug_Timer_Queue);
-
- while Timer_Queue.Common.LL.Succ /= Timer_Queue'Address and then
- To_Task_ID
- (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time < Now + Guess
- loop
- To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.State :=
- RT_TASK_READY;
- Move_Top_Task_From_Timer_Queue_To_Ready_Queue;
- end loop;
-
- -- Arm the timer if necessary.
- -- ??? This may be wasteful, if the tasks on the timer queue are
- -- of lower priority than the current task's priority. The problem
- -- is that we can't tell this without scanning the whole timer
- -- queue. This scanning takes extra time.
-
- if Timer_Queue.Common.LL.Succ /= Timer_Queue'Address then
- -- Timer_Queue is not empty, so set the timer to interrupt at
- -- the next resume time. The Wakeup procedure must also do this,
- -- and must do it while interrupts are disabled so that there is
- -- no danger of interleaving with this code.
- Rt_Set_Timer
- (To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time);
- else
- Rt_No_Timer;
- end if;
- end if;
-
- Top_Task := To_Task_ID (Idle_Task.Common.LL.Succ);
-
- -- If the ready queue is empty, the kernel has to wait until the timer
- -- or another interrupt makes a task ready.
-
- if Top_Task = To_Task_ID (Idle_Task'Address) then
- Scheduler_Idle := True;
- R_Restore_Flags (Flags);
- pragma Debug (Printk ("!!!kernel idle!!!" & LF));
- goto Idle;
- end if;
-
- if Top_Task = Current_Task then
- pragma Debug (Printk ("Rt_Schedule: Top_Task = Current_Task" & LF));
- -- if current task continues, just return.
-
- R_Restore_Flags (Flags);
- return;
- end if;
-
- if Top_Task = Environment_Task_ID then
- pragma Debug (Printk
- ("Rt_Schedule: Top_Task = Environment_Task" & LF));
- -- If there are no RT tasks ready, we execute the regular
- -- GNU/Linux kernel, and allow the regular GNU/Linux interrupt
- -- handlers to preempt the current task again.
-
- if not In_Elab_Code then
- SFIF := GNU_Linux_Irq_State;
- end if;
-
- elsif Current_Task = Environment_Task_ID then
- pragma Debug (Printk
- ("Rt_Schedule: Current_Task = Environment_Task" & LF));
- -- We are going to preempt the regular GNU/Linux kernel to
- -- execute an RT task, so don't allow the regular GNU/Linux
- -- interrupt handlers to preempt the current task any more.
-
- GNU_Linux_Irq_State := SFIF;
- SFIF := 0;
- end if;
-
- Top_Task.Common.LL.State := RT_TASK_READY;
- Rt_Switch_To (Top_Task);
- R_Restore_Flags (Flags);
- end Rt_Schedule;
-
- procedure Insert_R (T : Task_ID) is
- Q : Task_ID := To_Task_ID (Idle_Task.Common.LL.Succ);
- begin
- pragma Debug (Printk ("procedure Insert_R called" & LF));
-
- pragma Assert (T.Common.LL.Succ = To_Address (T));
- pragma Assert (T.Common.LL.Pred = To_Address (T));
-
- -- T is inserted in the queue between a task that has higher
- -- or the same Active_Priority as T and a task that has lower
- -- Active_Priority than T
-
- while Q /= To_Task_ID (Idle_Task'Address)
- and then T.Common.LL.Active_Priority <= Q.Common.LL.Active_Priority
- loop
- Q := To_Task_ID (Q.Common.LL.Succ);
- end loop;
-
- -- Q is successor of T
-
- T.Common.LL.Succ := To_Address (Q);
- T.Common.LL.Pred := Q.Common.LL.Pred;
- To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T);
- Q.Common.LL.Pred := To_Address (T);
- end Insert_R;
-
- procedure Insert_RF (T : Task_ID) is
- Q : Task_ID := To_Task_ID (Idle_Task.Common.LL.Succ);
- begin
- pragma Debug (Printk ("procedure Insert_RF called" & LF));
-
- pragma Assert (T.Common.LL.Succ = To_Address (T));
- pragma Assert (T.Common.LL.Pred = To_Address (T));
-
- -- T is inserted in the queue between a task that has higher
- -- Active_Priority as T and a task that has lower or the same
- -- Active_Priority as T
-
- while Q /= To_Task_ID (Idle_Task'Address) and then
- T.Common.LL.Active_Priority < Q.Common.LL.Active_Priority
- loop
- Q := To_Task_ID (Q.Common.LL.Succ);
- end loop;
-
- -- Q is successor of T
-
- T.Common.LL.Succ := To_Address (Q);
- T.Common.LL.Pred := Q.Common.LL.Pred;
- To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T);
- Q.Common.LL.Pred := To_Address (T);
- end Insert_RF;
-
- procedure Delete_R (T : Task_ID) is
- Tpred : constant Task_ID := To_Task_ID (T.Common.LL.Pred);
- Tsucc : constant Task_ID := To_Task_ID (T.Common.LL.Succ);
-
- begin
- pragma Debug (Printk ("procedure Delete_R called" & LF));
-
- -- checking whether T is in the queue is not necessary because
- -- if T is not in the queue, following statements changes
- -- nothing. But T cannot be in the Timer_Queue, otherwise
- -- activate the check below, note that checking whether T is
- -- in a queue is a relatively expensive operation
-
- Tpred.Common.LL.Succ := To_Address (Tsucc);
- Tsucc.Common.LL.Pred := To_Address (Tpred);
- T.Common.LL.Succ := To_Address (T);
- T.Common.LL.Pred := To_Address (T);
- end Delete_R;
-
- procedure Insert_T (T : Task_ID) is
- Q : Task_ID := To_Task_ID (Timer_Queue.Common.LL.Succ);
- begin
- pragma Debug (Printk ("procedure Insert_T called" & LF));
-
- pragma Assert (T.Common.LL.Succ = To_Address (T));
-
- while Q /= To_Task_ID (Timer_Queue'Address) and then
- T.Common.LL.Resume_Time > Q.Common.LL.Resume_Time
- loop
- Q := To_Task_ID (Q.Common.LL.Succ);
- end loop;
-
- -- Q is the task that has Resume_Time equal to or greater than that
- -- of T. If they have the same Resume_Time, continue looking for the
- -- location T is to be inserted using its Active_Priority
-
- while Q /= To_Task_ID (Timer_Queue'Address) and then
- T.Common.LL.Resume_Time = Q.Common.LL.Resume_Time
- loop
- exit when T.Common.LL.Active_Priority > Q.Common.LL.Active_Priority;
- Q := To_Task_ID (Q.Common.LL.Succ);
- end loop;
-
- -- Q is successor of T
-
- T.Common.LL.Succ := To_Address (Q);
- T.Common.LL.Pred := Q.Common.LL.Pred;
- To_Task_ID (T.Common.LL.Pred).Common.LL.Succ := To_Address (T);
- Q.Common.LL.Pred := To_Address (T);
- end Insert_T;
-
- procedure Delete_T (T : Task_ID) is
- Tpred : constant Task_ID := To_Task_ID (T.Common.LL.Pred);
- Tsucc : constant Task_ID := To_Task_ID (T.Common.LL.Succ);
-
- begin
- pragma Debug (Printk ("procedure Delete_T called" & LF));
-
- pragma Assert (T /= To_Task_ID (Timer_Queue'Address));
-
- Tpred.Common.LL.Succ := To_Address (Tsucc);
- Tsucc.Common.LL.Pred := To_Address (Tpred);
- T.Common.LL.Succ := To_Address (T);
- T.Common.LL.Pred := To_Address (T);
- end Delete_T;
-
- procedure Move_Top_Task_From_Timer_Queue_To_Ready_Queue is
- Top_Task : Task_ID := To_Task_ID (Timer_Queue.Common.LL.Succ);
- begin
- pragma Debug (Printk ("procedure Move_Top_Task called" & LF));
-
- if Top_Task /= To_Task_ID (Timer_Queue'Address) then
- Delete_T (Top_Task);
- Top_Task.Common.LL.State := RT_TASK_READY;
- Insert_R (Top_Task);
- end if;
- end Move_Top_Task_From_Timer_Queue_To_Ready_Queue;
-
- ----------
- -- Self --
- ----------
-
- function Self return Task_ID is
- begin
- pragma Debug (Printk ("function Self called" & LF));
-
- return Current_Task;
- end Self;
-
- ---------------------
- -- Initialize_Lock --
- ---------------------
-
- procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is
- begin
- pragma Debug (Printk ("procedure Initialize_Lock called" & LF));
-
- L.Ceiling_Priority := Prio;
- L.Owner := System.Null_Address;
- end Initialize_Lock;
-
- procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
- begin
- pragma Debug (Printk ("procedure Initialize_Lock (RTS) called" & LF));
-
- L.Ceiling_Priority := System.Any_Priority'Last;
- L.Owner := System.Null_Address;
- end Initialize_Lock;
-
- -------------------
- -- Finalize_Lock --
- -------------------
-
- procedure Finalize_Lock (L : access Lock) is
- begin
- pragma Debug (Printk ("procedure Finalize_Lock called" & LF));
- null;
- end Finalize_Lock;
-
- procedure Finalize_Lock (L : access RTS_Lock) is
- begin
- pragma Debug (Printk ("procedure Finalize_Lock (RTS) called" & LF));
- null;
- end Finalize_Lock;
-
- ----------------
- -- Write_Lock --
- ----------------
-
- procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
- Prio : constant System.Any_Priority :=
- Current_Task.Common.LL.Active_Priority;
-
- begin
- pragma Debug (Printk ("procedure Write_Lock called" & LF));
-
- Ceiling_Violation := False;
-
- if Prio > L.Ceiling_Priority then
- -- Ceiling violation.
- -- This should never happen, unless something is seriously
- -- wrong with task T or the entire run-time system.
- -- ???? extreme error recovery, e.g. shut down the system or task
-
- Ceiling_Violation := True;
- pragma Debug (Printk ("Ceiling Violation in Write_Lock" & LF));
- return;
- end if;
-
- L.Pre_Locking_Priority := Prio;
- L.Owner := To_Address (Current_Task);
- Current_Task.Common.LL.Active_Priority := L.Ceiling_Priority;
-
- if Current_Task.Common.LL.Outer_Lock = null then
- -- If this lock is not nested, record a pointer to it.
-
- Current_Task.Common.LL.Outer_Lock :=
- To_RTS_Lock_Ptr (L.all'Unchecked_Access);
- end if;
- end Write_Lock;
-
- procedure Write_Lock
- (L : access RTS_Lock; Global_Lock : Boolean := False)
- is
- Prio : constant System.Any_Priority :=
- Current_Task.Common.LL.Active_Priority;
-
- begin
- pragma Debug (Printk ("procedure Write_Lock (RTS) called" & LF));
-
- if Prio > L.Ceiling_Priority then
- -- Ceiling violation.
- -- This should never happen, unless something is seriously
- -- wrong with task T or the entire runtime system.
- -- ???? extreme error recovery, e.g. shut down the system or task
-
- Printk ("Ceiling Violation in Write_Lock (RTS)" & LF);
- return;
- end if;
-
- L.Pre_Locking_Priority := Prio;
- L.Owner := To_Address (Current_Task);
- Current_Task.Common.LL.Active_Priority := L.Ceiling_Priority;
-
- if Current_Task.Common.LL.Outer_Lock = null then
- Current_Task.Common.LL.Outer_Lock := L.all'Unchecked_Access;
- end if;
- end Write_Lock;
-
- procedure Write_Lock (T : Task_ID) is
- Prio : constant System.Any_Priority :=
- Current_Task.Common.LL.Active_Priority;
-
- begin
- pragma Debug (Printk ("procedure Write_Lock (Task_ID) called" & LF));
-
- if Prio > T.Common.LL.L.Ceiling_Priority then
- -- Ceiling violation.
- -- This should never happen, unless something is seriously
- -- wrong with task T or the entire runtime system.
- -- ???? extreme error recovery, e.g. shut down the system or task
-
- Printk ("Ceiling Violation in Write_Lock (Task)" & LF);
- return;
- end if;
-
- T.Common.LL.L.Pre_Locking_Priority := Prio;
- T.Common.LL.L.Owner := To_Address (Current_Task);
- Current_Task.Common.LL.Active_Priority := T.Common.LL.L.Ceiling_Priority;
-
- if Current_Task.Common.LL.Outer_Lock = null then
- Current_Task.Common.LL.Outer_Lock := T.Common.LL.L'Access;
- end if;
- end Write_Lock;
-
- ---------------
- -- Read_Lock --
- ---------------
-
- procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
- begin
- pragma Debug (Printk ("procedure Read_Lock called" & LF));
- Write_Lock (L, Ceiling_Violation);
- end Read_Lock;
-
- ------------
- -- Unlock --
- ------------
-
- procedure Unlock (L : access Lock) is
- Flags : Integer;
- begin
- pragma Debug (Printk ("procedure Unlock called" & LF));
-
- if L.Owner /= To_Address (Current_Task) then
- -- ...error recovery
-
- null;
- Printk ("The caller is not the owner of the lock" & LF);
- return;
- end if;
-
- L.Owner := System.Null_Address;
-
- -- Now that the lock is released, lower own priority,
-
- if Current_Task.Common.LL.Outer_Lock =
- To_RTS_Lock_Ptr (L.all'Unchecked_Access)
- then
- -- This lock is the outer-most one, reset own priority to
- -- Current_Priority;
-
- Current_Task.Common.LL.Active_Priority :=
- Current_Task.Common.Current_Priority;
- Current_Task.Common.LL.Outer_Lock := null;
-
- else
- -- If this lock is nested, pop the old active priority.
-
- Current_Task.Common.LL.Active_Priority := L.Pre_Locking_Priority;
- end if;
-
- -- Reschedule the task if necessary. Note we only need to reschedule
- -- the task if its Active_Priority becomes less than the one following
- -- it. The check depends on the fact that Environment_Task (tail of
- -- the ready queue) has the lowest Active_Priority
-
- if Current_Task.Common.LL.Active_Priority
- < To_Task_ID (Current_Task.Common.LL.Succ).Common.LL.Active_Priority
- then
- R_Save_Flags (Flags);
- R_Cli;
- Delete_R (Current_Task);
- Insert_RF (Current_Task);
- R_Restore_Flags (Flags);
- Rt_Schedule;
- end if;
- end Unlock;
-
- procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
- Flags : Integer;
- begin
- pragma Debug (Printk ("procedure Unlock (RTS_Lock) called" & LF));
-
- if L.Owner /= To_Address (Current_Task) then
- null;
- Printk ("The caller is not the owner of the lock" & LF);
- return;
- end if;
-
- L.Owner := System.Null_Address;
-
- if Current_Task.Common.LL.Outer_Lock = L.all'Unchecked_Access then
- Current_Task.Common.LL.Active_Priority :=
- Current_Task.Common.Current_Priority;
- Current_Task.Common.LL.Outer_Lock := null;
-
- else
- Current_Task.Common.LL.Active_Priority := L.Pre_Locking_Priority;
- end if;
-
- -- Reschedule the task if necessary
-
- if Current_Task.Common.LL.Active_Priority
- < To_Task_ID (Current_Task.Common.LL.Succ).Common.LL.Active_Priority
- then
- R_Save_Flags (Flags);
- R_Cli;
- Delete_R (Current_Task);
- Insert_RF (Current_Task);
- R_Restore_Flags (Flags);
- Rt_Schedule;
- end if;
- end Unlock;
-
- procedure Unlock (T : Task_ID) is
- begin
- pragma Debug (Printk ("procedure Unlock (Task_ID) called" & LF));
- Unlock (T.Common.LL.L'Access);
- end Unlock;
-
- -----------
- -- Sleep --
- -----------
-
- -- Unlock Self_ID.Common.LL.L and suspend Self_ID, atomically.
- -- Before return, lock Self_ID.Common.LL.L again
- -- Self_ID can only be reactivated by calling Wakeup.
- -- Unlock code is repeated intentionally.
-
- procedure Sleep
- (Self_ID : Task_ID;
- Reason : ST.Task_States)
- is
- Flags : Integer;
- begin
- pragma Debug (Printk ("procedure Sleep called" & LF));
-
- -- Note that Self_ID is actually Current_Task, that is, only the
- -- task that is running can put itself into sleep. To preserve
- -- consistency, we use Self_ID throughout the code here
-
- Self_ID.Common.State := Reason;
- Self_ID.Common.LL.State := RT_TASK_DORMANT;
-
- R_Save_Flags (Flags);
- R_Cli;
-
- Delete_R (Self_ID);
-
- -- Arrange to unlock Self_ID's ATCB lock. The following check
- -- may be unnecessary because the specification of Sleep says
- -- the caller should hold its own ATCB lock before calling Sleep
-
- if Self_ID.Common.LL.L.Owner = To_Address (Self_ID) then
- Self_ID.Common.LL.L.Owner := System.Null_Address;
-
- if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then
- Self_ID.Common.LL.Active_Priority :=
- Self_ID.Common.Current_Priority;
- Self_ID.Common.LL.Outer_Lock := null;
-
- else
- Self_ID.Common.LL.Active_Priority :=
- Self_ID.Common.LL.L.Pre_Locking_Priority;
- end if;
- end if;
-
- R_Restore_Flags (Flags);
- Rt_Schedule;
-
- -- Before leave, regain the lock
-
- Write_Lock (Self_ID);
- end Sleep;
-
- -----------------
- -- Timed_Sleep --
- -----------------
-
- -- Arrange to be awakened after/at Time (depending on Mode) then Unlock
- -- Self_ID.Common.LL.L and suspend self. If the timeout expires first,
- -- that should awaken the task. If it's awakened (by some other task
- -- calling Wakeup) before the timeout expires, the timeout should be
- -- cancelled.
-
- -- This is for use within the run-time system, so abort is
- -- assumed to be already deferred, and the caller should be
- -- holding its own ATCB lock.
-
- procedure Timed_Sleep
- (Self_ID : Task_ID;
- Time : Duration;
- Mode : ST.Delay_Modes;
- Reason : Task_States;
- Timedout : out Boolean;
- Yielded : out Boolean)
- is
- Flags : Integer;
- Abs_Time : RTIME;
-
- begin
- pragma Debug (Printk ("procedure Timed_Sleep called" & LF));
-
- Timedout := True;
- Yielded := False;
- -- ??? These two boolean seems not relevant here
-
- if Mode = Relative then
- Abs_Time := To_RTIME (Time) + Rt_Get_Time;
- else
- Abs_Time := To_RTIME (Time);
- end if;
-
- Self_ID.Common.LL.Resume_Time := Abs_Time;
- Self_ID.Common.LL.State := RT_TASK_DELAYED;
-
- R_Save_Flags (Flags);
- R_Cli;
- Delete_R (Self_ID);
- Insert_T (Self_ID);
-
- -- Check if the timer needs to be set
-
- if Timer_Queue.Common.LL.Succ = To_Address (Self_ID) then
- Rt_Set_Timer (Abs_Time);
- end if;
-
- -- Another way to do it
- --
- -- if Abs_Time <
- -- To_Task_ID (Timer_Queue.Common.LL.Succ).Common.LL.Resume_Time
- -- then
- -- Rt_Set_Timer (Abs_Time);
- -- end if;
-
- -- Arrange to unlock Self_ID's ATCB lock. see comments in Sleep
-
- if Self_ID.Common.LL.L.Owner = To_Address (Self_ID) then
- Self_ID.Common.LL.L.Owner := System.Null_Address;
-
- if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then
- Self_ID.Common.LL.Active_Priority :=
- Self_ID.Common.Current_Priority;
- Self_ID.Common.LL.Outer_Lock := null;
-
- else
- Self_ID.Common.LL.Active_Priority :=
- Self_ID.Common.LL.L.Pre_Locking_Priority;
- end if;
- end if;
-
- R_Restore_Flags (Flags);
- Rt_Schedule;
-
- -- Before leaving, regain the lock
-
- Write_Lock (Self_ID);
- end Timed_Sleep;
-
- -----------------
- -- Timed_Delay --
- -----------------
-
- -- This is for use in implementing delay statements, so we assume
- -- the caller is not abort-deferred and is holding no locks.
- -- Self_ID can only be awakened after the timeout, no Wakeup on it.
-
- procedure Timed_Delay
- (Self_ID : Task_ID;
- Time : Duration;
- Mode : ST.Delay_Modes)
- is
- Flags : Integer;
- Abs_Time : RTIME;
-
- begin
- pragma Debug (Printk ("procedure Timed_Delay called" & LF));
-
- -- Only the little window between deferring abort and
- -- locking Self_ID is the reason we need to
- -- check for pending abort and priority change below! :(
-
- Write_Lock (Self_ID);
-
- -- Take the lock in case its ATCB needs to be modified
-
- if Mode = Relative then
- Abs_Time := To_RTIME (Time) + Rt_Get_Time;
- else
- Abs_Time := To_RTIME (Time);
- end if;
-
- Self_ID.Common.LL.Resume_Time := Abs_Time;
- Self_ID.Common.LL.State := RT_TASK_DELAYED;
-
- R_Save_Flags (Flags);
- R_Cli;
- Delete_R (Self_ID);
- Insert_T (Self_ID);
-
- -- Check if the timer needs to be set
-
- if Timer_Queue.Common.LL.Succ = To_Address (Self_ID) then
- Rt_Set_Timer (Abs_Time);
- end if;
-
- -- Arrange to unlock Self_ID's ATCB lock.
- -- Note that the code below is slightly different from Unlock, so
- -- it is more than inline it.
-
- if To_Task_ID (Self_ID.Common.LL.L.Owner) = Self_ID then
- Self_ID.Common.LL.L.Owner := System.Null_Address;
-
- if Self_ID.Common.LL.Outer_Lock = Self_ID.Common.LL.L'Access then
- Self_ID.Common.LL.Active_Priority :=
- Self_ID.Common.Current_Priority;
- Self_ID.Common.LL.Outer_Lock := null;
-
- else
- Self_ID.Common.LL.Active_Priority :=
- Self_ID.Common.LL.L.Pre_Locking_Priority;
- end if;
- end if;
-
- R_Restore_Flags (Flags);
- Rt_Schedule;
- end Timed_Delay;
-
- ---------------------
- -- Monotonic_Clock --
- ---------------------
-
- -- RTIME is represented as a 64-bit signed count of ticks,
- -- where there are 1_193_180 ticks per second.
-
- -- Let T be a count of ticks and N the corresponding count of nanoseconds.
- -- From the following relationship
- -- T / (ticks_per_second) = N / (ns_per_second)
- -- where ns_per_second is 1_000_000_000 (number of nanoseconds in
- -- a second), we get
- -- T * (ns_per_second) = N * (ticks_per_second)
- -- or
- -- T * 1_000_000_000 = N * 1_193_180
- -- which can be reduced to
- -- T * 50_000_000 = N * 59_659
- -- Let Nano_Count = 50_000_000 and Tick_Count = 59_659, we then have
- -- T * Nano_Count = N * Tick_Count
-
- -- IMPORTANT FACT:
- -- These numbers are small enough that we can do arithmetic
- -- on them without overflowing 64 bits. To see this, observe
-
- -- 10**3 = 1000 < 1024 = 2**10
- -- Tick_Count < 60 * 1000 < 64 * 1024 < 2**16
- -- Nano_Count < 50 * 1000 * 1000 < 64 * 1024 * 1024 < 2**26
-
- -- It follows that if 0 <= R < Tick_Count, we can compute
- -- R * Nano_Count < 2**42 without overflow in 64 bits.
- -- Similarly, if 0 <= R < Nano_Count, we can compute
- -- R * Tick_Count < 2**42 without overflow in 64 bits.
-
- -- GNAT represents Duration as a count of nanoseconds internally.
-
- -- To convert T from RTIME to Duration, let
- -- Q = T / Tick_Count, with truncation
- -- R = T - Q * Tick_Count, the remainder 0 <= R < Tick_Count
- -- so
- -- N * Tick_Count
- -- = T * Nano_Count - Q * Tick_Count * Nano_Count
- -- + Q * Tick_Count * Nano_Count
- -- = (T - Q * Tick_Count) * Nano_Count
- -- + (Q * Nano_Count) * Tick_Count
- -- = R * Nano_Count + (Q * Nano_Count) * Tick_Count
-
- -- Now, let
- -- Q1 = R * Nano_Count / Tick_Count, with truncation
- -- R1 = R * Nano_Count - Q1 * Tick_Count, 0 <= R1 <Tick_Count
- -- R * Nano_Count = Q1 * Tick_Count + R1
- -- so
- -- N * Tick_Count
- -- = R * Nano_Count + (Q * Nano_Count) * Tick_Count
- -- = Q1 * Tick_Count + R1 + (Q * Nano_Count) * Tick_Count
- -- = R1 + (Q * Nano_Count + Q1) * Tick_Count
- -- and
- -- N = Q * Nano_Count + Q1 + R1 /Tick_Count,
- -- where 0 <= R1 /Tick_Count < 1
-
- function To_Duration (T : RTIME) return Duration is
- Q, Q1, RN : RTIME;
- begin
- Q := T / Tick_Count;
- RN := (T - Q * Tick_Count) * Nano_Count;
- Q1 := RN / Tick_Count;
- return Raw_Duration (Q * Nano_Count + Q1);
- end To_Duration;
-
- -- To convert D from Duration to RTIME,
- -- Let D be a Duration value, and N be the representation of D as an
- -- integer count of nanoseconds. Let
- -- Q = N / Nano_Count, with truncation
- -- R = N - Q * Nano_Count, the remainder 0 <= R < Nano_Count
- -- so
- -- T * Nano_Count
- -- = N * Tick_Count - Q * Nano_Count * Tick_Count
- -- + Q * Nano_Count * Tick_Count
- -- = (N - Q * Nano_Count) * Tick_Count
- -- + (Q * Tick_Count) * Nano_Count
- -- = R * Tick_Count + (Q * Tick_Count) * Nano_Count
- -- Now, let
- -- Q1 = R * Tick_Count / Nano_Count, with truncation
- -- R1 = R * Tick_Count - Q1 * Nano_Count, 0 <= R1 < Nano_Count
- -- R * Tick_Count = Q1 * Nano_Count + R1
- -- so
- -- T * Nano_Count
- -- = R * Tick_Count + (Q * Tick_Count) * Nano_Count
- -- = Q1 * Nano_Count + R1 + (Q * Tick_Count) * Nano_Count
- -- = (Q * Tick_Count + Q1) * Nano_Count + R1
- -- and
- -- T = Q * Tick_Count + Q1 + R1 / Nano_Count,
- -- where 0 <= R1 / Nano_Count < 1
-
- function To_RTIME (D : Duration) return RTIME is
- N : RTIME := Raw_RTIME (D);
- Q, Q1, RT : RTIME;
-
- begin
- Q := N / Nano_Count;
- RT := (N - Q * Nano_Count) * Tick_Count;
- Q1 := RT / Nano_Count;
- return Q * Tick_Count + Q1;
- end To_RTIME;
-
- function Monotonic_Clock return Duration is
- begin
- pragma Debug (Printk ("procedure Clock called" & LF));
-
- return To_Duration (Rt_Get_Time);
- end Monotonic_Clock;
-
- -------------------
- -- RT_Resolution --
- -------------------
-
- function RT_Resolution return Duration is
- begin
- return 10#1.0#E-6;
- end RT_Resolution;
-
- ------------
- -- Wakeup --
- ------------
-
- procedure Wakeup (T : Task_ID; Reason : ST.Task_States) is
- Flags : Integer;
- begin
- pragma Debug (Printk ("procedure Wakeup called" & LF));
-
- T.Common.State := Reason;
- T.Common.LL.State := RT_TASK_READY;
-
- R_Save_Flags (Flags);
- R_Cli;
-
- if Timer_Queue.Common.LL.Succ = To_Address (T) then
- -- T is the first task in Timer_Queue, further check
-
- if T.Common.LL.Succ = Timer_Queue'Address then
- -- T is the only task in Timer_Queue, so deactivate timer
-
- Rt_No_Timer;
-
- else
- -- T is the first task in Timer_Queue, so set timer to T's
- -- successor's Resume_Time
-
- Rt_Set_Timer (To_Task_ID (T.Common.LL.Succ).Common.LL.Resume_Time);
- end if;
- end if;
-
- Delete_T (T);
-
- -- If T is in Timer_Queue, T is removed. If not, nothing happened
-
- Insert_R (T);
- R_Restore_Flags (Flags);
-
- Rt_Schedule;
- end Wakeup;
-
- -----------
- -- Yield --
- -----------
-
- procedure Yield (Do_Yield : Boolean := True) is
- Flags : Integer;
- begin
- pragma Debug (Printk ("procedure Yield called" & LF));
-
- pragma Assert (Current_Task /= To_Task_ID (Idle_Task'Address));
-
- R_Save_Flags (Flags);
- R_Cli;
- Delete_R (Current_Task);
- Insert_R (Current_Task);
-
- -- Remove Current_Task from the top of the Ready_Queue
- -- and reinsert it back at proper position (the end of
- -- tasks with the same active priority).
-
- R_Restore_Flags (Flags);
- Rt_Schedule;
- end Yield;
-
- ------------------
- -- Set_Priority --
- ------------------
-
- -- This version implicitly assume that T is the Current_Task
-
- procedure Set_Priority
- (T : Task_ID;
- Prio : System.Any_Priority;
- Loss_Of_Inheritance : Boolean := False)
- is
- Flags : Integer;
- begin
- pragma Debug (Printk ("procedure Set_Priority called" & LF));
- pragma Assert (T = Self);
-
- T.Common.Current_Priority := Prio;
-
- if T.Common.LL.Outer_Lock /= null then
- -- If the task T is holding any lock, defer the priority change
- -- until the lock is released. That is, T's Active_Priority will
- -- be set to Prio after it unlocks the outer-most lock. See
- -- Unlock for detail.
- -- Nothing needs to be done here for this case
-
- null;
- else
- -- If T is not holding any lock, change the priority right away.
-
- R_Save_Flags (Flags);
- R_Cli;
- T.Common.LL.Active_Priority := Prio;
- Delete_R (T);
- Insert_RF (T);
-
- -- Insert at the front of the queue for its new priority
-
- R_Restore_Flags (Flags);
- end if;
-
- Rt_Schedule;
- end Set_Priority;
-
- ------------------
- -- Get_Priority --
- ------------------
-
- function Get_Priority (T : Task_ID) return System.Any_Priority is
- begin
- pragma Debug (Printk ("procedure Get_Priority called" & LF));
-
- return T.Common.Current_Priority;
- end Get_Priority;
-
- ----------------
- -- Enter_Task --
- ----------------
-
- -- Do any target-specific initialization that is needed for a new task
- -- that has to be done by the task itself. This is called from the task
- -- wrapper, immediately after the task starts execution.
-
- procedure Enter_Task (Self_ID : Task_ID) is
- begin
- -- Use this as "hook" to re-enable interrupts.
- pragma Debug (Printk ("procedure Enter_Task called" & LF));
-
- R_Sti;
- end Enter_Task;
-
- ----------------
- -- New_ATCB --
- ----------------
-
- function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is
- T : constant Task_ID := Available_TCBs;
- begin
- pragma Debug (Printk ("function New_ATCB called" & LF));
-
- if Entry_Num /= 0 then
- -- We are preallocating all TCBs, so they must all have the
- -- same number of entries, which means the value of
- -- Entry_Num must be bounded. We probably could choose a
- -- non-zero upper bound here, but the Ravenscar Profile
- -- specifies that there be no task entries.
- -- ???
- -- Later, do something better for recovery from this error.
-
- null;
- end if;
-
- if T /= null then
- Available_TCBs := To_Task_ID (T.Common.LL.Next);
- T.Common.LL.Next := System.Null_Address;
- Known_Tasks (T.Known_Tasks_Index) := T;
- end if;
-
- return T;
- end New_ATCB;
-
- ----------------------
- -- Initialize_TCB --
- ----------------------
-
- procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
- begin
- pragma Debug (Printk ("procedure Initialize_TCB called" & LF));
-
- -- Give the task a unique serial number.
-
- Self_ID.Serial_Number := Next_Serial_Number;
- Next_Serial_Number := Next_Serial_Number + 1;
- pragma Assert (Next_Serial_Number /= 0);
-
- Self_ID.Common.LL.L.Ceiling_Priority := System.Any_Priority'Last;
- Self_ID.Common.LL.L.Owner := System.Null_Address;
- Succeeded := True;
- end Initialize_TCB;
-
- -----------------
- -- Create_Task --
- -----------------
-
- procedure Create_Task
- (T : Task_ID;
- Wrapper : System.Address;
- Stack_Size : System.Parameters.Size_Type;
- Priority : System.Any_Priority;
- Succeeded : out Boolean)
- is
- Adjusted_Stack_Size : Integer;
- Bottom : System.Address;
- Flags : Integer;
-
- begin
- pragma Debug (Printk ("procedure Create_Task called" & LF));
-
- Succeeded := True;
-
- if T.Common.LL.Magic = RT_TASK_MAGIC then
- Succeeded := False;
- return;
- end if;
-
- if Stack_Size = Unspecified_Size then
- Adjusted_Stack_Size := To_Integer (Default_Stack_Size);
- elsif Stack_Size < Minimum_Stack_Size then
- Adjusted_Stack_Size := To_Integer (Minimum_Stack_Size);
- else
- Adjusted_Stack_Size := To_Integer (Stack_Size);
- end if;
-
- Bottom := Kmalloc (Adjusted_Stack_Size, GFP_KERNEL);
-
- if Bottom = System.Null_Address then
- Succeeded := False;
- return;
- end if;
-
- T.Common.LL.Uses_Fp := 1;
-
- -- This field has to be reset to 1 if T uses FP unit. But, without
- -- a library-level procedure provided by this package, it cannot
- -- be set easily. So temporarily, set it to 1 (which means all the
- -- tasks will use FP unit. ???
-
- T.Common.LL.Magic := RT_TASK_MAGIC;
- T.Common.LL.State := RT_TASK_READY;
- T.Common.LL.Succ := To_Address (T);
- T.Common.LL.Pred := To_Address (T);
- T.Common.LL.Active_Priority := Priority;
- T.Common.Current_Priority := Priority;
-
- T.Common.LL.Stack_Bottom := Bottom;
- T.Common.LL.Stack := Bottom + Storage_Offset (Adjusted_Stack_Size);
-
- -- Store the value T into the stack, so that Task_wrapper (defined
- -- in System.Tasking.Stages) will find that value for its parameter
- -- Self_ID, when the scheduler eventually transfers control to the
- -- new task.
-
- T.Common.LL.Stack := T.Common.LL.Stack - Addr_Bytes;
- To_Address_Ptr (T.Common.LL.Stack).all := To_Address (T);
-
- -- Leave space for the return address, which will not be used,
- -- since the task wrapper should never return.
-
- T.Common.LL.Stack := T.Common.LL.Stack - Addr_Bytes;
- To_Address_Ptr (T.Common.LL.Stack).all := System.Null_Address;
-
- -- Put the entry point address of the task wrapper
- -- procedure on the new top of the stack.
-
- T.Common.LL.Stack := T.Common.LL.Stack - Addr_Bytes;
- To_Address_Ptr (T.Common.LL.Stack).all := Wrapper;
-
- R_Save_Flags (Flags);
- R_Cli;
- Insert_R (T);
- R_Restore_Flags (Flags);
- end Create_Task;
-
- ------------------
- -- Finalize_TCB --
- ------------------
-
- procedure Finalize_TCB (T : Task_ID) is
- begin
- pragma Debug (Printk ("procedure Finalize_TCB called" & LF));
-
- pragma Assert (T.Common.LL.Succ = To_Address (T));
-
- if T.Common.LL.State = RT_TASK_DORMANT then
- Known_Tasks (T.Known_Tasks_Index) := null;
- T.Common.LL.Next := To_Address (Available_TCBs);
- Available_TCBs := T;
- Kfree (T.Common.LL.Stack_Bottom);
- end if;
- end Finalize_TCB;
-
- ---------------
- -- Exit_Task --
- ---------------
-
- procedure Exit_Task is
- Flags : Integer;
- begin
- pragma Debug (Printk ("procedure Exit_Task called" & LF));
- pragma Assert (Current_Task /= To_Task_ID (Idle_Task'Address));
- pragma Assert (Current_Task /= Environment_Task_ID);
-
- R_Save_Flags (Flags);
- R_Cli;
- Current_Task.Common.LL.State := RT_TASK_DORMANT;
- Current_Task.Common.LL.Magic := 0;
- Delete_R (Current_Task);
- R_Restore_Flags (Flags);
- Rt_Schedule;
- end Exit_Task;
-
- ----------------
- -- Abort_Task --
- ----------------
-
- -- ??? Not implemented for now
-
- procedure Abort_Task (T : Task_ID) is
- -- Should cause T to raise Abort_Signal the next time it
- -- executes.
- -- ??? Can this ever be called when T = Current_Task?
- -- To be safe, do nothing in this case.
- begin
- pragma Debug (Printk ("procedure Abort_Task called" & LF));
- null;
- end Abort_Task;
-
- ----------------
- -- Check_Exit --
- ----------------
-
- -- Dummy versions. The only currently working versions is for solaris
- -- (native).
- -- We should probably copy the working versions over from the Solaris
- -- version of this package, with any appropriate changes, since without
- -- the checks on it will probably be nearly impossible to debug the
- -- run-time system.
-
- -- Not implemented for now
-
- function Check_Exit (Self_ID : Task_ID) return Boolean is
- begin
- pragma Debug (Printk ("function Check_Exit called" & LF));
-
- return True;
- end Check_Exit;
-
- --------------------
- -- Check_No_Locks --
- --------------------
-
- function Check_No_Locks (Self_ID : Task_ID) return Boolean is
- begin
- pragma Debug (Printk ("function Check_No_Locks called" & LF));
-
- if Self_ID.Common.LL.Outer_Lock = null then
- return True;
- else
- return False;
- end if;
- end Check_No_Locks;
-
- ----------------------
- -- Environment_Task --
- ----------------------
-
- function Environment_Task return Task_ID is
- begin
- return Environment_Task_ID;
- end Environment_Task;
-
- --------------
- -- Lock_RTS --
- --------------
-
- procedure Lock_RTS is
- begin
- Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
- end Lock_RTS;
-
- ----------------
- -- Unlock_RTS --
- ----------------
-
- procedure Unlock_RTS is
- begin
- Unlock (Single_RTS_Lock'Access, Global_Lock => True);
- end Unlock_RTS;
-
- -----------------
- -- Stack_Guard --
- -----------------
-
- -- Not implemented for now
-
- procedure Stack_Guard (T : Task_ID; On : Boolean) is
- begin
- null;
- end Stack_Guard;
-
- --------------------
- -- Get_Thread_Id --
- --------------------
-
- function Get_Thread_Id (T : Task_ID) return OSI.Thread_Id is
- begin
- return To_Address (T);
- end Get_Thread_Id;
-
- ------------------
- -- Suspend_Task --
- ------------------
-
- function Suspend_Task
- (T : Task_ID;
- Thread_Self : OSI.Thread_Id) return Boolean is
- begin
- return False;
- end Suspend_Task;
-
- -----------------
- -- Resume_Task --
- -----------------
-
- function Resume_Task
- (T : ST.Task_ID;
- Thread_Self : OSI.Thread_Id) return Boolean is
- begin
- return False;
- end Resume_Task;
-
- -----------------
- -- Init_Module --
- -----------------
-
- function Init_Module return Integer is
- procedure adainit;
- pragma Import (C, adainit);
-
- begin
- adainit;
- In_Elab_Code := False;
- Set_Priority (Environment_Task_ID, Any_Priority'First);
- return 0;
- end Init_Module;
-
- --------------------
- -- Cleanup_Module --
- --------------------
-
- procedure Cleanup_Module is
- procedure adafinal;
- pragma Import (C, adafinal);
-
- begin
- adafinal;
- end Cleanup_Module;
-
- ----------------
- -- Initialize --
- ----------------
-
- -- The environment task is "special". The TCB of the environment task is
- -- not in the TCB_Array above. Logically, all initialization code for the
- -- runtime system is executed by the environment task, but until the
- -- environment task has initialized its own TCB we dare not execute any
- -- calls that try to access the TCB of Current_Task. It is allocated by
- -- target-independent runtime system code, in System.Tasking.Initializa-
- -- tion.Init_RTS, before the call to this procedure Initialize. The
- -- target-independent runtime system initializes all the components that
- -- are target-independent, but this package needs to be given a chance to
- -- initialize the target-dependent data. We do that in this procedure.
-
- -- In the present implementation, Environment_Task is set to be the
- -- regular GNU/Linux kernel task.
-
- procedure Initialize (Environment_Task : Task_ID) is
- begin
- pragma Debug (Printk ("procedure Initialize called" & LF));
-
- Environment_Task_ID := Environment_Task;
-
- -- Build the list of available ATCB's.
-
- Available_TCBs := To_Task_ID (TCB_Array (1)'Address);
-
- for J in TCB_Array'First + 1 .. TCB_Array'Last - 1 loop
- -- Note that the zeroth element in TCB_Array is not used, see
- -- comments following the declaration of TCB_Array
-
- TCB_Array (J).Common.LL.Next := TCB_Array (J + 1)'Address;
- end loop;
-
- TCB_Array (TCB_Array'Last).Common.LL.Next := System.Null_Address;
-
- -- Initialize the idle task, which is the head of Ready_Queue.
-
- Idle_Task.Common.LL.Magic := RT_TASK_MAGIC;
- Idle_Task.Common.LL.State := RT_TASK_READY;
- Idle_Task.Common.Current_Priority := System.Any_Priority'First;
- Idle_Task.Common.LL.Active_Priority := System.Any_Priority'First;
- Idle_Task.Common.LL.Succ := Idle_Task'Address;
- Idle_Task.Common.LL.Pred := Idle_Task'Address;
-
- -- Initialize the regular GNU/Linux kernel task.
-
- Environment_Task.Common.LL.Magic := RT_TASK_MAGIC;
- Environment_Task.Common.LL.State := RT_TASK_READY;
- Environment_Task.Common.Current_Priority := System.Any_Priority'First;
- Environment_Task.Common.LL.Active_Priority := System.Any_Priority'First;
- Environment_Task.Common.LL.Succ := To_Address (Environment_Task);
- Environment_Task.Common.LL.Pred := To_Address (Environment_Task);
-
- -- Initialize the head of Timer_Queue
-
- Timer_Queue.Common.LL.Succ := Timer_Queue'Address;
- Timer_Queue.Common.LL.Pred := Timer_Queue'Address;
- Timer_Queue.Common.LL.Resume_Time := Max_Sensible_Delay;
-
- -- Set the current task to regular GNU/Linux kernel task
-
- Current_Task := Environment_Task;
-
- -- Set Timer_Wrapper to be the timer handler
-
- Rt_Free_Timer;
- Rt_Request_Timer (Timer_Wrapper'Address);
-
- -- Initialize the lock used to synchronize chain of all ATCBs.
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- -- Single_Lock isn't supported in this configuration
- pragma Assert (not Single_Lock);
-
- Enter_Task (Environment_Task);
- end Initialize;
-
-end System.Task_Primitives.Operations;
diff --git a/gcc/ada/5sintman.adb b/gcc/ada/5sintman.adb
index 77315a7a15b..d8d5963fca2 100644
--- a/gcc/ada/5sintman.adb
+++ b/gcc/ada/5sintman.adb
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -77,10 +77,17 @@ package body System.Interrupt_Management is
info : access siginfo_t;
context : access ucontext_t);
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
procedure Notify_Exception
(signo : Signal;
info : access siginfo_t;
- context : access ucontext_t) is
+ context : access ucontext_t)
+ is
+ pragma Warnings (Off, context);
+
begin
-- Check that treatment of exception propagation here
-- is consistent with treatment of the abort signal in
@@ -136,6 +143,21 @@ begin
mask : aliased sigset_t;
Result : Interfaces.C.int;
+ function State (Int : Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+ --
+ User : constant Character := 'u';
+ Runtime : constant Character := 'r';
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
begin
-- Need to call pthread_init very early because it is doing signal
-- initializations.
@@ -169,37 +191,68 @@ begin
act.sa_mask := mask;
- Keep_Unmasked (Abort_Task_Interrupt) := True;
+ pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
- -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the
- -- same time, disable the ability of handling this signal
- -- via Ada.Interrupts.
- -- The pragma Unreserve_All_Interrupts let the user the ability to
- -- change this behavior.
+ for J in Exception_Interrupts'Range loop
+ if State (Exception_Interrupts (J)) /= User then
+ Keep_Unmasked (Exception_Interrupts (J)) := True;
+ Reserve (Exception_Interrupts (J)) := True;
+
+ if State (Exception_Interrupts (J)) /= Default then
+ Result :=
+ sigaction
+ (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end loop;
- if Unreserve_All_Interrupts = 0 then
+ if State (Abort_Task_Interrupt) /= User then
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+ Reserve (Abort_Task_Interrupt) := True;
+ end if;
+
+ -- Set SIGINT to unmasked state as long as it's
+ -- not in "User" state. Check for Unreserve_All_Interrupts last
+
+ if State (SIGINT) /= User then
Keep_Unmasked (SIGINT) := True;
+ Reserve (SIGINT) := True;
end if;
- for J in Exception_Interrupts'Range loop
- Keep_Unmasked (Exception_Interrupts (J)) := True;
- Result :=
- sigaction
- (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
+ -- Check all signals for state that requires keeping them
+ -- unmasked and reserved
+
+ for J in Interrupt_ID'Range loop
+ if State (J) = Default or else State (J) = Runtime then
+ Keep_Unmasked (J) := True;
+ Reserve (J) := True;
+ end if;
end loop;
+ -- Add the set of signals that must always be unmasked for this target
+
for J in Unmasked'Range loop
Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
+ Reserve (Interrupt_ID (Unmasked (J))) := True;
end loop;
- Reserve := Keep_Unmasked or Keep_Masked;
+ -- Add target-specific reserved signals
for J in Reserved'Range loop
Reserve (Interrupt_ID (Reserved (J))) := True;
end loop;
+ -- Process pragma Unreserve_All_Interrupts. This overrides any
+ -- settings due to pragma Interrupt_State:
+
+ if Unreserve_All_Interrupts /= 0 then
+ Keep_Unmasked (SIGINT) := False;
+ Reserve (SIGINT) := False;
+ end if;
+
-- We do not have Signal 0 in reality. We just use this value
-- to identify not existing signals (see s-intnam.ads). Therefore,
-- Signal 0 should not be used in all signal related operations hence
diff --git a/gcc/ada/5sml-tgt.adb b/gcc/ada/5sml-tgt.adb
new file mode 100644
index 00000000000..901e7a68bee
--- /dev/null
+++ b/gcc/ada/5sml-tgt.adb
@@ -0,0 +1,367 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T --
+-- (Solaris Version) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a set of target dependent routines to build
+-- static, dynamic and shared libraries.
+
+-- This is the Solaris version of the body
+
+with MLib.Fil;
+with MLib.Utl;
+with Namet; use Namet;
+with Opt;
+with Output; use Output;
+with Prj.Com;
+with System;
+
+package body MLib.Tgt is
+
+ No_Arguments : aliased Argument_List := (1 .. 0 => null);
+ Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access;
+
+ Wl_Init_String : constant String := "-Wl,-zinitarray=";
+ Wl_Fini_String : constant String := "-Wl,-zfiniarray=";
+
+ Init_Fini_List : constant Argument_List_Access :=
+ new Argument_List'(1 => null,
+ 2 => null);
+
+ -- Used to put switches for automatic elaboration/finalization
+
+ ---------------------
+ -- Archive_Builder --
+ ---------------------
+
+ function Archive_Builder return String is
+ begin
+ return "ar";
+ end Archive_Builder;
+
+ -----------------------------
+ -- Archive_Builder_Options --
+ -----------------------------
+
+ function Archive_Builder_Options return String_List_Access is
+ begin
+ return new String_List'(1 => new String'("cr"));
+ end Archive_Builder_Options;
+
+ -----------------
+ -- Archive_Ext --
+ -----------------
+
+ function Archive_Ext return String is
+ begin
+ return "a";
+ end Archive_Ext;
+
+ ---------------------
+ -- Archive_Indexer --
+ ---------------------
+
+ function Archive_Indexer return String is
+ begin
+ return "ranlib";
+ end Archive_Indexer;
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Foreign : Argument_List;
+ Afiles : Argument_List;
+ Options : Argument_List;
+ Interfaces : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Driver_Name : Name_Id := No_Name;
+ Lib_Address : String := "";
+ Lib_Version : String := "";
+ Relocatable : Boolean := False;
+ Auto_Init : Boolean := False)
+ is
+ pragma Unreferenced (Foreign);
+ pragma Unreferenced (Afiles);
+ pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Lib_Address);
+ pragma Unreferenced (Relocatable);
+
+ Lib_File : constant String :=
+ Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Filename, DLL_Ext);
+
+ Version_Arg : String_Access;
+ Symbolic_Link_Needed : Boolean := False;
+
+ Init_Fini : Argument_List_Access := Empty_Argument_List;
+
+ begin
+ if Opt.Verbose_Mode then
+ Write_Str ("building relocatable shared library ");
+ Write_Line (Lib_File);
+ end if;
+
+ -- If specified, add automatic elaboration/finalization
+ if Auto_Init then
+ Init_Fini := Init_Fini_List;
+ Init_Fini (1) :=
+ new String'(Wl_Init_String & Lib_Filename & "init");
+ Init_Fini (2) :=
+ new String'(Wl_Fini_String & Lib_Filename & "final");
+ end if;
+
+ if Lib_Version = "" then
+ Utl.Gcc
+ (Output_File => Lib_File,
+ Objects => Ofiles,
+ Options => Options & Init_Fini.all,
+ Driver_Name => Driver_Name);
+
+ else
+ Version_Arg := new String'("-Wl,-h," & Lib_Version);
+
+ if Is_Absolute_Path (Lib_Version) then
+ Utl.Gcc
+ (Output_File => Lib_Version,
+ Objects => Ofiles,
+ Options => Options & Version_Arg & Init_Fini.all,
+ Driver_Name => Driver_Name);
+ Symbolic_Link_Needed := Lib_Version /= Lib_File;
+
+ else
+ Utl.Gcc
+ (Output_File => Lib_Dir & Directory_Separator & Lib_Version,
+ Objects => Ofiles,
+ Options => Options & Version_Arg & Init_Fini.all,
+ Driver_Name => Driver_Name);
+ Symbolic_Link_Needed :=
+ Lib_Dir & Directory_Separator & Lib_Version /= Lib_File;
+ end if;
+
+ if Symbolic_Link_Needed then
+ declare
+ Success : Boolean;
+ Oldpath : String (1 .. Lib_Version'Length + 1);
+ Newpath : String (1 .. Lib_File'Length + 1);
+ Result : Integer;
+
+ function Symlink
+ (Oldpath : System.Address;
+ Newpath : System.Address)
+ return Integer;
+ pragma Import (C, Symlink, "__gnat_symlink");
+
+ begin
+ Oldpath (1 .. Lib_Version'Length) := Lib_Version;
+ Oldpath (Oldpath'Last) := ASCII.NUL;
+ Newpath (1 .. Lib_File'Length) := Lib_File;
+ Newpath (Newpath'Last) := ASCII.NUL;
+
+ Delete_File (Lib_File, Success);
+
+ Result := Symlink (Oldpath'Address, Newpath'Address);
+ end;
+ end if;
+ end if;
+ end Build_Dynamic_Library;
+
+ -------------------------
+ -- Default_DLL_Address --
+ -------------------------
+
+ function Default_DLL_Address return String is
+ begin
+ return "";
+ end Default_DLL_Address;
+
+ -------------
+ -- DLL_Ext --
+ -------------
+
+ function DLL_Ext return String is
+ begin
+ return "so";
+ end DLL_Ext;
+
+ --------------------
+ -- Dynamic_Option --
+ --------------------
+
+ function Dynamic_Option return String is
+ begin
+ return "-shared";
+ end Dynamic_Option;
+
+ -------------------
+ -- Is_Object_Ext --
+ -------------------
+
+ function Is_Object_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".o";
+ end Is_Object_Ext;
+
+ --------------
+ -- Is_C_Ext --
+ --------------
+
+ function Is_C_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".c";
+ end Is_C_Ext;
+
+ --------------------
+ -- Is_Archive_Ext --
+ --------------------
+
+ function Is_Archive_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".a" or else Ext = ".so";
+ end Is_Archive_Ext;
+
+ -------------
+ -- Libgnat --
+ -------------
+
+ function Libgnat return String is
+ begin
+ return "libgnat.a";
+ end Libgnat;
+
+ ------------------------
+ -- Library_Exists_For --
+ ------------------------
+
+ function Library_Exists_For (Project : Project_Id) return Boolean is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
+ "for non library project");
+ return False;
+
+ else
+ declare
+ Lib_Dir : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Dir);
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ if Projects.Table (Project).Library_Kind = Static then
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+ end;
+ end if;
+ end Library_Exists_For;
+
+ ---------------------------
+ -- Library_File_Name_For --
+ ---------------------------
+
+ function Library_File_Name_For (Project : Project_Id) return Name_Id is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
+ "for non library project");
+ return No_Name;
+
+ else
+ declare
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "lib";
+
+ if Projects.Table (Project).Library_Kind = Static then
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+
+ return Name_Find;
+ end;
+ end if;
+ end Library_File_Name_For;
+
+ --------------------------------
+ -- Linker_Library_Path_Option --
+ --------------------------------
+
+ function Linker_Library_Path_Option return String_Access is
+ begin
+ return new String'("-Wl,-R,");
+ end Linker_Library_Path_Option;
+
+ ----------------
+ -- Object_Ext --
+ ----------------
+
+ function Object_Ext return String is
+ begin
+ return "o";
+ end Object_Ext;
+
+ ----------------
+ -- PIC_Option --
+ ----------------
+
+ function PIC_Option return String is
+ begin
+ return "-fPIC";
+ end PIC_Option;
+
+ -----------------------------------------------
+ -- Standalone_Library_Auto_Init_Is_Supported --
+ -----------------------------------------------
+
+ function Standalone_Library_Auto_Init_Is_Supported return Boolean is
+ begin
+ return True;
+ end Standalone_Library_Auto_Init_Is_Supported;
+
+ ---------------------------
+ -- Support_For_Libraries --
+ ---------------------------
+
+ function Support_For_Libraries return Library_Support is
+ begin
+ return Full;
+ end Support_For_Libraries;
+
+end MLib.Tgt;
diff --git a/gcc/ada/5sosinte.adb b/gcc/ada/5sosinte.adb
index 2909c7d0a4e..299625dadc2 100644
--- a/gcc/ada/5sosinte.adb
+++ b/gcc/ada/5sosinte.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2002 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5sosinte.ads b/gcc/ada/5sosinte.ads
index 1bd01f161c5..a9bc30c2aa4 100644
--- a/gcc/ada/5sosinte.ads
+++ b/gcc/ada/5sosinte.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5sosprim.adb b/gcc/ada/5sosprim.adb
new file mode 100644
index 00000000000..b6d529d206c
--- /dev/null
+++ b/gcc/ada/5sosprim.adb
@@ -0,0 +1,124 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . O S _ P R I M I T I V E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1998-2003 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version uses gettimeofday and select
+-- This file is suitable for Solaris (32 and 64 bits).
+
+package body System.OS_Primitives is
+
+ -- ??? These definitions are duplicated from System.OS_Interface
+ -- because we don't want to depend on any package. Consider removing
+ -- these declarations in System.OS_Interface and move these ones in
+ -- the spec.
+
+ type struct_timeval is record
+ tv_sec : Long_Integer;
+ tv_usec : Long_Integer;
+ end record;
+ pragma Convention (C, struct_timeval);
+
+ procedure gettimeofday
+ (tv : access struct_timeval;
+ tz : Address := Null_Address);
+ pragma Import (C, gettimeofday, "gettimeofday");
+
+ procedure C_select
+ (n : Integer := 0;
+ readfds,
+ writefds,
+ exceptfds : Address := Null_Address;
+ timeout : access struct_timeval);
+ pragma Import (C, C_select, "select");
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock return Duration is
+ TV : aliased struct_timeval;
+
+ begin
+ gettimeofday (TV'Access);
+ return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
+ end Clock;
+
+ ---------------------
+ -- Monotonic_Clock --
+ ---------------------
+
+ function Monotonic_Clock return Duration renames Clock;
+
+ -----------------
+ -- Timed_Delay --
+ -----------------
+
+ procedure Timed_Delay
+ (Time : Duration;
+ Mode : Integer)
+ is
+ Rel_Time : Duration;
+ Abs_Time : Duration;
+ Check_Time : Duration := Clock;
+ timeval : aliased struct_timeval;
+
+ begin
+ if Mode = Relative then
+ Rel_Time := Time;
+ Abs_Time := Time + Check_Time;
+ else
+ Rel_Time := Time - Check_Time;
+ Abs_Time := Time;
+ end if;
+
+ if Rel_Time > 0.0 then
+ loop
+ timeval.tv_sec := Long_Integer (Rel_Time);
+
+ if Duration (timeval.tv_sec) > Rel_Time then
+ timeval.tv_sec := timeval.tv_sec - 1;
+ end if;
+
+ timeval.tv_usec :=
+ Long_Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6);
+
+ C_select (timeout => timeval'Unchecked_Access);
+ Check_Time := Clock;
+
+ exit when Abs_Time <= Check_Time;
+
+ Rel_Time := Abs_Time - Check_Time;
+ end loop;
+ end if;
+ end Timed_Delay;
+
+end System.OS_Primitives;
diff --git a/gcc/ada/5ssystem.ads b/gcc/ada/5ssystem.ads
index d39b090dc72..80621a76517 100644
--- a/gcc/ada/5ssystem.ads
+++ b/gcc/ada/5ssystem.ads
@@ -118,22 +118,33 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := True;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := True;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := True;
GCC_ZCX_Support : constant Boolean := True;
Front_End_ZCX_Support : constant Boolean := False;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
end System;
diff --git a/gcc/ada/5staprop.adb b/gcc/ada/5staprop.adb
index e23bd0163e5..588c0d3a0c7 100644
--- a/gcc/ada/5staprop.adb
+++ b/gcc/ada/5staprop.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. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -101,9 +101,9 @@ package body System.Task_Primitives.Operations is
package SSL renames System.Soft_Links;
- ------------------
- -- Local Data --
- ------------------
+ ----------------
+ -- Local Data --
+ ----------------
-- The following are logically constants, but need to be initialized
-- at run time.
@@ -130,9 +130,9 @@ package body System.Task_Primitives.Operations is
-- using in error checking.
-- The following are internal configuration constants needed.
- ------------------------
- -- Priority Support --
- ------------------------
+ ----------------------
+ -- Priority Support --
+ ----------------------
Priority_Ceiling_Emulation : constant Boolean := True;
-- controls whether we emulate priority ceiling locking
@@ -153,9 +153,9 @@ package body System.Task_Primitives.Operations is
-- Hold priority info (Real_Time) initialized during the package
-- elaboration.
- -------------------------------------
- -- External Configuration Values --
- -------------------------------------
+ -----------------------------------
+ -- External Configuration Values --
+ -----------------------------------
Time_Slice_Val : Interfaces.C.long;
pragma Import (C, Time_Slice_Val, "__gl_time_slice_val");
@@ -166,51 +166,9 @@ package body System.Task_Primitives.Operations is
Dispatching_Policy : Character;
pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy");
- --------------------------------
- -- Foreign Threads Detection --
- --------------------------------
-
- -- The following are used to allow the Self function to
- -- automatically generate ATCB's for C threads that happen to call
- -- Ada procedure, which in turn happen to call the Ada run-time system.
-
- type Fake_ATCB;
- type Fake_ATCB_Ptr is access Fake_ATCB;
- type Fake_ATCB is record
- Stack_Base : Interfaces.C.unsigned := 0;
- -- A value of zero indicates the node is not in use.
- Next : Fake_ATCB_Ptr;
- Real_ATCB : aliased Ada_Task_Control_Block (0);
- end record;
-
- Fake_ATCB_List : Fake_ATCB_Ptr;
- -- A linear linked list.
- -- The list is protected by Single_RTS_Lock;
- -- Nodes are added to this list from the front.
- -- Once a node is added to this list, it is never removed.
-
- Fake_Task_Elaborated : aliased Boolean := True;
+ Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads).
- Next_Fake_ATCB : Fake_ATCB_Ptr;
- -- Used to allocate one Fake_ATCB in advance. See comment in New_Fake_ATCB
-
- ------------
- -- Checks --
- ------------
-
- Check_Count : Integer := 0;
- Old_Owner : Task_ID;
- Lock_Count : Integer := 0;
- Unlock_Count : Integer := 0;
-
- function To_Lock_Ptr is
- new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr);
- function To_Task_ID is
- new Unchecked_Conversion (Owner_ID, Task_ID);
- function To_Owner_ID is
- new Unchecked_Conversion (Task_ID, Owner_ID);
-
-----------------------
-- Local Subprograms --
-----------------------
@@ -228,6 +186,9 @@ package body System.Task_Primitives.Operations is
(Sig : Signal;
Code : access siginfo_t;
Context : access ucontext_t);
+ -- Target-dependent binding of inter-thread Abort signal to
+ -- the raising of the Abort_Signal exception.
+ -- See also comments in 7staprop.adb
function To_thread_t is new Unchecked_Conversion
(Integer, System.OS_Interface.thread_t);
@@ -239,14 +200,6 @@ package body System.Task_Primitives.Operations is
function Thread_Body_Access is
new Unchecked_Conversion (System.Address, Thread_Body);
- function New_Fake_ATCB (Stack_Base : Interfaces.C.unsigned) return Task_ID;
- -- Allocate and Initialize a new ATCB. This code can safely be called from
- -- a foreign thread, as it doesn't access implicitly or explicitly
- -- "self" before having initialized the new ATCB.
- pragma Warnings (Off, New_Fake_ATCB);
- -- Disable warning on this function, since the Solaris x86 version does
- -- not use it.
-
------------
-- Checks --
------------
@@ -280,202 +233,88 @@ package body System.Task_Primitives.Operations is
function Check_Finalize_Lock (L : Lock_Ptr) return Boolean;
pragma Inline (Check_Finalize_Lock);
- -------------------
- -- New_Fake_ATCB --
- -------------------
-
- function New_Fake_ATCB (Stack_Base : Interfaces.C.unsigned)
- return Task_ID
- is
- Self_ID : Task_ID;
- P, Q : Fake_ATCB_Ptr;
- Succeeded : Boolean;
- Result : Interfaces.C.int;
-
- begin
- -- This section is ticklish.
- -- We dare not call anything that might require an ATCB, until
- -- we have the new ATCB in place.
- -- Note: we don't use Lock_RTS because we don't yet have an ATCB, and
- -- so can't pass the safety check.
-
- Result := mutex_lock (Single_RTS_Lock.L'Access);
- Q := null;
- P := Fake_ATCB_List;
-
- while P /= null loop
- if P.Stack_Base = 0 then
- Q := P;
- elsif thr_kill (P.Real_ATCB.Common.LL.Thread, 0) /= 0 then
- -- ????
- -- If a C thread that has dependent Ada tasks terminates
- -- abruptly, e.g. as a result of cancellation, any dependent
- -- tasks are likely to hang up in termination.
- P.Stack_Base := 0;
- Q := P;
- end if;
-
- P := P.Next;
- end loop;
-
- if Q = null then
-
- -- Create a new ATCB with zero entries.
-
- Self_ID := Next_Fake_ATCB.Real_ATCB'Access;
- Next_Fake_ATCB.Stack_Base := Stack_Base;
- Next_Fake_ATCB.Next := Fake_ATCB_List;
- Fake_ATCB_List := Next_Fake_ATCB;
- Next_Fake_ATCB := null;
-
- else
-
- -- Reuse an existing fake ATCB.
-
- Self_ID := Q.Real_ATCB'Access;
- Q.Stack_Base := Stack_Base;
- end if;
-
- -- Do the standard initializations
-
- System.Tasking.Initialize_ATCB
- (Self_ID, null, Null_Address, Null_Task, Fake_Task_Elaborated'Access,
- System.Priority'First, Task_Info.Unspecified_Task_Info, 0, Self_ID,
- Succeeded);
- pragma Assert (Succeeded);
-
- -- Record this as the Task_ID for the current thread.
-
- Self_ID.Common.LL.Thread := thr_self;
- Result := thr_setspecific (ATCB_Key, To_Address (Self_ID));
- pragma Assert (Result = 0);
-
- -- Finally, it is safe to use an allocator in this thread.
-
- if Next_Fake_ATCB = null then
- Next_Fake_ATCB := new Fake_ATCB;
- end if;
-
- Self_ID.Master_of_Task := 0;
- Self_ID.Master_Within := Self_ID.Master_of_Task + 1;
-
- for L in Self_ID.Entry_Calls'Range loop
- Self_ID.Entry_Calls (L).Self := Self_ID;
- Self_ID.Entry_Calls (L).Level := L;
- end loop;
+ --------------------
+ -- Local Packages --
+ --------------------
- Self_ID.Common.State := Runnable;
- Self_ID.Awake_Count := 1;
+ package Specific is
- -- Since this is not an ordinary Ada task, we will start out undeferred
+ procedure Initialize (Environment_Task : Task_ID);
+ pragma Inline (Initialize);
+ -- Initialize various data needed by this package.
- Self_ID.Deferral_Level := 0;
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does executing thread have a TCB?
- -- Give the task a unique serial number.
+ procedure Set (Self_Id : Task_ID);
+ pragma Inline (Set);
+ -- Set the self id for the current task.
- Self_ID.Serial_Number := Next_Serial_Number;
- Next_Serial_Number := Next_Serial_Number + 1;
- pragma Assert (Next_Serial_Number /= 0);
-
- System.Soft_Links.Create_TSD (Self_ID.Common.Compiler_Data);
-
- -- ????
- -- The following call is commented out to avoid dependence on
- -- the System.Tasking.Initialization package.
+ function Self return Task_ID;
+ pragma Inline (Self);
+ -- Return a pointer to the Ada Task Control Block of the calling task.
- -- It seems that if we want Ada.Task_Attributes to work correctly
- -- for C threads we will need to raise the visibility of this soft
- -- link to System.Soft_Links.
+ end Specific;
- -- We are putting that off until this new functionality is otherwise
- -- stable.
+ package body Specific is separate;
+ -- The body of this package is target specific.
- -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T);
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
- -- Must not unlock until Next_ATCB is again allocated.
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
+ -- Allocate and Initialize a new ATCB for the current Thread.
- for J in Known_Tasks'Range loop
- if Known_Tasks (J) = null then
- Known_Tasks (J) := Self_ID;
- Self_ID.Known_Tasks_Index := J;
- exit;
- end if;
- end loop;
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_ID is separate;
- Result := mutex_unlock (Single_RTS_Lock.L'Access);
+ ------------
+ -- Checks --
+ ------------
- -- We cannot use Unlock_RTS because we did not use Write_Lock, and so
- -- would not pass the checks.
+ Check_Count : Integer := 0;
+ Old_Owner : Task_ID;
+ Lock_Count : Integer := 0;
+ Unlock_Count : Integer := 0;
- return Self_ID;
- end New_Fake_ATCB;
+ function To_Lock_Ptr is
+ new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr);
+ function To_Task_ID is
+ new Unchecked_Conversion (Owner_ID, Task_ID);
+ function To_Owner_ID is
+ new Unchecked_Conversion (Task_ID, Owner_ID);
-------------------
-- Abort_Handler --
-------------------
- -- Target-dependent binding of inter-thread Abort signal to
- -- the raising of the Abort_Signal exception.
-
- -- The technical issues and alternatives here are essentially
- -- the same as for raising exceptions in response to other
- -- signals (e.g. Storage_Error). See code and comments in
- -- the package body System.Interrupt_Management.
-
- -- Some implementations may not allow an exception to be propagated
- -- out of a handler, and others might leave the signal or
- -- interrupt that invoked this handler masked after the exceptional
- -- return to the application code.
-
- -- GNAT exceptions are originally implemented using setjmp()/longjmp().
- -- On most UNIX systems, this will allow transfer out of a signal handler,
- -- which is usually the only mechanism available for implementing
- -- asynchronous handlers of this kind. However, some
- -- systems do not restore the signal mask on longjmp(), leaving the
- -- abort signal masked.
-
- -- Alternative solutions include:
-
- -- 1. Change the PC saved in the system-dependent Context
- -- parameter to point to code that raises the exception.
- -- Normal return from this handler will then raise
- -- the exception after the mask and other system state has
- -- been restored (see example below).
- -- 2. Use siglongjmp()/sigsetjmp() to implement exceptions.
- -- 3. Unmask the signal in the Abortion_Signal exception handler
- -- (in the RTS).
-
- -- The following procedure would be needed if we can't longjmp out of
- -- a signal handler. (See below.)
-
- -- procedure Raise_Abort_Signal is
- -- begin
- -- raise Standard'Abort_Signal;
- -- end if;
-
- -- ???
- -- The comments above need revising. They are partly obsolete.
-
procedure Abort_Handler
(Sig : Signal;
Code : access siginfo_t;
Context : access ucontext_t)
is
+ pragma Unreferenced (Sig);
+ pragma Unreferenced (Code);
+ pragma Unreferenced (Context);
+
Self_ID : Task_ID := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
begin
- -- Assuming it is safe to longjmp out of a signal handler, the
- -- following code can be used:
+ -- It is not safe to raise an exception when using ZCX and the GCC
+ -- exception handling mechanism.
+
+ if ZCX_By_Default and then GCC_ZCX_Support then
+ return;
+ end if;
if Self_ID.Deferral_Level = 0
and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
and then not Self_ID.Aborting
then
- -- You can comment the following out,
- -- to make all aborts synchronous, for debugging.
-
Self_ID.Aborting := True;
-- Make sure signals used for RTS internal purpose are unmasked
@@ -485,23 +324,7 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
raise Standard'Abort_Signal;
-
- -- ?????
- -- Must be certain that the implementation of "raise"
- -- does not make any OS/thread calls, or at least that
- -- if it makes any, they are safe for interruption by
- -- async. signals.
end if;
-
- -- Otherwise, something like this is required:
- -- if not Abort_Is_Deferred.all then
- -- -- Overwrite the return PC address with the address of the
- -- -- special raise routine, and "return" to that routine's
- -- -- starting address.
- -- Context.PC := Raise_Abort_Signal'Address;
- -- return;
- -- end if;
-
end Abort_Handler;
-------------------
@@ -512,6 +335,9 @@ package body System.Task_Primitives.Operations is
-- bottom of a thread stack, so nothing is needed.
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ pragma Unreferenced (T);
+ pragma Unreferenced (On);
+
begin
null;
end Stack_Guard;
@@ -525,11 +351,144 @@ package body System.Task_Primitives.Operations is
return T.Common.LL.Thread;
end Get_Thread_Id;
- -----------
- -- Self --
- -----------
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : ST.Task_ID) is
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : Interfaces.C.int;
+
+ procedure Configure_Processors;
+ -- Processors configuration
+ -- The user can specify a processor which the program should run
+ -- on to emulate a single-processor system. This can be easily
+ -- done by setting environment variable GNAT_PROCESSOR to one of
+ -- the following :
+ --
+ -- -2 : use the default configuration (run the program on all
+ -- available processors) - this is the same as having
+ -- GNAT_PROCESSOR unset
+ -- -1 : let the RTS choose one processor and run the program on
+ -- that processor
+ -- 0 .. Last_Proc : run the program on the specified processor
+ --
+ -- Last_Proc is equal to the value of the system variable
+ -- _SC_NPROCESSORS_CONF, minus one.
+
+ procedure Configure_Processors is
+ Proc_Acc : constant GNAT.OS_Lib.String_Access :=
+ GNAT.OS_Lib.Getenv ("GNAT_PROCESSOR");
+ Proc : aliased processorid_t; -- User processor #
+ Last_Proc : processorid_t; -- Last processor #
+
+ begin
+ if Proc_Acc.all'Length /= 0 then
+ -- Environment variable is defined
+
+ Last_Proc := Num_Procs - 1;
+
+ if Last_Proc /= -1 then
+ Proc := processorid_t'Value (Proc_Acc.all);
+
+ if Proc <= -2 or else Proc > Last_Proc then
+ -- Use the default configuration
+ null;
+ elsif Proc = -1 then
+ -- Choose a processor
+
+ Result := 0;
+
+ while Proc < Last_Proc loop
+ Proc := Proc + 1;
+ Result := p_online (Proc, PR_STATUS);
+ exit when Result = PR_ONLINE;
+ end loop;
+
+ pragma Assert (Result = PR_ONLINE);
+ Result := processor_bind (P_PID, P_MYID, Proc, null);
+ pragma Assert (Result = 0);
+
+ else
+ -- Use user processor
+
+ Result := processor_bind (P_PID, P_MYID, Proc, null);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end if;
+
+ exception
+ when Constraint_Error =>
+
+ -- Illegal environment variable GNAT_PROCESSOR - ignored
+
+ null;
+ end Configure_Processors;
+
+ function State (Int : System.Interrupt_Management.Interrupt_ID)
+ return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
- function Self return Task_ID is separate;
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
+ -- Start of processing for Initialize
+
+ begin
+ Environment_Task_ID := Environment_Task;
+
+ -- This is done in Enter_Task, but this is too late for the
+ -- Environment Task, since we need to call Self in Check_Locks when
+ -- the run time is compiled with assertions on.
+
+ Specific.Initialize (Environment_Task);
+
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ Enter_Task (Environment_Task);
+
+ -- Install the abort-signal handler
+
+ if State (System.Interrupt_Management.Abort_Task_Interrupt)
+ /= Default
+ then
+ -- Set sa_flags to SA_NODEFER so that during the handler execution
+ -- we do not change the Signal_Mask to be masked for the Abort_Signal
+ -- This is a temporary fix to the problem that the Signal_Mask is
+ -- not restored after the exception (longjmp) from the handler.
+ -- The right fix should be made in sigsetjmp so that we save
+ -- the Signal_Set and restore it after a longjmp.
+ -- In that case, this field should be changed back to 0. ???
+
+ act.sa_flags := 16;
+
+ act.sa_handler := Abort_Handler'Address;
+ Result := sigemptyset (Tmp_Set'Access);
+ pragma Assert (Result = 0);
+ act.sa_mask := Tmp_Set;
+
+ Result :=
+ sigaction (
+ Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+
+ Configure_Processors;
+ end Initialize;
---------------------
-- Initialize_Lock --
@@ -646,9 +605,11 @@ package body System.Task_Primitives.Operations is
end Write_Lock;
procedure Write_Lock
- (L : access RTS_Lock; Global_Lock : Boolean := False)
+ (L : access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
+
begin
if not Single_Lock or else Global_Lock then
pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
@@ -660,6 +621,7 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (T : Task_ID) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock then
pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access)));
@@ -684,6 +646,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
+
begin
pragma Assert (Check_Unlock (Lock_Ptr (L)));
@@ -707,6 +670,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock or else Global_Lock then
pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
@@ -717,6 +681,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (T : Task_ID) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock then
pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access)));
@@ -776,15 +741,23 @@ package body System.Task_Primitives.Operations is
end if;
end Yield;
+ -----------
+ -- Self ---
+ -----------
+
+ function Self return Task_ID renames Specific.Self;
+
------------------
-- Set_Priority --
------------------
procedure Set_Priority
- (T : Task_ID;
- Prio : System.Any_Priority;
+ (T : Task_ID;
+ Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
+ pragma Unreferenced (Loss_Of_Inheritance);
+
Result : Interfaces.C.int;
Param : aliased struct_pcparms;
@@ -885,8 +858,7 @@ package body System.Task_Primitives.Operations is
end if;
end if;
- Result := thr_setspecific (ATCB_Key, To_Address (Self_ID));
- pragma Assert (Result = 0);
+ Specific.Set (Self_ID);
-- We need the above code even if we do direct fetch of Task_ID in Self
-- for the main task on Sun, x86 Solaris and for gcc 2.7.2.
@@ -913,12 +885,33 @@ package body System.Task_Primitives.Operations is
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_ID is
+
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (thr_self);
+ end if;
+ end Register_Foreign_Thread;
+
--------------------
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
Result : Interfaces.C.int := 0;
+
begin
-- Give the task a unique serial number.
@@ -964,6 +957,8 @@ package body System.Task_Primitives.Operations is
Priority : System.Any_Priority;
Succeeded : out Boolean)
is
+ pragma Unreferenced (Priority);
+
Result : Interfaces.C.int;
Adjusted_Stack_Size : Interfaces.C.size_t;
Opts : Interfaces.C.int := THR_DETACHED;
@@ -976,6 +971,7 @@ package body System.Task_Primitives.Operations is
-- actual use.
use System.Task_Info;
+
begin
if Stack_Size = System.Parameters.Unspecified_Size then
Adjusted_Stack_Size :=
@@ -996,7 +992,6 @@ package body System.Task_Primitives.Operations is
-- All tasks in RTS will have All_Tasks_Mask initially.
if T.Common.Task_Info /= null then
-
if T.Common.Task_Info.New_LWP then
Opts := Opts + THR_NEW_LWP;
end if;
@@ -1031,6 +1026,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_TCB (T : Task_ID) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
+ Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
@@ -1051,6 +1047,11 @@ package body System.Task_Primitives.Operations is
end if;
Free (Tmp);
+
+ if Is_Self then
+ Specific.Set (null);
+ end if;
+
end Finalize_TCB;
---------------
@@ -1063,7 +1064,7 @@ package body System.Task_Primitives.Operations is
procedure Exit_Task is
begin
- thr_exit (System.Null_Address);
+ Specific.Set (null);
end Exit_Task;
----------------
@@ -1091,6 +1092,7 @@ package body System.Task_Primitives.Operations is
Reason : Task_States)
is
Result : Interfaces.C.int;
+
begin
pragma Assert (Check_Sleep (Reason));
@@ -1236,7 +1238,9 @@ package body System.Task_Primitives.Operations is
exit when Abs_Time <= Monotonic_Clock;
if Result = 0 or Result = EINTR then
- -- somebody may have called Wakeup for us
+
+ -- Somebody may have called Wakeup for us
+
Timedout := False;
exit;
end if;
@@ -1344,6 +1348,7 @@ package body System.Task_Primitives.Operations is
Reason : Task_States)
is
Result : Interfaces.C.int;
+
begin
pragma Assert (Check_Wakeup (T, Reason));
Result := cond_signal (T.Common.LL.CV'Access);
@@ -1386,7 +1391,7 @@ package body System.Task_Primitives.Operations is
----------------
function Check_Lock (L : Lock_Ptr) return Boolean is
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
P : Lock_Ptr;
begin
@@ -1475,6 +1480,8 @@ package body System.Task_Primitives.Operations is
-----------------
function Check_Sleep (Reason : Task_States) return Boolean is
+ pragma Unreferenced (Reason);
+
Self_ID : Task_ID := Self;
P : Lock_Ptr;
@@ -1519,6 +1526,8 @@ package body System.Task_Primitives.Operations is
Reason : Task_States)
return Boolean
is
+ pragma Unreferenced (Reason);
+
Self_ID : Task_ID := Self;
P : Lock_Ptr;
@@ -1553,7 +1562,7 @@ package body System.Task_Primitives.Operations is
Reason : Task_States)
return Boolean
is
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
begin
-- Is caller holding T's lock?
@@ -1625,7 +1634,8 @@ package body System.Task_Primitives.Operations is
--------------------
function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is
- Self_ID : Task_ID := Self;
+ Self_ID : constant Task_ID := Self;
+
begin
-- Check that caller is abort-deferred
@@ -1717,7 +1727,9 @@ package body System.Task_Primitives.Operations is
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
begin
if T.Common.LL.Thread /= Thread_Self then
return thr_suspend (T.Common.LL.Thread) = 0;
@@ -1732,7 +1744,9 @@ package body System.Task_Primitives.Operations is
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
begin
if T.Common.LL.Thread /= Thread_Self then
return thr_continue (T.Common.LL.Thread) = 0;
@@ -1741,135 +1755,12 @@ package body System.Task_Primitives.Operations is
end if;
end Resume_Task;
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Environment_Task : ST.Task_ID) is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Tmp_Set : aliased sigset_t;
- Result : Interfaces.C.int;
-
- procedure Configure_Processors;
- -- Processors configuration
- -- The user can specify a processor which the program should run
- -- on to emulate a single-processor system. This can be easily
- -- done by setting environment variable GNAT_PROCESSOR to one of
- -- the following :
- --
- -- -2 : use the default configuration (run the program on all
- -- available processors) - this is the same as having
- -- GNAT_PROCESSOR unset
- -- -1 : let the RTS choose one processor and run the program on
- -- that processor
- -- 0 .. Last_Proc : run the program on the specified processor
- --
- -- Last_Proc is equal to the value of the system variable
- -- _SC_NPROCESSORS_CONF, minus one.
-
- procedure Configure_Processors is
- Proc_Acc : constant GNAT.OS_Lib.String_Access :=
- GNAT.OS_Lib.Getenv ("GNAT_PROCESSOR");
- Proc : aliased processorid_t; -- User processor #
- Last_Proc : processorid_t; -- Last processor #
-
- begin
- if Proc_Acc.all'Length /= 0 then
- -- Environment variable is defined
-
- Last_Proc := Num_Procs - 1;
-
- if Last_Proc /= -1 then
- Proc := processorid_t'Value (Proc_Acc.all);
-
- if Proc <= -2 or else Proc > Last_Proc then
- -- Use the default configuration
- null;
- elsif Proc = -1 then
- -- Choose a processor
-
- Result := 0;
-
- while Proc < Last_Proc loop
- Proc := Proc + 1;
- Result := p_online (Proc, PR_STATUS);
- exit when Result = PR_ONLINE;
- end loop;
-
- pragma Assert (Result = PR_ONLINE);
- Result := processor_bind (P_PID, P_MYID, Proc, null);
- pragma Assert (Result = 0);
-
- else
- -- Use user processor
-
- Result := processor_bind (P_PID, P_MYID, Proc, null);
- pragma Assert (Result = 0);
- end if;
- end if;
- end if;
-
- exception
- when Constraint_Error =>
- -- Illegal environment variable GNAT_PROCESSOR - ignored
- null;
- end Configure_Processors;
-
- -- Start of processing for Initialize
-
- begin
- Environment_Task_ID := Environment_Task;
-
- -- This is done in Enter_Task, but this is too late for the
- -- Environment Task, since we need to call Self in Check_Locks when
- -- the run time is compiled with assertions on.
-
- Result := thr_setspecific (ATCB_Key, To_Address (Environment_Task));
- pragma Assert (Result = 0);
-
- -- Initialize the lock used to synchronize chain of all ATCBs.
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- Enter_Task (Environment_Task);
-
- -- Install the abort-signal handler
-
- -- Set sa_flags to SA_NODEFER so that during the handler execution
- -- we do not change the Signal_Mask to be masked for the Abort_Signal.
- -- This is a temporary fix to the problem that the Signal_Mask is
- -- not restored after the exception (longjmp) from the handler.
- -- The right fix should be made in sigsetjmp so that we save
- -- the Signal_Set and restore it after a longjmp.
- -- In that case, this field should be changed back to 0. ???
-
- act.sa_flags := 16;
-
- act.sa_handler := Abort_Handler'Address;
- Result := sigemptyset (Tmp_Set'Access);
- pragma Assert (Result = 0);
- act.sa_mask := Tmp_Set;
-
- Result :=
- sigaction (
- Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
-
- Configure_Processors;
-
- -- Create a free ATCB for use on the Fake_ATCB_List.
-
- Next_Fake_ATCB := new Fake_ATCB;
- end Initialize;
-
-- Package elaboration
begin
declare
Result : Interfaces.C.int;
+
begin
-- Mask Environment task for all signals. The original mask of the
-- Environment task will be recovered by Interrupt_Server task
diff --git a/gcc/ada/5stasinf.ads b/gcc/ada/5stasinf.ads
index 1002ee7ca21..ded456effa1 100644
--- a/gcc/ada/5stasinf.ads
+++ b/gcc/ada/5stasinf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,15 +32,22 @@
------------------------------------------------------------------------------
-- This package contains the definitions and routines associated with the
--- implementation of the Task_Info pragma.
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
+
+-- Note: the compiler generates direct calls to this interface, via Rtsfind.
+-- Any changes to this interface may require corresponding compiler changes.
+
+-- This unit may be used directly from an application program by providing
+-- an appropriate WITH, and the interface can be expected to remain stable.
-- This is the Solaris (native) version of this module.
with System.OS_Interface;
-with Unchecked_Deallocation;
+
package System.Task_Info is
-pragma Elaborate_Body;
--- To ensure that a body is allowed
+ pragma Elaborate_Body;
+ -- To ensure that a body is allowed
-----------------------------------------------------
-- Binding of Tasks to LWPs and LWPs to processors --
@@ -130,13 +137,6 @@ pragma Elaborate_Body;
function New_Bound_Thread_Attributes (CPU : CPU_Number)
return Task_Info_Type;
- type Task_Image_Type is access String;
- -- Used to generate a meaningful identifier for tasks that are variables
- -- and components of variables.
-
- procedure Free_Task_Image is new
- Unchecked_Deallocation (String, Task_Image_Type);
-
Unspecified_Task_Info : constant Task_Info_Type := null;
end System.Task_Info;
diff --git a/gcc/ada/5staspri.ads b/gcc/ada/5staspri.ads
index ea4653ee7f8..b1cb08b1df1 100644
--- a/gcc/ada/5staspri.ads
+++ b/gcc/ada/5staspri.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5stpopse.adb b/gcc/ada/5stpopse.adb
deleted file mode 100644
index a6c1e9e89b3..00000000000
--- a/gcc/ada/5stpopse.adb
+++ /dev/null
@@ -1,204 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SELF --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies, Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a Solaris Sparc (native) version of this package.
-
-with System.Machine_Code;
--- used for Asm
-
-separate (System.Task_Primitives.Operations)
-
-----------
--- Self --
-----------
-
--- For Solaris version of RTS, we use a short cut to get the self
--- information faster:
-
--- We have noticed that on Sparc Solaris, the register g7 always
--- contains the address near the frame pointer (fp) of the active
--- thread (fixed offset). This means, if we declare a variable near
--- the top of the stack for each threads (in our case in the task wrapper)
--- and let the variable hold the Task_ID information, we can get the
--- value without going through the thr_getspecific kernel call.
---
--- There are two things to take care in this trick.
---
--- 1) We need to calculate the offset between the g7 value and the
--- local variable address.
--- Possible Solutions :
--- a) Use gdb to figure out the offset.
--- b) Figure it out during the elaboration of RTS by, say,
--- creating a dummy task.
--- We used solution a) mainly because it is more efficient and keeps
--- the RTS from being cluttered with stuff that we won't be used
--- for all environments (i.e., we would have to at least introduce
--- new interfaces).
---
--- On Sparc Solaris the offset was #10#108# (= #16#6b#) with gcc 2.7.2.
--- With gcc 2.8.0, the offset is #10#116# (= #16#74#).
---
--- 2) We can not use the same offset business for the main thread
--- because we do not use a wrapper for the main thread.
--- Previousely, we used the difference between g7 and fp to determine
--- wether a task was the main task or not. But this was obviousely
--- wrong since it worked only for tasks that use small amount of
--- stack.
--- So, we now take advantage of the code that recognizes foreign
--- threads (see below) for the main task.
---
--- NOTE: What we are doing here is ABSOLUTELY for Solaris 2.4, 2.5 and 2.6
--- on Sun.
-
--- We need to make sure this is OK when we move to other versions
--- of the same OS.
-
--- We always can go back to the old way of doing this and we include
--- the code which use thr_getspecifics. Also, look for %%%%%
--- in comments for other necessary modifications.
-
--- This code happens to work with Solaris 2.5.1 too, but with gcc
--- 2.8.0, this offset is different.
-
--- ??? Try to rethink the approach here to get a more flexible
--- solution at run time ?
-
--- One other solution (close to 1-b) would be to add some scanning
--- routine in Enter_Task to compute the offset since now we have
--- a magic number at the beginning of the task code.
-
--- function Self return Task_ID is
--- Temp : aliased System.Address;
--- Result : Interfaces.C.int;
---
--- begin
--- Result := thr_getspecific (ATCB_Key, Temp'Unchecked_Access);
--- pragma Assert (Result = 0);
--- return To_Task_ID (Temp);
--- end Self;
-
--- To make Ada tasks and C threads interoperate better, we have
--- added some functionality to Self. Suppose a C main program
--- (with threads) calls an Ada procedure and the Ada procedure
--- calls the tasking run-time system. Eventually, a call will be
--- made to self. Since the call is not coming from an Ada task,
--- there will be no corresponding ATCB.
-
--- (The entire Ada run-time system may not have been elaborated,
--- either, but that is a different problem, that we will need to
--- solve another way.)
-
--- What we do in Self is to catch references that do not come
--- from recognized Ada tasks, and create an ATCB for the calling
--- thread.
-
--- The new ATCB will be "detached" from the normal Ada task
--- master hierarchy, much like the existing implicitly created
--- signal-server tasks.
-
--- We will also use such points to poll for disappearance of the
--- threads associated with any implicit ATCBs that we created
--- earlier, and take the opportunity to recover them.
-
--- A nasty problem here is the limitations of the compilation
--- order dependency, and in particular the GNARL/GNULLI layering.
--- To initialize an ATCB we need to assume System.Tasking has
--- been elaborated.
-
-function Self return Task_ID is
- ATCB_Magic_Code : constant := 16#ADAADAAD#;
- -- This is used to allow us to catch attempts to call Self
- -- from outside an Ada task, with high probability.
- -- For an Ada task, Task_Wrapper.Magic_Number = ATCB_Magic_Code.
-
- type Iptr is access Interfaces.C.unsigned;
- function To_Iptr is new Unchecked_Conversion (Interfaces.C.unsigned, Iptr);
-
- type Ptr is access Task_ID;
- function To_Ptr is new Unchecked_Conversion (Interfaces.C.unsigned, Ptr);
-
- X : Ptr;
- Result : Interfaces.C.int;
-
- function Get_G7 return Interfaces.C.unsigned;
- pragma Inline (Get_G7);
-
- use System.Machine_Code;
-
- ------------
- -- Get_G7 --
- ------------
-
- function Get_G7 return Interfaces.C.unsigned is
- Result : Interfaces.C.unsigned;
-
- begin
- Asm ("mov %%g7,%0", Interfaces.C.unsigned'Asm_Output ("=r", Result));
- return Result;
- end Get_G7;
-
--- Start of processing for Self
-
-begin
- if To_Iptr (Get_G7 - 120).all /=
- Interfaces.C.unsigned (ATCB_Magic_Code)
- then
- -- Check whether this is a thread we have seen before (e.g the
- -- main task).
- -- 120 = 116 + Magic_Type'Size/System.Storage_Unit
-
- declare
- Unknown_Task : aliased System.Address;
-
- begin
- Result :=
- thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access);
-
- pragma Assert (Result = 0);
-
- if Unknown_Task = System.Null_Address then
-
- -- We are seeing this thread for the first time.
-
- return New_Fake_ATCB (Get_G7);
-
- else
- return To_Task_ID (Unknown_Task);
- end if;
- end;
- end if;
-
- X := To_Ptr (Get_G7 - 116);
- return X.all;
-
-end Self;
diff --git a/gcc/ada/5stpopsp.adb b/gcc/ada/5stpopsp.adb
new file mode 100644
index 00000000000..8ff57977b9c
--- /dev/null
+++ b/gcc/ada/5stpopsp.adb
@@ -0,0 +1,109 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a version for Solaris native threads.
+
+separate (System.Task_Primitives.Operations)
+package body Specific is
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Environment_Task : Task_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := thr_setspecific (ATCB_Key, To_Address (Environment_Task));
+ pragma Assert (Result = 0);
+ end Initialize;
+
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ Unknown_Task : aliased System.Address;
+ Result : Interfaces.C.int;
+
+ begin
+ Result := thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ return Unknown_Task /= System.Null_Address;
+ end Is_Valid_Task;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (Self_Id : Task_ID) is
+ Result : Interfaces.C.int;
+ begin
+ Result := thr_setspecific (ATCB_Key, To_Address (Self_Id));
+ pragma Assert (Result = 0);
+ end Set;
+
+ ----------
+ -- Self --
+ ----------
+
+ -- To make Ada tasks and C threads interoperate better, we have
+ -- added some functionality to Self. Suppose a C main program
+ -- (with threads) calls an Ada procedure and the Ada procedure
+ -- calls the tasking run-time system. Eventually, a call will be
+ -- made to self. Since the call is not coming from an Ada task,
+ -- there will be no corresponding ATCB.
+
+ -- What we do in Self is to catch references that do not come
+ -- from recognized Ada tasks, and create an ATCB for the calling
+ -- thread.
+
+ -- The new ATCB will be "detached" from the normal Ada task
+ -- master hierarchy, much like the existing implicitly created
+ -- signal-server tasks.
+
+ function Self return Task_ID is
+ Result : Interfaces.C.int;
+ Self_Id : aliased System.Address;
+ begin
+ Result := thr_getspecific (ATCB_Key, Self_Id'Unchecked_Access);
+ pragma Assert (Result = 0);
+
+ if Self_Id = System.Null_Address then
+ return Register_Foreign_Thread;
+ else
+ return To_Task_ID (Self_Id);
+ end if;
+ end Self;
+
+end Specific;
diff --git a/gcc/ada/5svxwork.ads b/gcc/ada/5svxwork.ads
index 0fa38725b80..4fc9fd156e3 100644
--- a/gcc/ada/5svxwork.ads
+++ b/gcc/ada/5svxwork.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5tosinte.ads b/gcc/ada/5tosinte.ads
index 266ba885040..14570656b9b 100644
--- a/gcc/ada/5tosinte.ads
+++ b/gcc/ada/5tosinte.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5tsystem.ads b/gcc/ada/5tsystem.ads
new file mode 100644
index 00000000000..14fcaf06e07
--- /dev/null
+++ b/gcc/ada/5tsystem.ads
@@ -0,0 +1,236 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (OpenVMS DEC Threads Version) --
+-- --
+-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 0.01;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 32;
+ Memory_Size : constant := 2 ** 32;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := Low_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer range 0 .. 31;
+ subtype Priority is Any_Priority range 0 .. 30;
+ subtype Interrupt_Priority is Any_Priority range 31 .. 31;
+
+ Default_Priority : constant Priority := 15;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
+ Denorm : constant Boolean := False;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := True;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := True;
+ Stack_Check_Probes : constant Boolean := True;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := False;
+ GCC_ZCX_Support : constant Boolean := False;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
+ --------------------------
+ -- Underlying Priorities --
+ ---------------------------
+
+ -- Important note: this section of the file must come AFTER the
+ -- definition of the system implementation parameters to ensure
+ -- that the value of these parameters is available for analysis
+ -- of the declarations here (using Rtsfind at compile time).
+
+ -- The underlying priorities table provides a generalized mechanism
+ -- for mapping from Ada priorities to system priorities. In some
+ -- cases a 1-1 mapping is not the convenient or optimal choice.
+
+ -- For DEC Threads OpenVMS, we use the full range of 31 priorities
+ -- in the Ada model, but map them by compression onto the more limited
+ -- range of priorities available in OpenVMS.
+
+ -- To replace the default values of the Underlying_Priorities mapping,
+ -- copy this source file into your build directory, edit the file to
+ -- reflect your desired behavior, and recompile with the command:
+
+ -- $ gcc -c -O3 -gnatpgn system.ads
+
+ -- then recompile the run-time parts that depend on this package:
+
+ -- $ gnatmake -a -gnatn -O3 <your application>
+
+ -- then force rebuilding your application if you need different options:
+
+ -- $ gnatmake -f <your options> <your application>
+
+ type Priorities_Mapping is array (Any_Priority) of Integer;
+ pragma Suppress_Initialization (Priorities_Mapping);
+ -- Suppress initialization in case gnat.adc specifies Normalize_Scalars
+
+ Underlying_Priorities : constant Priorities_Mapping :=
+
+ (Priority'First => 16,
+
+ 1 => 17,
+ 2 => 18,
+ 3 => 18,
+ 4 => 18,
+ 5 => 18,
+ 6 => 19,
+ 7 => 19,
+ 8 => 19,
+ 9 => 20,
+ 10 => 20,
+ 11 => 21,
+ 12 => 21,
+ 13 => 22,
+ 14 => 23,
+
+ Default_Priority => 24,
+
+ 16 => 25,
+ 17 => 25,
+ 18 => 25,
+ 19 => 26,
+ 20 => 26,
+ 21 => 26,
+ 22 => 27,
+ 23 => 27,
+ 24 => 27,
+ 25 => 28,
+ 26 => 28,
+ 27 => 29,
+ 28 => 29,
+ 29 => 30,
+
+ Priority'Last => 30,
+
+ Interrupt_Priority => 31);
+
+ ----------------------------
+ -- Special VMS Interfaces --
+ ----------------------------
+
+ procedure Lib_Stop (I : in Integer);
+ pragma Interface (C, Lib_Stop);
+ pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
+ -- Interface to VMS condition handling. Used by RTSfind and pragma
+ -- {Import,Export}_Exception. Put here because this is the only
+ -- VMS specific package that doesn't drag in tasking.
+
+end System;
diff --git a/gcc/ada/5uintman.adb b/gcc/ada/5uintman.adb
deleted file mode 100644
index 42531492ae7..00000000000
--- a/gcc/ada/5uintman.adb
+++ /dev/null
@@ -1,257 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
--- --
--- B o d y --
--- --
--- Copyright (C) 1991-2002 Florida State University --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
--- This is a Sun OS (FSU THREADS) version of this package
-
--- PLEASE DO NOT add any dependences on other packages. ??? why not ???
--- This package is designed to work with or without tasking support.
-
--- Make a careful study of all signals available under the OS, to see which
--- need to be reserved, kept always unmasked, or kept always unmasked. Be on
--- the lookout for special signals that may be used by the thread library.
-
-with Interfaces.C;
--- used for int
-
-with System.Error_Reporting;
--- used for Shutdown
-
-with System.OS_Interface;
--- used for various Constants, Signal and types
-
-package body System.Interrupt_Management is
-
- use Interfaces.C;
- use System.Error_Reporting;
- use System.OS_Interface;
-
- type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
- Exception_Interrupts : constant Interrupt_List :=
- (SIGFPE, SIGILL, SIGSEGV);
-
- Unreserve_All_Interrupts : Interfaces.C.int;
- pragma Import
- (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Notify_Exception
- (signo : Signal;
- info : access siginfo_t;
- context : access struct_sigcontext);
- -- This function identifies the Ada exception to be raised using
- -- the information when the system received a synchronous signal.
- -- Since this function is machine and OS dependent, different code
- -- has to be provided for different target.
-
- ----------------------
- -- Notify_Exception --
- ----------------------
-
- -- The following code is intended for SunOS on Sparcstation.
-
- procedure Notify_Exception
- (signo : Signal;
- info : access siginfo_t;
- context : access struct_sigcontext)
- is
- begin
- -- As long as we are using a longjmp to return control to the
- -- exception handler on the runtime stack, we are safe. The original
- -- signal mask (the one we had before coming into this signal catching
- -- function) will be restored by the longjmp. Therefore, raising
- -- an exception in this handler should be a safe operation.
-
- -- Check that treatment of exception propagation here
- -- is consistent with treatment of the abort signal in
- -- System.Task_Primitives.Operations.
-
- case signo is
- when SIGFPE =>
- case info.si_code is
- when FPE_INTOVF_TRAP |
- FPE_STARTSIG_TRAP |
- FPE_INTDIV_TRAP |
- FPE_FLTDIV_TRAP |
- FPE_FLTUND_TRAP |
- FPE_FLTOPERR_TRAP |
- FPE_FLTOVF_TRAP =>
- raise Constraint_Error;
-
- when others =>
- pragma Assert (Shutdown ("Unexpected SIGFPE signal"));
- null;
- end case;
-
- when SIGILL =>
- case info.si_code is
- when ILL_STACK |
- ILL_ILLINSTR_FAULT |
- ILL_PRIVINSTR_FAULT =>
- raise Constraint_Error;
-
- when others =>
- pragma Assert (Shutdown ("Unexpected SIGILL signal"));
- null;
- end case;
-
- when SIGSEGV =>
-
- -- was caused by accessing a null pointer.
-
--- ???? Origin of this code is unclear, may be broken ???
-
- if context.sc_o0 in 0 .. 16#2000# then
- raise Constraint_Error;
- else
- raise Storage_Error;
- end if;
-
- when others =>
- pragma Assert (Shutdown ("Unexpected signal"));
- null;
- end case;
- end Notify_Exception;
-
- ---------------------------
- -- Initialize_Interrupts --
- ---------------------------
-
- -- Nothing needs to be done on this platform
-
- procedure Initialize_Interrupts is
- begin
- null;
- end Initialize_Interrupts;
-
--------------------------
--- Package Elaboration --
--------------------------
-
-begin
- declare
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- mask : aliased sigset_t;
- Result : Interfaces.C.int;
-
- begin
- -- Need to call pthread_init very early because it is doing signal
- -- initializations.
-
- pthread_init;
-
- -- Change the following assignment to use another signal for task abort.
- -- For example, SIGTERM might be a good one if SIGABRT is required for
- -- use elsewhere.
-
- Abort_Task_Interrupt := SIGABRT;
-
- act.sa_handler := Notify_Exception'Address;
-
- -- Set sa_flags to SA_NODEFER so that during the handler execution
- -- we do not change the Signal_Mask to be masked for the Signal.
- -- This is a temporary fix to the problem that the Signal_Mask is
- -- not restored after the exception (longjmp) from the handler.
- -- The right fix should be made in sigsetjmp so that we save
- -- the Signal_Set and restore it after a longjmp.
-
- -- In that case, this field should be changed back to 0. ???
-
- act.sa_flags := 16;
-
- Result := sigemptyset (mask'Access);
- pragma Assert (Result = 0);
-
- for J in Exception_Interrupts'Range loop
- Result := sigaddset (mask'Access, Signal (Exception_Interrupts (J)));
- pragma Assert (Result = 0);
- end loop;
-
- act.sa_mask := mask;
-
- for J in Exception_Interrupts'Range loop
- Keep_Unmasked (Exception_Interrupts (J)) := True;
-
- Result :=
- sigaction
- (Signal (Exception_Interrupts (J)),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
- end loop;
-
- Keep_Unmasked (Abort_Task_Interrupt) := True;
- Keep_Unmasked (SIGALRM) := True;
- Keep_Unmasked (SIGSTOP) := True;
- Keep_Unmasked (SIGKILL) := True;
-
- -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but at
- -- the same time, disable the ability of handling this signal using
- -- package Ada.Interrupts.
-
- -- The pragma Unreserve_All_Interrupts allows the user the ability to
- -- change this behavior.
-
- if Unreserve_All_Interrupts = 0 then
- Keep_Unmasked (SIGINT) := True;
- end if;
-
- -- Reserve this not to interfere with thread scheduling
-
- -- ??? consider adding this to interrupt exceptions
- -- Keep_Unmasked (SIGALRM) := True;
-
- -- An earlier version had a comment about SIGALRM needing to be unmasked
- -- in at least one thread for cond_timedwait to work.
-
- -- It is unclear whether this is True for Solaris threads, FSU threads,
- -- both, or maybe just an old version of FSU threads. ????
-
- -- Following signals should not be disturbed. Found by experiment
-
- Keep_Unmasked (SIGEMT) := True;
- Keep_Unmasked (SIGCHLD) := True;
-
- -- We do not have Signal 0 in reality. We just use this value
- -- to identify not existing signals (see s-intnam.ads). Therefore,
- -- Signal 0 should not be used in all signal related operations hence
- -- mark it as reserved.
-
- Reserve := Reserve or Keep_Unmasked or Keep_Masked;
- Reserve (0) := True;
- end;
-end System.Interrupt_Management;
diff --git a/gcc/ada/5uosinte.ads b/gcc/ada/5uosinte.ads
deleted file mode 100644
index 6afffa96aab..00000000000
--- a/gcc/ada/5uosinte.ads
+++ /dev/null
@@ -1,552 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
--- --
--- S Y S T E M . O S _ I N T E R F A C E --
--- --
--- S p e c --
--- --
--- Copyright (C) 1997-2001, Free Software Foundation, Inc. --
--- --
--- GNARL is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNARL; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is a Sun OS (FSU THREADS) version of this package.
-
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
-
--- PLEASE DO NOT add any with-clauses to this package
--- or remove the pragma Elaborate_Body.
--- It is designed to be a bottom-level (leaf) package.
-
-with Interfaces.C;
-package System.OS_Interface is
- pragma Preelaborate;
-
- pragma Linker_Options ("-lgthreads");
- pragma Linker_Options ("-lmalloc");
-
- subtype int is Interfaces.C.int;
- subtype short is Interfaces.C.short;
- subtype long is Interfaces.C.long;
- subtype unsigned is Interfaces.C.unsigned;
- subtype unsigned_short is Interfaces.C.unsigned_short;
- subtype unsigned_long is Interfaces.C.unsigned_long;
- subtype unsigned_char is Interfaces.C.unsigned_char;
- subtype plain_char is Interfaces.C.plain_char;
- subtype size_t is Interfaces.C.size_t;
-
- -----------
- -- Errno --
- -----------
-
- function errno return int;
- pragma Import (C, errno, "__get_errno");
-
- EAGAIN : constant := 11;
- EINTR : constant := 4;
- EINVAL : constant := 22;
- ENOMEM : constant := 12;
- ETIMEDOUT : constant := 60;
-
- -------------
- -- Signals --
- -------------
-
- Max_Interrupt : constant := 31;
- type Signal is new int range 0 .. Max_Interrupt;
- for Signal'Size use int'Size;
-
- SIGHUP : constant := 1; -- hangup
- SIGINT : constant := 2; -- interrupt (rubout)
- SIGQUIT : constant := 3; -- quit (ASCD FS)
- SIGILL : constant := 4; -- illegal instruction (not reset)
- SIGTRAP : constant := 5; -- trace trap (not reset)
- SIGIOT : constant := 6; -- IOT instruction
- SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
- SIGEMT : constant := 7; -- EMT instruction
- SIGFPE : constant := 8; -- floating point exception
- SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 10; -- bus error
- SIGSEGV : constant := 11; -- segmentation violation
- SIGSYS : constant := 12; -- bad argument to system call
- SIGPIPE : constant := 13; -- write on a pipe with no one to read it
- SIGALRM : constant := 14; -- alarm clock
- SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 30; -- user defined signal 1
- SIGUSR2 : constant := 31; -- user defined signal 2
- SIGCLD : constant := 20; -- alias for SIGCHLD
- SIGCHLD : constant := 20; -- child status change
- SIGWINCH : constant := 28; -- window size change
- SIGURG : constant := 16; -- urgent condition on IO channel
- SIGPOLL : constant := 23; -- pollable event occurred
- SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias)
- SIGSTOP : constant := 17; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 18; -- user stop requested from tty
- SIGCONT : constant := 19; -- stopped process has been continued
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
-
- type sigset_t is private;
-
- function sigaddset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigaddset, "sigaddset");
-
- function sigdelset (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigdelset, "sigdelset");
-
- function sigfillset (set : access sigset_t) return int;
- pragma Import (C, sigfillset, "sigfillset");
-
- function sigismember (set : access sigset_t; sig : Signal) return int;
- pragma Import (C, sigismember, "sigismember");
-
- function sigemptyset (set : access sigset_t) return int;
- pragma Import (C, sigemptyset, "sigemptyset");
-
- type struct_sigaction is record
- sa_handler : System.Address;
- sa_mask : sigset_t;
- sa_flags : int;
- end record;
- pragma Convention (C, struct_sigaction);
- type struct_sigaction_ptr is access all struct_sigaction;
-
- SIG_BLOCK : constant := 1;
- SIG_UNBLOCK : constant := 2;
- SIG_SETMASK : constant := 4;
-
- SIG_DFL : constant := 0;
- SIG_IGN : constant := 1;
-
- function sigaction
- (sig : Signal;
- act : struct_sigaction_ptr;
- oact : struct_sigaction_ptr) return int;
- pragma Import (C, sigaction, "sigaction");
-
- ----------
- -- Time --
- ----------
-
- Time_Slice_Supported : constant Boolean := False;
- -- Indicates wether time slicing is supported (i.e FSU threads have been
- -- compiled with DEF_RR)
-
- type timespec is private;
-
- type clockid_t is private;
-
- CLOCK_REALTIME : constant clockid_t;
-
- function clock_gettime
- (clock_id : clockid_t;
- tp : access timespec) return int;
- pragma Import (C, clock_gettime, "clock_gettime");
-
- function To_Duration (TS : timespec) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timespec (D : Duration) return timespec;
- pragma Inline (To_Timespec);
-
- type struct_timeval is private;
-
- function To_Duration (TV : struct_timeval) return Duration;
- pragma Inline (To_Duration);
-
- function To_Timeval (D : Duration) return struct_timeval;
- pragma Inline (To_Timeval);
-
- -------------------------
- -- Priority Scheduling --
- -------------------------
-
- SCHED_FIFO : constant := 0;
- SCHED_RR : constant := 1;
- SCHED_OTHER : constant := 2;
-
- -------------
- -- Process --
- -------------
-
- type pid_t is private;
-
- function kill (pid : pid_t; sig : Signal) return int;
- pragma Import (C, kill, "kill");
-
- function getpid return pid_t;
- pragma Import (C, getpid, "getpid");
-
- ---------
- -- LWP --
- ---------
-
- function lwp_self return System.Address;
- -- lwp_self does not exist on this thread library, revert to pthread_self
- -- which is the closest approximation (with getpid). This function is
- -- needed to share 7staprop.adb across POSIX-like targets.
- pragma Import (C, lwp_self, "pthread_self");
-
- -------------
- -- Threads --
- -------------
-
- type Thread_Body is access
- function (arg : System.Address) return System.Address;
- type pthread_t is private;
- subtype Thread_Id is pthread_t;
-
- type pthread_mutex_t is limited private;
- type pthread_cond_t is limited private;
- type pthread_attr_t is limited private;
- type pthread_mutexattr_t is limited private;
- type pthread_condattr_t is limited private;
- type pthread_key_t is private;
-
- PTHREAD_CREATE_DETACHED : constant := 1;
-
- -----------
- -- Stack --
- -----------
-
- Stack_Base_Available : constant Boolean := False;
- -- Indicates wether the stack base is available on this target.
- -- This allows us to share s-osinte.adb between all the FSU run time.
- -- Note that this value can only be true if pthread_t has a complete
- -- definition that corresponds exactly to the C header files.
-
- function Get_Stack_Base (thread : pthread_t) return Address;
- pragma Inline (Get_Stack_Base);
- -- returns the stack base of the specified thread.
- -- Only call this function when Stack_Base_Available is True.
-
- function Get_Page_Size return size_t;
- function Get_Page_Size return Address;
- pragma Import (C, Get_Page_Size, "getpagesize");
- -- returns the size of a page, or 0 if this is not relevant on this
- -- target
-
- PROT_NONE : constant := 0;
- PROT_READ : constant := 1;
- PROT_WRITE : constant := 2;
- PROT_EXEC : constant := 4;
- PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC;
-
- PROT_ON : constant := PROT_NONE;
- PROT_OFF : constant := PROT_ALL;
-
- function mprotect (addr : Address; len : size_t; prot : int) return int;
- pragma Import (C, mprotect);
-
- ---------------------------------------
- -- Nonstandard Thread Initialization --
- ---------------------------------------
- -- FSU_THREADS requires pthread_init, which is nonstandard
- -- and this should be invoked during the elaboration of s-taprop.adb
- procedure pthread_init;
- pragma Import (C, pthread_init, "pthread_init");
-
- -------------------------
- -- POSIX.1c Section 3 --
- -------------------------
-
- function sigwait (set : access sigset_t; sig : access Signal) return int;
- -- FSU_THREADS has a nonstandard sigwait
-
- function pthread_kill (thread : pthread_t; sig : Signal) return int;
- pragma Import (C, pthread_kill, "pthread_kill");
-
- -- FSU threads does not have pthread_sigmask. Instead, it uses
- -- sigprocmask to do the signal handling when the thread library is
- -- sucked in.
-
- type sigset_t_ptr is access all sigset_t;
-
- function pthread_sigmask
- (how : int;
- set : sigset_t_ptr;
- oset : sigset_t_ptr) return int;
- pragma Import (C, pthread_sigmask, "sigprocmask");
-
- --------------------------
- -- POSIX.1c Section 11 --
- --------------------------
-
- function pthread_mutexattr_init
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init");
-
- function pthread_mutexattr_destroy
- (attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy");
-
- function pthread_mutex_init
- (mutex : access pthread_mutex_t;
- attr : access pthread_mutexattr_t) return int;
- pragma Import (C, pthread_mutex_init, "pthread_mutex_init");
-
- function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
- pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy");
-
- function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
- -- FSU_THREADS has nonstandard pthread_mutex_lock
-
- function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
- -- FSU_THREADS has nonstandard pthread_mutex_lock
-
- function pthread_condattr_init
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_init, "pthread_condattr_init");
-
- function pthread_condattr_destroy
- (attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy");
-
- function pthread_cond_init
- (cond : access pthread_cond_t;
- attr : access pthread_condattr_t) return int;
- pragma Import (C, pthread_cond_init, "pthread_cond_init");
-
- function pthread_cond_destroy (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy");
-
- function pthread_cond_signal (cond : access pthread_cond_t) return int;
- pragma Import (C, pthread_cond_signal, "pthread_cond_signal");
-
- function pthread_cond_wait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t) return int;
- -- FSU_THREADS has a nonstandard pthread_cond_wait
-
- function pthread_cond_timedwait
- (cond : access pthread_cond_t;
- mutex : access pthread_mutex_t;
- abstime : access timespec) return int;
- -- FSU_THREADS has a nonstandard pthread_cond_timedwait
-
- Relative_Timed_Wait : constant Boolean := False;
- -- pthread_cond_timedwait requires an absolute delay time
-
- --------------------------
- -- POSIX.1c Section 13 --
- --------------------------
-
- PTHREAD_PRIO_NONE : constant := 0;
- PTHREAD_PRIO_PROTECT : constant := 2;
- PTHREAD_PRIO_INHERIT : constant := 1;
-
- function pthread_mutexattr_setprotocol
- (attr : access pthread_mutexattr_t;
- protocol : int) return int;
- pragma Import (C, pthread_mutexattr_setprotocol);
-
- function pthread_mutexattr_setprioceiling
- (attr : access pthread_mutexattr_t;
- prioceiling : int) return int;
- pragma Import
- (C, pthread_mutexattr_setprioceiling,
- "pthread_mutexattr_setprio_ceiling");
-
- type struct_sched_param is record
- sched_priority : int; -- scheduling priority
- end record;
-
- function pthread_setschedparam
- (thread : pthread_t;
- policy : int;
- param : access struct_sched_param) return int;
- -- FSU_THREADS does not have pthread_setschedparam
-
- function pthread_attr_setscope
- (attr : access pthread_attr_t;
- contentionscope : int) return int;
- pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope");
-
- function pthread_attr_setinheritsched
- (attr : access pthread_attr_t;
- inheritsched : int) return int;
- pragma Import (C, pthread_attr_setinheritsched);
-
- function pthread_attr_setschedpolicy
- (attr : access pthread_attr_t;
- policy : int) return int;
- pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched");
-
- function pthread_attr_setschedparam
- (attr : access pthread_attr_t;
- sched_param : int) return int;
- pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam");
-
- function sched_yield return int;
- -- FSU_THREADS does not have sched_yield;
-
- ---------------------------
- -- P1003.1c - Section 16 --
- ---------------------------
-
- function pthread_attr_init (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_init, "pthread_attr_init");
-
- function pthread_attr_destroy
- (attributes : access pthread_attr_t) return int;
- pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy");
-
- function pthread_attr_setdetachstate
- (attr : access pthread_attr_t;
- detachstate : int) return int;
- -- FSU_THREADS has a nonstandard pthread_attr_setdetachstate
-
- function pthread_attr_setstacksize
- (attr : access pthread_attr_t;
- stacksize : size_t) return int;
- pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize");
-
- function pthread_create
- (thread : access pthread_t;
- attributes : access pthread_attr_t;
- start_routine : Thread_Body;
- arg : System.Address) return int;
- pragma Import (C, pthread_create, "pthread_create");
-
- procedure pthread_exit (status : System.Address);
- pragma Import (C, pthread_exit, "pthread_exit");
-
- function pthread_self return pthread_t;
- pragma Import (C, pthread_self, "pthread_self");
-
- --------------------------
- -- POSIX.1c Section 17 --
- --------------------------
-
- function pthread_setspecific
- (key : pthread_key_t;
- value : System.Address) return int;
- pragma Import (C, pthread_setspecific, "pthread_setspecific");
-
- function pthread_getspecific (key : pthread_key_t) return System.Address;
- -- FSU_THREADS has a nonstandard pthread_getspecific
-
- type destructor_pointer is access procedure (arg : System.Address);
-
- function pthread_key_create
- (key : access pthread_key_t;
- destructor : destructor_pointer)
- return int;
- pragma Import (C, pthread_key_create, "pthread_key_create");
-
-private
-
- type sigset_t is new int;
-
- type pid_t is new int;
-
- type time_t is new long;
-
- type timespec is record
- tv_sec : time_t;
- tv_nsec : long;
- end record;
- pragma Convention (C, timespec);
-
- type clockid_t is new int;
- CLOCK_REALTIME : constant clockid_t := 0;
-
- type struct_timeval is record
- tv_sec : long;
- tv_usec : long;
- end record;
- pragma Convention (C, struct_timeval);
-
- type pthread_attr_t is record
- flags : int;
- stacksize : int;
- contentionscope : int;
- inheritsched : int;
- detachstate : int;
- sched : int;
- prio : int;
- starttime : timespec;
- deadline : timespec;
- period : timespec;
- end record;
- pragma Convention (C, pthread_attr_t);
-
- type pthread_condattr_t is record
- flags : int;
- end record;
- pragma Convention (C, pthread_condattr_t);
-
- type pthread_mutexattr_t is record
- flags : int;
- prio_ceiling : int;
- protocol : int;
- end record;
- pragma Convention (C, pthread_mutexattr_t);
-
- type sigjmp_buf is array (Integer range 0 .. 9) of int;
-
- type pthread_t_struct is record
- context : sigjmp_buf;
- pbody : sigjmp_buf;
- errno : int;
- ret : int;
- stack_base : System.Address;
- end record;
- pragma Convention (C, pthread_t_struct);
-
- type pthread_t is access all pthread_t_struct;
-
- type queue_t is record
- head : System.Address;
- tail : System.Address;
- end record;
- pragma Convention (C, queue_t);
-
- type pthread_mutex_t is record
- queue : queue_t;
- lock : plain_char;
- owner : System.Address;
- flags : int;
- prio_ceiling : int;
- protocol : int;
- prev_max_ceiling_prio : int;
- end record;
- pragma Convention (C, pthread_mutex_t);
-
- type pthread_cond_t is record
- queue : queue_t;
- flags : int;
- waiters : int;
- mutex : System.Address;
- end record;
- pragma Convention (C, pthread_cond_t);
-
- type pthread_key_t is new int;
-
-end System.OS_Interface;
diff --git a/gcc/ada/5usystem.ads b/gcc/ada/5usystem.ads
new file mode 100644
index 00000000000..dca552ebc5a
--- /dev/null
+++ b/gcc/ada/5usystem.ads
@@ -0,0 +1,150 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (Solaris Sparcv9 Version) --
+-- --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 0.01;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 64;
+ Memory_Size : constant := 2 ** 64;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := High_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer range 0 .. 31;
+ subtype Priority is Any_Priority range 0 .. 30;
+ subtype Interrupt_Priority is Any_Priority range 31 .. 31;
+
+ Default_Priority : constant Priority := 15;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
+ Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := False;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := False;
+ Stack_Check_Probes : constant Boolean := True;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := True;
+ GCC_ZCX_Support : constant Boolean := True;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
+end System;
diff --git a/gcc/ada/5vasthan.adb b/gcc/ada/5vasthan.adb
index 9a65ed269da..5f6c67ecf3d 100644
--- a/gcc/ada/5vasthan.adb
+++ b/gcc/ada/5vasthan.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -38,6 +38,7 @@ with System; use System;
with System.IO;
with System.Machine_Code;
+with System.Parameters;
with System.Storage_Elements;
with System.Tasking;
@@ -63,6 +64,7 @@ package body System.AST_Handling is
package ATID renames Ada.Task_Identification;
+ package SP renames System.Parameters;
package ST renames System.Tasking;
package STR renames System.Tasking.Rendezvous;
package STI renames System.Tasking.Initialization;
@@ -86,23 +88,23 @@ package body System.AST_Handling is
-- All nested locks must be released before other tasks competing for the
-- tasking lock are released.
- ---------------
+ --------------
-- Lock_AST --
- ---------------
+ --------------
procedure Lock_AST (Self_ID : ST.Task_ID) is
begin
STI.Defer_Abort_Nestable (Self_ID);
- STPO.Write_Lock (AST_Lock'Access);
+ STPO.Write_Lock (AST_Lock'Access, Global_Lock => True);
end Lock_AST;
- -----------------
+ ----------------
-- Unlock_AST --
- -----------------
+ ----------------
procedure Unlock_AST (Self_ID : ST.Task_ID) is
begin
- STPO.Unlock (AST_Lock'Access);
+ STPO.Unlock (AST_Lock'Access, Global_Lock => True);
STI.Undefer_Abort_Nestable (Self_ID);
end Unlock_AST;
@@ -134,6 +136,10 @@ package body System.AST_Handling is
type Descriptor_Type is new SSE.Storage_Array (1 .. 48);
for Descriptor_Type'Alignment use Standard'Maximum_Alignment;
+ pragma Warnings (Off, Descriptor_Type);
+ -- Suppress harmless warnings about alignment.
+ -- Should explain why this warning is harmless ???
+
type Descriptor_Ref is access all Descriptor_Type;
-- Normally, there is only one such descriptor for a given procedure, but
@@ -368,6 +374,11 @@ package body System.AST_Handling is
Unlock_AST (Self_Id);
STI.Defer_Abort (Self_Id);
+
+ if SP.Single_Lock then
+ STPO.Lock_RTS;
+ end if;
+
STPO.Write_Lock (Self_Id);
Is_Waiting (Num) := True;
@@ -378,6 +389,10 @@ package body System.AST_Handling is
STPO.Unlock (Self_Id);
+ if SP.Single_Lock then
+ STPO.Unlock_RTS;
+ end if;
+
-- If the process is finalizing, Undefer_Abort will simply end
-- this task.
@@ -413,21 +428,24 @@ package body System.AST_Handling is
(Acceptor => To_ST_Task_Id (Taskid),
E => ST.Task_Entry_Index (Entryno),
Uninterpreted_Data => P'Address);
+
exception
when E : others =>
System.IO.Put_Line ("%Debugging event");
System.IO.Put_Line (Exception_Name (E) &
" raised when trying to deliver an AST.");
+
if Exception_Message (E)'Length /= 0 then
System.IO.Put_Line (Exception_Message (E));
end if;
+
System.IO.Put_Line ("Task type is " & "Receiver_Type");
System.IO.Put_Line ("Task id is " & ATID.Image (Taskid));
end;
+
Lock_AST (Self_Id);
end loop;
end loop;
-
end AST_Server_Task;
------------------------
@@ -504,6 +522,7 @@ package body System.AST_Handling is
Actual_Number : out Natural;
Total_Number : out Natural)
is
+ pragma Unreferenced (Requested_Packets);
begin
-- The AST implementation of GNAT does not permit dynamic expansion
-- of the pool, so we simply add no entries and return the total. If
@@ -546,9 +565,13 @@ package body System.AST_Handling is
Entryno => Handler_Data_Ptr.Entryno,
Param => Param);
- -- ??? What is the protection of this variable ?
- -- It seems that trying to use any lock in this procedure will get
- -- an ACCVIO.
+ -- OpenVMS Programming Concepts manual, chapter 8.2.3:
+ -- "Implicit synchronization can be achieved for data that is shared
+ -- for write by using only AST routines to write the data, since only
+ -- one AST can be running at any one time."
+
+ -- This subprogram runs at AST level so is guaranteed to be
+ -- called sequentially at a given access level.
AST_Service_Queue_Put := AST_Service_Queue_Put + 1;
@@ -562,10 +585,8 @@ package body System.AST_Handling is
Is_Waiting (J) := False;
-- Sleeps are handled by ASTs on VMS, so don't call Wakeup.
- -- ??? We should lock AST_Task_Ids (J) here. What's the story ?
- STPOD.Interrupt_AST_Handler
- (To_Address (AST_Task_Ids (J)));
+ STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J)));
exit;
end if;
end loop;
diff --git a/gcc/ada/5vinmaop.adb b/gcc/ada/5vinmaop.adb
index e5c8eeedf7b..02e191150c5 100644
--- a/gcc/ada/5vinmaop.adb
+++ b/gcc/ada/5vinmaop.adb
@@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2001 Florida State University --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -38,6 +37,8 @@
with System.OS_Interface;
-- used for various type, constant, and operations
+with System.Parameters;
+
with System.Tasking;
with System.Tasking.Initialization;
@@ -51,6 +52,7 @@ with Unchecked_Conversion;
package body System.Interrupt_Management.Operations is
use System.OS_Interface;
+ use System.Parameters;
use System.Tasking;
use type unsigned_short;
@@ -62,6 +64,7 @@ package body System.Interrupt_Management.Operations is
----------------------------
procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID) is
+ pragma Warnings (Off, Interrupt);
begin
null;
end Thread_Block_Interrupt;
@@ -71,6 +74,7 @@ package body System.Interrupt_Management.Operations is
------------------------------
procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID) is
+ pragma Warnings (Off, Interrupt);
begin
null;
end Thread_Unblock_Interrupt;
@@ -80,13 +84,17 @@ package body System.Interrupt_Management.Operations is
------------------------
procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ pragma Warnings (Off, Mask);
begin
null;
end Set_Interrupt_Mask;
procedure Set_Interrupt_Mask
(Mask : access Interrupt_Mask;
- OMask : access Interrupt_Mask) is
+ OMask : access Interrupt_Mask)
+ is
+ pragma Warnings (Off, Mask);
+ pragma Warnings (Off, OMask);
begin
null;
end Set_Interrupt_Mask;
@@ -96,6 +104,7 @@ package body System.Interrupt_Management.Operations is
------------------------
procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
+ pragma Warnings (Off, Mask);
begin
null;
end Get_Interrupt_Mask;
@@ -153,8 +162,18 @@ package body System.Interrupt_Management.Operations is
end if;
else
POP.Unlock (Self_ID);
+
+ if Single_Lock then
+ POP.Unlock_RTS;
+ end if;
+
System.Tasking.Initialization.Undefer_Abort (Self_ID);
System.Tasking.Initialization.Defer_Abort (Self_ID);
+
+ if Single_Lock then
+ POP.Lock_RTS;
+ end if;
+
POP.Write_Lock (Self_ID);
end if;
end loop;
@@ -165,6 +184,7 @@ package body System.Interrupt_Management.Operations is
----------------------------
procedure Install_Default_Action (Interrupt : Interrupt_ID) is
+ pragma Warnings (Off, Interrupt);
begin
null;
end Install_Default_Action;
@@ -174,6 +194,7 @@ package body System.Interrupt_Management.Operations is
---------------------------
procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
+ pragma Warnings (Off, Interrupt);
begin
null;
end Install_Ignore_Action;
@@ -259,19 +280,16 @@ package body System.Interrupt_Management.Operations is
P2 => Interrupt_ID'Size / 8);
pragma Assert ((Status and 1) = 1);
-
end Interrupt_Self_Process;
begin
-
Environment_Mask := (others => False);
All_Tasks_Mask := (others => True);
- for I in Interrupt_ID loop
- if Keep_Unmasked (I) then
- Environment_Mask (Signal (I)) := True;
- All_Tasks_Mask (Signal (I)) := False;
+ for J in Interrupt_ID loop
+ if Keep_Unmasked (J) then
+ Environment_Mask (Signal (J)) := True;
+ All_Tasks_Mask (Signal (J)) := False;
end if;
end loop;
-
end System.Interrupt_Management.Operations;
diff --git a/gcc/ada/5vinterr.adb b/gcc/ada/5vinterr.adb
index c32dd9938c5..2f78912d8c6 100644
--- a/gcc/ada/5vinterr.adb
+++ b/gcc/ada/5vinterr.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. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -128,7 +128,6 @@ package body System.Interrupts is
use System.Parameters;
use Ada.Exceptions;
- package PRI renames System.Task_Primitives;
package POP renames System.Task_Primitives.Operations;
package PIO renames System.Task_Primitives.Interrupt_Operations;
package IMNG renames System.Interrupt_Management;
@@ -151,20 +150,20 @@ package body System.Interrupts is
entry Initialize (Mask : IMNG.Interrupt_Mask);
entry Attach_Handler
- (New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean;
- Restoration : in Boolean := False);
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
entry Exchange_Handler
(Old_Handler : out Parameterless_Handler;
- New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean);
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean);
entry Detach_Handler
- (Interrupt : in Interrupt_ID;
- Static : in Boolean);
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
entry Bind_Interrupt_To_Entry
(T : Task_ID;
@@ -184,6 +183,11 @@ package body System.Interrupts is
task type Server_Task (Interrupt : Interrupt_ID) is
pragma Priority (System.Interrupt_Priority'Last);
+ -- Note: the above pragma Priority is strictly speaking improper
+ -- since it is outside the range of allowed priorities, but the
+ -- compiler treats system units specially and does not apply
+ -- this range checking rule to system units.
+
end Server_Task;
type Server_Task_Access is access Server_Task;
@@ -429,9 +433,9 @@ package body System.Interrupts is
-- can detach handlers attached through pragma Attach_Handler.
procedure Attach_Handler
- (New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean := False) is
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False) is
begin
if Is_Reserved (Interrupt) then
Raise_Exception (Program_Error'Identity, "Interrupt" &
@@ -456,9 +460,9 @@ package body System.Interrupts is
procedure Exchange_Handler
(Old_Handler : out Parameterless_Handler;
- New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean := False) is
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False) is
begin
if Is_Reserved (Interrupt) then
Raise_Exception (Program_Error'Identity, "Interrupt" &
@@ -482,8 +486,9 @@ package body System.Interrupts is
-- detach handlers attached through pragma Attach_Handler.
procedure Detach_Handler
- (Interrupt : in Interrupt_ID;
- Static : in Boolean := False) is
+ (Interrupt : Interrupt_ID;
+ Static : Boolean := False)
+ is
begin
if Is_Reserved (Interrupt) then
Raise_Exception (Program_Error'Identity, "Interrupt" &
@@ -621,28 +626,19 @@ package body System.Interrupts is
task body Interrupt_Manager is
---------------------
- -- Local Variables --
- ---------------------
-
- Intwait_Mask : aliased IMNG.Interrupt_Mask;
- Ret_Interrupt : Interrupt_ID;
- Old_Mask : aliased IMNG.Interrupt_Mask;
- Self_ID : Task_ID := POP.Self;
-
- ---------------------
-- Local Routines --
---------------------
procedure Unprotected_Exchange_Handler
(Old_Handler : out Parameterless_Handler;
- New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean;
- Restoration : in Boolean := False);
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
procedure Unprotected_Detach_Handler
- (Interrupt : in Interrupt_ID;
- Static : in Boolean);
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
----------------------------------
-- Unprotected_Exchange_Handler --
@@ -650,10 +646,11 @@ package body System.Interrupts is
procedure Unprotected_Exchange_Handler
(Old_Handler : out Parameterless_Handler;
- New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean;
- Restoration : in Boolean := False) is
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False)
+ is
begin
if User_Entry (Interrupt).T /= Null_Task then
-- In case we have an Interrupt Entry already installed.
@@ -726,8 +723,8 @@ package body System.Interrupts is
--------------------------------
procedure Unprotected_Detach_Handler
- (Interrupt : in Interrupt_ID;
- Static : in Boolean)
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
is
Old_Handler : Parameterless_Handler;
@@ -786,6 +783,7 @@ package body System.Interrupts is
-- during elaboration of the body of this package.
accept Initialize (Mask : IMNG.Interrupt_Mask) do
+ pragma Warnings (Off, Mask);
null;
end Initialize;
@@ -795,7 +793,7 @@ package body System.Interrupts is
-- Abort_Task_Interrupt is one of the Interrupt unmasked
-- in all tasks. We mask the Interrupt in this particular task
- -- so that "sigwait" is possible to catch an explicitly sent
+ -- so that "sigwait" is possible to catch an explicitely sent
-- Abort_Task_Interrupt from the Server_Tasks.
-- This sigwaiting is needed so that we make sure a Server_Task is
@@ -824,10 +822,10 @@ package body System.Interrupts is
select
accept Attach_Handler
- (New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean;
- Restoration : in Boolean := False)
+ (New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False)
do
Unprotected_Exchange_Handler
(Old_Handler, New_Handler, Interrupt, Static, Restoration);
@@ -835,17 +833,17 @@ package body System.Interrupts is
or accept Exchange_Handler
(Old_Handler : out Parameterless_Handler;
- New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean)
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean)
do
Unprotected_Exchange_Handler
(Old_Handler, New_Handler, Interrupt, Static);
end Exchange_Handler;
or accept Detach_Handler
- (Interrupt : in Interrupt_ID;
- Static : in Boolean)
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
do
Unprotected_Detach_Handler (Interrupt, Static);
end Detach_Handler;
@@ -869,7 +867,7 @@ package body System.Interrupts is
-- it was ever ignored.
Ignored (Interrupt) := False;
- User_Entry (Interrupt) := Entry_Assoc' (T => T, E => E);
+ User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
-- Indicate the attachment of Interrupt Entry in ATCB.
-- This is need so that when an Interrupt Entry task
@@ -895,17 +893,17 @@ package body System.Interrupts is
or accept Detach_Interrupt_Entries (T : Task_ID)
do
- for I in Interrupt_ID'Range loop
- if not Is_Reserved (I) then
- if User_Entry (I).T = T then
+ for J in Interrupt_ID'Range loop
+ if not Is_Reserved (J) then
+ if User_Entry (J).T = T then
-- The interrupt should no longer be ignored if
-- it was ever ignored.
- Ignored (I) := False;
- User_Entry (I) := Entry_Assoc'
- (T => Null_Task, E => Null_Task_Entry);
- IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (I));
+ Ignored (J) := False;
+ User_Entry (J) :=
+ Entry_Assoc'(T => Null_Task, E => Null_Task_Entry);
+ IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (J));
end if;
end if;
end loop;
@@ -916,18 +914,22 @@ package body System.Interrupts is
end Detach_Interrupt_Entries;
or accept Block_Interrupt (Interrupt : Interrupt_ID) do
+ pragma Warnings (Off, Interrupt);
raise Program_Error;
end Block_Interrupt;
or accept Unblock_Interrupt (Interrupt : Interrupt_ID) do
+ pragma Warnings (Off, Interrupt);
raise Program_Error;
end Unblock_Interrupt;
or accept Ignore_Interrupt (Interrupt : Interrupt_ID) do
+ pragma Warnings (Off, Interrupt);
raise Program_Error;
end Ignore_Interrupt;
or accept Unignore_Interrupt (Interrupt : Interrupt_ID) do
+ pragma Warnings (Off, Interrupt);
raise Program_Error;
end Unignore_Interrupt;
@@ -1033,12 +1035,13 @@ package body System.Interrupts is
end if;
Tmp_Handler.all;
- POP.Write_Lock (Self_ID);
if Single_Lock then
POP.Lock_RTS;
end if;
+ POP.Write_Lock (Self_ID);
+
elsif User_Entry (Interrupt).T /= Null_Task then
Tmp_ID := User_Entry (Interrupt).T;
Tmp_Entry_Index := User_Entry (Interrupt).E;
@@ -1054,11 +1057,11 @@ package body System.Interrupts is
System.Tasking.Rendezvous.Call_Simple
(Tmp_ID, Tmp_Entry_Index, System.Null_Address);
- POP.Write_Lock (Self_ID);
-
if Single_Lock then
POP.Lock_RTS;
end if;
+
+ POP.Write_Lock (Self_ID);
end if;
end if;
end if;
@@ -1081,7 +1084,11 @@ package body System.Interrupts is
-------------------------------------
function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection) return Boolean is
+ (Object : access Dynamic_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Warnings (Off, Object);
+
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
@@ -1116,6 +1123,7 @@ package body System.Interrupts is
(Object : access Static_Interrupt_Protection)
return Boolean
is
+ pragma Warnings (Off, Object);
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
@@ -1126,7 +1134,8 @@ package body System.Interrupts is
procedure Install_Handlers
(Object : access Static_Interrupt_Protection;
- New_Handlers : in New_Handler_Array) is
+ New_Handlers : New_Handler_Array)
+ is
begin
for N in New_Handlers'Range loop
diff --git a/gcc/ada/5vintman.adb b/gcc/ada/5vintman.adb
index d679bd0375d..1190378766f 100644
--- a/gcc/ada/5vintman.adb
+++ b/gcc/ada/5vintman.adb
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5vintman.ads b/gcc/ada/5vintman.ads
index 5a0382db90b..60f410b01d7 100644
--- a/gcc/ada/5vintman.ads
+++ b/gcc/ada/5vintman.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,10 +27,10 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
---
+
-- This is the Alpha/VMS version of this package.
--
-- This package encapsulates and centralizes information about
diff --git a/gcc/ada/5vmastop.adb b/gcc/ada/5vmastop.adb
index bf4cc308273..5bb3f8a1eff 100644
--- a/gcc/ada/5vmastop.adb
+++ b/gcc/ada/5vmastop.adb
@@ -28,7 +28,7 @@
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -77,45 +77,35 @@ package body System.Machine_State_Operations is
for ICB_Hdr_Quad_Type'Size use 64;
type Invo_Context_Blk_Type is record
- --
+
+ Hdr_Quad : ICB_Hdr_Quad_Type;
-- The first quadword contains:
- -- o The length of the structure in bytes (a longword field)
- -- o The frame flags (a 3 byte field of bits)
- -- o The version number (a 1 byte field)
- --
- Hdr_Quad : ICB_Hdr_Quad_Type;
- --
- -- The address of the procedure descriptor for the procedure.
- --
+ -- o The length of the structure in bytes (a longword field)
+ -- o The frame flags (a 3 byte field of bits)
+ -- o The version number (a 1 byte field)
+
Procedure_Descriptor : Unsigned_Quadword;
- --
- -- The current PC of a given procedure invocation.
- --
- Program_Counter : Integer_64;
- --
- -- The current PS of a given procedure invocation.
- --
- Processor_Status : Integer_64;
- --
+ -- The address of the procedure descriptor for the procedure
+
+ Program_Counter : Integer_64;
+ -- The current PC of a given procedure invocation
+
+ Processor_Status : Integer_64;
+ -- The current PS of a given procedure invocation
+
+ Ireg : Unsigned_Quadword_Array (0 .. 30);
+ Freg : Unsigned_Quadword_Array (0 .. 30);
-- The register contents areas. 31 for scalars, 31 for float.
- --
- Ireg : Unsigned_Quadword_Array (0 .. 30);
- Freg : Unsigned_Quadword_Array (0 .. 30);
- --
+
+ System_Defined : Unsigned_Quadword_Array (0 .. 1);
-- The following is an "internal" area that's reserved for use by
-- the operating system. It's size may vary over time.
- --
- System_Defined : Unsigned_Quadword_Array (0 .. 1);
- ----Component(s) below are defined as comments since they
- ----overlap other fields
- ----
- ----Chfctx_Addr : Unsigned_Quadword;
+ -- Chfctx_Addr : Unsigned_Quadword;
+ -- Defined as a comment since it overlaps other fields
- --
- -- Align to octaword.
- --
Filler_1 : String (1 .. 0);
+ -- Align to octaword
end record;
for Invo_Context_Blk_Type use record
@@ -127,10 +117,10 @@ package body System.Machine_State_Operations is
Freg at 280 range 0 .. 1983;
System_Defined at 528 range 0 .. 127;
- ----Component representation spec(s) below are defined as
- ----comments since they overlap other fields
- ----
- ----Chfctx_Addr at 528 range 0 .. 63;
+ -- Component representation spec(s) below are defined as
+ -- comments since they overlap other fields
+
+ -- Chfctx_Addr at 528 range 0 .. 63;
Filler_1 at 544 range 0 .. -1;
end record;
@@ -165,7 +155,7 @@ package body System.Machine_State_Operations is
procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
procedure Get_Invo_Context (
Result : out Unsigned_Longword; -- return value
- Invo_Handle : in Invo_Handle_Type;
+ Invo_Handle : Invo_Handle_Type;
Invo_Context : out Invo_Context_Blk_Type);
pragma Interface (External, Get_Invo_Context);
@@ -178,12 +168,10 @@ package body System.Machine_State_Operations is
procedure Goto_Unwind (
Status : out Cond_Value_Type; -- return value
- Target_Invo : in Address := Address_Zero;
- Target_PC : in Address := Address_Zero;
- New_R0 : in Unsigned_Quadword
- := Unsigned_Quadword'Null_Parameter;
- New_R1 : in Unsigned_Quadword
- := Unsigned_Quadword'Null_Parameter);
+ Target_Invo : Address := Address_Zero;
+ Target_PC : Address := Address_Zero;
+ New_R0 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter;
+ New_R1 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter);
pragma Interface (External, Goto_Unwind);
@@ -194,7 +182,7 @@ package body System.Machine_State_Operations is
(Value, Reference, Reference,
Reference, Reference));
- Status : Cond_Value_Type;
+ Status : Cond_Value_Type;
begin
Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB);
@@ -209,6 +197,7 @@ package body System.Machine_State_Operations is
function Fetch_Code (Loc : Code_Loc) return Code_Loc is
begin
-- The starting address is in the second longword pointed to by Loc.
+
return Fetch (System.Aux_DEC."+" (Loc, 8));
end Fetch_Code;
@@ -247,9 +236,11 @@ package body System.Machine_State_Operations is
begin
Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB);
+
if (Status and 1) /= 1 then
return Code_Loc (System.Null_Address);
end if;
+
return Code_Loc (ICB.Program_Counter - Asm_Call_Size);
end Get_Code_Loc;
@@ -274,6 +265,7 @@ package body System.Machine_State_Operations is
(M : Machine_State;
Info : Subprogram_Info_Type)
is
+ pragma Warnings (Off, Info);
procedure Get_Prev_Invo_Handle (
Result : out Invo_Handle_Type; -- return value
@@ -335,7 +327,11 @@ package body System.Machine_State_Operations is
procedure Set_Signal_Machine_State
(M : Machine_State;
- Context : System.Address) is
+ Context : System.Address)
+ is
+ pragma Warnings (Off, M);
+ pragma Warnings (Off, Context);
+
begin
null;
end Set_Signal_Machine_State;
diff --git a/gcc/ada/5vml-tgt.adb b/gcc/ada/5vml-tgt.adb
new file mode 100644
index 00000000000..3dba336db29
--- /dev/null
+++ b/gcc/ada/5vml-tgt.adb
@@ -0,0 +1,571 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T --
+-- (VMS Version) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003, Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a set of target dependent routines to build
+-- static, dynamic and shared libraries.
+
+-- This is the VMS version of the body.
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Text_IO; use Ada.Text_IO;
+
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+
+with MLib.Fil;
+with MLib.Utl;
+with Namet; use Namet;
+with Opt; use Opt;
+with Output; use Output;
+with Prj.Com;
+with System; use System;
+with System.Case_Util; use System.Case_Util;
+
+package body MLib.Tgt is
+
+ use GNAT;
+
+ Empty_Argument_List : aliased Argument_List := (1 .. 0 => null);
+ Additional_Objects : Argument_List_Access := Empty_Argument_List'Access;
+ -- Used to add the generated auto-init object files for auto-initializing
+ -- stand-alone libraries.
+
+ Macro_Name : constant String := "macro";
+ -- The name of the command to invoke the macro-assembler
+
+ -- Options to use when invoking gcc to build the dynamic library
+
+ No_Start_Files : aliased String := "-nostartfiles";
+ For_Linker_Opt : aliased String := "--for-linker=symvec.opt";
+ Gsmatch : aliased String := "--for-linker=gsmatch=equal,1,0";
+
+ VMS_Options : constant Argument_List :=
+ (No_Start_Files'Access, For_Linker_Opt'Access, Gsmatch'Access);
+
+-- Command : String_Access;
+
+ Gnatsym_Name : constant String := "gnatsym";
+
+ Gnatsym_Path : String_Access;
+
+ Arguments : Argument_List_Access := null;
+ Last_Argument : Natural := 0;
+
+ Success : Boolean := False;
+
+ ------------------------------
+ -- Target dependent section --
+ ------------------------------
+
+ function Popen (Command, Mode : System.Address) return System.Address;
+ pragma Import (C, Popen);
+
+ function Pclose (File : System.Address) return Integer;
+ pragma Import (C, Pclose);
+
+ ---------------------
+ -- Archive_Builder --
+ ---------------------
+
+ function Archive_Builder return String is
+ begin
+ return "ar";
+ end Archive_Builder;
+
+ -----------------------------
+ -- Archive_Builder_Options --
+ -----------------------------
+
+ function Archive_Builder_Options return String_List_Access is
+ begin
+ return new String_List'(1 => new String'("cr"));
+ end Archive_Builder_Options;
+
+ -----------------
+ -- Archive_Ext --
+ -----------------
+
+ function Archive_Ext return String is
+ begin
+ return "olb";
+ end Archive_Ext;
+
+ ---------------------
+ -- Archive_Indexer --
+ ---------------------
+
+ function Archive_Indexer return String is
+ begin
+ return "ranlib";
+ end Archive_Indexer;
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Foreign : Argument_List;
+ Afiles : Argument_List;
+ Options : Argument_List;
+ Interfaces : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Driver_Name : Name_Id := No_Name;
+ Lib_Address : String := "";
+ Lib_Version : String := "";
+ Relocatable : Boolean := False;
+ Auto_Init : Boolean := False)
+ is
+ pragma Unreferenced (Foreign);
+ pragma Unreferenced (Afiles);
+ pragma Unreferenced (Lib_Address);
+ pragma Unreferenced (Lib_Version);
+ pragma Unreferenced (Relocatable);
+
+ Opt_File_Name : constant String := "symvec.opt";
+
+ Lib_File : constant String :=
+ Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Filename, DLL_Ext);
+
+ Opts : Argument_List := Options;
+ Last_Opt : Natural := Opts'Last;
+ Opts2 : Argument_List (Options'Range);
+ Last_Opt2 : Natural := Opts2'First - 1;
+ Inter : Argument_List := Interfaces;
+
+ function Is_Interface (Obj_File : String) return Boolean;
+ -- For a Stand-Alone Library, returns True if Obj_File is the object
+ -- file name of an interface of the SAL.
+ -- For other libraries, always return True.
+
+ ------------------
+ -- Is_Interface --
+ ------------------
+
+ function Is_Interface (Obj_File : String) return Boolean is
+ ALI : constant String :=
+ Fil.Ext_To
+ (Filename => To_Lower (Base_Name (Obj_File)),
+ New_Ext => "ali");
+ begin
+ if Inter'Length = 0 then
+ return True;
+
+ elsif ALI'Length > 2 and then
+ ALI (ALI'First .. ALI'First + 1) = "b$"
+ then
+ return True;
+
+ else
+ for J in Inter'Range loop
+ if Inter (J).all = ALI then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end if;
+ end Is_Interface;
+
+ begin
+ for J in Inter'Range loop
+ To_Lower (Inter (J).all);
+ end loop;
+
+ -- "gnatsym" is necessary for building the option file
+
+ if Gnatsym_Path = null then
+ Gnatsym_Path := OS_Lib.Locate_Exec_On_Path (Gnatsym_Name);
+
+ if Gnatsym_Path = null then
+ Fail (Gnatsym_Name, " not found in path");
+ end if;
+ end if;
+
+ -- For auto-initialization of a stand-alone library, we create
+ -- a macro-assembly file and we invoke the macro-assembler.
+
+ if Auto_Init then
+ declare
+ Macro_File_Name : constant String := Lib_Filename & "$init.mar";
+ Macro_File : Ada.Text_IO.File_Type;
+ Init_Proc : String := Lib_Filename & "INIT";
+ Popen_Result : System.Address;
+ Pclose_Result : Integer;
+
+ Command : constant String :=
+ Macro_Name & " " & Macro_File_Name & ASCII.NUL;
+ -- The command to invoke the macro-assembler on the generated
+ -- assembly file.
+
+ Mode : constant String := "r" & ASCII.NUL;
+ -- The mode for the invocation of Popen
+
+ begin
+ To_Upper (Init_Proc);
+
+ if Verbose_Mode then
+ Write_Str ("Creating auto-init assembly file """);
+ Write_Str (Macro_File_Name);
+ Write_Line ("""");
+ end if;
+
+ begin
+ Create (Macro_File, Out_File, Macro_File_Name);
+
+ Put_Line (Macro_File, ASCII.HT & ".EXTRN LIB$INITIALIZE");
+ Put_Line (Macro_File, ASCII.HT & ".EXTRN " & Init_Proc);
+ Put_Line
+ (Macro_File,
+ ASCII.HT & ".PSECT LIB$INITIALIZE USR,GBL,NOEXE,NOWRT,LONG");
+ Put_Line (Macro_File, ASCII.HT & ".ADDRESS " & Init_Proc);
+ Put_Line (Macro_File, ASCII.HT & ".END");
+
+ Close (Macro_File);
+
+ exception
+ when others =>
+ Fail ("creation of auto-init assembly file """,
+ Macro_File_Name, """ failed");
+ end;
+
+ -- Invoke the macro-assembler
+
+ if Verbose_Mode then
+ Write_Str ("Assembling auto-init assembly file """);
+ Write_Str (Macro_File_Name);
+ Write_Line ("""");
+ end if;
+
+ Popen_Result := Popen (Command (Command'First)'Address,
+ Mode (Mode'First)'Address);
+
+ if Popen_Result = Null_Address then
+ Fail ("assembly of auto-init assembly file """,
+ Macro_File_Name, """ failed");
+ end if;
+
+ -- Wait for the end of execution of the macro-assembler
+
+ Pclose_Result := Pclose (Popen_Result);
+
+ if Pclose_Result < 0 then
+ Fail ("assembly of auto init assembly file """,
+ Macro_File_Name, """ failed");
+ end if;
+
+ -- Add the generated object file to the list of objects to be
+ -- included in the library.
+
+ Additional_Objects :=
+ new Argument_List'
+ (1 => new String'(Lib_Filename & "$init.obj"));
+ end;
+ end if;
+
+ -- Allocate the argument list and put the symbol file name
+
+ Arguments := new Argument_List (1 .. Ofiles'Length + 2);
+
+ Last_Argument := 1;
+
+ if Verbose_Mode then
+ Arguments (Last_Argument) := new String'("-v");
+ Last_Argument := Last_Argument + 1;
+ end if;
+
+ Arguments (Last_Argument) := new String'(Opt_File_Name);
+
+ -- Add each relevant object file
+
+ for Index in Ofiles'Range loop
+ if Is_Interface (Ofiles (Index).all) then
+ Last_Argument := Last_Argument + 1;
+ Arguments (Last_Argument) := new String'(Ofiles (Index).all);
+ end if;
+ end loop;
+
+ -- Spawn gnatsym
+
+ Spawn (Program_Name => Gnatsym_Path.all,
+ Args => Arguments (1 .. Last_Argument),
+ Success => Success);
+
+ if not Success then
+ Fail ("unable to create symbol file for library """,
+ Lib_Filename, """");
+ end if;
+
+ Free (Arguments);
+
+ -- Move all the -l switches from Opts to Opts2
+
+ declare
+ Index : Natural := Opts'First;
+ Opt : String_Access;
+ begin
+ while Index <= Last_Opt loop
+ Opt := Opts (Index);
+
+ if Opt'Length > 2 and then
+ Opt (Opt'First .. Opt'First + 1) = "-l"
+ then
+ if Index < Last_Opt then
+ Opts (Index .. Last_Opt - 1) :=
+ Opts (Index + 1 .. Last_Opt);
+ end if;
+
+ Last_Opt := Last_Opt - 1;
+
+ Last_Opt2 := Last_Opt2 + 1;
+ Opts2 (Last_Opt2) := Opt;
+
+ else
+ Index := Index + 1;
+ end if;
+ end loop;
+ end;
+
+ -- Invoke gcc to build the library
+
+ Utl.Gcc
+ (Output_File => Lib_File,
+ Objects => Ofiles & Additional_Objects.all,
+ Options => VMS_Options,
+ Options_2 => Opts (Opts'First .. Last_Opt) &
+ Opts2 (Opts2'First .. Last_Opt2),
+ Driver_Name => Driver_Name);
+
+ -- The auto-init object file need to be deleted, so that it will not
+ -- be included in the library as a regular object file, otherwise
+ -- it will be included twice when the library will be built next
+ -- time, which may lead to errors.
+
+ if Auto_Init then
+ declare
+ Auto_Init_Object_File_Name : constant String :=
+ Lib_Filename & "$init.obj";
+ Disregard : Boolean;
+
+ begin
+ if Verbose_Mode then
+ Write_Str ("deleting auto-init object file """);
+ Write_Str (Auto_Init_Object_File_Name);
+ Write_Line ("""");
+ end if;
+
+ Delete_File (Auto_Init_Object_File_Name, Success => Disregard);
+ end;
+ end if;
+ end Build_Dynamic_Library;
+
+ -------------------------
+ -- Default_DLL_Address --
+ -------------------------
+
+ function Default_DLL_Address return String is
+ begin
+ return "";
+ end Default_DLL_Address;
+
+ -------------
+ -- DLL_Ext --
+ -------------
+
+ function DLL_Ext return String is
+ begin
+ return "exe";
+ end DLL_Ext;
+
+ --------------------
+ -- Dynamic_Option --
+ --------------------
+
+ function Dynamic_Option return String is
+ begin
+ return "-shared";
+ end Dynamic_Option;
+
+ -------------------
+ -- Is_Object_Ext --
+ -------------------
+
+ function Is_Object_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".obj";
+ end Is_Object_Ext;
+
+ --------------
+ -- Is_C_Ext --
+ --------------
+
+ function Is_C_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".c";
+ end Is_C_Ext;
+
+ --------------------
+ -- Is_Archive_Ext --
+ --------------------
+
+ function Is_Archive_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".olb" or else Ext = ".exe";
+ end Is_Archive_Ext;
+
+ -------------
+ -- Libgnat --
+ -------------
+
+ function Libgnat return String is
+ Libgnat_A : constant String := "libgnat.a";
+ Libgnat_Olb : constant String := "libgnat.olb";
+
+ begin
+ Name_Len := Libgnat_A'Length;
+ Name_Buffer (1 .. Name_Len) := Libgnat_A;
+
+ if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then
+ return Libgnat_A;
+
+ else
+ return Libgnat_Olb;
+ end if;
+ end Libgnat;
+
+ ------------------------
+ -- Library_Exists_For --
+ ------------------------
+
+ function Library_Exists_For (Project : Project_Id) return Boolean is
+ begin
+ if not Projects.Table (Project).Library then
+ Fail ("INTERNAL ERROR: Library_Exists_For called " &
+ "for non library project");
+ return False;
+
+ else
+ declare
+ Lib_Dir : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Dir);
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ if Projects.Table (Project).Library_Kind = Static then
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+ end;
+ end if;
+ end Library_Exists_For;
+
+ ---------------------------
+ -- Library_File_Name_For --
+ ---------------------------
+
+ function Library_File_Name_For (Project : Project_Id) return Name_Id is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
+ "for non library project");
+ return No_Name;
+
+ else
+ declare
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "lib";
+
+ if Projects.Table (Project).Library_Kind = Static then
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+
+ return Name_Find;
+ end;
+ end if;
+ end Library_File_Name_For;
+
+ --------------------------------
+ -- Linker_Library_Path_Option --
+ --------------------------------
+
+ function Linker_Library_Path_Option return String_Access is
+ begin
+ return null;
+ end Linker_Library_Path_Option;
+
+ ----------------
+ -- Object_Ext --
+ ----------------
+
+ function Object_Ext return String is
+ begin
+ return "obj";
+ end Object_Ext;
+
+ ----------------
+ -- PIC_Option --
+ ----------------
+
+ function PIC_Option return String is
+ begin
+ return "";
+ end PIC_Option;
+
+ -----------------------------------------------
+ -- Standalone_Library_Auto_Init_Is_Supported --
+ -----------------------------------------------
+
+ function Standalone_Library_Auto_Init_Is_Supported return Boolean is
+ begin
+ return True;
+ end Standalone_Library_Auto_Init_Is_Supported;
+
+ ---------------------------
+ -- Support_For_Libraries --
+ ---------------------------
+
+ function Support_For_Libraries return Library_Support is
+ begin
+ return Full;
+ end Support_For_Libraries;
+
+end MLib.Tgt;
diff --git a/gcc/ada/5vosinte.adb b/gcc/ada/5vosinte.adb
index 5c0909ee39e..0b806daa809 100644
--- a/gcc/ada/5vosinte.adb
+++ b/gcc/ada/5vosinte.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2002 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5vosinte.ads b/gcc/ada/5vosinte.ads
index 7903bb67fbe..2a14f44c979 100644
--- a/gcc/ada/5vosinte.ads
+++ b/gcc/ada/5vosinte.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5vosprim.adb b/gcc/ada/5vosprim.adb
index 6db0ccea5b1..c49c861bf34 100644
--- a/gcc/ada/5vosprim.adb
+++ b/gcc/ada/5vosprim.adb
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5vparame.ads b/gcc/ada/5vparame.ads
index 360596d4dbc..5b41ab79ec6 100644
--- a/gcc/ada/5vparame.ads
+++ b/gcc/ada/5vparame.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -141,8 +141,8 @@ pragma Pure (Parameters);
---------------------
-- In the following sections, constant parameters are defined to
- -- allow some optimizations within the tasking run time based on
- -- restrictions on the tasking features.
+ -- allow some optimizations and fine tuning within the tasking run time
+ -- based on restrictions on the tasking features.
----------------------
-- Locking Strategy --
@@ -182,6 +182,14 @@ pragma Pure (Parameters);
-- point. A value of False for Dynamic_Priority_Support corresponds
-- to pragma Restrictions (No_Dynamic_Priorities);
+ ---------------------
+ -- Task Attributes --
+ ---------------------
+
+ Default_Attribute_Count : constant := 4;
+ -- Number of pre-allocated Address-sized task attributes stored in the
+ -- task control block.
+
--------------------
-- Runtime Traces --
--------------------
diff --git a/gcc/ada/5vsymbol.adb b/gcc/ada/5vsymbol.adb
new file mode 100644
index 00000000000..d505491c86b
--- /dev/null
+++ b/gcc/ada/5vsymbol.adb
@@ -0,0 +1,528 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y M B O L S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VMS version of this package
+
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Sequential_IO;
+with Ada.Text_IO; use Ada.Text_IO;
+
+package body Symbols is
+
+ Case_Sensitive : constant String := "case_sensitive=";
+ Symbol_Vector : constant String := "SYMBOL_VECTOR=(";
+ Equal_Data : constant String := "=DATA)";
+ Equal_Procedure : constant String := "=PROCEDURE)";
+
+ Symbol_File_Name : String_Access := null;
+ -- Name of the symbol file
+
+ subtype Byte is Character;
+ -- Object files are stream of bytes, but some of these bytes, those for
+ -- the names of the symbols, are ASCII characters.
+
+ package Byte_IO is new Ada.Sequential_IO (Byte);
+ use Byte_IO;
+
+ type Number is mod 2**16;
+ -- 16 bits unsigned number for number of characters
+
+ GSD : constant Number := 10;
+ -- Code for the Global Symbol Definition section
+
+ C_SYM : constant Number := 1;
+ -- Code for a Symbol subsection
+
+ V_DEF_Mask : constant Number := 2**1;
+ V_NORM_Mask : constant Number := 2**6;
+
+ File : Byte_IO.File_Type;
+ -- Each object file is read as a stream of bytes (characters)
+
+ B : Byte;
+
+ Number_Of_Characters : Natural := 0;
+ -- The number of characters of each section
+
+ Code : Number := 0;
+ Length : Natural := 0;
+
+ Dummy : Number;
+
+ Nchars : Natural := 0;
+ Flags : Number := 0;
+
+ Symbol : String (1 .. 255);
+ LSymb : Natural;
+
+ function Equal (Left, Right : Symbol_Data) return Boolean;
+ -- Test for equality of symbols
+
+ procedure Get (N : out Number);
+ -- Read two bytes from the object file LSB first as unsigned 16 bit number
+
+ procedure Get (N : out Natural);
+ -- Read two bytes from the object file, LSByte first, as a Natural
+
+ -----------
+ -- Equal --
+ -----------
+
+ function Equal (Left, Right : Symbol_Data) return Boolean is
+ begin
+ return Left.Name /= null and then
+ Right.Name /= null and then
+ Left.Name.all = Right.Name.all and then
+ Left.Kind = Right.Kind and then
+ Left.Present = Right.Present;
+ end Equal;
+
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get (N : out Number) is
+ C : Byte;
+ LSByte : Number;
+ begin
+ Read (File, C);
+ LSByte := Byte'Pos (C);
+ Read (File, C);
+ N := LSByte + (256 * Byte'Pos (C));
+ end Get;
+
+ procedure Get (N : out Natural) is
+ Result : Number;
+ begin
+ Get (Result);
+ N := Natural (Result);
+ end Get;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize
+ (Symbol_File : String;
+ Force : Boolean;
+ Quiet : Boolean;
+ Success : out Boolean)
+ is
+ File : Ada.Text_IO.File_Type;
+ Line : String (1 .. 1_000);
+ Last : Natural;
+
+ begin
+ -- Record the symbol file name
+
+ Symbol_File_Name := new String'(Symbol_File);
+
+ -- Empty the symbol tables
+
+ Symbol_Table.Set_Last (Original_Symbols, 0);
+ Symbol_Table.Set_Last (Complete_Symbols, 0);
+
+ -- Assume that everything will be fine
+
+ Success := True;
+
+ -- If Force is not set, attempt to read the symbol file
+
+ if not Force then
+ begin
+ Open (File, In_File, Symbol_File);
+
+ exception
+ when Ada.Text_IO.Name_Error =>
+ return;
+
+ when X : others =>
+ if not Quiet then
+ Put_Line ("could not open """ & Symbol_File & """");
+ Put_Line (Exception_Message (X));
+ end if;
+
+ Success := False;
+ return;
+ end;
+
+ while not End_Of_File (File) loop
+ Get_Line (File, Line, Last);
+
+ if Last = 0 then
+ null;
+
+ elsif Last > Case_Sensitive'Length
+ and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive
+ then
+ null;
+
+ elsif Last > Symbol_Vector'Length
+ and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector
+ then
+ if Last > Symbol_Vector'Length + Equal_Data'Length and then
+ Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data
+ then
+ Symbol_Table.Increment_Last (Original_Symbols);
+ Original_Symbols.Table
+ (Symbol_Table.Last (Original_Symbols)) :=
+ (Name =>
+ new String'(Line (Symbol_Vector'Length + 1 ..
+ Last - Equal_Data'Length)),
+ Kind => Data,
+ Present => True);
+
+ elsif Last > Symbol_Vector'Length + Equal_Procedure'Length
+ and then
+ Line (Last - Equal_Procedure'Length + 1 .. Last) =
+ Equal_Procedure
+ then
+ Symbol_Table.Increment_Last (Original_Symbols);
+ Original_Symbols.Table
+ (Symbol_Table.Last (Original_Symbols)) :=
+ (Name =>
+ new String'(Line (Symbol_Vector'Length + 1 ..
+ Last - Equal_Procedure'Length)),
+ Kind => Proc,
+ Present => True);
+
+ else
+ if not Quiet then
+ Put_Line ("symbol file """ & Symbol_File &
+ """ is incorrectly formatted:");
+ Put_Line ("""" & Line (1 .. Last) & """");
+ end if;
+
+ Close (File);
+ Success := False;
+ return;
+ end if;
+
+ else
+ if not Quiet then
+ Put_Line ("unexpected line in symbol file """ &
+ Symbol_File & """");
+ Put_Line ("""" & Line (1 .. Last) & """");
+ end if;
+
+ Close (File);
+ Success := False;
+ return;
+ end if;
+ end loop;
+
+ Close (File);
+ end if;
+ end Initialize;
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process
+ (Object_File : String;
+ Success : out Boolean)
+ is
+ begin
+ -- Open the object file. Return with Success = False if this fails.
+
+ begin
+ Open (File, In_File, Object_File);
+ exception
+ when others =>
+ Put_Line
+ ("*** Unable to open object file """ & Object_File & """");
+ Success := False;
+ return;
+ end;
+
+ -- Assume that the object file has a correct format
+
+ Success := True;
+
+ -- Get the different sections one by one from the object file
+
+ while not End_Of_File (File) loop
+
+ Get (Code);
+ Get (Number_Of_Characters);
+ Number_Of_Characters := Number_Of_Characters - 4;
+
+ -- If this is not a Global Symbol Definition section, skip to the
+ -- next section.
+
+ if Code /= GSD then
+
+ for J in 1 .. Number_Of_Characters loop
+ Read (File, B);
+ end loop;
+
+ else
+
+ -- Skip over the next 4 bytes
+
+ Get (Dummy);
+ Get (Dummy);
+ Number_Of_Characters := Number_Of_Characters - 4;
+
+ -- Get each subsection in turn
+
+ loop
+ Get (Code);
+ Get (Nchars);
+ Get (Dummy);
+ Get (Flags);
+ Number_Of_Characters := Number_Of_Characters - 8;
+ Nchars := Nchars - 8;
+
+ -- If this is a symbol and the V_DEF flag is set, get the
+ -- symbol.
+
+ if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then
+ -- First, reach the symbol length
+
+ for J in 1 .. 25 loop
+ Read (File, B);
+ Nchars := Nchars - 1;
+ Number_Of_Characters := Number_Of_Characters - 1;
+ end loop;
+
+ Length := Byte'Pos (B);
+ LSymb := 0;
+
+ -- Get the symbol characters
+
+ for J in 1 .. Nchars loop
+ Read (File, B);
+ Number_Of_Characters := Number_Of_Characters - 1;
+ if Length > 0 then
+ LSymb := LSymb + 1;
+ Symbol (LSymb) := B;
+ Length := Length - 1;
+ end if;
+ end loop;
+
+ -- Create the new Symbol
+
+ declare
+ S_Data : Symbol_Data;
+ begin
+ S_Data.Name := new String'(Symbol (1 .. LSymb));
+
+ -- The symbol kind (Data or Procedure) depends on the
+ -- V_NORM flag.
+
+ if (Flags and V_NORM_Mask) = 0 then
+ S_Data.Kind := Data;
+
+ else
+ S_Data.Kind := Proc;
+ end if;
+
+ -- Put the new symbol in the table
+
+ Symbol_Table.Increment_Last (Complete_Symbols);
+ Complete_Symbols.Table
+ (Symbol_Table.Last (Complete_Symbols)) := S_Data;
+ end;
+
+ else
+ -- As it is not a symbol subsection, skip to the next
+ -- subsection.
+
+ for J in 1 .. Nchars loop
+ Read (File, B);
+ Number_Of_Characters := Number_Of_Characters - 1;
+ end loop;
+ end if;
+
+ -- Exit the GSD section when number of characters reaches 0
+
+ exit when Number_Of_Characters = 0;
+ end loop;
+ end if;
+ end loop;
+
+ -- The object file has been processed, close it
+
+ Close (File);
+
+ exception
+ -- For any exception, output an error message, close the object file
+ -- and return with Success = False.
+
+ when X : others =>
+ Put_Line ("unexpected exception raised while processing """
+ & Object_File & """");
+ Put_Line (Exception_Information (X));
+ Close (File);
+ Success := False;
+ end Process;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize
+ (Quiet : Boolean;
+ Success : out Boolean)
+ is
+ File : Ada.Text_IO.File_Type;
+ -- The symbol file
+
+ S_Data : Symbol_Data;
+ -- A symbol
+
+ Cur : Positive := 1;
+ -- Most probable index in the Complete_Symbols of the current symbol
+ -- in Original_Symbol.
+
+ Found : Boolean;
+
+ begin
+ -- Nothing to be done if Initialize has never been called
+
+ if Symbol_File_Name = null then
+ Success := False;
+
+ else
+
+ -- First find if the symbols in the symbol file are also in the
+ -- object files.
+
+ -- Expect the first symbol in the symbol file to also be the first
+ -- in Complete_Symbols.
+
+ Cur := 1;
+
+ for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop
+ S_Data := Original_Symbols.Table (Index_1);
+ Found := False;
+
+ First_Object_Loop :
+ for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop
+ if Equal (S_Data, Complete_Symbols.Table (Index_2)) then
+ Cur := Index_2 + 1;
+ Complete_Symbols.Table (Index_2).Present := False;
+ Found := True;
+ exit First_Object_Loop;
+ end if;
+ end loop First_Object_Loop;
+
+ -- If the symbol could not be found between Cur and Last, try
+ -- before Cur.
+
+ if not Found then
+ Second_Object_Loop :
+ for Index_2 in 1 .. Cur - 1 loop
+ if Equal (S_Data, Complete_Symbols.Table (Index_2)) then
+ Cur := Index_2 + 1;
+ Complete_Symbols.Table (Index_2).Present := False;
+ Found := True;
+ exit Second_Object_Loop;
+ end if;
+ end loop Second_Object_Loop;
+ end if;
+
+ -- If the symbol is not found, mark it as such in the table
+
+ if not Found then
+ if not Quiet then
+ Put_Line ("symbol """ & S_Data.Name.all &
+ """ is no longer present in the object files");
+ end if;
+
+ Original_Symbols.Table (Index_1).Present := False;
+ Free (Original_Symbols.Table (Index_1).Name);
+ end if;
+ end loop;
+
+ -- Append additional symbols, if any, to the Original_Symbols table
+
+ for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop
+ S_Data := Complete_Symbols.Table (Index);
+
+ if S_Data.Present then
+ Symbol_Table.Increment_Last (Original_Symbols);
+ Original_Symbols.Table (Symbol_Table.Last (Original_Symbols)) :=
+ S_Data;
+ Complete_Symbols.Table (Index).Present := False;
+ end if;
+ end loop;
+
+ -- Create the symbol file
+
+ Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all);
+
+ Put (File, Case_Sensitive);
+ Put_Line (File, "yes");
+
+ -- Put a line in the symbol file for each symbol in the symbol table
+
+ for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop
+ if Original_Symbols.Table (Index).Present then
+ Put (File, Symbol_Vector);
+ Put (File, Original_Symbols.Table (Index).Name.all);
+
+ if Original_Symbols.Table (Index).Kind = Data then
+ Put_Line (File, Equal_Data);
+
+ else
+ Put_Line (File, Equal_Procedure);
+ end if;
+
+ Free (Original_Symbols.Table (Index).Name);
+ end if;
+ end loop;
+
+ Put (File, Case_Sensitive);
+ Put_Line (File, "NO");
+
+ -- And we are done
+
+ Close (File);
+
+ -- Reset both tables
+
+ Symbol_Table.Set_Last (Original_Symbols, 0);
+ Symbol_Table.Set_Last (Complete_Symbols, 0);
+
+ -- Clear the symbol file name
+
+ Free (Symbol_File_Name);
+
+ Success := True;
+ end if;
+
+ exception
+ when X : others =>
+ Put_Line ("unexpected exception raised while finalizing """
+ & Symbol_File_Name.all & """");
+ Put_Line (Exception_Information (X));
+ Success := False;
+ end Finalize;
+
+end Symbols;
diff --git a/gcc/ada/5vsystem.ads b/gcc/ada/5vsystem.ads
index ddf582bd046..3a66df33bfe 100644
--- a/gcc/ada/5vsystem.ads
+++ b/gcc/ada/5vsystem.ads
@@ -118,24 +118,35 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := False;
+ Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- High_Integrity_Mode : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := True;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := True;
Stack_Check_Probes : constant Boolean := True;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := True;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := True;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+
--------------------------
-- Underlying Priorities --
---------------------------
diff --git a/gcc/ada/5vtaprop.adb b/gcc/ada/5vtaprop.adb
index 07664744502..8a291c2f72e 100644
--- a/gcc/ada/5vtaprop.adb
+++ b/gcc/ada/5vtaprop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -88,14 +88,14 @@ package body System.Task_Primitives.Operations is
-- The followings are logically constants, but need to be initialized
-- at run time.
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_ID associated with a thread
-
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
@@ -108,6 +108,46 @@ package body System.Task_Primitives.Operations is
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set.
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads).
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ procedure Initialize (Environment_Task : Task_ID);
+ pragma Inline (Initialize);
+ -- Initialize various data needed by this package.
+
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does executing thread have a TCB?
+
+ procedure Set (Self_Id : Task_ID);
+ pragma Inline (Set);
+ -- Set the self id for the current task.
+
+ function Self return Task_ID;
+ pragma Inline (Self);
+ -- Return a pointer to the Ada Task Control Block of the calling task.
+
+ end Specific;
+
+ package body Specific is separate;
+ -- The body of this package is target specific.
+
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
+ -- Allocate and Initialize a new ATCB for the current Thread.
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_ID is separate;
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -137,6 +177,9 @@ package body System.Task_Primitives.Operations is
-- ??? Check the comment above
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ pragma Unreferenced (T);
+ pragma Unreferenced (On);
+
begin
null;
end Stack_Guard;
@@ -154,25 +197,18 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
- function Self return Task_ID is
- Result : System.Address;
-
- begin
- Result := pthread_getspecific (ATCB_Key);
- pragma Assert (Result /= System.Null_Address);
- return To_Task_ID (Result);
- end Self;
+ function Self return Task_ID renames Specific.Self;
---------------------
-- Initialize_Lock --
---------------------
-- Note: mutexes and cond_variables needed per-task basis are
- -- initialized in Initialize_TCB and the Storage_Error is
- -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
- -- used in RTS is initialized before any status change of RTS.
- -- Therefore rasing Storage_Error in the following routines
- -- should be able to be handled safely.
+ -- initialized in Initialize_TCB and the Storage_Error is
+ -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
+ -- used in RTS is initialized before any status change of RTS.
+ -- Therefore rasing Storage_Error in the following routines
+ -- should be able to be handled safely.
procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is
Attributes : aliased pthread_mutexattr_t;
@@ -201,6 +237,8 @@ package body System.Task_Primitives.Operations is
end Initialize_Lock;
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ pragma Unreferenced (Level);
+
Attributes : aliased pthread_mutexattr_t;
Result : Interfaces.C.int;
@@ -212,7 +250,7 @@ package body System.Task_Primitives.Operations is
raise Storage_Error;
end if;
--- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes.
+-- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes???
-- Result := pthread_mutexattr_settype_np
-- (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP);
-- pragma Assert (Result = 0);
@@ -243,6 +281,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
+
begin
Result := pthread_mutex_destroy (L.L'Access);
pragma Assert (Result = 0);
@@ -250,6 +289,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
+
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@@ -287,9 +327,11 @@ package body System.Task_Primitives.Operations is
end Write_Lock;
procedure Write_Lock
- (L : access RTS_Lock; Global_Lock : Boolean := False)
+ (L : access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
+
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
@@ -299,6 +341,7 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (T : Task_ID) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
@@ -321,6 +364,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
+
begin
Result := pthread_mutex_unlock (L.L'Access);
pragma Assert (Result = 0);
@@ -328,6 +372,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
@@ -337,6 +382,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (T : Task_ID) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
@@ -352,7 +398,9 @@ package body System.Task_Primitives.Operations is
(Self_ID : Task_ID;
Reason : System.Tasking.Task_States)
is
+ pragma Unreferenced (Reason);
Result : Interfaces.C.int;
+
begin
if Single_Lock then
Result := pthread_cond_wait
@@ -363,6 +411,7 @@ package body System.Task_Primitives.Operations is
end if;
-- EINTR is not considered a failure.
+
pragma Assert (Result = 0 or else Result = EINTR);
if Self_ID.Deferral_Level = 0
@@ -385,6 +434,8 @@ package body System.Task_Primitives.Operations is
Timedout : out Boolean;
Yielded : out Boolean)
is
+ pragma Unreferenced (Reason);
+
Sleep_Time : OS_Time;
Result : Interfaces.C.int;
Status : Cond_Value_Type;
@@ -535,7 +586,10 @@ package body System.Task_Primitives.Operations is
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+
Result : Interfaces.C.int;
+
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -547,6 +601,7 @@ package body System.Task_Primitives.Operations is
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
+
begin
if Do_Yield then
Result := sched_yield;
@@ -562,8 +617,11 @@ package body System.Task_Primitives.Operations is
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
+ pragma Unreferenced (Loss_Of_Inheritance);
+
Result : Interfaces.C.int;
Param : aliased struct_sched_param;
+
begin
T.Common.Current_Priority := Prio;
Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
@@ -577,6 +635,11 @@ package body System.Task_Primitives.Operations is
(T.Common.LL.Thread, SCHED_FIFO, Param'Access);
else
+ -- SCHED_OTHER priorities are restricted to the range 8 - 15.
+ -- Since the translation from Underlying priorities results
+ -- in a range of 16 - 31, dividing by 2 gives the correct result.
+
+ Param.sched_priority := Param.sched_priority / 2;
Result := pthread_setschedparam
(T.Common.LL.Thread, SCHED_OTHER, Param'Access);
end if;
@@ -598,17 +661,10 @@ package body System.Task_Primitives.Operations is
----------------
procedure Enter_Task (Self_ID : Task_ID) is
- Result : Interfaces.C.int;
begin
Self_ID.Common.LL.Thread := pthread_self;
- -- It is not safe for the new task accept signals until it
- -- has bound its TCB pointer to the thread with pthread_setspecific (),
- -- since the handler wrappers use the TCB pointer
- -- to restore the stack limit.
-
- Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
- pragma Assert (Result = 0);
+ Specific.Set (Self_ID);
Lock_RTS;
@@ -632,6 +688,25 @@ package body System.Task_Primitives.Operations is
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_ID is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (pthread_self);
+ end if;
+ end Register_Foreign_Thread;
+
----------------------
-- Initialize_TCB --
----------------------
@@ -742,8 +817,9 @@ package body System.Task_Primitives.Operations is
-- This call may be unnecessary, not sure. ???
- Result := pthread_attr_setinheritsched
- (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
+ Result :=
+ pthread_attr_setinheritsched
+ (Attributes'Access, PTHREAD_EXPLICIT_SCHED);
pragma Assert (Result = 0);
Result := pthread_create
@@ -772,8 +848,9 @@ package body System.Task_Primitives.Operations is
------------------
procedure Finalize_TCB (T : Task_ID) is
- Result : Interfaces.C.int;
- Tmp : Task_ID := T;
+ Result : Interfaces.C.int;
+ Tmp : Task_ID := T;
+ Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
@@ -795,7 +872,13 @@ package body System.Task_Primitives.Operations is
end if;
Free (T.Common.LL.Exc_Stack_Ptr);
+
Free (Tmp);
+
+ if Is_Self then
+ Result := pthread_setspecific (ATCB_Key, System.Null_Address);
+ pragma Assert (Result = 0);
+ end if;
end Finalize_TCB;
---------------
@@ -804,7 +887,7 @@ package body System.Task_Primitives.Operations is
procedure Exit_Task is
begin
- pthread_exit (System.Null_Address);
+ Specific.Set (null);
end Exit_Task;
----------------
@@ -812,33 +895,23 @@ package body System.Task_Primitives.Operations is
----------------
procedure Abort_Task (T : Task_ID) is
-
begin
-
- -- Why is this commented out ???
--- if T = Self and then T.Deferral_Level = 0
--- and then T.Pending_ATC_Level < T.ATC_Nesting_Level
--- then
--- raise Standard'Abort_Signal;
--- end if;
-
- --
-- Interrupt Server_Tasks may be waiting on an event flag
- --
+
if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then
Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag);
end if;
-
end Abort_Task;
----------------
-- Check_Exit --
----------------
- -- Dummy versions. The only currently working versions is for solaris
- -- (native).
+ -- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
+
begin
return True;
end Check_Exit;
@@ -848,6 +921,8 @@ package body System.Task_Primitives.Operations is
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
+
begin
return True;
end Check_No_Locks;
@@ -885,7 +960,12 @@ package body System.Task_Primitives.Operations is
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
+ pragma Unreferenced (T);
+ pragma Unreferenced (Thread_Self);
+
begin
return False;
end Suspend_Task;
@@ -896,7 +976,12 @@ package body System.Task_Primitives.Operations is
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
+ pragma Unreferenced (T);
+ pragma Unreferenced (Thread_Self);
+
begin
return False;
end Resume_Task;
@@ -909,17 +994,13 @@ package body System.Task_Primitives.Operations is
begin
Environment_Task_ID := Environment_Task;
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-- Initialize the lock used to synchronize chain of all ATCBs.
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ Specific.Initialize (Environment_Task);
+
Enter_Task (Environment_Task);
end Initialize;
-begin
- declare
- Result : Interfaces.C.int;
- begin
- Result := pthread_key_create (ATCB_Key'Access, null);
- pragma Assert (Result = 0);
- end;
end System.Task_Primitives.Operations;
diff --git a/gcc/ada/5vtaspri.ads b/gcc/ada/5vtaspri.ads
index f0bbc051051..09179325c81 100644
--- a/gcc/ada/5vtaspri.ads
+++ b/gcc/ada/5vtaspri.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5vtpopde.adb b/gcc/ada/5vtpopde.adb
index 59b2f8a96f4..1e5c6ca3135 100644
--- a/gcc/ada/5vtpopde.adb
+++ b/gcc/ada/5vtpopde.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,25 +27,30 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This package is for OpenVMS/Alpha
with System.OS_Interface;
+with System.Parameters;
with System.Tasking;
with Unchecked_Conversion;
+with System.Soft_Links;
package body System.Task_Primitives.Operations.DEC is
use System.OS_Interface;
+ use System.Parameters;
use System.Tasking;
use System.Aux_DEC;
use type Interfaces.C.int;
+ package SSL renames System.Soft_Links;
+
-- The FAB_RAB_Type specifies where the context field (the calling
- -- task) is stored. Other fields defined for FAB_RAB aren't need and
+ -- task) is stored. Other fields defined for FAB_RAB arent' need and
-- so are ignored.
type FAB_RAB_Type is record
@@ -106,7 +111,6 @@ package body System.Task_Primitives.Operations.DEC is
function Self return Unsigned_Longword is
Self_ID : Task_ID := Self;
-
begin
Self_ID.Common.LL.AST_Pending := True;
return To_Unsigned_Longword (Self);
@@ -131,10 +135,15 @@ package body System.Task_Primitives.Operations.DEC is
----------------
procedure Task_Synch is
- Synch_Self_ID : Task_ID := Self;
-
+ Synch_Self_ID : constant Task_ID := Self;
begin
- Write_Lock (Synch_Self_ID);
+ if Single_Lock then
+ Lock_RTS;
+ else
+ Write_Lock (Synch_Self_ID);
+ end if;
+
+ SSL.Abort_Defer.all;
Synch_Self_ID.Common.State := AST_Server_Sleep;
while Synch_Self_ID.Common.LL.AST_Pending loop
@@ -142,7 +151,14 @@ package body System.Task_Primitives.Operations.DEC is
end loop;
Synch_Self_ID.Common.State := Runnable;
- Unlock (Synch_Self_ID);
+
+ if Single_Lock then
+ Unlock_RTS;
+ else
+ Unlock (Synch_Self_ID);
+ end if;
+
+ SSL.Abort_Undefer.all;
end Task_Synch;
end System.Task_Primitives.Operations.DEC;
diff --git a/gcc/ada/5vtpopde.ads b/gcc/ada/5vtpopde.ads
index 03a531eaa8e..46d92470f0b 100644
--- a/gcc/ada/5vtpopde.ads
+++ b/gcc/ada/5vtpopde.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,10 +27,10 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
---
+
-- This package is for OpenVMS/Alpha.
--
with System.Aux_DEC;
diff --git a/gcc/ada/5vtraent.adb b/gcc/ada/5vtraent.adb
new file mode 100644
index 00000000000..bab8daf7f08
--- /dev/null
+++ b/gcc/ada/5vtraent.adb
@@ -0,0 +1,77 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E B A C K _ E N T R I E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Traceback_Entries is
+
+ ------------
+ -- PC_For --
+ ------------
+
+ function PC_For (TB_Entry : Traceback_Entry) return System.Address is
+ begin
+ return TB_Entry.PC;
+ end PC_For;
+
+ ------------
+ -- SP_For --
+ ------------
+
+ function SP_For (TB_Entry : Traceback_Entry) return System.Address is
+ begin
+ return TB_Entry.SP;
+ end SP_For;
+
+ ------------
+ -- FP_For --
+ ------------
+
+ function FP_For (TB_Entry : Traceback_Entry) return System.Address is
+ begin
+ return TB_Entry.FP;
+ end FP_For;
+
+ ------------------
+ -- TB_Entry_For --
+ ------------------
+
+ function TB_Entry_For (PC : System.Address) return Traceback_Entry is
+ begin
+ return (PC => PC, SP => System.Null_Address, FP => System.Null_Address);
+ end TB_Entry_For;
+
+end System.Traceback_Entries;
+
diff --git a/gcc/ada/5vtraent.ads b/gcc/ada/5vtraent.ads
new file mode 100644
index 00000000000..ed71437ea62
--- /dev/null
+++ b/gcc/ada/5vtraent.ads
@@ -0,0 +1,68 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E B A C K _ E N T R I E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Alpha/OpenVMS version of this package.
+
+package System.Traceback_Entries is
+
+ type Traceback_Entry is private;
+
+ Null_TB_Entry : constant Traceback_Entry;
+
+ function PC_For (TB_Entry : Traceback_Entry) return System.Address;
+ function SP_For (TB_Entry : Traceback_Entry) return System.Address;
+ function FP_For (TB_Entry : Traceback_Entry) return System.Address;
+
+ function TB_Entry_For (PC : System.Address) return Traceback_Entry;
+
+private
+
+ type Traceback_Entry is record
+ PC : System.Address;
+ SP : System.Address;
+ FP : System.Address;
+ end record;
+
+ pragma Suppress_Initialization (Traceback_Entry);
+
+ Null_TB_Entry : constant Traceback_Entry
+ := (PC => System.Null_Address,
+ SP => System.Null_Address,
+ FP => System.Null_Address);
+
+end System.Traceback_Entries;
+
diff --git a/gcc/ada/5wgloloc.adb b/gcc/ada/5wgloloc.adb
index dc367b6a0e0..2b775b239db 100644
--- a/gcc/ada/5wgloloc.adb
+++ b/gcc/ada/5wgloloc.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/5wintman.adb b/gcc/ada/5wintman.adb
index b6ade065740..362e50132ff 100644
--- a/gcc/ada/5wintman.adb
+++ b/gcc/ada/5wintman.adb
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -63,7 +63,7 @@ package body System.Interrupt_Management is
end Initialize_Interrupts;
begin
- -- "Reserve" all the interrupts, except those that are explicitly defined
+ -- "Reserve" all the interrupts, except those that are explicitely defined
for J in Interrupt_ID'Range loop
Reserve (J) := True;
diff --git a/gcc/ada/5wmemory.adb b/gcc/ada/5wmemory.adb
index 0452ae8668b..a81665a0a59 100644
--- a/gcc/ada/5wmemory.adb
+++ b/gcc/ada/5wmemory.adb
@@ -4,13 +4,9 @@
-- --
-- S Y S T E M . M E M O R Y --
-- --
--- S p e c --
+-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
+-- Copyright (C) 2001-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- --
diff --git a/gcc/ada/5wml-tgt.adb b/gcc/ada/5wml-tgt.adb
new file mode 100644
index 00000000000..ffb3b2acf68
--- /dev/null
+++ b/gcc/ada/5wml-tgt.adb
@@ -0,0 +1,354 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T --
+-- (Windows Version) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2003, Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a set of target dependent routines to build
+-- static, dynamic and shared libraries.
+
+-- This is the Windows version of the body.
+
+with Namet; use Namet;
+with Opt;
+with Output; use Output;
+with Prj.Com;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with MDLL;
+with MDLL.Utl;
+with MLib.Fil;
+
+package body MLib.Tgt is
+
+ ---------------------
+ -- Archive_Builder --
+ ---------------------
+
+ function Archive_Builder return String is
+ begin
+ return "ar";
+ end Archive_Builder;
+
+ -----------------------------
+ -- Archive_Builder_Options --
+ -----------------------------
+
+ function Archive_Builder_Options return String_List_Access is
+ begin
+ return new String_List'(1 => new String'("cr"));
+ end Archive_Builder_Options;
+
+ -----------------
+ -- Archive_Ext --
+ -----------------
+
+ function Archive_Ext return String is
+ begin
+ return "a";
+ end Archive_Ext;
+
+ ---------------------
+ -- Archive_Indexer --
+ ---------------------
+
+ function Archive_Indexer return String is
+ begin
+ return "ranlib";
+ end Archive_Indexer;
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Foreign : Argument_List;
+ Afiles : Argument_List;
+ Options : Argument_List;
+ Interfaces : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Driver_Name : Name_Id := No_Name;
+ Lib_Address : String := "";
+ Lib_Version : String := "";
+ Relocatable : Boolean := False;
+ Auto_Init : Boolean := False)
+ is
+ pragma Unreferenced (Ofiles);
+ pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Driver_Name);
+ pragma Unreferenced (Lib_Version);
+ pragma Unreferenced (Auto_Init);
+
+ Imp_File : constant String :=
+ "lib" & MLib.Fil.Ext_To (Lib_Filename, Archive_Ext);
+ -- Name of the import library
+
+ DLL_File : constant String := MLib.Fil.Ext_To (Lib_Filename, DLL_Ext);
+ -- Name of the DLL file
+
+ Lib_File : constant String := Lib_Dir & Directory_Separator & DLL_File;
+ -- Full path of the DLL file
+
+ Success : Boolean;
+
+ begin
+ if Opt.Verbose_Mode then
+ if Relocatable then
+ Write_Str ("building relocatable shared library ");
+ else
+ Write_Str ("building non-relocatable shared library ");
+ end if;
+
+ Write_Line (Lib_File);
+ end if;
+
+ MDLL.Verbose := Opt.Verbose_Mode;
+ MDLL.Quiet := not MDLL.Verbose;
+
+ MDLL.Utl.Locate;
+
+ MDLL.Build_Dynamic_Library
+ (Foreign, Afiles,
+ MDLL.Null_Argument_List, MDLL.Null_Argument_List, Options,
+ Lib_Filename, Lib_Filename & ".def",
+ Lib_Address, True, Relocatable);
+
+ -- Move the DLL and import library in the lib directory
+
+ Copy_File (DLL_File, Lib_Dir, Success, Mode => Overwrite);
+
+ if not Success then
+ Fail ("could not copy DLL to library dir");
+ end if;
+
+ Copy_File (Imp_File, Lib_Dir, Success, Mode => Overwrite);
+
+ if not Success then
+ Fail ("could not copy import library to library dir");
+ end if;
+
+ -- Delete files
+
+ Delete_File (DLL_File, Success);
+
+ if not Success then
+ Fail ("could not delete DLL from build dir");
+ end if;
+
+ Delete_File (Imp_File, Success);
+
+ if not Success then
+ Fail ("could not delete import library from build dir");
+ end if;
+ end Build_Dynamic_Library;
+
+ -------------------------
+ -- Default_DLL_Address --
+ -------------------------
+
+ function Default_DLL_Address return String is
+ begin
+ return "0x11000000";
+ end Default_DLL_Address;
+
+ -------------
+ -- DLL_Ext --
+ -------------
+
+ function DLL_Ext return String is
+ begin
+ return "dll";
+ end DLL_Ext;
+
+ --------------------
+ -- Dynamic_Option --
+ --------------------
+
+ function Dynamic_Option return String is
+ begin
+ return "";
+ end Dynamic_Option;
+
+ -------------------
+ -- Is_Object_Ext --
+ -------------------
+
+ function Is_Object_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".o";
+ end Is_Object_Ext;
+
+ --------------
+ -- Is_C_Ext --
+ --------------
+
+ function Is_C_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".c";
+ end Is_C_Ext;
+
+ --------------------
+ -- Is_Archive_Ext --
+ --------------------
+
+ function Is_Archive_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".a";
+ end Is_Archive_Ext;
+
+ -------------
+ -- Libgnat --
+ -------------
+
+ function Libgnat return String is
+ begin
+ return "libgnat.a";
+ end Libgnat;
+
+ ------------------------
+ -- Library_Exists_For --
+ ------------------------
+
+ function Library_Exists_For (Project : Project_Id) return Boolean is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
+ "for non library project");
+ return False;
+
+ else
+ declare
+ Lib_Dir : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Dir);
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ if Projects.Table (Project).Library_Kind = Static then
+
+ -- Static libraries are named : lib<name>.a
+
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ MLib.Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ -- Shared libraries are named : <name>.dll
+
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator &
+ MLib.Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+ end;
+ end if;
+ end Library_Exists_For;
+
+ ---------------------------
+ -- Library_File_Name_For --
+ ---------------------------
+
+ function Library_File_Name_For (Project : Project_Id) return Name_Id is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
+ "for non library project");
+ return No_Name;
+
+ else
+ declare
+ Lib_Name : constant String :=
+ Get_Name_String
+ (Projects.Table (Project).Library_Name);
+
+ begin
+ if Projects.Table (Project).Library_Kind = Static then
+
+ -- Static libraries are named : lib<name>.a
+
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "lib";
+
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ -- Shared libraries are named : <name>.dll
+
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+
+ return Name_Find;
+ end;
+ end if;
+ end Library_File_Name_For;
+
+ --------------------------------
+ -- Linker_Library_Path_Option --
+ --------------------------------
+
+ function Linker_Library_Path_Option return String_Access is
+ begin
+ return null;
+ end Linker_Library_Path_Option;
+
+ ----------------
+ -- Object_Ext --
+ ----------------
+
+ function Object_Ext return String is
+ begin
+ return "o";
+ end Object_Ext;
+
+ ----------------
+ -- PIC_Option --
+ ----------------
+
+ function PIC_Option return String is
+ begin
+ return "";
+ end PIC_Option;
+
+ -----------------------------------------------
+ -- Standalone_Library_Auto_Init_Is_Supported --
+ -----------------------------------------------
+
+ function Standalone_Library_Auto_Init_Is_Supported return Boolean is
+ begin
+ return False;
+ end Standalone_Library_Auto_Init_Is_Supported;
+
+ ---------------------------
+ -- Support_For_Libraries --
+ ---------------------------
+
+ function Support_For_Libraries return Library_Support is
+ begin
+ return Full;
+ end Support_For_Libraries;
+
+end MLib.Tgt;
diff --git a/gcc/ada/5wosprim.adb b/gcc/ada/5wosprim.adb
index 4ceee490e6e..5ec73987a72 100644
--- a/gcc/ada/5wosprim.adb
+++ b/gcc/ada/5wosprim.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,45 +27,103 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the NT version of this package
with Ada.Exceptions;
-with System.OS_Interface;
+with Interfaces.C;
package body System.OS_Primitives is
- use System.OS_Interface;
+ ---------------------------
+ -- Win32 API Definitions --
+ ---------------------------
- ---------------------------------------
- -- Data for the high resolution clock --
- ---------------------------------------
+ -- These definitions are copied from System.OS_Interface because we do not
+ -- want to depend on gnarl here.
+
+ type DWORD is new Interfaces.C.unsigned_long;
+
+ type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0;
+
+ type BOOL is new Boolean;
+ for BOOL'Size use Interfaces.C.unsigned_long'Size;
+
+ procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer);
+ pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime");
+
+ function QueryPerformanceCounter
+ (lpPerformanceCount : access LARGE_INTEGER) return BOOL;
+ pragma Import
+ (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter");
- Tick_Frequency : aliased LARGE_INTEGER;
+ function QueryPerformanceFrequency
+ (lpFrequency : access LARGE_INTEGER) return BOOL;
+ pragma Import
+ (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency");
+
+ procedure Sleep (dwMilliseconds : DWORD);
+ pragma Import (Stdcall, Sleep, External_Name => "Sleep");
+
+ ----------------------------------------
+ -- Data for the high resolution clock --
+ ----------------------------------------
+
+ -- Declare some pointers to access multi-word data above. This is needed
+ -- to workaround a limitation in the GNU/Linker auto-import feature used
+ -- to build the GNAT runtime DLLs. In fact the Clock and Monotonic_Clock
+ -- routines are inlined and they are using some multi-word variables.
+ -- GNU/Linker will fail to auto-import those variables when building
+ -- libgnarl.dll. The indirection level introduced here has no measurable
+ -- penalties.
+ --
+ -- Note that access variables below must not be declared as constant
+ -- otherwise the compiler optimization will remove this indirect access.
+
+ type DA is access all Duration;
+ -- Use to have indirect access to multi-word variables
+
+ type LIA is access all LARGE_INTEGER;
+ -- Use to have indirect access to multi-word variables
+
+ type LLIA is access all Long_Long_Integer;
+ -- Use to have indirect access to multi-word variables
+
+ Tick_Frequency : aliased LARGE_INTEGER;
+ TFA : LIA := Tick_Frequency'Access;
-- Holds frequency of high-performance counter used by Clock
-- Windows NT uses a 1_193_182 Hz counter on PCs.
- Base_Ticks : aliased LARGE_INTEGER;
+ Base_Ticks : aliased LARGE_INTEGER;
+ BTA : LIA := Base_Ticks'Access;
-- Holds the Tick count for the base time.
- Base_Clock : Duration;
+ Base_Monotonic_Ticks : aliased LARGE_INTEGER;
+ BMTA : LIA := Base_Monotonic_Ticks'Access;
+ -- Holds the Tick count for the base monotonic time.
+
+ Base_Clock : aliased Duration;
+ BCA : DA := Base_Clock'Access;
-- Holds the current clock for the standard clock's base time
- Base_Monotonic_Clock : Duration;
+ Base_Monotonic_Clock : aliased Duration;
+ BMCA : DA := Base_Monotonic_Clock'Access;
-- Holds the current clock for monotonic clock's base time
- Base_Time : aliased Long_Long_Integer;
+ Base_Time : aliased Long_Long_Integer;
+ BTiA : LLIA := Base_Time'Access;
-- Holds the base time used to check for system time change, used with
-- the standard clock.
procedure Get_Base_Time;
- -- Retrieve the base time. This base time will be used by clock to
- -- compute the current time by adding to it a fraction of the
+ -- Retrieve the base time and base ticks. These values will be used by
+ -- clock to compute the current time by adding to it a fraction of the
-- performance counter. This is for the implementation of a
- -- high-resolution clock.
+ -- high-resolution clock. Note that this routine does not change the base
+ -- monotonic values used by the monotonic clock.
-----------
-- Clock --
@@ -78,8 +136,8 @@ package body System.OS_Primitives is
-- microsecs to complete.
function Clock return Duration is
- Max_Shift : constant Duration := 2.0;
- Hundreds_Nano_In_Sec : constant := 1E7;
+ Max_Shift : constant Duration := 2.0;
+ Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7;
Current_Ticks : aliased LARGE_INTEGER;
Elap_Secs_Tick : Duration;
Elap_Secs_Sys : Duration;
@@ -93,26 +151,27 @@ package body System.OS_Primitives is
GetSystemTimeAsFileTime (Now'Access);
Elap_Secs_Sys :=
- Duration (abs (Now - Base_Time) / Hundreds_Nano_In_Sec);
+ Duration (Long_Long_Float (abs (Now - BTiA.all)) /
+ Hundreds_Nano_In_Sec);
Elap_Secs_Tick :=
- Duration (Long_Long_Float (Current_Ticks - Base_Ticks) /
- Long_Long_Float (Tick_Frequency));
+ Duration (Long_Long_Float (Current_Ticks - BTA.all) /
+ Long_Long_Float (TFA.all));
-- If we have a shift of more than Max_Shift seconds we resynchonize the
-- Clock. This is probably due to a manual Clock adjustment, an DST
- -- adjustment or an NNTP synchronisation. And we want to adjust the
+ -- adjustment or an NTP synchronisation. And we want to adjust the
-- time for this system (non-monotonic) clock.
if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then
Get_Base_Time;
Elap_Secs_Tick :=
- Duration (Long_Long_Float (Current_Ticks - Base_Ticks) /
- Long_Long_Float (Tick_Frequency));
+ Duration (Long_Long_Float (Current_Ticks - BTA.all) /
+ Long_Long_Float (TFA.all));
end if;
- return Base_Clock + Elap_Secs_Tick;
+ return BCA.all + Elap_Secs_Tick;
end Clock;
-------------------
@@ -120,8 +179,6 @@ package body System.OS_Primitives is
-------------------
procedure Get_Base_Time is
- use System.OS_Interface;
-
-- The resolution for GetSystemTime is 1 millisecond.
-- The time to get both base times should take less than 1 millisecond.
@@ -174,10 +231,10 @@ package body System.OS_Primitives is
end if;
Elap_Secs_Tick :=
- Duration (Long_Long_Float (Current_Ticks - Base_Ticks) /
- Long_Long_Float (Tick_Frequency));
+ Duration (Long_Long_Float (Current_Ticks - BMTA.all) /
+ Long_Long_Float (TFA.all));
- return Base_Monotonic_Clock + Elap_Secs_Tick;
+ return BMCA.all + Elap_Secs_Tick;
end Monotonic_Clock;
-----------------
@@ -221,5 +278,9 @@ begin
Get_Base_Time;
+ -- Keep base clock and ticks for the monotonic clock. These values should
+ -- never be changed to ensure proper behavior of the monotonic clock.
+
Base_Monotonic_Clock := Base_Clock;
+ Base_Monotonic_Ticks := Base_Ticks;
end System.OS_Primitives;
diff --git a/gcc/ada/5wsystem.ads b/gcc/ada/5wsystem.ads
index 0e832334e0a..9316644e0d9 100644
--- a/gcc/ada/5wsystem.ads
+++ b/gcc/ada/5wsystem.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (NT Version) --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -58,7 +58,7 @@ pragma Pure (System);
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
- Tick : constant := 1.0;
+ Tick : constant := 0.01;
-- Storage-related Declarations
@@ -118,22 +118,34 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := True;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
- GCC_ZCX_Support : constant Boolean := False;
- Front_End_ZCX_Support : constant Boolean := True;
+ GCC_ZCX_Support : constant Boolean := True;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
---------------------------
-- Underlying Priorities --
diff --git a/gcc/ada/5wtaprop.adb b/gcc/ada/5wtaprop.adb
index a4094c886c1..506ece210c1 100644
--- a/gcc/ada/5wtaprop.adb
+++ b/gcc/ada/5wtaprop.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. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,11 +27,11 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
--- This is a NT (native) version of this package.
+-- This is a NT (native) version of this package
-- This package contains all the GNULL primitives that interface directly
-- with the underlying OS.
@@ -95,9 +95,9 @@ package body System.Task_Primitives.Operations is
package SSL renames System.Soft_Links;
- ------------------
- -- Local Data --
- ------------------
+ ----------------
+ -- Local Data --
+ ----------------
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
@@ -116,44 +116,9 @@ package body System.Task_Primitives.Operations is
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set.
- ---------------------------------
- -- Foreign Threads Detection --
- ---------------------------------
-
- -- The following are used to allow the Self function to
- -- automatically generate ATCB's for C threads that happen to call
- -- Ada procedure, which in turn happen to call the Ada run-time system.
-
- type Fake_ATCB;
- type Fake_ATCB_Ptr is access Fake_ATCB;
- type Fake_ATCB is record
- Stack_Base : Interfaces.C.unsigned := 0;
- -- A value of zero indicates the node is not in use.
- Next : Fake_ATCB_Ptr;
- Real_ATCB : aliased Ada_Task_Control_Block (0);
- end record;
-
- Fake_ATCB_List : Fake_ATCB_Ptr;
- -- A linear linked list.
- -- The list is protected by Single_RTS_Lock;
- -- Nodes are added to this list from the front.
- -- Once a node is added to this list, it is never removed.
-
- Fake_Task_Elaborated : aliased Boolean := True;
+ Foreign_Task_Elaborated : aliased Boolean := True;
-- Used to identified fake tasks (i.e., non-Ada Threads).
- Next_Fake_ATCB : Fake_ATCB_Ptr;
- -- Used to allocate one Fake_ATCB in advance. See comment in New_Fake_ATCB
-
- ---------------------------------
- -- Support for New_Fake_ATCB --
- ---------------------------------
-
- function New_Fake_ATCB return Task_ID;
- -- Allocate and Initialize a new ATCB. This code can safely be called from
- -- a foreign thread, as it doesn't access implicitly or explicitly
- -- "self" before having initialized the new ATCB.
-
------------------------------------
-- The thread local storage index --
------------------------------------
@@ -163,111 +128,55 @@ package body System.Task_Primitives.Operations is
-- To ensure that this variable won't be local to this package, since
-- in some cases, inlining forces this variable to be global anyway.
- ----------------------------------
- -- Utility Conversion Functions --
- ----------------------------------
-
- function To_Task_Id is new Unchecked_Conversion (System.Address, Task_ID);
-
- function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
-
- -------------------
- -- New_Fake_ATCB --
- -------------------
-
- function New_Fake_ATCB return Task_ID is
- Self_ID : Task_ID;
- P, Q : Fake_ATCB_Ptr;
- Succeeded : Boolean;
- Res : BOOL;
-
- begin
- -- This section is ticklish.
- -- We dare not call anything that might require an ATCB, until
- -- we have the new ATCB in place.
-
- Lock_RTS;
- Q := null;
- P := Fake_ATCB_List;
-
- while P /= null loop
- if P.Stack_Base = 0 then
- Q := P;
- end if;
-
- P := P.Next;
- end loop;
-
- if Q = null then
-
- -- Create a new ATCB with zero entries.
-
- Self_ID := Next_Fake_ATCB.Real_ATCB'Access;
- Next_Fake_ATCB.Stack_Base := 1;
- Next_Fake_ATCB.Next := Fake_ATCB_List;
- Fake_ATCB_List := Next_Fake_ATCB;
- Next_Fake_ATCB := null;
-
- else
- -- Reuse an existing fake ATCB.
-
- Self_ID := Q.Real_ATCB'Access;
- Q.Stack_Base := 1;
- end if;
-
- -- Record this as the Task_ID for the current thread.
-
- Self_ID.Common.LL.Thread := GetCurrentThread;
+ --------------------
+ -- Local Packages --
+ --------------------
- Res := TlsSetValue (TlsIndex, To_Address (Self_ID));
- pragma Assert (Res = True);
+ package Specific is
- -- Do the standard initializations
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does executing thread have a TCB?
- System.Tasking.Initialize_ATCB
- (Self_ID, null, Null_Address, Null_Task, Fake_Task_Elaborated'Access,
- System.Priority'First, Task_Info.Unspecified_Task_Info, 0, Self_ID,
- Succeeded);
- pragma Assert (Succeeded);
+ procedure Set (Self_Id : Task_ID);
+ pragma Inline (Set);
+ -- Set the self id for the current task.
- -- Finally, it is safe to use an allocator in this thread.
+ end Specific;
- if Next_Fake_ATCB = null then
- Next_Fake_ATCB := new Fake_ATCB;
- end if;
+ package body Specific is
- Self_ID.Master_of_Task := 0;
- Self_ID.Master_Within := Self_ID.Master_of_Task + 1;
+ function Is_Valid_Task return Boolean is
+ begin
+ return TlsGetValue (TlsIndex) /= System.Null_Address;
+ end Is_Valid_Task;
- for L in Self_ID.Entry_Calls'Range loop
- Self_ID.Entry_Calls (L).Self := Self_ID;
- Self_ID.Entry_Calls (L).Level := L;
- end loop;
+ procedure Set (Self_Id : Task_ID) is
+ Succeeded : BOOL;
+ begin
+ Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id));
+ pragma Assert (Succeeded = True);
+ end Set;
- Self_ID.Common.State := Runnable;
- Self_ID.Awake_Count := 1;
+ end Specific;
- -- Since this is not an ordinary Ada task, we will start out undeferred
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
- Self_ID.Deferral_Level := 0;
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
+ -- Allocate and Initialize a new ATCB for the current Thread.
- System.Soft_Links.Create_TSD (Self_ID.Common.Compiler_Data);
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_ID is separate;
- -- ????
- -- The following call is commented out to avoid dependence on
- -- the System.Tasking.Initialization package.
- -- It seems that if we want Ada.Task_Attributes to work correctly
- -- for C threads we will need to raise the visibility of this soft
- -- link to System.Soft_Links.
- -- We are putting that off until this new functionality is otherwise
- -- stable.
- -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T);
+ ----------------------------------
+ -- Utility Conversion Functions --
+ ----------------------------------
- -- Must not unlock until Next_ATCB is again allocated.
+ function To_Task_Id is new Unchecked_Conversion (System.Address, Task_ID);
- Unlock_RTS;
- return Self_ID;
- end New_Fake_ATCB;
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
----------------------------------
-- Condition Variable Functions --
@@ -296,7 +205,8 @@ package body System.Task_Primitives.Operations is
-- Do timed wait on condition variable Cond using lock L. The duration
-- of the timed wait is given by Rel_Time. When the condition is
-- signalled, Timed_Out shows whether or not a time out occurred.
- -- Status shows whether Cond_Timed_Wait completed successfully.
+ -- Status is only valid if Timed_Out is False, in which case it
+ -- shows whether Cond_Timed_Wait completed successfully.
---------------------
-- Initialize_Cond --
@@ -320,7 +230,6 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Cond (Cond : access Condition_Variable) is
Result : BOOL;
-
begin
Result := CloseHandle (HANDLE (Cond.all));
pragma Assert (Result = True);
@@ -332,7 +241,6 @@ package body System.Task_Primitives.Operations is
procedure Cond_Signal (Cond : access Condition_Variable) is
Result : BOOL;
-
begin
Result := SetEvent (HANDLE (Cond.all));
pragma Assert (Result = True);
@@ -388,11 +296,9 @@ package body System.Task_Primitives.Operations is
Timed_Out : out Boolean;
Status : out Integer)
is
- Time_Out : DWORD;
- Result : BOOL;
-
- Int_Rel_Time : DWORD;
- Wait_Result : DWORD;
+ Time_Out : DWORD;
+ Result : BOOL;
+ Wait_Result : DWORD;
begin
-- Must reset Cond BEFORE L is unlocked.
@@ -406,10 +312,15 @@ package body System.Task_Primitives.Operations is
if Rel_Time <= 0.0 then
Timed_Out := True;
+ Wait_Result := 0;
+
else
- Int_Rel_Time := DWORD (Rel_Time);
- Time_Out := Int_Rel_Time * 1000 +
- DWORD ((Rel_Time - Duration (Int_Rel_Time)) * 1000.0);
+ if Rel_Time >= Duration (DWORD'Last - 1) / 1000 then
+ Time_Out := DWORD'Last - 1;
+ else
+ Time_Out := DWORD (Rel_Time * 1000);
+ end if;
+
Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out);
if Wait_Result = WAIT_TIMEOUT then
@@ -441,6 +352,9 @@ package body System.Task_Primitives.Operations is
-- ??? Check the comment above
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ pragma Warnings (Off, T);
+ pragma Warnings (Off, On);
+
begin
null;
end Stack_Guard;
@@ -459,16 +373,14 @@ package body System.Task_Primitives.Operations is
----------
function Self return Task_ID is
- Self_Id : Task_ID;
+ Self_Id : constant Task_ID := To_Task_Id (TlsGetValue (TlsIndex));
begin
- Self_Id := To_Task_Id (TlsGetValue (TlsIndex));
-
if Self_Id = null then
- return New_Fake_ATCB;
+ return Register_Foreign_Thread (GetCurrentThread);
+ else
+ return Self_Id;
end if;
-
- return Self_Id;
end Self;
---------------------
@@ -476,7 +388,7 @@ package body System.Task_Primitives.Operations is
---------------------
-- Note: mutexes and cond_variables needed per-task basis are
- -- initialized in Initialize_TCB and the Storage_Error is handled.
+ -- initialized in Intialize_TCB and the Storage_Error is handled.
-- Other mutexes (such as RTS_Lock, Memory_Lock...) used in
-- the RTS is initialized before any status change of RTS.
-- Therefore raising Storage_Error in the following routines
@@ -484,7 +396,8 @@ package body System.Task_Primitives.Operations is
procedure Initialize_Lock
(Prio : System.Any_Priority;
- L : access Lock) is
+ L : access Lock)
+ is
begin
InitializeCriticalSection (L.Mutex'Access);
L.Owner_Priority := 0;
@@ -492,6 +405,8 @@ package body System.Task_Primitives.Operations is
end Initialize_Lock;
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ pragma Unreferenced (Level);
+
begin
InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
end Initialize_Lock;
@@ -529,7 +444,9 @@ package body System.Task_Primitives.Operations is
end Write_Lock;
procedure Write_Lock
- (L : access RTS_Lock; Global_Lock : Boolean := False) is
+ (L : access RTS_Lock;
+ Global_Lock : Boolean := False)
+ is
begin
if not Single_Lock or else Global_Lock then
EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
@@ -583,7 +500,10 @@ package body System.Task_Primitives.Operations is
procedure Sleep
(Self_ID : Task_ID;
- Reason : System.Tasking.Task_States) is
+ Reason : System.Tasking.Task_States)
+ is
+ pragma Unreferenced (Reason);
+
begin
pragma Assert (Self_ID = Self);
@@ -617,7 +537,8 @@ package body System.Task_Primitives.Operations is
Timedout : out Boolean;
Yielded : out Boolean)
is
- Check_Time : constant Duration := Monotonic_Clock;
+ pragma Unreferenced (Reason);
+ Check_Time : Duration := Monotonic_Clock;
Rel_Time : Duration;
Abs_Time : Duration;
Result : Integer;
@@ -649,15 +570,18 @@ package body System.Task_Primitives.Operations is
Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result);
end if;
- exit when Abs_Time <= Monotonic_Clock;
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time;
if not Local_Timedout then
- -- somebody may have called Wakeup for us
+
+ -- Somebody may have called Wakeup for us
+
Timedout := False;
exit;
end if;
- Rel_Time := Abs_Time - Monotonic_Clock;
+ Rel_Time := Abs_Time - Check_Time;
end loop;
end if;
end Timed_Sleep;
@@ -671,7 +595,7 @@ package body System.Task_Primitives.Operations is
Time : Duration;
Mode : ST.Delay_Modes)
is
- Check_Time : constant Duration := Monotonic_Clock;
+ Check_Time : Duration := Monotonic_Clock;
Rel_Time : Duration;
Abs_Time : Duration;
Result : Integer;
@@ -718,9 +642,10 @@ package body System.Task_Primitives.Operations is
Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result);
end if;
- exit when Abs_Time <= Monotonic_Clock;
+ Check_Time := Monotonic_Clock;
+ exit when Abs_Time <= Check_Time;
- Rel_Time := Abs_Time - Monotonic_Clock;
+ Rel_Time := Abs_Time - Check_Time;
end loop;
Self_ID.Common.State := Runnable;
@@ -741,6 +666,8 @@ package body System.Task_Primitives.Operations is
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+
begin
Cond_Signal (T.Common.LL.CV'Access);
end Wakeup;
@@ -771,8 +698,8 @@ package body System.Task_Primitives.Operations is
-- scheduling.
procedure Set_Priority
- (T : Task_ID;
- Prio : System.Any_Priority;
+ (T : Task_ID;
+ Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
Res : BOOL;
@@ -783,20 +710,6 @@ package body System.Task_Primitives.Operations is
(T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio)));
pragma Assert (Res = True);
- -- ??? Work around a bug in NT 4.0 SP3 scheduler
- -- It looks like when a task with Thread_Priority_Idle (using RT class)
- -- never reaches its time slice (e.g by doing multiple and simple RV,
- -- see CXD8002), the scheduler never gives higher priority task a
- -- chance to run.
- -- Note that this works fine on NT 4.0 SP1
-
- if Time_Slice_Val = 0
- and then Underlying_Priorities (Prio) = Thread_Priority_Idle
- and then Loss_Of_Inheritance
- then
- Sleep (20);
- end if;
-
if FIFO_Within_Priorities then
-- Annex D requirement [RM D.2.2 par. 9]:
@@ -860,11 +773,8 @@ package body System.Task_Primitives.Operations is
pragma Import (C, Init_Float, "__gnat_init_float");
-- Properly initializes the FPU for x86 systems.
- Succeeded : BOOL;
-
begin
- Succeeded := TlsSetValue (TlsIndex, To_Address (Self_ID));
- pragma Assert (Succeeded = True);
+ Specific.Set (Self_ID);
Init_Float;
Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
@@ -891,12 +801,36 @@ package body System.Task_Primitives.Operations is
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_ID is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (GetCurrentThread);
+ end if;
+ end Register_Foreign_Thread;
+
--------------------
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
begin
+ -- Initialize thread ID to 0, this is needed to detect threads that
+ -- are not yet activated.
+
+ Self_ID.Common.LL.Thread := 0;
+
Initialize_Cond (Self_ID.Common.LL.CV'Access);
if not Single_Lock then
@@ -964,6 +898,14 @@ package body System.Task_Primitives.Operations is
Set_Priority (T, Priority);
+ if Time_Slice_Val = 0 or else FIFO_Within_Priorities then
+ -- Here we need Annex E semantics so we disable the NT priority
+ -- boost. A priority boost is temporarily given by the system to a
+ -- thread when it is taken out of a wait state.
+
+ SetThreadPriorityBoost (hTask, DisablePriorityBoost => True);
+ end if;
+
-- Step 4: Now, start it for good:
Result := ResumeThread (hTask);
@@ -980,6 +922,7 @@ package body System.Task_Primitives.Operations is
Self_ID : Task_ID := T;
Result : DWORD;
Succeeded : BOOL;
+ Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
@@ -995,15 +938,23 @@ package body System.Task_Primitives.Operations is
Known_Tasks (T.Known_Tasks_Index) := null;
end if;
- -- Wait for the thread to terminate then close it. this is needed
- -- to release system ressources.
+ if Self_ID.Common.LL.Thread /= 0 then
+
+ -- This task has been activated. Wait for the thread to terminate
+ -- then close it. this is needed to release system ressources.
- Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite);
- pragma Assert (Result /= WAIT_FAILED);
- Succeeded := CloseHandle (T.Common.LL.Thread);
- pragma Assert (Succeeded = True);
+ Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite);
+ pragma Assert (Result /= WAIT_FAILED);
+ Succeeded := CloseHandle (T.Common.LL.Thread);
+ pragma Assert (Succeeded = True);
+ end if;
Free (Self_ID);
+
+ if Is_Self then
+ Succeeded := TlsSetValue (TlsIndex, System.Null_Address);
+ pragma Assert (Succeeded = True);
+ end if;
end Finalize_TCB;
---------------
@@ -1012,7 +963,7 @@ package body System.Task_Primitives.Operations is
procedure Exit_Task is
begin
- ExitThread (0);
+ Specific.Set (null);
end Exit_Task;
----------------
@@ -1020,6 +971,7 @@ package body System.Task_Primitives.Operations is
----------------
procedure Abort_Task (T : Task_ID) is
+ pragma Unreferenced (T);
begin
null;
end Abort_Task;
@@ -1057,12 +1009,24 @@ package body System.Task_Primitives.Operations is
procedure Initialize (Environment_Task : Task_ID) is
Res : BOOL;
+
begin
Environment_Task_ID := Environment_Task;
if Time_Slice_Val = 0 or else FIFO_Within_Priorities then
- Res := OS_Interface.SetPriorityClass
- (GetCurrentProcess, Realtime_Priority_Class);
+
+ -- Here we need Annex E semantics, switch the current process to the
+ -- High_Priority_Class.
+
+ Res :=
+ OS_Interface.SetPriorityClass
+ (GetCurrentProcess, High_Priority_Class);
+
+ -- ??? In theory it should be possible to use the priority class
+ -- Realtime_Prioriry_Class but we suspect a bug in the NT scheduler
+ -- which prevents (in some obscure cases) a thread to get on top of
+ -- the running queue by another thread of lower priority. For
+ -- example cxd8002 ACATS test freeze.
end if;
TlsIndex := TlsAlloc;
@@ -1073,10 +1037,6 @@ package body System.Task_Primitives.Operations is
Environment_Task.Common.LL.Thread := GetCurrentThread;
Enter_Task (Environment_Task);
-
- -- Create a free ATCB for use on the Fake_ATCB_List
-
- Next_Fake_ATCB := new Fake_ATCB;
end Initialize;
---------------------
@@ -1103,6 +1063,8 @@ package body System.Task_Primitives.Operations is
-- (native).
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
+
begin
return True;
end Check_Exit;
@@ -1112,6 +1074,8 @@ package body System.Task_Primitives.Operations is
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
+
begin
return True;
end Check_No_Locks;
@@ -1122,7 +1086,9 @@ package body System.Task_Primitives.Operations is
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
begin
if T.Common.LL.Thread /= Thread_Self then
return SuspendThread (T.Common.LL.Thread) = NO_ERROR;
@@ -1137,7 +1103,9 @@ package body System.Task_Primitives.Operations is
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
begin
if T.Common.LL.Thread /= Thread_Self then
return ResumeThread (T.Common.LL.Thread) = NO_ERROR;
diff --git a/gcc/ada/5wtaspri.ads b/gcc/ada/5wtaspri.ads
index 26160c6b094..01cde2c6910 100644
--- a/gcc/ada/5wtaspri.ads
+++ b/gcc/ada/5wtaspri.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -84,9 +84,8 @@ private
-- make sure is that they are updated in atomic fashion.
Thread_Id : aliased System.OS_Interface.DWORD;
- -- The purpose of this field is to provide a better
- -- tasking support on gdb. The order of the two first fields (Thread
- -- and LWP) is important.
+ -- The purpose of this field is to provide a better tasking support
+ -- in gdb.
CV : aliased Condition_Variable;
-- Condition Variable used to implement Sleep/Wakeup
diff --git a/gcc/ada/5xparame.ads b/gcc/ada/5xparame.ads
new file mode 100644
index 00000000000..d1d48188176
--- /dev/null
+++ b/gcc/ada/5xparame.ads
@@ -0,0 +1,203 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the OpenVMS version for restricted tasking.
+
+-- Blank line intentional so that it lines up exactly with default.
+
+-- This package defines some system dependent parameters for GNAT. These
+-- are values that are referenced by the runtime library and are therefore
+-- relevant to the target machine.
+
+-- The parameters whose value is defined in the spec are not generally
+-- expected to be changed. If they are changed, it will be necessary to
+-- recompile the run-time library.
+
+-- The parameters which are defined by functions can be changed by modifying
+-- the body of System.Parameters in file s-parame.adb. A change to this body
+-- requires only rebinding and relinking of the application.
+
+-- Note: do not introduce any pragma Inline statements into this unit, since
+-- otherwise the relinking and rebinding capability would be deactivated.
+
+package System.Parameters is
+pragma Pure (Parameters);
+
+ ---------------------------------------
+ -- Task And Stack Allocation Control --
+ ---------------------------------------
+
+ type Task_Storage_Size is new Integer;
+ -- Type used in tasking units for task storage size
+
+ type Size_Type is new Task_Storage_Size;
+ -- Type used to provide task storage size to runtime
+
+ Unspecified_Size : constant Size_Type := Size_Type'First;
+ -- Value used to indicate that no size type is set
+
+ subtype Ratio is Size_Type range -1 .. 100;
+ Dynamic : constant Size_Type := -1;
+ -- The secondary stack ratio is a constant between 0 and 100 which
+ -- determines the percentage of the allocated task stack that is
+ -- used by the secondary stack (the rest being the primary stack).
+ -- The special value of minus one indicates that the secondary
+ -- stack is to be allocated from the heap instead.
+
+ Sec_Stack_Ratio : constant Ratio := Dynamic;
+ -- This constant defines the handling of the secondary stack
+
+ Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic;
+ -- Convenient Boolean for testing for dynamic secondary stack
+
+ function Default_Stack_Size return Size_Type;
+ -- Default task stack size used if none is specified
+
+ function Minimum_Stack_Size return Size_Type;
+ -- Minimum task stack size permitted
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
+ -- Given the storage size stored in the TCB, return the Storage_Size
+ -- value required by the RM for the Storage_Size attribute. The
+ -- required adjustment is as follows:
+ --
+ -- when Size = Unspecified_Size, return Default_Stack_Size
+ -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
+ -- otherwise return given Size
+
+ Default_Env_Stack_Size : constant Size_Type := 8_192_000;
+ -- Assumed size of the environment task, if no other information
+ -- is available. This value is used when stack checking is
+ -- enabled and no GNAT_STACK_LIMIT environment variable is set.
+
+ Stack_Grows_Down : constant Boolean := True;
+ -- This constant indicates whether the stack grows up (False) or
+ -- down (True) in memory as functions are called. It is used for
+ -- proper implementation of the stack overflow check.
+
+ ----------------------------------------------
+ -- Characteristics of types in Interfaces.C --
+ ----------------------------------------------
+
+ long_bits : constant := 32;
+ -- Number of bits in type long and unsigned_long. The normal convention
+ -- is that this is the same as type Long_Integer, but this is not true
+ -- of all targets. For example, in OpenVMS long /= Long_Integer.
+
+ ----------------------------------------------
+ -- Behavior of Pragma Finalize_Storage_Only --
+ ----------------------------------------------
+
+ -- Garbage_Collected is a Boolean constant whose value indicates the
+ -- effect of the pragma Finalize_Storage_Entry on a controlled type.
+
+ -- Garbage_Collected = False
+
+ -- The system releases all storage on program termination only,
+ -- but not other garbage collection occurs, so finalization calls
+ -- are ommitted only for outer level onjects can be omitted if
+ -- pragma Finalize_Storage_Only is used.
+
+ -- Garbage_Collected = True
+
+ -- The system provides full garbage collection, so it is never
+ -- necessary to release storage for controlled objects for which
+ -- a pragma Finalize_Storage_Only is used.
+
+ Garbage_Collected : constant Boolean := False;
+ -- The storage mode for this system (release on program exit)
+
+ ---------------------
+ -- Tasking Profile --
+ ---------------------
+
+ -- In the following sections, constant parameters are defined to
+ -- allow some optimizations and fine tuning within the tasking run time
+ -- based on restrictions on the tasking features.
+
+ ----------------------
+ -- Locking Strategy --
+ ----------------------
+
+ Single_Lock : constant Boolean := True;
+ -- Indicates whether a single lock should be used within the tasking
+ -- run-time to protect internal structures. If True, a single lock
+ -- will be used, meaning less locking/unlocking operations, but also
+ -- more global contention. In general, Single_Lock should be set to
+ -- True on single processor machines, and to False to multi-processor
+ -- systems, but this can vary from application to application and also
+ -- depends on the scheduling policy.
+
+ -------------------
+ -- Task Abortion --
+ -------------------
+
+ No_Abort : constant Boolean := True;
+ -- This constant indicates whether abort statements and asynchronous
+ -- transfer of control (ATC) are disallowed. If set to True, it is
+ -- assumed that neither construct is used, and the run time does not
+ -- need to defer/undefer abort and check for pending actions at
+ -- completion points. A value of True for No_Abort corresponds to:
+ -- pragma Restrictions (No_Abort_Statements);
+ -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
+
+ ----------------------
+ -- Dynamic Priority --
+ ----------------------
+
+ Dynamic_Priority_Support : constant Boolean := False;
+ -- This constant indicates whether dynamic changes of task priorities
+ -- are allowed (True means normal RM mode in which such changes are
+ -- allowed). In particular, if this is False, then we do not need to
+ -- poll for pending base priority changes at every abort completion
+ -- point. A value of False for Dynamic_Priority_Support corresponds
+ -- to pragma Restrictions (No_Dynamic_Priorities);
+
+ ---------------------
+ -- Task Attributes --
+ ---------------------
+
+ Default_Attribute_Count : constant := 4;
+ -- Number of pre-allocated Address-sized task attributes stored in the
+ -- task control block.
+
+ --------------------
+ -- Runtime Traces --
+ --------------------
+
+ Runtime_Traces : constant Boolean := False;
+ -- This constant indicates whether the runtime outputs traces to a
+ -- predefined output or not (True means that traces are output).
+ -- See System.Traces for more details.
+
+end System.Parameters;
diff --git a/gcc/ada/5xsystem.ads b/gcc/ada/5xsystem.ads
new file mode 100644
index 00000000000..c7fa20898df
--- /dev/null
+++ b/gcc/ada/5xsystem.ads
@@ -0,0 +1,236 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M --
+-- --
+-- S p e c --
+-- (OpenVMS GCC_ZCX DEC Threads Version) --
+-- --
+-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package System is
+pragma Pure (System);
+-- Note that we take advantage of the implementation permission to
+-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
+
+ type Name is (SYSTEM_NAME_GNAT);
+ System_Name : constant Name := SYSTEM_NAME_GNAT;
+
+ -- System-Dependent Named Numbers
+
+ Min_Int : constant := Long_Long_Integer'First;
+ Max_Int : constant := Long_Long_Integer'Last;
+
+ Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
+ Max_Nonbinary_Modulus : constant := Integer'Last;
+
+ Max_Base_Digits : constant := Long_Long_Float'Digits;
+ Max_Digits : constant := Long_Long_Float'Digits;
+
+ Max_Mantissa : constant := 63;
+ Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
+
+ Tick : constant := 0.01;
+
+ -- Storage-related Declarations
+
+ type Address is private;
+ Null_Address : constant Address;
+
+ Storage_Unit : constant := 8;
+ Word_Size : constant := 32;
+ Memory_Size : constant := 2 ** 32;
+
+ -- Address comparison
+
+ function "<" (Left, Right : Address) return Boolean;
+ function "<=" (Left, Right : Address) return Boolean;
+ function ">" (Left, Right : Address) return Boolean;
+ function ">=" (Left, Right : Address) return Boolean;
+ function "=" (Left, Right : Address) return Boolean;
+
+ pragma Import (Intrinsic, "<");
+ pragma Import (Intrinsic, "<=");
+ pragma Import (Intrinsic, ">");
+ pragma Import (Intrinsic, ">=");
+ pragma Import (Intrinsic, "=");
+
+ -- Other System-Dependent Declarations
+
+ type Bit_Order is (High_Order_First, Low_Order_First);
+ Default_Bit_Order : constant Bit_Order := Low_Order_First;
+
+ -- Priority-related Declarations (RM D.1)
+
+ Max_Priority : constant Positive := 30;
+ Max_Interrupt_Priority : constant Positive := 31;
+
+ subtype Any_Priority is Integer range 0 .. 31;
+ subtype Priority is Any_Priority range 0 .. 30;
+ subtype Interrupt_Priority is Any_Priority range 31 .. 31;
+
+ Default_Priority : constant Priority := 15;
+
+private
+
+ type Address is mod Memory_Size;
+ Null_Address : constant Address := 0;
+
+ --------------------------------------
+ -- System Implementation Parameters --
+ --------------------------------------
+
+ -- These parameters provide information about the target that is used
+ -- by the compiler. They are in the private part of System, where they
+ -- can be accessed using the special circuitry in the Targparm unit
+ -- whose source should be consulted for more detailed descriptions
+ -- of the individual switch values.
+
+ AAMP : constant Boolean := False;
+ Backend_Divide_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := False;
+ Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
+ Denorm : constant Boolean := False;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
+ Fractional_Fixed_Ops : constant Boolean := False;
+ Frontend_Layout : constant Boolean := False;
+ Functions_Return_By_DSP : constant Boolean := False;
+ Machine_Overflows : constant Boolean := False;
+ Machine_Rounds : constant Boolean := True;
+ OpenVMS : constant Boolean := True;
+ Signed_Zeros : constant Boolean := True;
+ Stack_Check_Default : constant Boolean := True;
+ Stack_Check_Probes : constant Boolean := True;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
+ Use_Ada_Main_Program_Name : constant Boolean := False;
+ ZCX_By_Default : constant Boolean := True;
+ GCC_ZCX_Support : constant Boolean := True;
+ Front_End_ZCX_Support : constant Boolean := False;
+
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+
+ --------------------------
+ -- Underlying Priorities --
+ ---------------------------
+
+ -- Important note: this section of the file must come AFTER the
+ -- definition of the system implementation parameters to ensure
+ -- that the value of these parameters is available for analysis
+ -- of the declarations here (using Rtsfind at compile time).
+
+ -- The underlying priorities table provides a generalized mechanism
+ -- for mapping from Ada priorities to system priorities. In some
+ -- cases a 1-1 mapping is not the convenient or optimal choice.
+
+ -- For DEC Threads OpenVMS, we use the full range of 31 priorities
+ -- in the Ada model, but map them by compression onto the more limited
+ -- range of priorities available in OpenVMS.
+
+ -- To replace the default values of the Underlying_Priorities mapping,
+ -- copy this source file into your build directory, edit the file to
+ -- reflect your desired behavior, and recompile with the command:
+
+ -- $ gcc -c -O3 -gnatpgn system.ads
+
+ -- then recompile the run-time parts that depend on this package:
+
+ -- $ gnatmake -a -gnatn -O3 <your application>
+
+ -- then force rebuilding your application if you need different options:
+
+ -- $ gnatmake -f <your options> <your application>
+
+ type Priorities_Mapping is array (Any_Priority) of Integer;
+ pragma Suppress_Initialization (Priorities_Mapping);
+ -- Suppress initialization in case gnat.adc specifies Normalize_Scalars
+
+ Underlying_Priorities : constant Priorities_Mapping :=
+
+ (Priority'First => 16,
+
+ 1 => 17,
+ 2 => 18,
+ 3 => 18,
+ 4 => 18,
+ 5 => 18,
+ 6 => 19,
+ 7 => 19,
+ 8 => 19,
+ 9 => 20,
+ 10 => 20,
+ 11 => 21,
+ 12 => 21,
+ 13 => 22,
+ 14 => 23,
+
+ Default_Priority => 24,
+
+ 16 => 25,
+ 17 => 25,
+ 18 => 25,
+ 19 => 26,
+ 20 => 26,
+ 21 => 26,
+ 22 => 27,
+ 23 => 27,
+ 24 => 27,
+ 25 => 28,
+ 26 => 28,
+ 27 => 29,
+ 28 => 29,
+ 29 => 30,
+
+ Priority'Last => 30,
+
+ Interrupt_Priority => 31);
+
+ ----------------------------
+ -- Special VMS Interfaces --
+ ----------------------------
+
+ procedure Lib_Stop (I : in Integer);
+ pragma Interface (C, Lib_Stop);
+ pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
+ -- Interface to VMS condition handling. Used by RTSfind and pragma
+ -- {Import,Export}_Exception. Put here because this is the only
+ -- VMS specific package that doesn't drag in tasking.
+
+end System;
diff --git a/gcc/ada/5etpopse.adb b/gcc/ada/5xvxwork.ads
index 957a58332f3..4183ee6bb1f 100644
--- a/gcc/ada/5etpopse.adb
+++ b/gcc/ada/5xvxwork.ads
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SELF --
+-- S Y S T E M . V X W O R K S --
-- --
--- B o d y --
+-- S p e c --
-- --
--- Copyright (C) 1991-1998, Florida State University --
+-- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,26 +26,29 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
--- This is a Solaris/X86 (native) version of this package.
+-- This is the Xscale VxWorks version of this package.
-separate (System.Task_Primitives.Operations)
+package System.VxWorks is
+ pragma Preelaborate (System.VxWorks);
-----------
--- Self --
-----------
+ -- Floating point context record. Xscale version
-function Self return Task_ID is
- Temp : aliased System.Address;
- Result : Interfaces.C.int;
+ -- There is no floating point unit on Xscale. The record definition
+ -- below matches what arch/arm/fppArmLib.h says.
-begin
- Result := thr_getspecific (ATCB_Key, Temp'Unchecked_Access);
- pragma Assert (Result = 0);
- return To_Task_ID (Temp);
-end Self;
+ type FP_CONTEXT is record
+ Dummy : Integer;
+ end record;
+
+ for FP_CONTEXT'Alignment use 4;
+ pragma Convention (C, FP_CONTEXT);
+
+ Num_HW_Interrupts : constant := 256;
+ -- Number of entries in hardware interrupt vector table.
+
+end System.VxWorks;
diff --git a/gcc/ada/5yparame.ads b/gcc/ada/5yparame.ads
new file mode 100644
index 00000000000..af397c2aeb7
--- /dev/null
+++ b/gcc/ada/5yparame.ads
@@ -0,0 +1,203 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the default VxWorks AE 653 version of the package.`
+
+-- This package defines some system dependent parameters for GNAT. These
+-- are values that are referenced by the runtime library and are therefore
+-- relevant to the target machine.
+
+-- The parameters whose value is defined in the spec are not generally
+-- expected to be changed. If they are changed, it will be necessary to
+-- recompile the run-time library.
+
+-- The parameters which are defined by functions can be changed by modifying
+-- the body of System.Parameters in file s-parame.adb. A change to this body
+-- requires only rebinding and relinking of the application.
+
+-- Note: do not introduce any pragma Inline statements into this unit, since
+-- otherwise the relinking and rebinding capability would be deactivated.
+
+package System.Parameters is
+pragma Pure (Parameters);
+
+ ---------------------------------------
+ -- Task And Stack Allocation Control --
+ ---------------------------------------
+
+ type Task_Storage_Size is new Integer;
+ -- Type used in tasking units for task storage size
+
+ type Size_Type is new Task_Storage_Size;
+ -- Type used to provide task storage size to runtime
+
+ Unspecified_Size : constant Size_Type := Size_Type'First;
+ -- Value used to indicate that no size type is set
+
+ subtype Ratio is Size_Type range -1 .. 100;
+ Dynamic : constant Size_Type := -1;
+ -- The secondary stack ratio is a constant between 0 and 100 which
+ -- determines the percentage of the allocated task stack that is
+ -- used by the secondary stack (the rest being the primary stack).
+ -- The special value of minus one indicates that the secondary
+ -- stack is to be allocated from the heap instead.
+
+ Sec_Stack_Ratio : constant Ratio := 50;
+ -- This constant defines the handling of the secondary stack
+
+ Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic;
+ -- Convenient Boolean for testing for dynamic secondary stack
+
+ function Default_Stack_Size return Size_Type;
+ -- Default task stack size used if none is specified
+
+ function Minimum_Stack_Size return Size_Type;
+ -- Minimum task stack size permitted
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
+ -- Given the storage size stored in the TCB, return the Storage_Size
+ -- value required by the RM for the Storage_Size attribute. The
+ -- required adjustment is as follows:
+ --
+ -- when Size = Unspecified_Size, return Default_Stack_Size
+ -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
+ -- otherwise return given Size
+
+ Default_Env_Stack_Size : constant Size_Type := 14_336;
+ -- Assumed size of the environment task, if no other information
+ -- is available. This value is used when stack checking is
+ -- enabled and no GNAT_STACK_LIMIT environment variable is set.
+ -- This value is chosen as the VxWorks default stack size is 20kB,
+ -- and a little more than 4kB is necessary for the run time.
+
+ Stack_Grows_Down : constant Boolean := True;
+ -- This constant indicates whether the stack grows up (False) or
+ -- down (True) in memory as functions are called. It is used for
+ -- proper implementation of the stack overflow check.
+
+ ----------------------------------------------
+ -- Characteristics of types in Interfaces.C --
+ ----------------------------------------------
+
+ long_bits : constant := Long_Integer'Size;
+ -- Number of bits in type long and unsigned_long. The normal convention
+ -- is that this is the same as type Long_Integer, but this is not true
+ -- of all targets. For example, in OpenVMS long /= Long_Integer.
+
+ ----------------------------------------------
+ -- Behavior of Pragma Finalize_Storage_Only --
+ ----------------------------------------------
+
+ -- Garbage_Collected is a Boolean constant whose value indicates the
+ -- effect of the pragma Finalize_Storage_Entry on a controlled type.
+
+ -- Garbage_Collected = False
+
+ -- The system releases all storage on program termination only,
+ -- but not other garbage collection occurs, so finalization calls
+ -- are ommitted only for outer level onjects can be omitted if
+ -- pragma Finalize_Storage_Only is used.
+
+ -- Garbage_Collected = True
+
+ -- The system provides full garbage collection, so it is never
+ -- necessary to release storage for controlled objects for which
+ -- a pragma Finalize_Storage_Only is used.
+
+ Garbage_Collected : constant Boolean := False;
+ -- The storage mode for this system (release on program exit)
+
+ ---------------------
+ -- Tasking Profile --
+ ---------------------
+
+ -- In the following sections, constant parameters are defined to
+ -- allow some optimizations and fine tuning within the tasking run time
+ -- based on restrictions on the tasking features.
+
+ ----------------------
+ -- Locking Strategy --
+ ----------------------
+
+ Single_Lock : constant Boolean := False;
+ -- Indicates whether a single lock should be used within the tasking
+ -- run-time to protect internal structures. If True, a single lock
+ -- will be used, meaning less locking/unlocking operations, but also
+ -- more global contention. In general, Single_Lock should be set to
+ -- True on single processor machines, and to False to multi-processor
+ -- systems, but this can vary from application to application and also
+ -- depends on the scheduling policy.
+
+ -------------------
+ -- Task Abortion --
+ -------------------
+
+ No_Abort : constant Boolean := False;
+ -- This constant indicates whether abort statements and asynchronous
+ -- transfer of control (ATC) are disallowed. If set to True, it is
+ -- assumed that neither construct is used, and the run time does not
+ -- need to defer/undefer abort and check for pending actions at
+ -- completion points. A value of True for No_Abort corresponds to:
+ -- pragma Restrictions (No_Abort_Statements);
+ -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
+
+ ----------------------
+ -- Dynamic Priority --
+ ----------------------
+
+ Dynamic_Priority_Support : constant Boolean := True;
+ -- This constant indicates whether dynamic changes of task priorities
+ -- are allowed (True means normal RM mode in which such changes are
+ -- allowed). In particular, if this is False, then we do not need to
+ -- poll for pending base priority changes at every abort completion
+ -- point. A value of False for Dynamic_Priority_Support corresponds
+ -- to pragma Restrictions (No_Dynamic_Priorities);
+
+ ---------------------
+ -- Task Attributes --
+ ---------------------
+
+ Default_Attribute_Count : constant := 4;
+ -- Number of pre-allocated Address-sized task attributes stored in the
+ -- task control block.
+
+ --------------------
+ -- Runtime Traces --
+ --------------------
+
+ Runtime_Traces : constant Boolean := False;
+ -- This constant indicates whether the runtime outputs traces to a
+ -- predefined output or not (True means that traces are output).
+ -- See System.Traces for more details.
+
+end System.Parameters;
diff --git a/gcc/ada/5ysystem.ads b/gcc/ada/5ysystem.ads
index 7612018554d..69602c86d78 100644
--- a/gcc/ada/5ysystem.ads
+++ b/gcc/ada/5ysystem.ads
@@ -5,9 +5,9 @@
-- S Y S T E M --
-- --
-- S p e c --
--- (VXWORKS Version PPC) --
+-- (VxWorks Version PPC) --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -58,7 +58,7 @@ pragma Pure (System);
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
- Tick : constant := 1.0;
+ Tick : constant := 1.0 / 60.0;
-- Storage-related Declarations
@@ -126,21 +126,33 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := False;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := False;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := True;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+
end System;
diff --git a/gcc/ada/5ytiitho.adb b/gcc/ada/5ytiitho.adb
new file mode 100644
index 00000000000..f0027fd24e1
--- /dev/null
+++ b/gcc/ada/5ytiitho.adb
@@ -0,0 +1,66 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T H R E A D S . I N I T I A L I Z A T I O N . --
+-- I N I T I A L I Z E _ T A S K _ H O O K S --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks AE 653 version of this procedure
+
+separate (System.Threads.Initialization)
+
+procedure Initialize_Task_Hooks is
+
+ -- When defining the following routines for export in an AE 1.1
+ -- simulation of AE653, Interfaces.C.int may be used for the
+ -- parameters of FUNCPTR.
+ type FUNCPTR is access function (T : OSI.Thread_Id) return OSI.STATUS;
+
+ --------------------------------
+ -- Imported vThreads Routines --
+ --------------------------------
+
+ procedure procCreateHookAdd (createHookFunction : FUNCPTR);
+ pragma Import (C, procCreateHookAdd, "procCreateHookAdd");
+ -- Registers task registration routine for AE653
+
+ procedure procStartHookAdd (StartHookFunction : FUNCPTR);
+ pragma Import (C, procStartHookAdd, "procStartHookAdd");
+ -- Registers task restart routine for AE653
+
+ Result : OSI.STATUS;
+begin
+ -- Register the exported routines with the vThreads ARINC API
+ procCreateHookAdd (Register'Access);
+ procStartHookAdd (Reset_TSD'Access);
+ -- Register the environment task
+ Result := Register (OSI.taskIdSelf);
+ pragma Assert (Result /= -1);
+end Initialize_Task_Hooks;
diff --git a/gcc/ada/5zinit.adb b/gcc/ada/5zinit.adb
new file mode 100644
index 00000000000..c947057f044
--- /dev/null
+++ b/gcc/ada/5zinit.adb
@@ -0,0 +1,285 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . I N I T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks version of this package
+
+with System.OS_Interface;
+-- used for various Constants, Signal and types
+
+with Interfaces.C;
+-- used for int and other types
+
+with Ada.Exceptions;
+-- used for Raise_Exception
+
+package body System.Init is
+
+ -- This unit contains initialization circuits that are system dependent.
+
+ use Ada.Exceptions;
+ use System.OS_Interface;
+ use type Interfaces.C.int;
+
+ -- Copies of global values computed by the binder
+ Gl_Main_Priority : Integer := -1;
+ pragma Export (C, Gl_Main_Priority, "__gl_main_priority");
+
+ Gl_Time_Slice_Val : Integer := -1;
+ pragma Export (C, Gl_Time_Slice_Val, "__gl_time_slice_val");
+
+ Gl_Wc_Encoding : Character := 'n';
+ pragma Export (C, Gl_Wc_Encoding, "__gl_wc_encoding");
+
+ Gl_Locking_Policy : Character := ' ';
+ pragma Export (C, Gl_Locking_Policy, "__gl_locking_policy");
+
+ Gl_Queuing_Policy : Character := ' ';
+ pragma Export (C, Gl_Queuing_Policy, "__gl_queuing_policy");
+
+ Gl_Task_Dispatching_Policy : Character := ' ';
+ pragma Export (C, Gl_Task_Dispatching_Policy,
+ "__gl_task_dispatching_policy");
+
+ Gl_Restrictions : Address := Null_Address;
+ pragma Export (C, Gl_Restrictions, "__gl_restrictions");
+
+ Gl_Interrupt_States : Address := Null_Address;
+ pragma Export (C, Gl_Interrupt_States, "__gl_interrupt_states");
+
+ Gl_Num_Interrupt_States : Integer := 0;
+ pragma Export (C, Gl_Num_Interrupt_States, "__gl_num_interrupt_states");
+
+ Gl_Unreserve_All_Interrupts : Integer := 0;
+ pragma Export (C, Gl_Unreserve_All_Interrupts,
+ "__gl_unreserve_all_interrupts");
+
+ Gl_Exception_Tracebacks : Integer := 0;
+ pragma Export (C, Gl_Exception_Tracebacks, "__gl_exception_tracebacks");
+
+ Gl_Zero_Cost_Exceptions : Integer := 0;
+ pragma Export (C, Gl_Zero_Cost_Exceptions, "__gl_zero_cost_exceptions");
+
+ Already_Called : Boolean := False;
+
+ Handler_Installed : Integer := 0;
+ -- Indication of whether synchronous signal handlers have already been
+ -- installed by a previous call to Install_Handler.
+ pragma Export (C, Handler_Installed, "__gnat_handler_installed");
+
+ ------------------------
+ -- Local procedures --
+ ------------------------
+
+ procedure GNAT_Error_Handler (Sig : Signal);
+ -- Common procedure that is executed when a SIGFPE, SIGILL,
+ -- SIGSEGV, or SIGBUS is captured.
+
+ procedure Install_Handler;
+ pragma Export (C, Install_Handler, "__gnat_install_handler");
+ -- Install handler for the synchronous signals. The C profile
+ -- here is what is expected by the binder-generated main.
+
+ ------------------------
+ -- GNAT_Error_Handler --
+ ------------------------
+
+ procedure GNAT_Error_Handler (Sig : Signal) is
+ Mask : aliased sigset_t;
+ Result : int;
+
+ begin
+ -- VxWorks will always mask out the signal during the signal
+ -- handler and will reenable it on a longjmp. GNAT does not
+ -- generate a longjmp to return from a signal handler so the
+ -- signal will still be masked unless we unmask it.
+
+ Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
+ Result := sigdelset (Mask'Access, Sig);
+ Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null);
+
+ case Sig is
+ when SIGFPE =>
+ Raise_Exception (Constraint_Error'Identity, "SIGFPE");
+ when SIGILL =>
+ Raise_Exception (Constraint_Error'Identity, "SIGILL");
+ when SIGSEGV =>
+ Raise_Exception
+ (Program_Error'Identity,
+ "erroneous memory access");
+ when SIGBUS =>
+ Raise_Exception
+ (Storage_Error'Identity,
+ "stack overflow or SIGBUS");
+ when others =>
+ Raise_Exception (Program_Error'Identity, "unhandled signal");
+ end case;
+ end GNAT_Error_Handler;
+
+ -----------------
+ -- Set_Globals --
+ -----------------
+
+ -- This routine is called from the binder generated main program. It
+ -- copies the values for global quantities computed by the binder
+ -- into the following global locations. The reason that we go through
+ -- this copy, rather than just define the global locations in the
+ -- binder generated file, is that they are referenced from the
+ -- runtime, which may be in a shared library, and the binder file is
+ -- not in the shared library. Global references across library
+ -- boundaries like this are not handled correctly in all systems.
+
+ procedure Set_Globals
+ (Main_Priority : Integer;
+ Time_Slice_Value : Integer;
+ WC_Encoding : Character;
+ Locking_Policy : Character;
+ Queuing_Policy : Character;
+ Task_Dispatching_Policy : Character;
+ Restrictions : System.Address;
+ Interrupt_States : System.Address;
+ Num_Interrupt_States : Integer;
+ Unreserve_All_Interrupts : Integer;
+ Exception_Tracebacks : Integer;
+ Zero_Cost_Exceptions : Integer) is
+ begin
+ -- If this procedure has been already called once, check that the
+ -- arguments in this call are consistent with the ones in the
+ -- previous calls. Otherwise, raise a Program_Error exception.
+ --
+ -- We do not check for consistency of the wide character encoding
+ -- method. This default affects only Wide_Text_IO where no
+ -- explicit coding method is given, and there is no particular
+ -- reason to let this default be affected by the source
+ -- representation of a library in any case.
+ --
+ -- We do not check either for the consistency of exception tracebacks,
+ -- because exception tracebacks are not normally set in Stand-Alone
+ -- libraries. If a library or the main program set the exception
+ -- tracebacks, then they are never reset afterwards (see below).
+ --
+ -- The value of main_priority is meaningful only when we are
+ -- invoked from the main program elaboration routine of an Ada
+ -- application. Checking the consistency of this parameter should
+ -- therefore not be done. Since it is assured that the main
+ -- program elaboration will always invoke this procedure before
+ -- any library elaboration routine, only the value of
+ -- main_priority during the first call should be taken into
+ -- account and all the subsequent ones should be ignored. Note
+ -- that the case where the main program is not written in Ada is
+ -- also properly handled, since the default value will then be
+ -- used for this parameter.
+ --
+ -- For identical reasons, the consistency of time_slice_val should
+ -- not be checked.
+
+ if Already_Called then
+ if (Gl_Locking_Policy /= Locking_Policy) or
+ (Gl_Queuing_Policy /= Queuing_Policy) or
+ (Gl_Task_Dispatching_Policy /= Task_Dispatching_Policy) or
+ (Gl_Unreserve_All_Interrupts /= Unreserve_All_Interrupts) or
+ (Gl_Exception_Tracebacks /= Exception_Tracebacks) or
+ (Gl_Zero_Cost_Exceptions /= Zero_Cost_Exceptions)
+ then
+ raise Program_Error;
+ end if;
+
+ -- If either a library or the main program set the exception
+ -- traceback flag, it is never reset later.
+
+ if Gl_Exception_Tracebacks /= 0 then
+ Gl_Exception_Tracebacks := Exception_Tracebacks;
+ end if;
+
+ else
+ Already_Called := True;
+
+ Gl_Main_Priority := Main_Priority;
+ Gl_Time_Slice_Val := Time_Slice_Value;
+ Gl_Wc_Encoding := WC_Encoding;
+ Gl_Locking_Policy := Locking_Policy;
+ Gl_Queuing_Policy := Queuing_Policy;
+ Gl_Task_Dispatching_Policy := Task_Dispatching_Policy;
+ Gl_Restrictions := Restrictions;
+ Gl_Interrupt_States := Interrupt_States;
+ Gl_Num_Interrupt_States := Num_Interrupt_States;
+ Gl_Unreserve_All_Interrupts := Unreserve_All_Interrupts;
+ Gl_Exception_Tracebacks := Exception_Tracebacks;
+ Gl_Zero_Cost_Exceptions := Zero_Cost_Exceptions;
+ end if;
+ end Set_Globals;
+
+ -----------------------------
+ -- Install_Signal_Handlers --
+ -----------------------------
+
+ function Install_Signal_Handlers return Interfaces.C.int is
+ begin
+ Install_Handler;
+ return 0;
+ end Install_Signal_Handlers;
+
+ ---------------------
+ -- Install_Handler --
+ ---------------------
+
+ procedure Install_Handler is
+ Mask : aliased sigset_t;
+ Signal_Action : aliased struct_sigaction;
+ Result : Interfaces.C.int;
+
+ begin
+ -- Set up signal handler to map synchronous signals to appropriate
+ -- exceptions. Make sure that the handler isn't interrupted by
+ -- another signal that might cause a scheduling event!
+
+ Signal_Action.sa_handler := GNAT_Error_Handler'Address;
+ Signal_Action.sa_flags := SA_ONSTACK;
+ Result := sigemptyset (Mask'Access);
+ Signal_Action.sa_mask := Mask;
+
+ Result := sigaction
+ (Signal (SIGFPE), Signal_Action'Unchecked_Access, null);
+
+ Result := sigaction
+ (Signal (SIGILL), Signal_Action'Unchecked_Access, null);
+
+ Result := sigaction
+ (Signal (SIGSEGV), Signal_Action'Unchecked_Access, null);
+
+ Result := sigaction
+ (Signal (SIGBUS), Signal_Action'Unchecked_Access, null);
+
+ Handler_Installed := 1;
+ end Install_Handler;
+
+end System.Init;
diff --git a/gcc/ada/5zinterr.adb b/gcc/ada/5zinterr.adb
index 03a724a83df..674c08f3322 100644
--- a/gcc/ada/5zinterr.adb
+++ b/gcc/ada/5zinterr.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. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -77,6 +77,9 @@ with Ada.Task_Identification;
with Ada.Exceptions;
-- used for Raise_Exception
+with System.Interrupt_Management;
+-- used for Reserve
+
with System.Task_Primitives.Operations;
-- used for Write_Lock
-- Unlock
@@ -109,7 +112,6 @@ package body System.Interrupts is
use Tasking;
use Ada.Exceptions;
- package PRI renames System.Task_Primitives;
package POP renames System.Task_Primitives.Operations;
function To_Ada is new Unchecked_Conversion
@@ -447,13 +449,21 @@ package body System.Interrupts is
-------------------------------------
function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection) return Boolean is
+ (Object : access Dynamic_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Unreferenced (Object);
+
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
function Has_Interrupt_Or_Attach_Handler
- (Object : access Static_Interrupt_Protection) return Boolean is
+ (Object : access Static_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Unreferenced (Object);
+
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
@@ -617,8 +627,9 @@ package body System.Interrupts is
-----------------
function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
+ use System.Interrupt_Management;
begin
- return False;
+ return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt));
end Is_Reserved;
----------------------
@@ -737,11 +748,6 @@ package body System.Interrupts is
-----------------------
task body Interrupt_Manager is
- ---------------------
- -- Local Variables --
- ---------------------
-
- Self_Id : constant Task_ID := POP.Self;
--------------------
-- Local Routines --
@@ -991,7 +997,7 @@ package body System.Interrupts is
"A binding for this interrupt is already present");
end if;
- User_Entry (Interrupt) := Entry_Assoc' (T => T, E => E);
+ User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
-- Indicate the attachment of interrupt entry in the ATCB.
-- This is needed so when an interrupt entry task terminates
@@ -1022,8 +1028,9 @@ package body System.Interrupts is
for Int in Interrupt_ID'Range loop
if not Is_Reserved (Int) then
if User_Entry (Int).T = T then
- User_Entry (Int) := Entry_Assoc'
- (T => Null_Task, E => Null_Task_Entry);
+ User_Entry (Int) :=
+ Entry_Assoc'
+ (T => Null_Task, E => Null_Task_Entry);
Unbind_Handler (Int);
end if;
end if;
diff --git a/gcc/ada/5zintman.adb b/gcc/ada/5zintman.adb
index 0f1defc4715..2933f240a39 100644
--- a/gcc/ada/5zintman.adb
+++ b/gcc/ada/5zintman.adb
@@ -53,8 +53,12 @@ with Interfaces.C;
with System.OS_Interface;
-- used for various Constants, Signal and types
+with Ada.Exceptions;
+-- used for Raise_Exception
+
package body System.Interrupt_Management is
+ use Ada.Exceptions;
use System.OS_Interface;
use type Interfaces.C.int;
@@ -87,6 +91,7 @@ package body System.Interrupt_Management is
-- VxWorks will suspend the task when it gets a hardware
-- exception. We take the liberty of resuming the task
-- for the application.
+
My_Id := taskIdSelf;
if taskIsSuspended (My_Id) /= 0 then
@@ -95,16 +100,17 @@ package body System.Interrupt_Management is
case signo is
when SIGFPE =>
- raise Constraint_Error;
+ Raise_Exception (Constraint_Error'Identity, "SIGFPE");
when SIGILL =>
- raise Constraint_Error;
+ Raise_Exception (Constraint_Error'Identity, "SIGILL");
when SIGSEGV =>
- raise Program_Error;
+ Raise_Exception
+ (Program_Error'Identity,
+ "stack overflow or erroneous memory access");
when SIGBUS =>
- raise Program_Error;
+ Raise_Exception (Program_Error'Identity, "SIGBUS");
when others =>
- -- Unexpected signal
- raise Program_Error;
+ Raise_Exception (Program_Error'Identity, "unhandled signal");
end case;
end Notify_Exception;
@@ -133,11 +139,29 @@ begin
declare
mask : aliased sigset_t;
Result : int;
+
+ function State (Int : Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ Runtime : constant Character := 'r';
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
begin
- Abort_Task_Interrupt := SIGABRT;
+ -- Initialize signal handling
+
-- Change this if you want to use another signal for task abort.
-- SIGTERM might be a good one.
+ Abort_Task_Interrupt := SIGABRT;
+
Exception_Action.sa_handler := Notify_Exception'Address;
Exception_Action.sa_flags := SA_ONSTACK;
Result := sigemptyset (mask'Access);
@@ -149,5 +173,17 @@ begin
end loop;
Exception_Action.sa_mask := mask;
+
+ -- Initialize hardware interrupt handling
+
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
+
+ -- Check all interrupts for state that requires keeping them reserved
+
+ for J in Interrupt_ID'Range loop
+ if State (J) = Default or else State (J) = Runtime then
+ Reserve (J) := True;
+ end if;
+ end loop;
end;
end System.Interrupt_Management;
diff --git a/gcc/ada/5zml-tgt.adb b/gcc/ada/5zml-tgt.adb
new file mode 100644
index 00000000000..7016a222cd6
--- /dev/null
+++ b/gcc/ada/5zml-tgt.adb
@@ -0,0 +1,322 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- M L I B . T G T --
+-- (VxWorks Version) --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a set of target dependent routines to build
+-- static libraries.
+
+-- This is the VxWorks version of the body
+
+with MLib.Fil;
+with Namet; use Namet;
+with Prj.Com;
+with Sdefault;
+
+package body MLib.Tgt is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Get_Target_Suffix return String;
+ -- Returns the required suffix for some utilities
+ -- (such as ar and ranlib) that depend on the real target.
+
+ ---------------------
+ -- Archive_Builder --
+ ---------------------
+
+ function Archive_Builder return String is
+ begin
+ return "ar" & Get_Target_Suffix;
+ end Archive_Builder;
+
+ -----------------------------
+ -- Archive_Builder_Options --
+ -----------------------------
+
+ function Archive_Builder_Options return String_List_Access is
+ begin
+ return new String_List'(1 => new String'("cr"));
+ end Archive_Builder_Options;
+
+ -----------------
+ -- Archive_Ext --
+ -----------------
+
+ function Archive_Ext return String is
+ begin
+ return "a";
+ end Archive_Ext;
+
+ ---------------------
+ -- Archive_Indexer --
+ ---------------------
+
+ function Archive_Indexer return String is
+ begin
+ return "ranlib" & Get_Target_Suffix;
+ end Archive_Indexer;
+
+ ---------------------------
+ -- Build_Dynamic_Library --
+ ---------------------------
+
+ procedure Build_Dynamic_Library
+ (Ofiles : Argument_List;
+ Foreign : Argument_List;
+ Afiles : Argument_List;
+ Options : Argument_List;
+ Interfaces : Argument_List;
+ Lib_Filename : String;
+ Lib_Dir : String;
+ Driver_Name : Name_Id := No_Name;
+ Lib_Address : String := "";
+ Lib_Version : String := "";
+ Relocatable : Boolean := False;
+ Auto_Init : Boolean := False)
+ is
+ pragma Unreferenced (Ofiles);
+ pragma Unreferenced (Foreign);
+ pragma Unreferenced (Afiles);
+ pragma Unreferenced (Options);
+ pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Lib_Filename);
+ pragma Unreferenced (Lib_Dir);
+ pragma Unreferenced (Driver_Name);
+ pragma Unreferenced (Lib_Address);
+ pragma Unreferenced (Lib_Version);
+ pragma Unreferenced (Relocatable);
+ pragma Unreferenced (Auto_Init);
+
+ begin
+ null;
+ end Build_Dynamic_Library;
+
+ -------------------------
+ -- Default_DLL_Address --
+ -------------------------
+
+ function Default_DLL_Address return String is
+ begin
+ return "";
+ end Default_DLL_Address;
+
+ -------------
+ -- DLL_Ext --
+ -------------
+
+ function DLL_Ext return String is
+ begin
+ return "";
+ end DLL_Ext;
+
+ --------------------
+ -- Dynamic_Option --
+ --------------------
+
+ function Dynamic_Option return String is
+ begin
+ return "";
+ end Dynamic_Option;
+
+ -----------------------------
+ -- Get_Target_Suffix --
+ -----------------------------
+
+ function Get_Target_Suffix return String is
+ Target_Name : String_Ptr := Sdefault.Target_Name;
+ Index : Positive := Target_Name'First;
+ begin
+ while ((Index < Target_Name'Last) and then
+ (Target_Name (Index + 1) /= '-')) loop
+ Index := Index + 1;
+ end loop;
+
+ if Target_Name (Target_Name'First .. Index) = "m68k" then
+ return "68k";
+ elsif Target_Name (Target_Name'First .. Index) = "mips" then
+ return "mips";
+ elsif Target_Name (Target_Name'First .. Index) = "powerpc" then
+ return "ppc";
+ elsif Target_Name (Target_Name'First .. Index) = "sparc" then
+ return "sparc";
+ elsif Target_Name (Target_Name'First .. Index) = "sparc64" then
+ return "sparc64";
+ elsif Target_Name (Target_Name'First .. Index) = "xscale" then
+ return "arm";
+ else
+ return "";
+ end if;
+ end Get_Target_Suffix;
+
+ -------------------
+ -- Is_Object_Ext --
+ -------------------
+
+ function Is_Object_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".o";
+ end Is_Object_Ext;
+
+ --------------
+ -- Is_C_Ext --
+ --------------
+
+ function Is_C_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".c";
+ end Is_C_Ext;
+
+ --------------------
+ -- Is_Archive_Ext --
+ --------------------
+
+ function Is_Archive_Ext (Ext : String) return Boolean is
+ begin
+ return Ext = ".a";
+ end Is_Archive_Ext;
+
+ -------------
+ -- Libgnat --
+ -------------
+
+ function Libgnat return String is
+ begin
+ return "libgnat.a";
+ end Libgnat;
+
+ ------------------------
+ -- Library_Exists_For --
+ ------------------------
+
+ function Library_Exists_For (Project : Project_Id) return Boolean is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
+ "for non library project");
+ return False; -- To avoid warning;
+
+ else
+ declare
+ Lib_Dir : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Dir);
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ if Projects.Table (Project).Library_Kind = Static then
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ return Is_Regular_File
+ (Lib_Dir & Directory_Separator & "lib" &
+ Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+ end;
+ end if;
+ end Library_Exists_For;
+
+ ---------------------------
+ -- Library_File_Name_For --
+ ---------------------------
+
+ function Library_File_Name_For (Project : Project_Id) return Name_Id is
+ begin
+ if not Projects.Table (Project).Library then
+ Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
+ "for non library project");
+ return No_Name;
+
+ else
+ declare
+ Lib_Name : constant String :=
+ Get_Name_String (Projects.Table (Project).Library_Name);
+
+ begin
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "lib";
+
+ if Projects.Table (Project).Library_Kind = Static then
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext));
+
+ else
+ Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext));
+ end if;
+
+ return Name_Find;
+ end;
+ end if;
+ end Library_File_Name_For;
+
+ --------------------------------
+ -- Linker_Library_Path_Option --
+ --------------------------------
+
+ function Linker_Library_Path_Option return String_Access is
+ begin
+ return new String'("-Wl,-R,");
+ end Linker_Library_Path_Option;
+
+ ----------------
+ -- Object_Ext --
+ ----------------
+
+ function Object_Ext return String is
+ begin
+ return "o";
+ end Object_Ext;
+
+ ----------------
+ -- PIC_Option --
+ ----------------
+
+ function PIC_Option return String is
+ begin
+ return "";
+ end PIC_Option;
+
+ -----------------------------------------------
+ -- Standalone_Library_Auto_Init_Is_Supported --
+ -----------------------------------------------
+
+ function Standalone_Library_Auto_Init_Is_Supported return Boolean is
+ begin
+ return False;
+ end Standalone_Library_Auto_Init_Is_Supported;
+
+ ---------------------------
+ -- Support_For_Libraries --
+ ---------------------------
+
+ function Support_For_Libraries return Library_Support is
+ begin
+ return Static_Only;
+ end Support_For_Libraries;
+
+end MLib.Tgt;
diff --git a/gcc/ada/5zosinte.adb b/gcc/ada/5zosinte.adb
index 1fbb58c6405..7c665e7d2a4 100644
--- a/gcc/ada/5zosinte.adb
+++ b/gcc/ada/5zosinte.adb
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -100,8 +100,8 @@ package body System.OS_Interface is
F := F + 1.0;
end if;
- return timespec' (ts_sec => S,
- ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ return timespec'(ts_sec => S,
+ ts_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
-------------------------
diff --git a/gcc/ada/5zosinte.ads b/gcc/ada/5zosinte.ads
index 398db312c0d..fb14fa0762f 100644
--- a/gcc/ada/5zosinte.ads
+++ b/gcc/ada/5zosinte.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2002 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -214,6 +214,15 @@ package System.OS_Interface is
-- VxWorks specific API --
--------------------------
+ subtype STATUS is int;
+ -- Equivalent of the C type STATUS
+
+ OK : constant STATUS := 0;
+ ERROR : constant STATUS := Interfaces.C.int (-1);
+
+ function taskIdVerify (tid : t_id) return STATUS;
+ pragma Import (C, taskIdVerify, "taskIdVerify");
+
function taskIdSelf return t_id;
pragma Import (C, taskIdSelf, "taskIdSelf");
@@ -227,7 +236,7 @@ package System.OS_Interface is
pragma Import (C, taskIsSuspended, "taskIsSuspended");
function taskVarAdd
- (tid : t_id; pVar : System.Address) return int;
+ (tid : t_id; pVar : access System.Address) return int;
pragma Import (C, taskVarAdd, "taskVarAdd");
function taskVarDelete
@@ -287,12 +296,6 @@ package System.OS_Interface is
(tid : t_id; newPriority : int) return int;
pragma Import (C, taskPrioritySet, "taskPrioritySet");
- subtype STATUS is int;
- -- Equivalent of the C type STATUS
-
- OK : constant STATUS := 0;
- ERROR : constant STATUS := Interfaces.C.int (-1);
-
-- Semaphore creation flags.
SEM_Q_FIFO : constant := 0;
diff --git a/gcc/ada/5zosprim.adb b/gcc/ada/5zosprim.adb
index 1a5d036e3aa..0f32bbe6dce 100644
--- a/gcc/ada/5zosprim.adb
+++ b/gcc/ada/5zosprim.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -45,6 +45,7 @@ with Interfaces.C;
package body System.OS_Primitives is
use System.OS_Interface;
+ use type Interfaces.C.int;
--------------------------
-- Internal functions --
@@ -59,7 +60,12 @@ package body System.OS_Primitives is
Ticks : Long_Long_Integer;
Rate_Duration : Duration;
Ticks_Duration : Duration;
+
begin
+ if D < 0.0 then
+ return -1;
+ end if;
+
-- Ensure that the duration can be converted to ticks
-- at the current clock tick rate without overflowing.
@@ -68,8 +74,6 @@ package body System.OS_Primitives is
if D > (Duration'Last / Rate_Duration) then
Ticks := Long_Long_Integer (int'Last);
else
- -- We always want to round up to the nearest clock tick.
-
Ticks_Duration := D * Rate_Duration;
Ticks := Long_Long_Integer (Ticks_Duration);
@@ -94,6 +98,7 @@ package body System.OS_Primitives is
Result : int;
use type Interfaces.C.int;
+
begin
Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
pragma Assert (Result = 0);
@@ -114,10 +119,13 @@ package body System.OS_Primitives is
(Time : Duration;
Mode : Integer)
is
- Result : int;
Rel_Time : Duration;
Abs_Time : Duration;
Check_Time : Duration := Clock;
+ Ticks : int;
+
+ Result : int;
+ pragma Unreferenced (Result);
begin
if Mode = Relative then
@@ -130,7 +138,17 @@ package body System.OS_Primitives is
if Rel_Time > 0.0 then
loop
- Result := taskDelay (To_Clock_Ticks (Rel_Time));
+ Ticks := To_Clock_Ticks (Rel_Time);
+
+ if Mode = Relative and then Ticks < int'Last then
+ -- The first tick will delay anytime between 0 and
+ -- 1 / sysClkRateGet seconds, so we need to add one to
+ -- be on the safe side.
+
+ Ticks := Ticks + 1;
+ end if;
+
+ Result := taskDelay (Ticks);
Check_Time := Clock;
exit when Abs_Time <= Check_Time;
diff --git a/gcc/ada/5zparame.ads b/gcc/ada/5zparame.ads
new file mode 100644
index 00000000000..774280f8307
--- /dev/null
+++ b/gcc/ada/5zparame.ads
@@ -0,0 +1,203 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . P A R A M E T E R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the default VxWorks version of the package.`
+
+-- This package defines some system dependent parameters for GNAT. These
+-- are values that are referenced by the runtime library and are therefore
+-- relevant to the target machine.
+
+-- The parameters whose value is defined in the spec are not generally
+-- expected to be changed. If they are changed, it will be necessary to
+-- recompile the run-time library.
+
+-- The parameters which are defined by functions can be changed by modifying
+-- the body of System.Parameters in file s-parame.adb. A change to this body
+-- requires only rebinding and relinking of the application.
+
+-- Note: do not introduce any pragma Inline statements into this unit, since
+-- otherwise the relinking and rebinding capability would be deactivated.
+
+package System.Parameters is
+pragma Pure (Parameters);
+
+ ---------------------------------------
+ -- Task And Stack Allocation Control --
+ ---------------------------------------
+
+ type Task_Storage_Size is new Integer;
+ -- Type used in tasking units for task storage size
+
+ type Size_Type is new Task_Storage_Size;
+ -- Type used to provide task storage size to runtime
+
+ Unspecified_Size : constant Size_Type := Size_Type'First;
+ -- Value used to indicate that no size type is set
+
+ subtype Ratio is Size_Type range -1 .. 100;
+ Dynamic : constant Size_Type := -1;
+ -- The secondary stack ratio is a constant between 0 and 100 which
+ -- determines the percentage of the allocated task stack that is
+ -- used by the secondary stack (the rest being the primary stack).
+ -- The special value of minus one indicates that the secondary
+ -- stack is to be allocated from the heap instead.
+
+ Sec_Stack_Ratio : constant Ratio := Dynamic;
+ -- This constant defines the handling of the secondary stack
+
+ Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic;
+ -- Convenient Boolean for testing for dynamic secondary stack
+
+ function Default_Stack_Size return Size_Type;
+ -- Default task stack size used if none is specified
+
+ function Minimum_Stack_Size return Size_Type;
+ -- Minimum task stack size permitted
+
+ function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
+ -- Given the storage size stored in the TCB, return the Storage_Size
+ -- value required by the RM for the Storage_Size attribute. The
+ -- required adjustment is as follows:
+ --
+ -- when Size = Unspecified_Size, return Default_Stack_Size
+ -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
+ -- otherwise return given Size
+
+ Default_Env_Stack_Size : constant Size_Type := 14_336;
+ -- Assumed size of the environment task, if no other information
+ -- is available. This value is used when stack checking is
+ -- enabled and no GNAT_STACK_LIMIT environment variable is set.
+ -- This value is chosen as the VxWorks default stack size is 20kB,
+ -- and a little more than 4kB is necessary for the run time.
+
+ Stack_Grows_Down : constant Boolean := True;
+ -- This constant indicates whether the stack grows up (False) or
+ -- down (True) in memory as functions are called. It is used for
+ -- proper implementation of the stack overflow check.
+
+ ----------------------------------------------
+ -- Characteristics of types in Interfaces.C --
+ ----------------------------------------------
+
+ long_bits : constant := Long_Integer'Size;
+ -- Number of bits in type long and unsigned_long. The normal convention
+ -- is that this is the same as type Long_Integer, but this is not true
+ -- of all targets. For example, in OpenVMS long /= Long_Integer.
+
+ ----------------------------------------------
+ -- Behavior of Pragma Finalize_Storage_Only --
+ ----------------------------------------------
+
+ -- Garbage_Collected is a Boolean constant whose value indicates the
+ -- effect of the pragma Finalize_Storage_Entry on a controlled type.
+
+ -- Garbage_Collected = False
+
+ -- The system releases all storage on program termination only,
+ -- but not other garbage collection occurs, so finalization calls
+ -- are ommitted only for outer level onjects can be omitted if
+ -- pragma Finalize_Storage_Only is used.
+
+ -- Garbage_Collected = True
+
+ -- The system provides full garbage collection, so it is never
+ -- necessary to release storage for controlled objects for which
+ -- a pragma Finalize_Storage_Only is used.
+
+ Garbage_Collected : constant Boolean := False;
+ -- The storage mode for this system (release on program exit)
+
+ ---------------------
+ -- Tasking Profile --
+ ---------------------
+
+ -- In the following sections, constant parameters are defined to
+ -- allow some optimizations and fine tuning within the tasking run time
+ -- based on restrictions on the tasking features.
+
+ ----------------------
+ -- Locking Strategy --
+ ----------------------
+
+ Single_Lock : constant Boolean := False;
+ -- Indicates whether a single lock should be used within the tasking
+ -- run-time to protect internal structures. If True, a single lock
+ -- will be used, meaning less locking/unlocking operations, but also
+ -- more global contention. In general, Single_Lock should be set to
+ -- True on single processor machines, and to False to multi-processor
+ -- systems, but this can vary from application to application and also
+ -- depends on the scheduling policy.
+
+ -------------------
+ -- Task Abortion --
+ -------------------
+
+ No_Abort : constant Boolean := False;
+ -- This constant indicates whether abort statements and asynchronous
+ -- transfer of control (ATC) are disallowed. If set to True, it is
+ -- assumed that neither construct is used, and the run time does not
+ -- need to defer/undefer abort and check for pending actions at
+ -- completion points. A value of True for No_Abort corresponds to:
+ -- pragma Restrictions (No_Abort_Statements);
+ -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
+
+ ----------------------
+ -- Dynamic Priority --
+ ----------------------
+
+ Dynamic_Priority_Support : constant Boolean := True;
+ -- This constant indicates whether dynamic changes of task priorities
+ -- are allowed (True means normal RM mode in which such changes are
+ -- allowed). In particular, if this is False, then we do not need to
+ -- poll for pending base priority changes at every abort completion
+ -- point. A value of False for Dynamic_Priority_Support corresponds
+ -- to pragma Restrictions (No_Dynamic_Priorities);
+
+ ---------------------
+ -- Task Attributes --
+ ---------------------
+
+ Default_Attribute_Count : constant := 4;
+ -- Number of pre-allocated Address-sized task attributes stored in the
+ -- task control block.
+
+ --------------------
+ -- Runtime Traces --
+ --------------------
+
+ Runtime_Traces : constant Boolean := False;
+ -- This constant indicates whether the runtime outputs traces to a
+ -- predefined output or not (True means that traces are output).
+ -- See System.Traces for more details.
+
+end System.Parameters;
diff --git a/gcc/ada/5zsystem.ads b/gcc/ada/5zsystem.ads
index e7fd405966c..12bbec478ff 100644
--- a/gcc/ada/5zsystem.ads
+++ b/gcc/ada/5zsystem.ads
@@ -5,9 +5,9 @@
-- S Y S T E M --
-- --
-- S p e c --
--- (VXWORKS Version Alpha) --
+-- (VxWorks Version Alpha) --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -58,7 +58,7 @@ pragma Pure (System);
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
- Tick : constant := 1.0;
+ Tick : constant := 1.0 / 60.0;
-- Storage-related Declarations
@@ -126,21 +126,33 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := False;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := False;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := False;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := True;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := False;
+
end System;
diff --git a/gcc/ada/5ztaprop.adb b/gcc/ada/5ztaprop.adb
index 2051041becb..2451e91dce5 100644
--- a/gcc/ada/5ztaprop.adb
+++ b/gcc/ada/5ztaprop.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. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -68,9 +68,6 @@ with System.Tasking;
-- Task_ID
-- ATCB components and types
-with System.Task_Info;
--- used for Task_Image
-
with Interfaces.C;
with Unchecked_Conversion;
@@ -80,7 +77,6 @@ package body System.Task_Primitives.Operations is
use System.Tasking.Debug;
use System.Tasking;
- use System.Task_Info;
use System.OS_Interface;
use System.Parameters;
use type Interfaces.C.int;
@@ -98,15 +94,20 @@ package body System.Task_Primitives.Operations is
-- The followings are logically constants, but need to be initialized
-- at run time.
- Current_Task : aliased Task_ID;
- pragma Export (Ada, Current_Task);
- -- Task specific value used to store the Ada Task_ID.
-
Single_RTS_Lock : aliased RTS_Lock;
-- This is a lock to allow only one thread of control in the RTS at
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ ATCB_Key : aliased System.Address := System.Null_Address;
+ -- Key used to find the Ada Task_ID associated with a thread
+
+ ATCB_Key_Addr : System.Address := ATCB_Key'Address;
+ pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr");
+ -- Exported to support the temporary AE653 task registration
+ -- implementation. This mechanism is used to minimize impact on other
+ -- targets.
+
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
@@ -129,11 +130,51 @@ package body System.Task_Primitives.Operations is
Mutex_Protocol : Priority_Type;
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads).
+
+ --------------------
+ -- Local Packages --
+ --------------------
+
+ package Specific is
+
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does executing thread have a TCB?
+
+ procedure Set (Self_Id : Task_ID);
+ pragma Inline (Set);
+ -- Set the self id for the current task.
+
+ function Self return Task_ID;
+ pragma Inline (Self);
+ -- Return a pointer to the Ada Task Control Block of the calling task.
+
+ end Specific;
+
+ package body Specific is separate;
+ -- The body of this package is target specific.
+
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
+ -- Allocate and Initialize a new ATCB for the current Thread.
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_ID is separate;
+
-----------------------
-- Local Subprograms --
-----------------------
procedure Abort_Handler (signo : Signal);
+ -- Handler for the abort (SIGABRT) signal to handle asynchronous abortion.
+
+ procedure Install_Signal_Handlers;
+ -- Install the default signal handlers for the current task
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
@@ -142,11 +183,20 @@ package body System.Task_Primitives.Operations is
-------------------
procedure Abort_Handler (signo : Signal) is
+ pragma Unreferenced (signo);
+
Self_ID : constant Task_ID := Self;
Result : int;
Old_Set : aliased sigset_t;
begin
+ -- It is not safe to raise an exception when using ZCX and the GCC
+ -- exception handling mechanism.
+
+ if ZCX_By_Default and then GCC_ZCX_Support then
+ return;
+ end if;
+
if Self_ID.Deferral_Level = 0
and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
and then not Self_ID.Aborting
@@ -168,8 +218,12 @@ package body System.Task_Primitives.Operations is
-----------------
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
+ pragma Unreferenced (T);
+ pragma Unreferenced (On);
+
begin
- -- Nothing needed.
+ -- Nothing needed (why not???)
+
null;
end Stack_Guard;
@@ -186,24 +240,17 @@ package body System.Task_Primitives.Operations is
-- Self --
----------
- function Self return Task_ID is
- begin
- pragma Assert (Current_Task /= null);
- return Current_Task;
- end Self;
+ function Self return Task_ID renames Specific.Self;
-----------------------------
-- Install_Signal_Handlers --
-----------------------------
- procedure Install_Signal_Handlers;
- -- Install the default signal handlers for the current task.
-
procedure Install_Signal_Handlers is
- act : aliased struct_sigaction;
- old_act : aliased struct_sigaction;
- Tmp_Set : aliased sigset_t;
- Result : int;
+ act : aliased struct_sigaction;
+ old_act : aliased struct_sigaction;
+ Tmp_Set : aliased sigset_t;
+ Result : int;
begin
act.sa_flags := 0;
@@ -236,6 +283,8 @@ package body System.Task_Primitives.Operations is
end Initialize_Lock;
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ pragma Unreferenced (Level);
+
begin
L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
L.Prio_Ceiling := int (System.Any_Priority'Last);
@@ -249,6 +298,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Lock (L : access Lock) is
Result : int;
+
begin
Result := semDelete (L.Mutex);
pragma Assert (Result = 0);
@@ -256,6 +306,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Lock (L : access RTS_Lock) is
Result : int;
+
begin
Result := semDelete (L.Mutex);
pragma Assert (Result = 0);
@@ -267,6 +318,7 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Result : int;
+
begin
if L.Protocol = Prio_Protect
and then int (Self.Common.Current_Priority) > L.Prio_Ceiling
@@ -282,9 +334,11 @@ package body System.Task_Primitives.Operations is
end Write_Lock;
procedure Write_Lock
- (L : access RTS_Lock; Global_Lock : Boolean := False)
+ (L : access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : int;
+
begin
if not Single_Lock or else Global_Lock then
Result := semTake (L.Mutex, WAIT_FOREVER);
@@ -294,6 +348,7 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (T : Task_ID) is
Result : int;
+
begin
if not Single_Lock then
Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER);
@@ -316,6 +371,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access Lock) is
Result : int;
+
begin
Result := semGive (L.Mutex);
pragma Assert (Result = 0);
@@ -323,6 +379,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : int;
+
begin
if not Single_Lock or else Global_Lock then
Result := semGive (L.Mutex);
@@ -332,6 +389,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (T : Task_ID) is
Result : int;
+
begin
if not Single_Lock then
Result := semGive (T.Common.LL.L.Mutex);
@@ -344,16 +402,14 @@ package body System.Task_Primitives.Operations is
-----------
procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is
+ pragma Unreferenced (Reason);
+
Result : int;
+
begin
pragma Assert (Self_ID = Self);
- -- Disable task scheduling.
-
- Result := taskLock;
-
-- Release the mutex before sleeping.
-
if Single_Lock then
Result := semGive (Single_RTS_Lock.Mutex);
else
@@ -362,24 +418,15 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
- -- Indicate that there is another thread waiting on the CV.
-
- Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1;
-
-- Perform a blocking operation to take the CV semaphore.
-- Note that a blocking operation in VxWorks will reenable
-- task scheduling. When we are no longer blocked and control
-- is returned, task scheduling will again be disabled.
- Result := semTake (Self_ID.Common.LL.CV.Sem, WAIT_FOREVER);
-
- if Result /= 0 then
- Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting - 1;
- pragma Assert (False);
- end if;
+ Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER);
+ pragma Assert (Result = 0);
-- Take the mutex back.
-
if Single_Lock then
Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
else
@@ -387,10 +434,6 @@ package body System.Task_Primitives.Operations is
end if;
pragma Assert (Result = 0);
-
- -- Reenable task scheduling.
-
- Result := taskUnlock;
end Sleep;
-----------------
@@ -409,78 +452,105 @@ package body System.Task_Primitives.Operations is
Timedout : out Boolean;
Yielded : out Boolean)
is
- Ticks : int;
- Result : int;
+ pragma Unreferenced (Reason);
+
+ Orig : constant Duration := Monotonic_Clock;
+ Absolute : Duration;
+ Ticks : int;
+ Result : int;
+ Wakeup : Boolean := False;
begin
- Timedout := True;
- Yielded := True;
+ Timedout := False;
+ Yielded := True;
if Mode = Relative then
+ Absolute := Orig + Time;
+
-- Systematically add one since the first tick will delay
-- *at most* 1 / Rate_Duration seconds, so we need to add one to
-- be on the safe side.
- Ticks := To_Clock_Ticks (Time) + 1;
+ Ticks := To_Clock_Ticks (Time);
+
+ if Ticks > 0 and then Ticks < int'Last then
+ Ticks := Ticks + 1;
+ end if;
+
else
- Ticks := To_Clock_Ticks (Time - Monotonic_Clock);
+ Absolute := Time;
+ Ticks := To_Clock_Ticks (Time - Monotonic_Clock);
end if;
if Ticks > 0 then
- -- Disable task scheduling.
-
- Result := taskLock;
-
- -- Release the mutex before sleeping.
-
- if Single_Lock then
- Result := semGive (Single_RTS_Lock.Mutex);
- else
- Result := semGive (Self_ID.Common.LL.L.Mutex);
- end if;
+ loop
+ -- Release the mutex before sleeping.
+ if Single_Lock then
+ Result := semGive (Single_RTS_Lock.Mutex);
+ else
+ Result := semGive (Self_ID.Common.LL.L.Mutex);
+ end if;
- pragma Assert (Result = 0);
+ pragma Assert (Result = 0);
- -- Indicate that there is another thread waiting on the CV.
+ -- Perform a blocking operation to take the CV semaphore.
+ -- Note that a blocking operation in VxWorks will reenable
+ -- task scheduling. When we are no longer blocked and control
+ -- is returned, task scheduling will again be disabled.
- Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1;
+ Result := semTake (Self_ID.Common.LL.CV, Ticks);
- -- Perform a blocking operation to take the CV semaphore.
- -- Note that a blocking operation in VxWorks will reenable
- -- task scheduling. When we are no longer blocked and control
- -- is returned, task scheduling will again be disabled.
+ if Result = 0 then
+ -- Somebody may have called Wakeup for us
- Result := semTake (Self_ID.Common.LL.CV.Sem, Ticks);
+ Wakeup := True;
- if Result = 0 then
- -- Somebody may have called Wakeup for us
+ else
+ if errno /= S_objLib_OBJ_TIMEOUT then
+ Wakeup := True;
+ else
+ -- If Ticks = int'last, it was most probably truncated
+ -- so let's make another round after recomputing Ticks
+ -- from the the absolute time.
+
+ if Ticks /= int'Last then
+ Timedout := True;
+ else
+ Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
+
+ if Ticks < 0 then
+ Timedout := True;
+ end if;
+ end if;
+ end if;
+ end if;
- Timedout := False;
+ -- Take the mutex back.
+ if Single_Lock then
+ Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
+ else
+ Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
+ end if;
- else
- Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting - 1;
+ pragma Assert (Result = 0);
- if errno /= S_objLib_OBJ_TIMEOUT then
- Timedout := False;
- end if;
- end if;
+ exit when Timedout or Wakeup;
+ end loop;
- -- Take the mutex back.
+ else
+ Timedout := True;
+ -- Should never hold a lock while yielding.
if Single_Lock then
+ Result := semGive (Single_RTS_Lock.Mutex);
+ taskDelay (0);
Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
+
else
+ Result := semGive (Self_ID.Common.LL.L.Mutex);
+ taskDelay (0);
Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
end if;
-
- pragma Assert (Result = 0);
-
- -- Reenable task scheduling.
-
- Result := taskUnlock;
-
- else
- taskDelay (0);
end if;
end Timed_Sleep;
@@ -501,75 +571,83 @@ package body System.Task_Primitives.Operations is
Ticks : int;
Timedout : Boolean;
Result : int;
+ Aborted : Boolean := False;
begin
SSL.Abort_Defer.all;
- if Single_Lock then
- Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
- else
- Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
- end if;
-
- pragma Assert (Result = 0);
-
if Mode = Relative then
Absolute := Orig + Time;
+ Ticks := To_Clock_Ticks (Time);
- Ticks := To_Clock_Ticks (Time);
+ if Ticks > 0 and then Ticks < int'Last then
- if Ticks > 0 then
-- The first tick will delay anytime between 0 and
-- 1 / sysClkRateGet seconds, so we need to add one to
-- be on the safe side.
Ticks := Ticks + 1;
end if;
+
else
Absolute := Time;
Ticks := To_Clock_Ticks (Time - Orig);
end if;
if Ticks > 0 then
+ -- Modifying State and Pending_Priority_Change, locking the TCB.
+ if Single_Lock then
+ Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
+ else
+ Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER);
+ end if;
+
+ pragma Assert (Result = 0);
+
Self_ID.Common.State := Delay_Sleep;
+ Timedout := False;
loop
if Self_ID.Pending_Priority_Change then
Self_ID.Pending_Priority_Change := False;
- Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
+ Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority;
Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
end if;
- exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
+ Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
- Timedout := False;
- Result := taskLock;
+ -- Release the TCB before sleeping
if Single_Lock then
Result := semGive (Single_RTS_Lock.Mutex);
else
Result := semGive (Self_ID.Common.LL.L.Mutex);
end if;
-
pragma Assert (Result = 0);
- -- Indicate that there is another thread waiting on the CV.
-
- Self_ID.Common.LL.CV.Waiting := Self_ID.Common.LL.CV.Waiting + 1;
+ exit when Aborted;
- Result := semTake (Self_ID.Common.LL.CV.Sem, Ticks);
+ Result := semTake (Self_ID.Common.LL.CV, Ticks);
if Result /= 0 then
- Self_ID.Common.LL.CV.Waiting :=
- Self_ID.Common.LL.CV.Waiting - 1;
+ -- If Ticks = int'last, it was most probably truncated
+ -- so let's make another round after recomputing Ticks
+ -- from the the absolute time.
- if errno = S_objLib_OBJ_TIMEOUT then
+ if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then
Timedout := True;
else
Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock);
+
+ if Ticks < 0 then
+ Timedout := True;
+ end if;
end if;
end if;
+ -- Take back the lock after having slept, to protect further
+ -- access to Self_ID
+
if Single_Lock then
Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER);
else
@@ -578,25 +656,21 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0);
- -- Reenable task scheduling.
-
- Result := taskUnlock;
-
exit when Timedout;
end loop;
Self_ID.Common.State := Runnable;
- else
- taskDelay (0);
- end if;
- if Single_Lock then
- Result := semGive (Single_RTS_Lock.Mutex);
+ if Single_Lock then
+ Result := semGive (Single_RTS_Lock.Mutex);
+ else
+ Result := semGive (Self_ID.Common.LL.L.Mutex);
+ end if;
+
else
- Result := semGive (Self_ID.Common.LL.L.Mutex);
+ taskDelay (0);
end if;
- pragma Assert (Result = 0);
SSL.Abort_Undefer.all;
end Timed_Delay;
@@ -620,7 +694,7 @@ package body System.Task_Primitives.Operations is
function RT_Resolution return Duration is
begin
- return 10#1.0#E-6;
+ return 1.0 / Duration (sysClkRateGet);
end RT_Resolution;
------------
@@ -628,30 +702,13 @@ package body System.Task_Primitives.Operations is
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
- Result : int;
- begin
- -- Disable task scheduling.
-
- Result := taskLock;
-
- -- Iff someone is currently waiting on the condition variable
- -- then release the semaphore; we don't want to leave the
- -- semaphore in the full state because the next guy to do
- -- a condition wait operation would not block.
-
- if T.Common.LL.CV.Waiting > 0 then
- Result := semGive (T.Common.LL.CV.Sem);
+ pragma Unreferenced (Reason);
- -- One less thread waiting on the CV.
-
- T.Common.LL.CV.Waiting := T.Common.LL.CV.Waiting - 1;
-
- pragma Assert (Result = 0);
- end if;
-
- -- Reenable task scheduling.
+ Result : int;
- Result := taskUnlock;
+ begin
+ Result := semGive (T.Common.LL.CV);
+ pragma Assert (Result = 0);
end Wakeup;
-----------
@@ -659,7 +716,10 @@ package body System.Task_Primitives.Operations is
-----------
procedure Yield (Do_Yield : Boolean := True) is
+ pragma Unreferenced (Do_Yield);
+
Result : int;
+
begin
Result := taskDelay (0);
end Yield;
@@ -673,25 +733,25 @@ package body System.Task_Primitives.Operations is
Prio_Array : Prio_Array_Type;
-- Global array containing the id of the currently running task for
- -- each priority.
- --
- -- Note: we assume that we are on a single processor with run-til-blocked
- -- scheduling.
+ -- each priority. Note that we assume that we are on a single processor
+ -- with run-till-blocked scheduling.
procedure Set_Priority
- (T : Task_ID;
- Prio : System.Any_Priority;
+ (T : Task_ID;
+ Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
Array_Item : Integer;
Result : int;
begin
- Result := taskPrioritySet
- (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio)));
+ Result :=
+ taskPrioritySet
+ (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio)));
pragma Assert (Result = 0);
if FIFO_Within_Priorities then
+
-- Annex D requirement [RM D.2.2 par. 9]:
-- If the task drops its priority due to the loss of inherited
-- priority, it is added at the head of the ready queue for its
@@ -704,9 +764,9 @@ package body System.Task_Primitives.Operations is
Prio_Array (T.Common.Base_Priority) := Array_Item;
loop
- -- Let some processes a chance to arrive
+ -- Give some processes a chance to arrive
- Yield;
+ taskDelay (0);
-- Then wait for our turn to proceed
@@ -736,16 +796,14 @@ package body System.Task_Primitives.Operations is
----------------
procedure Enter_Task (Self_ID : Task_ID) is
- Result : int;
-
procedure Init_Float;
pragma Import (C, Init_Float, "__gnat_init_float");
-- Properly initializes the FPU for PPC/MIPS systems.
begin
Self_ID.Common.LL.Thread := taskIdSelf;
- Result := taskVarAdd (0, Current_Task'Address);
- Current_Task := Self_ID;
+ Specific.Set (Self_ID);
+
Init_Float;
-- Install the signal handlers.
@@ -776,17 +834,35 @@ package body System.Task_Primitives.Operations is
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_ID is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (taskIdSelf);
+ end if;
+ end Register_Foreign_Thread;
+
--------------------
-- Initialize_TCB --
--------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
begin
- Self_ID.Common.LL.CV.Sem := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
- Self_ID.Common.LL.CV.Waiting := 0;
+ Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY);
Self_ID.Common.LL.Thread := 0;
- if Self_ID.Common.LL.CV.Sem = 0 then
+ if Self_ID.Common.LL.CV = 0 then
Succeeded := False;
else
Succeeded := True;
@@ -808,10 +884,7 @@ package body System.Task_Primitives.Operations is
Priority : System.Any_Priority;
Succeeded : out Boolean)
is
- use type System.Task_Info.Task_Image_Type;
-
Adjusted_Stack_Size : size_t;
-
begin
if Stack_Size = Unspecified_Size then
Adjusted_Stack_Size := size_t (Default_Stack_Size);
@@ -838,6 +911,7 @@ package body System.Task_Primitives.Operations is
--
-- XXX - we should come back and visit this so we can
-- set the task name to something appropriate.
+
Adjusted_Stack_Size := Adjusted_Stack_Size + 2048;
-- Since the initial signal mask of a thread is inherited from the
@@ -845,7 +919,7 @@ package body System.Task_Primitives.Operations is
-- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially.
- if T.Common.Task_Image = null then
+ if T.Common.Task_Image_Len = 0 then
T.Common.LL.Thread := taskSpawn
(System.Null_Address,
To_VxWorks_Priority (int (Priority)),
@@ -855,9 +929,10 @@ package body System.Task_Primitives.Operations is
To_Address (T));
else
declare
- Name : aliased String (1 .. T.Common.Task_Image'Length + 1);
+ Name : aliased String (1 .. T.Common.Task_Image_Len + 1);
begin
- Name (1 .. Name'Last - 1) := T.Common.Task_Image.all;
+ Name (1 .. Name'Last - 1) :=
+ T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
Name (Name'Last) := ASCII.NUL;
T.Common.LL.Thread := taskSpawn
@@ -885,21 +960,22 @@ package body System.Task_Primitives.Operations is
------------------
procedure Finalize_TCB (T : Task_ID) is
- Result : int;
- Tmp : Task_ID := T;
+ Result : int;
+ Tmp : Task_ID := T;
+ Is_Self : constant Boolean := (T = Self);
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
begin
- if Single_Lock then
+ if not Single_Lock then
Result := semDelete (T.Common.LL.L.Mutex);
pragma Assert (Result = 0);
end if;
T.Common.LL.Thread := 0;
- Result := semDelete (T.Common.LL.CV.Sem);
+ Result := semDelete (T.Common.LL.CV);
pragma Assert (Result = 0);
if T.Known_Tasks_Index /= -1 then
@@ -907,6 +983,11 @@ package body System.Task_Primitives.Operations is
end if;
Free (Tmp);
+
+ if Is_Self then
+ Result := taskVarDelete (taskIdSelf, ATCB_Key'Access);
+ pragma Assert (Result /= ERROR);
+ end if;
end Finalize_TCB;
---------------
@@ -915,8 +996,7 @@ package body System.Task_Primitives.Operations is
procedure Exit_Task is
begin
- Task_Termination_Hook;
- taskDelete (0);
+ Specific.Set (null);
end Exit_Task;
----------------
@@ -925,6 +1005,7 @@ package body System.Task_Primitives.Operations is
procedure Abort_Task (T : Task_ID) is
Result : int;
+
begin
Result := kill (T.Common.LL.Thread,
Signal (Interrupt_Management.Abort_Task_Interrupt));
@@ -935,10 +1016,11 @@ package body System.Task_Primitives.Operations is
-- Check_Exit --
----------------
- -- Dummy versions. The only currently working version is for solaris
- -- (native).
+ -- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
+
begin
return True;
end Check_Exit;
@@ -948,6 +1030,8 @@ package body System.Task_Primitives.Operations is
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ pragma Unreferenced (Self_ID);
+
begin
return True;
end Check_No_Locks;
@@ -985,7 +1069,9 @@ package body System.Task_Primitives.Operations is
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
begin
if T.Common.LL.Thread /= 0
and then T.Common.LL.Thread /= Thread_Self
@@ -1002,7 +1088,9 @@ package body System.Task_Primitives.Operations is
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
begin
if T.Common.LL.Thread /= 0
and then T.Common.LL.Thread /= Thread_Self
@@ -1018,19 +1106,8 @@ package body System.Task_Primitives.Operations is
----------------
procedure Initialize (Environment_Task : Task_ID) is
- begin
- Environment_Task_ID := Environment_Task;
-
- -- Initialize the lock used to synchronize chain of all ATCBs.
-
- Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
-
- Enter_Task (Environment_Task);
- end Initialize;
-
-begin
- declare
Result : int;
+
begin
if Locking_Policy = 'C' then
Mutex_Protocol := Prio_Protect;
@@ -1048,5 +1125,14 @@ begin
Result := sigemptyset (Unblocked_Signal_Mask'Access);
pragma Assert (Result = 0);
- end;
+
+ Environment_Task_ID := Environment_Task;
+
+ -- Initialize the lock used to synchronize chain of all ATCBs.
+
+ Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
+
+ Enter_Task (Environment_Task);
+ end Initialize;
+
end System.Task_Primitives.Operations;
diff --git a/gcc/ada/5ztaspri.ads b/gcc/ada/5ztaspri.ads
new file mode 100644
index 00000000000..efd41ccd984
--- /dev/null
+++ b/gcc/ada/5ztaspri.ads
@@ -0,0 +1,95 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is a VxWorks version of this package.
+
+pragma Polling (Off);
+-- Turn off polling, we do not want ATC polling to take place during
+-- tasking operations. It causes infinite loops and other problems.
+
+with System.OS_Interface;
+
+package System.Task_Primitives is
+
+ type Lock is limited private;
+ -- Should be used for implementation of protected objects.
+
+ type RTS_Lock is limited private;
+ -- Should be used inside the runtime system.
+ -- The difference between Lock and the RTS_Lock is that the later
+ -- one serves only as a semaphore so that do not check for
+ -- ceiling violations.
+
+ type Task_Body_Access is access procedure;
+ -- Pointer to the task body's entry point (or possibly a wrapper
+ -- declared local to the GNARL).
+
+ type Private_Data is limited private;
+ -- Any information that the GNULLI needs maintained on a per-task
+ -- basis. A component of this type is guaranteed to be included
+ -- in the Ada_Task_Control_Block.
+
+private
+
+ type Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit);
+
+ type Lock is record
+ Mutex : System.OS_Interface.SEM_ID;
+ Protocol : Priority_Type;
+ Prio_Ceiling : System.OS_Interface.int;
+ -- priority ceiling of lock
+ end record;
+
+ type RTS_Lock is new Lock;
+
+ type Private_Data is record
+ Thread : aliased System.OS_Interface.t_id := 0;
+ pragma Atomic (Thread);
+ -- Thread field may be updated by two different threads of control.
+ -- (See, Enter_Task and Create_Task in s-taprop.adb).
+ -- They put the same value (thr_self value). We do not want to
+ -- use lock on those operations and the only thing we have to
+ -- make sure is that they are updated in atomic fashion.
+
+ LWP : aliased System.Address;
+ -- The purpose of this field is to provide a better tasking support on
+ -- gdb. The order of the two first fields (Thread and LWP) is important.
+ -- On targets where lwp is not relevant, this is equivalent to Thread.
+
+ CV : aliased System.OS_Interface.SEM_ID;
+
+ L : aliased RTS_Lock;
+ -- Protection for all components is lock L
+ end record;
+
+end System.Task_Primitives;
diff --git a/gcc/ada/5ztfsetr.adb b/gcc/ada/5ztfsetr.adb
new file mode 100644
index 00000000000..0cd3d1b1107
--- /dev/null
+++ b/gcc/ada/5ztfsetr.adb
@@ -0,0 +1,107 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E S . S E N D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for VxWorks targets.
+
+-- Trace information is sent to WindView using the wvEvent function.
+
+-- Note that wvEvent is from the VxWorks API.
+
+-- When adding a new event, just give an Id to then event, and then modify
+-- the WindView events database.
+
+-- Refer to WindView User's Guide for more details on how to add new events
+-- to the events database.
+
+----------------
+-- Send_Trace --
+----------------
+
+-- This procedure formats the string, maps the event Id to an Id
+-- recognized by WindView, and send the event using wvEvent
+
+separate (System.Traces.Format)
+procedure Send_Trace (Id : Trace_T; Info : String) is
+
+ procedure Wv_Event
+ (Id : Integer;
+ Buffer : System.Address;
+ Size : Integer);
+ pragma Import (C, Wv_Event, "wvEvent");
+
+ Info_Trace : String_Trace;
+ Id_Event : Integer;
+
+begin
+ Info_Trace := Format_Trace (Info);
+
+ case Id is
+ when M_Accept_Complete => Id_Event := 30000;
+ when M_Select_Else => Id_Event := 30001;
+ when M_RDV_Complete => Id_Event := 30002;
+ when M_Call_Complete => Id_Event := 30003;
+ when M_Delay => Id_Event := 30004;
+ when E_Kill => Id_Event := 30005;
+ when E_Missed => Id_Event := 30006;
+ when E_Timeout => Id_Event := 30007;
+
+ when W_Call => Id_Event := 30010;
+ when W_Accept => Id_Event := 30011;
+ when W_Select => Id_Event := 30012;
+ when W_Completion => Id_Event := 30013;
+ when W_Delay => Id_Event := 30014;
+ when WT_Select => Id_Event := 30015;
+ when WT_Call => Id_Event := 30016;
+ when WT_Completion => Id_Event := 30017;
+ when WU_Delay => Id_Event := 30018;
+
+ when PO_Call => Id_Event := 30020;
+ when POT_Call => Id_Event := 30021;
+ when PO_Run => Id_Event := 30022;
+ when PO_Lock => Id_Event := 30023;
+ when PO_Unlock => Id_Event := 30024;
+ when PO_Done => Id_Event := 30025;
+
+ when T_Create => Id_Event := 30030;
+ when T_Activate => Id_Event := 30031;
+ when T_Abort => Id_Event := 30032;
+ when T_Terminate => Id_Event := 30033;
+
+ -- Unrecognized events are given the special Id_Event value 29999
+
+ when others => Id_Event := 29999;
+
+ end case;
+
+ Wv_Event (Id_Event, Info_Trace'Address, Max_Size);
+end Send_Trace;
diff --git a/gcc/ada/5zthrini.adb b/gcc/ada/5zthrini.adb
new file mode 100644
index 00000000000..ded9a5118bb
--- /dev/null
+++ b/gcc/ada/5zthrini.adb
@@ -0,0 +1,113 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T H R E A D S . I N I T I A L I Z A T I O N --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks version of this package; to use this implementation,
+-- the task hook libraries should be included in the VxWorks kernel.
+
+with System.Secondary_Stack;
+with Interfaces.C;
+with Unchecked_Conversion;
+
+package body System.Threads.Initialization is
+
+ use Interfaces.C;
+
+ package SSS renames System.Secondary_Stack;
+
+ procedure Initialize_Task_Hooks;
+ -- Register the appropriate hooks (Register and Reset_TSD) to the
+ -- underlying OS, so that they will be called when a task is created
+ -- or reset.
+
+ Current_ATSD : aliased System.Address;
+ pragma Import (C, Current_ATSD, "__gnat_current_atsd");
+
+ ---------------------------
+ -- Initialize_Task_Hooks --
+ ---------------------------
+
+ procedure Initialize_Task_Hooks is separate;
+ -- Separate, as these hooks are different for AE653 and VxWorks 5.5.
+
+ --------------
+ -- Register --
+ --------------
+
+ function Register (T : OSI.Thread_Id) return OSI.STATUS is
+ TSD : ATSD_Access := new ATSD;
+ Result : OSI.STATUS;
+ begin
+ -- It cannot be assumed that the caller of this routine has a ATSD;
+ -- so neither this procedure nor the procedures that it calls should
+ -- raise or handle exceptions, or make use of a secondary stack.
+
+ if OSI.taskIdVerify (T) = OSI.ERROR
+ or else OSI.taskVarGet (T, Current_ATSD'Access) /= OSI.ERROR
+ then
+ return OSI.ERROR;
+ end if;
+
+ Result := OSI.taskVarAdd (T, Current_ATSD'Access);
+ pragma Assert (Result /= -1);
+ Result := OSI.taskVarSet (T, Current_ATSD'Access, TSD.all'Address);
+ pragma Assert (Result /= -1);
+ TSD.Sec_Stack_Addr := SSS.SS_Create;
+ SSS.SS_Init (TSD.Sec_Stack_Addr);
+ return Result;
+ end Register;
+
+ ---------------
+ -- Reset_TSD --
+ ---------------
+
+ function Reset_TSD (T : OSI.Thread_Id) return OSI.STATUS is
+ TSD_Ptr : int;
+ function To_Address is new Unchecked_Conversion
+ (Interfaces.C.int, ATSD_Access);
+ begin
+ TSD_Ptr := OSI.taskVarGet (T, Current_ATSD'Access);
+ pragma Assert (TSD_Ptr /= OSI.ERROR);
+
+ -- Just reset the secondary stack pointer. The implementation here
+ -- assumes that the fixed secondary stack implementation is used.
+ -- If not, there will be a memory leak (along with allocation, which
+ -- is prohibited for ARINC processes once the system enters "normal"
+ -- mode).
+
+ SSS.SS_Init (To_Address (TSD_Ptr).Sec_Stack_Addr);
+ return OSI.OK;
+ end Reset_TSD;
+
+begin
+ Initialize_Task_Hooks;
+end System.Threads.Initialization;
diff --git a/gcc/ada/5ztiitho.adb b/gcc/ada/5ztiitho.adb
new file mode 100644
index 00000000000..f5c60043dee
--- /dev/null
+++ b/gcc/ada/5ztiitho.adb
@@ -0,0 +1,52 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T H R E A D S . I N I T I A L I Z A T I O N . --
+-- I N I T I A L I Z E _ T A S K _ H O O K S --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks 5.5 version of this procedure
+
+separate (System.Threads.Initialization)
+
+procedure Initialize_Task_Hooks is
+
+ type FUNCPTR is access function (T : OSI.Thread_Id) return OSI.STATUS;
+
+ procedure taskCreateHookAdd (createHookFunction : FUNCPTR);
+ pragma Import (C, taskCreateHookAdd, "taskCreateHookAdd");
+
+ Result : OSI.STATUS;
+begin
+ taskCreateHookAdd (Register'Access);
+ -- Register the environment task
+ Result := Register (OSI.taskIdSelf);
+ pragma Assert (Result /= -1);
+end Initialize_Task_Hooks;
diff --git a/gcc/ada/5qstache.adb b/gcc/ada/5ztpopsp.adb
index 58460cdfb0f..6a69c38b511 100644
--- a/gcc/ada/5qstache.adb
+++ b/gcc/ada/5ztpopsp.adb
@@ -2,12 +2,11 @@
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- S Y S T E M . S T A C K _ C H E C K I N G --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
-- --
-- B o d y --
--- (Dummy version) --
-- --
--- Copyright (C) 2000 Ada Core Technologies, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,51 +26,49 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-package body System.Stack_Checking is
+-- This is a VxWorks version of this package where foreign threads are
+-- recognized.
- -----------------
- -- Stack_Check --
- -----------------
+separate (System.Task_Primitives.Operations)
+package body Specific is
- function Stack_Check (Stack_Address : System.Address) return Stack_Access is
- begin
- return null;
- end Stack_Check;
-
- ----------------------------
- -- Invalidate_Stack_Cache --
- ----------------------------
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
- procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
+ function Is_Valid_Task return Boolean is
begin
- null;
- end Invalidate_Stack_Cache;
+ return taskVarGet (taskIdSelf, ATCB_Key'Access) /= ERROR;
+ end Is_Valid_Task;
- --------------------
- -- Set_Stack_Size --
- --------------------
+ ---------
+ -- Set --
+ ---------
- -- Specify the stack size for the current frame.
+ procedure Set (Self_Id : Task_ID) is
+ Result : STATUS;
- procedure Set_Stack_Size
- (Stack_Size : System.Storage_Elements.Storage_Offset) is
begin
- null;
- end Set_Stack_Size;
+ if taskVarGet (0, ATCB_Key'Access) = ERROR then
+ Result := taskVarAdd (0, ATCB_Key'Access);
+ pragma Assert (Result = OK);
+ end if;
+
+ ATCB_Key := To_Address (Self_Id);
+ end Set;
- ------------------------
- -- Update_Stack_Cache --
- ------------------------
+ ----------
+ -- Self --
+ ----------
- procedure Update_Stack_Cache (Stack : Stack_Access) is
+ function Self return Task_ID is
begin
- null;
- end Update_Stack_Cache;
+ return To_Task_Id (ATCB_Key);
+ end Self;
-end System.Stack_Checking;
+end Specific;
diff --git a/gcc/ada/6vcpp.adb b/gcc/ada/6vcpp.adb
index 8e4764ea7b4..864e2377ce6 100644
--- a/gcc/ada/6vcpp.adb
+++ b/gcc/ada/6vcpp.adb
@@ -105,6 +105,8 @@ package body Interfaces.CPP is
Position : Positive)
return System.Address
is
+ pragma Warnings (Off, Vptr);
+ pragma Warnings (Off, Position);
begin
return Current_This;
-- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
@@ -168,6 +170,7 @@ package body Interfaces.CPP is
-------------------------------
function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is
+ pragma Warnings (Off, T);
begin
return True;
end CPP_Get_Remotely_Callable;
@@ -270,6 +273,8 @@ package body Interfaces.CPP is
-------------------------------
procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is
+ pragma Warnings (Off, T);
+ pragma Warnings (Off, Value);
begin
null;
end CPP_Set_Remotely_Callable;
@@ -321,11 +326,14 @@ package body Interfaces.CPP is
end Length;
procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is
+ pragma Warnings (Off, T);
+ pragma Warnings (Off, Value);
begin
null;
end CPP_Set_RC_Offset;
function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is
+ pragma Warnings (Off, T);
begin
return 0;
end CPP_Get_RC_Offset;
diff --git a/gcc/ada/6vcstrea.adb b/gcc/ada/6vcstrea.adb
index 20379da30ac..1a320bc545e 100644
--- a/gcc/ada/6vcstrea.adb
+++ b/gcc/ada/6vcstrea.adb
@@ -63,7 +63,7 @@ package body Interfaces.C_Streams is
for S in 1 .. size loop
Ch := fgetc (stream);
if Ch = EOF then
- return 0;
+ return Get_Count;
end if;
BA.all (C, S) := Character'Val (Ch);
end loop;
@@ -100,7 +100,7 @@ package body Interfaces.C_Streams is
for S in 1 .. size loop
Ch := fgetc (stream);
if Ch = EOF then
- return 0;
+ return Get_Count;
end if;
BA.all (C, S) := Character'Val (Ch);
end loop;
@@ -135,7 +135,7 @@ package body Interfaces.C_Streams is
for C in 1 .. count loop
for S in 1 .. size loop
if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then
- exit;
+ return Put_Count;
end if;
end loop;
Put_Count := Put_Count + 1;
@@ -168,7 +168,7 @@ package body Interfaces.C_Streams is
-- In order for the above fwrite hack to work, we must always buffer
-- stdout and stderr. Is_regular_file on VMS cannot detect when
-- these are redirected to a file, so checking for that condition
- -- doesn't help.
+ -- doesnt help.
if mode = IONBF
and then (stream = stdout or else stream = stderr)
diff --git a/gcc/ada/6vinterf.ads b/gcc/ada/6vinterf.ads
index 96902868ec3..e4c39108cc9 100644
--- a/gcc/ada/6vinterf.ads
+++ b/gcc/ada/6vinterf.ads
@@ -6,16 +6,38 @@
-- --
-- S p e c --
-- --
--- This specification is adapted from the Ada Reference Manual for use with --
--- GNAT. In accordance with the copyright of that document, you can freely --
--- copy and modify this specification, provided that if you redistribute a --
--- modified version, any changes that you have made are clearly indicated. --
+-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the implementation dependent sections of this file. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS version of this package which adds Float_Representation
--- pragmas to the IEEE floating point types to enusre they remain IEEE in
--- thse presence of a VAX_Float Float_Representatin configuration pragma.
+-- pragmas to the IEEE floating point types to ensure they remain IEEE in
+-- the presence of a configuration pragma Float_Representation (Vax_Float).
-- It assumes integer sizes of 8, 16, 32 and 64 are available, and that IEEE
-- floating-point formats are available.
diff --git a/gcc/ada/7sinmaop.adb b/gcc/ada/7sinmaop.adb
index 98058a22d8d..8c767b231e4 100644
--- a/gcc/ada/7sinmaop.adb
+++ b/gcc/ada/7sinmaop.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-1998, Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/7sintman.adb b/gcc/ada/7sintman.adb
index ee8acee5d58..72b1cf87380 100644
--- a/gcc/ada/7sintman.adb
+++ b/gcc/ada/7sintman.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2002, Florida State University --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,15 +26,12 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
--- This is the default version of this package
-
--- This is a Sun OS (FSU THREADS) version of this package
+-- This is the POSIX threads version of this package
-- PLEASE DO NOT add any dependences on other packages. ??? why not ???
-- This package is designed to work with or without tasking support.
@@ -51,16 +48,16 @@
-- signal handling, create a new s-intman.adb that will fit your needs.
-- This file assumes that:
---
+
-- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows:
-- SIGPFE => Constraint_Error
-- SIGILL => Program_Error
-- SIGSEGV => Storage_Error
-- SIGBUS => Storage_Error
---
+
-- SIGINT exists and will be kept unmasked unless the pragma
-- Unreserve_All_Interrupts is specified anywhere in the application.
---
+
-- System.OS_Interface contains the following:
-- SIGADAABORT: the signal that will be used to abort tasks.
-- Unmasked: the OS specific set of signals that should be unmasked in
@@ -109,7 +106,7 @@ package body System.Interrupt_Management is
begin
-- With the __builtin_longjmp, the signal mask is not restored, so we
- -- need to restore it explicitly.
+ -- need to restore it explicitely.
Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
pragma Assert (Result = 0);
@@ -151,7 +148,22 @@ begin
declare
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
- Result : Interfaces.C.int;
+ Result : System.OS_Interface.int;
+
+ function State (Int : Interrupt_ID) return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ User : constant Character := 'u';
+ Runtime : constant Character := 'r';
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
begin
-- Need to call pthread_init very early because it is doing signal
@@ -174,51 +186,86 @@ begin
-- The right fix should be made in sigsetjmp so that we save
-- the Signal_Set and restore it after a longjmp.
- -- Since SA_NODEFER is obsolete, instead we reset explicitly
+ -- Since SA_NODEFER is obsolete, instead we reset explicitely
-- the mask in the exception handler.
Result := sigemptyset (Signal_Mask'Access);
pragma Assert (Result = 0);
- -- ??? For the same reason explained above, we can't mask these
- -- signals because otherwise we won't be able to catch more than
- -- one signal.
+ -- Add signals that map to Ada exceptions to the mask.
+ for J in Exception_Interrupts'Range loop
+ if State (Exception_Interrupts (J)) /= Default then
+ Result :=
+ sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
+ pragma Assert (Result = 0);
+ end if;
+ end loop;
act.sa_mask := Signal_Mask;
- Keep_Unmasked (Abort_Task_Interrupt) := True;
+ pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
+ pragma Assert (Reserve = (Interrupt_ID'Range => False));
+
+ -- Process state of exception signals
+ for J in Exception_Interrupts'Range loop
+ if State (Exception_Interrupts (J)) /= User then
+ Keep_Unmasked (Exception_Interrupts (J)) := True;
+ Reserve (Exception_Interrupts (J)) := True;
+
+ if State (Exception_Interrupts (J)) /= Default then
+ Result :=
+ sigaction
+ (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
+ end if;
+ end loop;
- -- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but at
- -- the same time, disable the ability of handling this signal via
- -- package Ada.Interrupts.
+ if State (Abort_Task_Interrupt) /= User then
+ Keep_Unmasked (Abort_Task_Interrupt) := True;
+ Reserve (Abort_Task_Interrupt) := True;
+ end if;
- -- The pragma Unreserve_All_Interrupts let the user the ability to
- -- change this behavior.
+ -- Set SIGINT to unmasked state as long as it is not in "User"
+ -- state. Check for Unreserve_All_Interrupts last
- if Unreserve_All_Interrupts = 0 then
+ if State (SIGINT) /= User then
Keep_Unmasked (SIGINT) := True;
+ Reserve (SIGINT) := True;
end if;
- for J in Exception_Interrupts'Range loop
- Keep_Unmasked (Exception_Interrupts (J)) := True;
+ -- Check all signals for state that requires keeping them
+ -- unmasked and reserved
- Result :=
- sigaction
- (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
- old_act'Unchecked_Access);
- pragma Assert (Result = 0);
+ for J in Interrupt_ID'Range loop
+ if State (J) = Default or else State (J) = Runtime then
+ Keep_Unmasked (J) := True;
+ Reserve (J) := True;
+ end if;
end loop;
+ -- Add the set of signals that must always be unmasked for this target
+
for J in Unmasked'Range loop
Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
+ Reserve (Interrupt_ID (Unmasked (J))) := True;
end loop;
- Reserve := Keep_Unmasked or Keep_Masked;
+ -- Add target-specific reserved signals
for J in Reserved'Range loop
Reserve (Interrupt_ID (Reserved (J))) := True;
end loop;
+ -- Process pragma Unreserve_All_Interrupts. This overrides any
+ -- settings due to pragma Interrupt_State:
+
+ if Unreserve_All_Interrupts /= 0 then
+ Keep_Unmasked (SIGINT) := False;
+ Reserve (SIGINT) := False;
+ end if;
+
-- We do not have Signal 0 in reality. We just use this value
-- to identify non-existent signals (see s-intnam.ads). Therefore,
-- Signal 0 should not be used in all signal related operations hence
diff --git a/gcc/ada/7sosinte.adb b/gcc/ada/7sosinte.adb
index 252ce1f3046..b646a789b50 100644
--- a/gcc/ada/7sosinte.adb
+++ b/gcc/ada/7sosinte.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2001 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -78,8 +78,8 @@ package body System.OS_Interface is
F := F + 1.0;
end if;
- return timespec' (tv_sec => S,
- tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
+ return timespec'(tv_sec => S,
+ tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
----------------
@@ -102,8 +102,10 @@ package body System.OS_Interface is
F := F + 1.0;
end if;
- return struct_timeval' (tv_sec => S,
- tv_usec => long (Long_Long_Integer (F * 10#1#E6)));
+ return
+ struct_timeval'
+ (tv_sec => S,
+ tv_usec => long (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
-------------
diff --git a/gcc/ada/7sosprim.adb b/gcc/ada/7sosprim.adb
index a0c76f5c6d8..7cc32510576 100644
--- a/gcc/ada/7sosprim.adb
+++ b/gcc/ada/7sosprim.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -75,7 +75,9 @@ package body System.OS_Primitives is
function Clock return Duration is
TV : aliased struct_timeval;
+
Result : Integer;
+ pragma Unreferenced (Result);
begin
Result := gettimeofday (TV'Access, null);
@@ -110,8 +112,9 @@ package body System.OS_Primitives is
F := F + 1.0;
end if;
- return timespec' (tv_sec => S,
- tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9)));
+ return
+ timespec'(tv_sec => S,
+ tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
-----------------
@@ -124,10 +127,13 @@ package body System.OS_Primitives is
is
Request : aliased timespec;
Remaind : aliased timespec;
- Result : Integer;
Rel_Time : Duration;
Abs_Time : Duration;
Check_Time : Duration := Clock;
+
+ Result : Integer;
+ pragma Unreferenced (Result);
+
begin
if Mode = Relative then
Rel_Time := Time;
diff --git a/gcc/ada/7staprop.adb b/gcc/ada/7staprop.adb
index 5c1b1e16e0e..6ce0b46811b 100644
--- a/gcc/ada/7staprop.adb
+++ b/gcc/ada/7staprop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -110,6 +110,9 @@ package body System.Task_Primitives.Operations is
-- a time; it is used to execute in mutual exclusion from all other tasks.
-- Used mainly in Single_Lock mode, but also to protect All_Tasks_List
+ ATCB_Key : aliased pthread_key_t;
+ -- Key used to find the Ada Task_ID associated with a thread
+
Environment_Task_ID : Task_ID;
-- A variable to hold Task_ID for the environment task.
@@ -138,15 +141,8 @@ package body System.Task_Primitives.Operations is
FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F';
-- Indicates whether FIFO_Within_Priorities is set.
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Abort_Handler (Sig : Signal);
-
- function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
-
- function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+ Foreign_Task_Elaborated : aliased Boolean := True;
+ -- Used to identified fake tasks (i.e., non-Ada Threads).
--------------------
-- Local Packages --
@@ -158,6 +154,10 @@ package body System.Task_Primitives.Operations is
pragma Inline (Initialize);
-- Initialize various data needed by this package.
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does executing thread have a TCB?
+
procedure Set (Self_Id : Task_ID);
pragma Inline (Set);
-- Set the self id for the current task.
@@ -171,6 +171,26 @@ package body System.Task_Primitives.Operations is
package body Specific is separate;
-- The body of this package is target specific.
+ ---------------------------------
+ -- Support for foreign threads --
+ ---------------------------------
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
+ -- Allocate and Initialize a new ATCB for the current Thread.
+
+ function Register_Foreign_Thread
+ (Thread : Thread_Id) return Task_ID is separate;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Abort_Handler (Sig : Signal);
+ -- Signal handler used to implement asynchronous abort.
+ -- See also comment before body, below.
+
+ function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
+
-------------------
-- Abort_Handler --
-------------------
@@ -195,37 +215,20 @@ package body System.Task_Primitives.Operations is
-- systems do not restore the signal mask on longjmp(), leaving the
-- abort signal masked.
- -- Alternative solutions include:
-
- -- 1. Change the PC saved in the system-dependent Context
- -- parameter to point to code that raises the exception.
- -- Normal return from this handler will then raise
- -- the exception after the mask and other system state has
- -- been restored (see example below).
-
- -- 2. Use siglongjmp()/sigsetjmp() to implement exceptions.
-
- -- 3. Unmask the signal in the Abortion_Signal exception handler
- -- (in the RTS).
-
- -- The following procedure would be needed if we can't lonjmp out of
- -- a signal handler (See below)
-
- -- procedure Raise_Abort_Signal is
- -- begin
- -- raise Standard'Abort_Signal;
- -- end if;
-
- procedure Abort_Handler
- (Sig : Signal) is
+ procedure Abort_Handler (Sig : Signal) is
+ pragma Warnings (Off, Sig);
T : Task_ID := Self;
Result : Interfaces.C.int;
Old_Set : aliased sigset_t;
begin
- -- Assuming it is safe to longjmp out of a signal handler, the
- -- following code can be used:
+ -- It is not safe to raise an exception when using ZCX and the GCC
+ -- exception handling mechanism.
+
+ if ZCX_By_Default and then GCC_ZCX_Support then
+ return;
+ end if;
if T.Deferral_Level = 0
and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then
@@ -241,15 +244,6 @@ package body System.Task_Primitives.Operations is
raise Standard'Abort_Signal;
end if;
-
- -- Otherwise, something like this is required:
- -- if not Abort_Is_Deferred.all then
- -- -- Overwrite the return PC address with the address of the
- -- -- special raise routine, and "return" to that routine's
- -- -- starting address.
- -- Context.PC := Raise_Abort_Signal'Address;
- -- return;
- -- end if;
end Abort_Handler;
-----------------
@@ -264,6 +258,7 @@ package body System.Task_Primitives.Operations is
begin
if Stack_Base_Available then
+
-- Compute the guard page address
Guard_Page_Address :=
@@ -299,7 +294,7 @@ package body System.Task_Primitives.Operations is
---------------------
-- Note: mutexes and cond_variables needed per-task basis are
- -- initialized in Initialize_TCB and the Storage_Error is
+ -- initialized in Intialize_TCB and the Storage_Error is
-- handled. Other mutexes (such as RTS_Lock, Memory_Lock...)
-- used in RTS is initialized before any status change of RTS.
-- Therefore rasing Storage_Error in the following routines
@@ -347,8 +342,10 @@ package body System.Task_Primitives.Operations is
end Initialize_Lock;
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
+ pragma Warnings (Off, Level);
+
Attributes : aliased pthread_mutexattr_t;
- Result : Interfaces.C.int;
+ Result : Interfaces.C.int;
begin
Result := pthread_mutexattr_init (Attributes'Access);
@@ -391,6 +388,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Lock (L : access Lock) is
Result : Interfaces.C.int;
+
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@@ -398,6 +396,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_Lock (L : access RTS_Lock) is
Result : Interfaces.C.int;
+
begin
Result := pthread_mutex_destroy (L);
pragma Assert (Result = 0);
@@ -409,6 +408,7 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
Result : Interfaces.C.int;
+
begin
Result := pthread_mutex_lock (L);
@@ -419,9 +419,11 @@ package body System.Task_Primitives.Operations is
end Write_Lock;
procedure Write_Lock
- (L : access RTS_Lock; Global_Lock : Boolean := False)
+ (L : access RTS_Lock;
+ Global_Lock : Boolean := False)
is
Result : Interfaces.C.int;
+
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_lock (L);
@@ -431,6 +433,7 @@ package body System.Task_Primitives.Operations is
procedure Write_Lock (T : Task_ID) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock then
Result := pthread_mutex_lock (T.Common.LL.L'Access);
@@ -453,6 +456,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access Lock) is
Result : Interfaces.C.int;
+
begin
Result := pthread_mutex_unlock (L);
pragma Assert (Result = 0);
@@ -460,6 +464,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock or else Global_Lock then
Result := pthread_mutex_unlock (L);
@@ -469,6 +474,7 @@ package body System.Task_Primitives.Operations is
procedure Unlock (T : Task_ID) is
Result : Interfaces.C.int;
+
begin
if not Single_Lock then
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
@@ -484,7 +490,10 @@ package body System.Task_Primitives.Operations is
(Self_ID : Task_ID;
Reason : System.Tasking.Task_States)
is
+ pragma Warnings (Off, Reason);
+
Result : Interfaces.C.int;
+
begin
if Single_Lock then
Result := pthread_cond_wait
@@ -515,6 +524,8 @@ package body System.Task_Primitives.Operations is
Timedout : out Boolean;
Yielded : out Boolean)
is
+ pragma Warnings (Off, Reason);
+
Check_Time : constant Duration := Monotonic_Clock;
Rel_Time : Duration;
Abs_Time : Duration;
@@ -699,7 +710,10 @@ package body System.Task_Primitives.Operations is
------------
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
+ pragma Warnings (Off, Reason);
+
Result : Interfaces.C.int;
+
begin
Result := pthread_cond_signal (T.Common.LL.CV'Access);
pragma Assert (Result = 0);
@@ -711,6 +725,7 @@ package body System.Task_Primitives.Operations is
procedure Yield (Do_Yield : Boolean := True) is
Result : Interfaces.C.int;
+
begin
if Do_Yield then
Result := sched_yield;
@@ -726,6 +741,8 @@ package body System.Task_Primitives.Operations is
Prio : System.Any_Priority;
Loss_Of_Inheritance : Boolean := False)
is
+ pragma Warnings (Off, Loss_Of_Inheritance);
+
Result : Interfaces.C.int;
Param : aliased struct_sched_param;
@@ -791,9 +808,28 @@ package body System.Task_Primitives.Operations is
return new Ada_Task_Control_Block (Entry_Num);
end New_ATCB;
- ----------------------
- -- Initialize_TCB --
- ----------------------
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ function Register_Foreign_Thread return Task_ID is
+ begin
+ if Is_Valid_Task then
+ return Self;
+ else
+ return Register_Foreign_Thread (pthread_self);
+ end if;
+ end Register_Foreign_Thread;
+
+ --------------------
+ -- Initialize_TCB --
+ --------------------
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
Mutex_Attr : aliased pthread_mutexattr_t;
@@ -812,13 +848,21 @@ package body System.Task_Primitives.Operations is
pragma Assert (Result = 0 or else Result = ENOMEM);
if Result = 0 then
- Result := pthread_mutexattr_setprotocol
- (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
- pragma Assert (Result = 0);
-
- Result := pthread_mutexattr_setprioceiling
- (Mutex_Attr'Access, Interfaces.C.int (System.Any_Priority'Last));
- pragma Assert (Result = 0);
+ if Locking_Policy = 'C' then
+ Result := pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT);
+ pragma Assert (Result = 0);
+
+ Result := pthread_mutexattr_setprioceiling
+ (Mutex_Attr'Access,
+ Interfaces.C.int (System.Any_Priority'Last));
+ pragma Assert (Result = 0);
+
+ elsif Locking_Policy = 'I' then
+ Result := pthread_mutexattr_setprotocol
+ (Mutex_Attr'Access, PTHREAD_PRIO_INHERIT);
+ pragma Assert (Result = 0);
+ end if;
Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
Mutex_Attr'Access);
@@ -953,6 +997,7 @@ package body System.Task_Primitives.Operations is
procedure Finalize_TCB (T : Task_ID) is
Result : Interfaces.C.int;
Tmp : Task_ID := T;
+ Is_Self : constant Boolean := T = Self;
procedure Free is new
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
@@ -971,6 +1016,12 @@ package body System.Task_Primitives.Operations is
end if;
Free (Tmp);
+
+ if Is_Self then
+ Result := pthread_setspecific (ATCB_Key, System.Null_Address);
+ pragma Assert (Result = 0);
+ end if;
+
end Finalize_TCB;
---------------
@@ -979,7 +1030,10 @@ package body System.Task_Primitives.Operations is
procedure Exit_Task is
begin
- pthread_exit (System.Null_Address);
+ -- Mark this task as unknown, so that if Self is called, it won't
+ -- return a dangling pointer.
+
+ Specific.Set (null);
end Exit_Task;
----------------
@@ -999,10 +1053,11 @@ package body System.Task_Primitives.Operations is
-- Check_Exit --
----------------
- -- Dummy versions. The only currently working versions is for solaris
- -- (native).
+ -- Dummy version
function Check_Exit (Self_ID : ST.Task_ID) return Boolean is
+ pragma Warnings (Off, Self_ID);
+
begin
return True;
end Check_Exit;
@@ -1012,6 +1067,8 @@ package body System.Task_Primitives.Operations is
--------------------
function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is
+ pragma Warnings (Off, Self_ID);
+
begin
return True;
end Check_No_Locks;
@@ -1049,7 +1106,12 @@ package body System.Task_Primitives.Operations is
function Suspend_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
+ pragma Warnings (Off, T);
+ pragma Warnings (Off, Thread_Self);
+
begin
return False;
end Suspend_Task;
@@ -1060,7 +1122,12 @@ package body System.Task_Primitives.Operations is
function Resume_Task
(T : ST.Task_ID;
- Thread_Self : Thread_Id) return Boolean is
+ Thread_Self : Thread_Id)
+ return Boolean
+ is
+ pragma Warnings (Off, T);
+ pragma Warnings (Off, Thread_Self);
+
begin
return False;
end Resume_Task;
@@ -1075,6 +1142,20 @@ package body System.Task_Primitives.Operations is
Tmp_Set : aliased sigset_t;
Result : Interfaces.C.int;
+ function State (Int : System.Interrupt_Management.Interrupt_ID)
+ return Character;
+ pragma Import (C, State, "__gnat_get_interrupt_state");
+ -- Get interrupt state. Defined in a-init.c
+ -- The input argument is the interrupt number,
+ -- and the result is one of the following:
+
+ Default : constant Character := 's';
+ -- 'n' this interrupt not set by any Interrupt_State pragma
+ -- 'u' Interrupt_State pragma set state to User
+ -- 'r' Interrupt_State pragma set state to Runtime
+ -- 's' Interrupt_State pragma set state to System (use "default"
+ -- system handler)
+
begin
Environment_Task_ID := Environment_Task;
@@ -1088,20 +1169,23 @@ package body System.Task_Primitives.Operations is
-- Install the abort-signal handler
- act.sa_flags := 0;
- act.sa_handler := Abort_Handler'Address;
-
- Result := sigemptyset (Tmp_Set'Access);
- pragma Assert (Result = 0);
- act.sa_mask := Tmp_Set;
+ if State (System.Interrupt_Management.Abort_Task_Interrupt)
+ /= Default
+ then
+ act.sa_flags := 0;
+ act.sa_handler := Abort_Handler'Address;
- Result :=
- sigaction (
- Signal (System.Interrupt_Management.Abort_Task_Interrupt),
- act'Unchecked_Access,
- old_act'Unchecked_Access);
+ Result := sigemptyset (Tmp_Set'Access);
+ pragma Assert (Result = 0);
+ act.sa_mask := Tmp_Set;
- pragma Assert (Result = 0);
+ Result :=
+ sigaction
+ (Signal (System.Interrupt_Management.Abort_Task_Interrupt),
+ act'Unchecked_Access,
+ old_act'Unchecked_Access);
+ pragma Assert (Result = 0);
+ end if;
end Initialize;
begin
diff --git a/gcc/ada/7staspri.ads b/gcc/ada/7staspri.ads
index 5fc600cdb90..1717cce47f5 100644
--- a/gcc/ada/7staspri.ads
+++ b/gcc/ada/7staspri.ads
@@ -6,7 +6,8 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2000, Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/7stfsetr.adb b/gcc/ada/7stfsetr.adb
new file mode 100644
index 00000000000..a8e166d04ed
--- /dev/null
+++ b/gcc/ada/7stfsetr.adb
@@ -0,0 +1,313 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E S . S E N D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This version is for all targets, provided that System.IO.Put_Line is
+-- functional. It prints debug information to Standard Output
+
+with System.IO; use System.IO;
+with GNAT.Regpat; use GNAT.Regpat;
+
+----------------
+-- Send_Trace --
+----------------
+
+-- Prints debug information both in a human readable form
+-- and in the form they are sent from upper layers.
+
+separate (System.Traces.Format)
+procedure Send_Trace (Id : Trace_T; Info : String) is
+
+ type Param_Type is
+ (Name_Param,
+ Caller_Param,
+ Entry_Param,
+ Timeout_Param,
+ Acceptor_Param,
+ Parent_Param,
+ Number_Param);
+ -- Type of parameter found in the message
+
+ Info_Trace : String_Trace := Format_Trace (Info);
+
+ function Get_Param
+ (Input : String_Trace;
+ Param : Param_Type;
+ How_Many : Integer)
+ return String;
+ -- Extract a parameter from the given input string
+
+ ---------------
+ -- Get_Param --
+ ---------------
+
+ function Get_Param
+ (Input : String_Trace;
+ Param : Param_Type;
+ How_Many : Integer)
+ return String
+ is
+ pragma Unreferenced (How_Many);
+
+ Matches : Match_Array (1 .. 2);
+ begin
+ -- We need comments here ???
+
+ case Param is
+ when Name_Param =>
+ Match ("/N:([\w]+)", Input, Matches);
+
+ when Caller_Param =>
+ Match ("/C:([\w]+)", Input, Matches);
+
+ when Entry_Param =>
+ Match ("/E:([\s]*) +([0-9 ,]+)", Input, Matches);
+
+ when Timeout_Param =>
+ Match ("/T:([\s]*) +([0-9]+.[0-9]+)", Input, Matches);
+
+ when Acceptor_Param =>
+ Match ("/A:([\w]+)", Input, Matches);
+
+ when Parent_Param =>
+ Match ("/P:([\w]+)", Input, Matches);
+
+ when Number_Param =>
+ Match ("/#:([\s]*) +([0-9]+)", Input, Matches);
+ end case;
+
+ if Matches (1).First < Input'First then
+ return "";
+ end if;
+
+ case Param is
+ when Timeout_Param | Entry_Param | Number_Param =>
+ return Input (Matches (2).First .. Matches (2).Last);
+
+ when others =>
+ return Input (Matches (1).First .. Matches (1).Last);
+ end case;
+ end Get_Param;
+
+-- Start of processing for Send_Trace
+
+begin
+ New_Line;
+ Put_Line ("- Trace Debug Info ----------------");
+ Put ("Caught event Id : ");
+
+ case Id is
+ when M_Accept_Complete => Put ("M_Accept_Complete");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " completes accept on entry "
+ & Get_Param (Info_Trace, Entry_Param, 1) & " with "
+ & Get_Param (Info_Trace, Caller_Param, 1));
+
+ when M_Select_Else => Put ("M_Select_Else");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " selects else statement");
+
+ when M_RDV_Complete => Put ("M_RDV_Complete");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " completes rendezvous with "
+ & Get_Param (Info_Trace, Caller_Param, 1));
+
+ when M_Call_Complete => Put ("M_Call_Complete");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " completes call");
+
+ when M_Delay => Put ("M_Delay");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " completes delay "
+ & Get_Param (Info_Trace, Timeout_Param, 1));
+
+ when E_Missed => Put ("E_Missed");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " got an invalid acceptor "
+ & Get_Param (Info_Trace, Acceptor_Param, 1));
+
+ when E_Timeout => Put ("E_Timeout");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " ends select due to timeout ");
+
+ when E_Kill => Put ("E_Kill");
+ New_Line;
+ Put_Line ("Asynchronous Transfer of Control on task "
+ & Get_Param (Info_Trace, Name_Param, 1));
+
+ when W_Delay => Put ("W_Delay");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " sleeping "
+ & Get_Param (Info_Trace, Timeout_Param, 1)
+ & " seconds");
+
+ when WU_Delay => Put ("WU_Delay");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " sleeping until "
+ & Get_Param (Info_Trace, Timeout_Param, 1));
+
+ when W_Call => Put ("W_Call");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " calling entry "
+ & Get_Param (Info_Trace, Entry_Param, 1)
+ & " of " & Get_Param (Info_Trace, Acceptor_Param, 1));
+
+ when W_Accept => Put ("W_Accept");
+ New_Line;
+ Put ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " waiting on "
+ & Get_Param (Info_Trace, Number_Param, 1)
+ & " accept(s)"
+ & ", " & Get_Param (Info_Trace, Entry_Param, 1));
+ New_Line;
+
+ when W_Select => Put ("W_Select");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " waiting on "
+ & Get_Param (Info_Trace, Number_Param, 1)
+ & " select(s)"
+ & ", " & Get_Param (Info_Trace, Entry_Param, 1));
+ New_Line;
+
+ when W_Completion => Put ("W_Completion");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " waiting for completion ");
+
+ when WT_Select => Put ("WT_Select");
+ New_Line;
+ Put ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " waiting " & Get_Param (Info_Trace, Timeout_Param, 1)
+ & " seconds on "
+ & Get_Param (Info_Trace, Number_Param, 1)
+ & " select(s)");
+
+ if Get_Param (Info_Trace, Number_Param, 1) /= "" then
+ Put (", " & Get_Param (Info_Trace, Entry_Param, 1));
+ end if;
+
+ New_Line;
+
+ when WT_Call => Put ("WT_Call");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " calling entry "
+ & Get_Param (Info_Trace, Entry_Param, 1)
+ & " of " & Get_Param (Info_Trace, Acceptor_Param, 1)
+ & " with timeout "
+ & Get_Param (Info_Trace, Timeout_Param, 1));
+
+ when WT_Completion => Put ("WT_Completion");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " waiting "
+ & Get_Param (Info_Trace, Timeout_Param, 1)
+ & " for call completion");
+
+ when PO_Call => Put ("PO_Call");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " calling protected entry "
+ & Get_Param (Info_Trace, Entry_Param, 1));
+
+ when POT_Call => Put ("POT_Call");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " calling protected entry "
+ & Get_Param (Info_Trace, Entry_Param, 1)
+ & " with timeout "
+ & Get_Param (Info_Trace, Timeout_Param, 1));
+
+ when PO_Run => Put ("PO_Run");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " running entry "
+ & Get_Param (Info_Trace, Entry_Param, 1)
+ & " for "
+ & Get_Param (Info_Trace, Caller_Param, 1));
+
+ when PO_Done => Put ("PO_Done");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " finished call from "
+ & Get_Param (Info_Trace, Caller_Param, 1));
+
+ when PO_Lock => Put ("PO_Lock");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " took lock");
+
+ when PO_Unlock => Put ("PO_Unlock");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " released lock");
+
+ when T_Create => Put ("T_Create");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " created");
+
+ when T_Activate => Put ("T_Activate");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " activated");
+
+ when T_Abort => Put ("T_Abort");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " aborted by "
+ & Get_Param (Info_Trace, Parent_Param, 1));
+
+ when T_Terminate => Put ("T_Terminate");
+ New_Line;
+ Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
+ & " terminated");
+
+ when others
+ => Put ("Invalid Id");
+ end case;
+
+ Put_Line (" --> " & Info_Trace);
+ Put_Line ("-----------------------------------");
+ New_Line;
+end Send_Trace;
diff --git a/gcc/ada/7stpopsp.adb b/gcc/ada/7stpopsp.adb
index a0833b86836..1b84b8feb48 100644
--- a/gcc/ada/7stpopsp.adb
+++ b/gcc/ada/7stpopsp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2001, Florida State University --
+-- Copyright (C) 1992-2002, Free Software Fundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,40 +26,38 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
--- This is a FSU-like version of this package.
+-- This is a POSIX-like version of this package.
separate (System.Task_Primitives.Operations)
package body Specific is
- ------------------
- -- Local Data --
- ------------------
-
- -- The followings are logically constants, but need to be initialized
- -- at run time.
-
- ATCB_Key : aliased pthread_key_t;
- -- Key used to find the Ada Task_ID associated with a thread
-
----------------
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
+ pragma Warnings (Off, Environment_Task);
Result : Interfaces.C.int;
+
begin
Result := pthread_key_create (ATCB_Key'Access, null);
pragma Assert (Result = 0);
- Result := pthread_setspecific (ATCB_Key, To_Address (Environment_Task));
- pragma Assert (Result = 0);
end Initialize;
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
+ function Is_Valid_Task return Boolean is
+ begin
+ return pthread_getspecific (ATCB_Key) /= System.Null_Address;
+ end Is_Valid_Task;
+
---------
-- Set --
---------
@@ -77,12 +75,9 @@ package body Specific is
----------
function Self return Task_ID is
- Result : System.Address;
begin
- Result := pthread_getspecific (ATCB_Key);
- pragma Assert (Result /= System.Null_Address);
- return To_Task_ID (Result);
+ return To_Task_Id (pthread_getspecific (ATCB_Key));
end Self;
end Specific;
diff --git a/gcc/ada/7straceb.adb b/gcc/ada/7straceb.adb
index e3a7ff7f980..1811c5a603b 100644
--- a/gcc/ada/7straceb.adb
+++ b/gcc/ada/7straceb.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2000 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -48,36 +48,51 @@ package body System.Traceback is
(Traceback : System.Address;
Max_Len : Natural;
Len : out Natural;
- Exclude_Min,
- Exclude_Max : System.Address := System.Null_Address)
+ Exclude_Min : System.Address := System.Null_Address;
+ Exclude_Max : System.Address := System.Null_Address;
+ Skip_Frames : Natural := 1)
is
type Tracebacks_Array is array (1 .. Max_Len) of Code_Loc;
pragma Suppress_Initialization (Tracebacks_Array);
M : Machine_State;
Code : Code_Loc;
- J : Natural := 1;
+
Trace : Tracebacks_Array;
for Trace'Address use Traceback;
+ N_Skips : Natural := 0;
+
begin
M := Allocate_Machine_State;
Set_Machine_State (M);
+ -- Skip the requested number of frames
+
loop
Code := Get_Code_Loc (M);
+ exit when Code = Null_Address or else N_Skips = Skip_Frames;
- exit when Code = Null_Address or else J = Max_Len + 1;
+ Pop_Frame (M, System.Null_Address);
+ N_Skips := N_Skips + 1;
+ end loop;
+
+ -- Now, record the frames outside the exclusion bounds, updating
+ -- the Len output value along the way.
+
+ Len := 0;
+ loop
+ Code := Get_Code_Loc (M);
+ exit when Code = Null_Address or else Len = Max_Len;
if Code < Exclude_Min or else Code > Exclude_Max then
- Trace (J) := Code;
- J := J + 1;
+ Len := Len + 1;
+ Trace (Len) := Code;
end if;
Pop_Frame (M, System.Null_Address);
end loop;
- Len := J - 1;
Free_Machine_State (M);
end Call_Chain;
diff --git a/gcc/ada/s-explin.ads b/gcc/ada/7straces.adb
index aa1a442c52f..46822242a40 100644
--- a/gcc/ada/s-explin.ads
+++ b/gcc/ada/7straces.adb
@@ -1,21 +1,21 @@
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- S Y S T E M . E X P _ L I N T --
+-- S Y S T E M . T R A C E S --
-- --
--- S p e c --
+-- B o d y --
-- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- Copyright (C) 2001 Free Software Foundation, Inc. --
-- --
--- GNAT is free software; you can redistribute it and/or modify it under --
+-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
@@ -31,14 +31,43 @@
-- --
------------------------------------------------------------------------------
--- Long_Integer exponentiation (checks on)
+with System.Soft_Links;
+with System.Parameters;
+with System.Traces.Format;
-with System.Exp_Gen;
+package body System.Traces is
-package System.Exp_LInt is
-pragma Pure (Exp_LInt);
+ package SSL renames System.Soft_Links;
+ use System.Traces.Format;
- function Exp_Long_Integer is
- new System.Exp_Gen.Exp_Integer_Type (Long_Integer);
+ ----------------------
+ -- Send_Trace_Info --
+ ----------------------
-end System.Exp_LInt;
+ procedure Send_Trace_Info (Id : Trace_T) is
+ Task_S : String := SSL.Task_Name.all;
+ Trace_S : String (1 .. 3 + Task_S'Length);
+
+ begin
+ if Parameters.Runtime_Traces then
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. Trace_S'Last) := Task_S;
+ Send_Trace (Id, Trace_S);
+ end if;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info (Id : Trace_T; Timeout : Duration) is
+ Task_S : String := SSL.Task_Name.all;
+ Timeout_S : String := Duration'Image (Timeout);
+ Trace_S : String (1 .. 6 + Task_S'Length + Timeout_S'Length);
+
+ begin
+ if Parameters.Runtime_Traces then
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + Task_S'Length) := Task_S;
+ Trace_S (4 + Task_S'Length .. 6 + Task_S'Length) := "/T:";
+ Trace_S (7 + Task_S'Length .. Trace_S'Last) := Timeout_S;
+ Send_Trace (Id, Trace_S);
+ end if;
+ end Send_Trace_Info;
+end System.Traces;
diff --git a/gcc/ada/7strafor.adb b/gcc/ada/7strafor.adb
new file mode 100644
index 00000000000..8aa564463ad
--- /dev/null
+++ b/gcc/ada/7strafor.adb
@@ -0,0 +1,113 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E S . F O R M A T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Parameters;
+
+package body System.Traces.Format is
+
+ procedure Send_Trace (Id : Trace_T; Info : String) is separate;
+
+ ------------------
+ -- Format_Trace --
+ ------------------
+
+ function Format_Trace (Source : in String) return String_Trace is
+ Length : Integer := Source'Length;
+ Result : String_Trace := (others => ' ');
+
+ begin
+ -- If run-time tracing active, then fill the string
+
+ if Parameters.Runtime_Traces then
+ if Max_Size - Length > 0 then
+ Result (1 .. Length) := Source (1 .. Length);
+ Result (Length + 1 .. Max_Size) := (others => ' ');
+ Result (Length + 1) := ASCII.NUL;
+ else
+ Result (1 .. Max_Size - 1) := Source (1 .. Max_Size - 1);
+ Result (Max_Size) := ASCII.NUL;
+ end if;
+ end if;
+
+ return Result;
+ end Format_Trace;
+
+ ------------
+ -- Append --
+ ------------
+
+ function Append
+ (Source : String_Trace;
+ Annex : String)
+ return String_Trace
+ is
+ Result : String_Trace := (others => ' ');
+ Source_Length : Integer := 1;
+ Annex_Length : Integer := Annex'Length;
+
+ begin
+ if Parameters.Runtime_Traces then
+
+ -- First we determine the size used, without the spaces at the
+ -- end, if a String_Trace is present. Look at
+ -- System.Traces.Tasking for examples.
+
+ while Source (Source_Length) /= ASCII.NUL loop
+ Source_Length := Source_Length + 1;
+ end loop;
+
+ -- Then we fill the string.
+
+ if Source_Length - 1 + Annex_Length <= Max_Size then
+ Result (1 .. Source_Length - 1) :=
+ Source (1 .. Source_Length - 1);
+
+ Result (Source_Length .. Source_Length - 1 + Annex_Length) :=
+ Annex (1 .. Annex_Length);
+
+ Result (Source_Length + Annex_Length) := ASCII.NUL;
+
+ Result (Source_Length + Annex_Length + 1 .. Max_Size) :=
+ (others => ' ');
+ else
+ Result (1 .. Source_Length - 1) := Source (1 .. Source_Length - 1);
+ Result (Source_Length .. Max_Size - 1) :=
+ Annex (1 .. Max_Size - Source_Length);
+ Result (Max_Size) := ASCII.NUL;
+ end if;
+ end if;
+
+ return Result;
+ end Append;
+
+end System.Traces.Format;
diff --git a/gcc/ada/7strafor.ads b/gcc/ada/7strafor.ads
new file mode 100644
index 00000000000..fe232beeea8
--- /dev/null
+++ b/gcc/ada/7strafor.ads
@@ -0,0 +1,62 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E S . F O R M A T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package implements functions to format run-time traces
+
+package System.Traces.Format is
+
+ Max_Size : constant Integer := 128;
+ -- Event messages' maximum size.
+
+ subtype String_Trace is String (1 .. Max_Size);
+ -- Specific type in which trace information is stored. An ASCII.NUL
+ -- character ends the string so that it is compatible with C strings
+ -- which is useful on some targets (eg. VxWorks)
+
+ -- These private functions handles String_Trace formatting
+
+ function Format_Trace (Source : String) return String_Trace;
+ -- Put a String in a String_Trace, truncates the string if necessary.
+ -- Similar to Head( .. ) found in Ada.Strings.Bounded
+
+ function Append
+ (Source : String_Trace;
+ Annex : String)
+ return String_Trace;
+ pragma Inline (Append);
+ -- Concatenates two string, similar to & operator from Ada.String.Unbounded
+
+ procedure Send_Trace (Id : Trace_T; Info : String);
+ -- This function (which is a subunit) send messages to external programs
+
+end System.Traces.Format;
diff --git a/gcc/ada/7stratas.adb b/gcc/ada/7stratas.adb
new file mode 100644
index 00000000000..0e18aed2d96
--- /dev/null
+++ b/gcc/ada/7stratas.adb
@@ -0,0 +1,367 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E S . T A S K I N G --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Tasking; use System.Tasking;
+with System.Soft_Links;
+with System.Parameters;
+with System.Traces.Format; use System.Traces.Format;
+with System.Traces; use System.Traces;
+
+package body System.Traces.Tasking is
+
+ use System.Tasking;
+ use System.Traces;
+ use System.Traces.Format;
+
+ package SSL renames System.Soft_Links;
+
+ function Extract_Accepts (Task_Name : Task_ID) return String_Trace;
+ -- This function is used to extract data joined with
+ -- W_Select, WT_Select, W_Accept events
+
+ ---------------------
+ -- Send_Trace_Info --
+ ---------------------
+
+ procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : Task_ID) is
+ Task_S : constant String := SSL.Task_Name.all;
+ Task2_S : constant String :=
+ Task_Name2.Common.Task_Image
+ (1 .. Task_Name2.Common.Task_Image_Len);
+ Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
+
+ L0 : Integer := Task_S'Length;
+ L1 : Integer := Task2_S'Length;
+
+ begin
+ if Parameters.Runtime_Traces then
+ case Id is
+ when M_RDV_Complete | PO_Done =>
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + L0) := Task_S;
+ Trace_S (4 + L0 .. 6 + L0) := "/C:";
+ Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
+ Send_Trace (Id, Trace_S);
+
+ when E_Missed =>
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + L0) := Task_S;
+ Trace_S (4 + L0 .. 6 + L0) := "/A:";
+ Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
+ Send_Trace (Id, Trace_S);
+
+ when E_Kill =>
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + L1) := Task2_S;
+ Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
+ Send_Trace (Id, Trace_S);
+
+ when T_Create =>
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + L1) := Task2_S;
+ Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
+ Send_Trace (Id, Trace_S);
+
+ when others =>
+ null;
+ -- should raise an exception ???
+ end case;
+ end if;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name2 : Task_ID;
+ Entry_Number : Entry_Index)
+ is
+ Task_S : constant String := SSL.Task_Name.all;
+ Task2_S : constant String :=
+ Task_Name2.Common.Task_Image
+ (1 .. Task_Name2.Common.Task_Image_Len);
+ Entry_S : String := Integer'Image (Integer (Entry_Number));
+ Trace_S : String (1 .. 9 + Task_S'Length
+ + Task2_S'Length + Entry_S'Length);
+
+ L0 : Integer := Task_S'Length;
+ L1 : Integer := Task_S'Length + Entry_S'Length;
+ L2 : Integer := Task_S'Length + Task2_S'Length;
+
+ begin
+ if Parameters.Runtime_Traces then
+ case Id is
+ when M_Accept_Complete =>
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + L0) := Task_S;
+ Trace_S (4 + L0 .. 6 + L0) := "/E:";
+ Trace_S (7 + L0 .. 6 + L1) := Entry_S;
+ Trace_S (7 + L1 .. 9 + L1) := "/C:";
+ Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
+ Send_Trace (Id, Trace_S);
+
+ when W_Call =>
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + L0) := Task_S;
+ Trace_S (4 + L0 .. 6 + L0) := "/A:";
+ Trace_S (7 + L0 .. 6 + L2) := Task2_S;
+ Trace_S (7 + L2 .. 9 + L2) := "/C:";
+ Trace_S (10 + L2 .. Trace_S'Last) := Entry_S;
+ Send_Trace (Id, Trace_S);
+
+ when others =>
+ null;
+ -- should raise an exception ???
+ end case;
+ end if;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name : Task_ID;
+ Task_Name2 : Task_ID;
+ Entry_Number : Entry_Index)
+ is
+ Task_S : constant String :=
+ Task_Name.Common.Task_Image
+ (1 .. Task_Name.Common.Task_Image_Len);
+ Task2_S : constant String :=
+ Task_Name2.Common.Task_Image
+ (1 .. Task_Name2.Common.Task_Image_Len);
+ Entry_S : String := Integer'Image (Integer (Entry_Number));
+ Trace_S : String (1 .. 9 + Task_S'Length
+ + Task2_S'Length + Entry_S'Length);
+
+ L0 : Integer := Task_S'Length;
+ L1 : Integer := Task_S'Length + Entry_S'Length;
+
+ begin
+ if Parameters.Runtime_Traces then
+ case Id is
+ when PO_Run =>
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + L0) := Task_S;
+ Trace_S (4 + L0 .. 6 + L0) := "/E:";
+ Trace_S (7 + L0 .. 6 + L1) := Entry_S;
+ Trace_S (7 + L1 .. 9 + L1) := "/C:";
+ Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
+ Send_Trace (Id, Trace_S);
+
+ when others =>
+ null;
+ -- should raise an exception ???
+ end case;
+ end if;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info (Id : Trace_T; Entry_Number : Entry_Index) is
+ Task_S : String := SSL.Task_Name.all;
+ Entry_S : String := Integer'Image (Integer (Entry_Number));
+ Trace_S : String (1 .. 6 + Task_S'Length + Entry_S'Length);
+
+ L0 : Integer := Task_S'Length;
+
+ begin
+ if Parameters.Runtime_Traces then
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + L0) := Task_S;
+ Trace_S (4 + L0 .. 6 + L0) := "/E:";
+ Trace_S (7 + L0 .. Trace_S'Last) := Entry_S;
+ Send_Trace (Id, Trace_S);
+ end if;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name : Task_ID;
+ Task_Name2 : Task_ID)
+ is
+ Task_S : constant String :=
+ Task_Name.Common.Task_Image
+ (1 .. Task_Name.Common.Task_Image_Len);
+ Task2_S : constant String :=
+ Task_Name2.Common.Task_Image
+ (1 .. Task_Name2.Common.Task_Image_Len);
+ Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
+
+ L0 : Integer := Task2_S'Length;
+
+ begin
+ if Parameters.Runtime_Traces then
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + L0) := Task2_S;
+ Trace_S (4 + L0 .. 6 + L0) := "/P:";
+ Trace_S (7 + L0 .. Trace_S'Last) := Task_S;
+ Send_Trace (Id, Trace_S);
+ end if;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Acceptor : Task_ID;
+ Entry_Number : Entry_Index;
+ Timeout : Duration)
+ is
+ Task_S : constant String := SSL.Task_Name.all;
+ Acceptor_S : constant String :=
+ Acceptor.Common.Task_Image
+ (1 .. Acceptor.Common.Task_Image_Len);
+ Entry_S : String := Integer'Image (Integer (Entry_Number));
+ Timeout_S : String := Duration'Image (Timeout);
+ Trace_S : String (1 .. 12 + Task_S'Length + Acceptor_S'Length
+ + Entry_S'Length + Timeout_S'Length);
+
+ L0 : Integer := Task_S'Length;
+ L1 : Integer := Task_S'Length + Acceptor_S'Length;
+ L2 : Integer := Task_S'Length + Acceptor_S'Length + Entry_S'Length;
+
+ begin
+ if Parameters.Runtime_Traces then
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + L0) := Task_S;
+ Trace_S (4 + L0 .. 6 + L0) := "/A:";
+ Trace_S (7 + L0 .. 6 + L1) := Acceptor_S;
+ Trace_S (7 + L1 .. 9 + L1) := "/E:";
+ Trace_S (10 + L1 .. 9 + L2) := Entry_S;
+ Trace_S (10 + L2 .. 12 + L2) := "/T:";
+ Trace_S (13 + L2 .. Trace_S'Last) := Timeout_S;
+ Send_Trace (Id, Trace_S);
+ end if;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Entry_Number : Entry_Index;
+ Timeout : Duration)
+ is
+ Task_S : String := SSL.Task_Name.all;
+ Entry_S : String := Integer'Image (Integer (Entry_Number));
+ Timeout_S : String := Duration'Image (Timeout);
+ Trace_S : String (1 .. 9 + Task_S'Length
+ + Entry_S'Length + Timeout_S'Length);
+
+ L0 : Integer := Task_S'Length;
+ L1 : Integer := Task_S'Length + Entry_S'Length;
+
+ begin
+ if Parameters.Runtime_Traces then
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + L0) := Task_S;
+ Trace_S (4 + L0 .. 6 + L0) := "/E:";
+ Trace_S (7 + L0 .. 6 + L1) := Entry_S;
+ Trace_S (7 + L1 .. 9 + L1) := "/T:";
+ Trace_S (10 + L1 .. Trace_S'Last) := Timeout_S;
+ Send_Trace (Id, Trace_S);
+ end if;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name : Task_ID;
+ Number : Integer)
+ is
+ Task_S : String := SSL.Task_Name.all;
+ Number_S : String := Integer'Image (Number);
+ Accepts_S : String := Extract_Accepts (Task_Name);
+ Trace_S : String (1 .. 9 + Task_S'Length
+ + Number_S'Length + Accepts_S'Length);
+
+ L0 : Integer := Task_S'Length;
+ L1 : Integer := Task_S'Length + Number_S'Length;
+
+ begin
+ if Parameters.Runtime_Traces then
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + L0) := Task_S;
+ Trace_S (4 + L0 .. 6 + L0) := "/#:";
+ Trace_S (7 + L0 .. 6 + L1) := Number_S;
+ Trace_S (7 + L1 .. 9 + L1) := "/E:";
+ Trace_S (10 + L1 .. Trace_S'Last) := Accepts_S;
+ Send_Trace (Id, Trace_S);
+ end if;
+ end Send_Trace_Info;
+
+ procedure Send_Trace_Info
+ (Id : Trace_T;
+ Task_Name : Task_ID;
+ Number : Integer;
+ Timeout : Duration)
+ is
+ Task_S : String := SSL.Task_Name.all;
+ Timeout_S : String := Duration'Image (Timeout);
+ Number_S : String := Integer'Image (Number);
+ Accepts_S : String := Extract_Accepts (Task_Name);
+ Trace_S : String (1 .. 12 + Task_S'Length + Timeout_S'Length
+ + Number_S'Length + Accepts_S'Length);
+
+ L0 : Integer := Task_S'Length;
+ L1 : Integer := Task_S'Length + Timeout_S'Length;
+ L2 : Integer := Task_S'Length + Timeout_S'Length + Number_S'Length;
+
+ begin
+ if Parameters.Runtime_Traces then
+ Trace_S (1 .. 3) := "/N:";
+ Trace_S (4 .. 3 + L0) := Task_S;
+ Trace_S (4 + L0 .. 6 + L0) := "/T:";
+ Trace_S (7 + L0 .. 6 + L1) := Timeout_S;
+ Trace_S (7 + L1 .. 9 + L1) := "/#:";
+ Trace_S (10 + L1 .. 9 + L2) := Number_S;
+ Trace_S (10 + L2 .. 12 + L2) := "/E:";
+ Trace_S (13 + L2 .. Trace_S'Last) := Accepts_S;
+ Send_Trace (Id, Trace_S);
+ end if;
+ end Send_Trace_Info;
+
+ ---------------------
+ -- Extract_Accepts --
+ ---------------------
+
+ -- This function returns a string in which all opened
+ -- Accepts or Selects are given, separated by semi-colons.
+
+ function Extract_Accepts (Task_Name : Task_ID) return String_Trace is
+ Info_Annex : String_Trace := (ASCII.NUL, others => ' ');
+
+ begin
+ for J in Task_Name.Open_Accepts'First ..
+ Task_Name.Open_Accepts'Last - 1
+ loop
+ Info_Annex := Append (Info_Annex, Integer'Image
+ (Integer (Task_Name.Open_Accepts (J).S)) & ",");
+ end loop;
+
+ Info_Annex := Append (Info_Annex,
+ Integer'Image (Integer
+ (Task_Name.Open_Accepts
+ (Task_Name.Open_Accepts'Last).S)));
+ return Info_Annex;
+ end Extract_Accepts;
+end System.Traces.Tasking;
diff --git a/gcc/ada/9drpc.adb b/gcc/ada/9drpc.adb
index cca1785bbc1..dab584ed908 100644
--- a/gcc/ada/9drpc.adb
+++ b/gcc/ada/9drpc.adb
@@ -1009,7 +1009,7 @@ package body System.RPC is
Partition_ID'Image (Partition));
Garbage_Collector.Allocate (Anonymous);
- -- We subtracted the size of the header from the size of the
+ -- We substracted the size of the header from the size of the
-- global message in order to provide immediatly Params size
Anonymous.Element.Start
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 9d55409d2e9..b8d103e4ad2 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,262 @@
+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.
+
2003-10-20 Mark Mitchell <mark@codesourcery.com>
* Make-lang.in (gnat_ug_unx.info): Add dependency on stmp-docobjdir.
diff --git a/gcc/ada/Make-lang.in b/gcc/ada/Make-lang.in
index a3ef9109b7c..60c99135661 100644
--- a/gcc/ada/Make-lang.in
+++ b/gcc/ada/Make-lang.in
@@ -67,13 +67,14 @@ ADA_INCLUDE_DIR = $(libsubdir)/adainclude
ADA_RTL_OBJ_DIR = $(libsubdir)/adalib
THREAD_KIND=native
TRACE=no
-GNATBIND = $(STAGE_PREFIX)gnatbind -C
+GNATBIND = $(STAGE_PREFIX)gnatbind
ADA_FLAGS_TO_PASS = \
"ADA_FOR_BUILD=$(ADA_FOR_BUILD)" \
"ADA_INCLUDE_DIR=$(ADA_INCLUDE_DIR)" \
"ADA_RTL_OBJ_DIR=$(ADA_RTL_OBJ_DIR)" \
"ADAFLAGS=$(ADAFLAGS)" \
"ADA_FOR_TARGET=$(ADA_FOR_TARGET)" \
+ "INSTALL=$(INSTALL)" \
"INSTALL_DATA=$(INSTALL_DATA)" \
"INSTALL_PROGRAM=$(INSTALL_PROGRAM)"
@@ -85,11 +86,12 @@ ADA_FLAGS_TO_PASS = \
ada-warn = $(ALL_ADA_CFLAGS) $(WERROR)
# unresolved warnings in a couple of files
ada/tracebak.o-warn = -Wno-error
+ada/b_gnatb.o-warn = -Wno-error
.adb.o:
- $(ADAC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
+ $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
.ads.o:
- $(ADAC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
+ $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
# Define the names for selecting Ada in LANGUAGES.
Ada ada: gnat1$(exeext) gnatbind$(exeext)
@@ -119,40 +121,43 @@ GNAT1_C_OBJS = ada/b_gnat1.o ada/adadecode.o ada/adaint.o ada/cstreams.o \
# Object files from Ada sources that are used by gnat1
-GNAT_ADA_OBJS = \
- ada/ada.o ada/a-charac.o ada/a-chlat1.o ada/a-except.o ada/s-memory.o \
- ada/s-traceb.o ada/s-mastop.o ada/s-except.o ada/ali.o ada/alloc.o \
- ada/atree.o ada/butil.o ada/casing.o ada/checks.o ada/comperr.o ada/csets.o \
- ada/cstand.o ada/debug.o ada/debug_a.o ada/einfo.o ada/elists.o ada/errout.o \
- ada/eval_fat.o ada/exp_attr.o ada/exp_ch11.o ada/exp_ch12.o ada/exp_ch13.o \
- ada/exp_ch2.o ada/exp_ch3.o ada/exp_ch4.o ada/exp_ch5.o ada/exp_ch6.o \
- ada/exp_ch7.o ada/exp_ch8.o ada/exp_ch9.o ada/exp_code.o ada/exp_dbug.o \
- ada/exp_disp.o ada/exp_dist.o ada/exp_fixd.o ada/exp_aggr.o ada/exp_imgv.o \
- ada/exp_intr.o ada/exp_pakd.o ada/exp_prag.o ada/exp_smem.o ada/exp_strm.o \
- ada/exp_tss.o ada/exp_util.o ada/exp_vfpt.o ada/expander.o ada/fname.o \
- ada/fname-uf.o ada/fmap.o ada/freeze.o ada/frontend.o ada/gnat.o \
- ada/g-hesora.o ada/g-htable.o ada/g-os_lib.o ada/g-speche.o ada/s-crc32.o \
- ada/get_targ.o ada/gnatvsn.o ada/hlo.o ada/hostparm.o ada/impunit.o \
- ada/interfac.o ada/itypes.o ada/inline.o ada/krunch.o ada/lib.o ada/layout.o \
- ada/lib-load.o ada/lib-util.o ada/lib-xref.o ada/lib-writ.o ada/live.o \
- ada/namet.o ada/nlists.o ada/nmake.o ada/opt.o ada/osint.o ada/osint-c.o \
- ada/output.o ada/par.o ada/repinfo.o ada/restrict.o ada/rident.o \
- ada/rtsfind.o ada/s-assert.o ada/s-parame.o ada/s-stache.o ada/s-stalib.o \
- ada/s-imgenu.o ada/s-stoele.o ada/s-soflin.o ada/s-exctab.o ada/s-secsta.o \
- ada/s-wchcnv.o ada/s-wchcon.o ada/s-wchjis.o ada/s-unstyp.o ada/scans.o \
- ada/scn.o ada/sdefault.o ada/sem.o ada/sem_aggr.o ada/sem_attr.o \
- ada/sem_cat.o ada/sem_ch10.o ada/sem_ch11.o ada/sem_ch12.o ada/sem_ch13.o \
- ada/sem_ch2.o ada/sem_ch3.o ada/sem_ch4.o ada/sem_ch5.o ada/sem_ch6.o \
- ada/sem_ch7.o ada/sem_ch8.o ada/sem_ch9.o ada/sem_case.o ada/sem_disp.o \
- ada/sem_dist.o ada/sem_elab.o ada/sem_elim.o ada/sem_eval.o ada/sem_intr.o \
- ada/sem_maps.o ada/sem_mech.o ada/sem_prag.o ada/sem_res.o ada/sem_smem.o \
- ada/sem_type.o ada/sem_util.o ada/sem_vfpt.o ada/sem_warn.o ada/sinfo-cn.o \
- ada/sinfo.o ada/sinput.o ada/sinput-d.o ada/sinput-l.o ada/snames.o \
- ada/sprint.o ada/stand.o ada/stringt.o ada/style.o ada/switch.o \
- ada/switch-c.o ada/stylesw.o ada/validsw.o ada/system.o ada/table.o \
- ada/targparm.o ada/tbuild.o ada/tree_gen.o ada/tree_io.o ada/treepr.o \
- ada/treeprs.o ada/ttypef.o ada/ttypes.o ada/types.o ada/uintp.o ada/uname.o \
- ada/urealp.o ada/usage.o ada/widechar.o
+GNAT_ADA_OBJS = ada/ada.o ada/a-charac.o ada/a-chlat1.o ada/a-except.o \
+ ada/a-ioexce.o \
+ ada/s-memory.o ada/s-carun8.o ada/s-casuti.o ada/s-strcom.o ada/s-purexc.o \
+ ada/s-htable.o ada/s-traceb.o ada/s-mastop.o ada/s-except.o ada/ali.o \
+ ada/alloc.o ada/atree.o ada/butil.o ada/casing.o ada/checks.o ada/comperr.o \
+ ada/csets.o ada/cstand.o ada/debug.o ada/debug_a.o ada/einfo.o ada/elists.o \
+ ada/errout.o ada/erroutc.o ada/err_vars.o ada/eval_fat.o ada/exp_attr.o \
+ ada/exp_ch11.o ada/exp_ch12.o ada/exp_ch13.o ada/exp_ch2.o ada/exp_ch3.o \
+ ada/exp_ch4.o ada/exp_ch5.o ada/exp_ch6.o ada/exp_ch7.o ada/exp_ch8.o \
+ ada/exp_ch9.o ada/exp_code.o ada/exp_dbug.o ada/exp_disp.o ada/exp_dist.o \
+ ada/exp_fixd.o ada/exp_aggr.o ada/exp_imgv.o ada/exp_intr.o ada/exp_pakd.o \
+ ada/exp_prag.o ada/exp_smem.o ada/exp_strm.o ada/exp_tss.o ada/exp_util.o \
+ ada/exp_vfpt.o ada/expander.o ada/fname.o ada/fname-uf.o ada/fmap.o \
+ ada/freeze.o ada/frontend.o ada/gnat.o ada/g-hesora.o ada/g-htable.o \
+ ada/g-os_lib.o ada/g-speche.o ada/g-string.o ada/s-crc32.o ada/get_targ.o \
+ ada/gnatvsn.o ada/hlo.o ada/hostparm.o ada/impunit.o ada/interfac.o \
+ ada/itypes.o ada/inline.o ada/krunch.o ada/lib.o ada/layout.o ada/lib-load.o \
+ ada/lib-util.o ada/lib-xref.o ada/lib-writ.o ada/live.o ada/namet.o \
+ ada/nlists.o ada/nmake.o ada/opt.o ada/osint.o ada/osint-c.o ada/output.o \
+ ada/par.o ada/prep.o ada/prepcomp.o ada/repinfo.o ada/restrict.o \
+ ada/rident.o ada/rtsfind.o ada/s-assert.o ada/s-parame.o ada/s-stache.o \
+ ada/s-stalib.o ada/s-imgenu.o ada/s-stoele.o ada/s-soflin.o ada/s-exctab.o \
+ ada/s-secsta.o ada/s-traent.o ada/s-wchcnv.o ada/s-wchcon.o ada/s-wchjis.o \
+ ada/s-unstyp.o ada/scans.o ada/scng.o ada/scn.o ada/sdefault.o ada/sem.o \
+ ada/sem_aggr.o ada/sem_attr.o ada/sem_cat.o ada/sem_ch10.o ada/sem_ch11.o \
+ ada/sem_ch12.o ada/sem_ch13.o ada/sem_ch2.o ada/sem_ch3.o ada/sem_ch4.o \
+ ada/sem_ch5.o ada/sem_ch6.o ada/sem_ch7.o ada/sem_ch8.o ada/sem_ch9.o \
+ ada/sem_case.o ada/sem_disp.o ada/sem_dist.o ada/sem_elab.o ada/sem_elim.o \
+ ada/sem_eval.o ada/sem_intr.o ada/sem_maps.o ada/sem_mech.o ada/sem_prag.o \
+ ada/sem_res.o ada/sem_smem.o ada/sem_type.o ada/sem_util.o ada/sem_vfpt.o \
+ ada/sem_warn.o ada/sinfo-cn.o ada/sinfo.o ada/sinput.o ada/sinput-d.o \
+ ada/sinput-l.o ada/snames.o ada/sprint.o ada/stand.o ada/stringt.o \
+ ada/style.o ada/styleg.o ada/styleg-c.o ada/switch.o ada/switch-c.o \
+ ada/stylesw.o ada/validsw.o ada/system.o ada/table.o ada/targparm.o \
+ ada/tbuild.o ada/tree_gen.o ada/tree_io.o ada/treepr.o ada/treeprs.o \
+ ada/ttypef.o ada/ttypes.o ada/types.o ada/uintp.o ada/uname.o ada/urealp.o \
+ ada/usage.o ada/widechar.o
# Object files for gnat executables
GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o
@@ -160,38 +165,101 @@ GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o
GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) $(EXTRA_GNAT1_OBJS)
GNATBIND_OBJS = \
- ada/link.o ada/ada.o ada/adaint.o ada/cstreams.o ada/cio.o ada/ali.o \
- ada/ali-util.o ada/alloc.o ada/a-tags.o ada/a-stream.o ada/bcheck.o \
- ada/binde.o ada/binderr.o ada/bindgen.o ada/bindusg.o ada/butil.o \
- ada/casing.o ada/csets.o ada/debug.o ada/fname.o ada/gnat.o ada/g-hesora.o \
- ada/g-htable.o ada/g-os_lib.o ada/s-crc32.o ada/fmap.o ada/gnatbind.o \
- ada/gnatvsn.o ada/hostparm.o ada/krunch.o ada/namet.o ada/opt.o ada/osint.o \
- ada/osint-b.o ada/output.o ada/rident.o ada/s-assert.o ada/s-parame.o \
- ada/s-sopco3.o ada/s-sopco4.o ada/s-sopco5.o ada/s-stache.o ada/s-stalib.o \
- ada/s-stoele.o ada/s-imgenu.o ada/s-strops.o ada/s-soflin.o ada/s-wchcon.o \
- ada/s-wchjis.o ada/sdefault.o ada/switch.o ada/switch-b.o ada/stylesw.o \
- ada/validsw.o ada/system.o ada/table.o ada/tree_io.o ada/types.o \
- ada/widechar.o ada/raise.o ada/exit.o ada/argv.o ada/init.o ada/adafinal.o \
- ada/s-wchcnv.o ada/s-exctab.o ada/a-except.o ada/s-memory.o ada/s-traceb.o \
- ada/tracebak.o ada/s-mastop.o ada/s-except.o ada/s-secsta.o ada/atree.o \
- ada/scans.o ada/einfo.o ada/sinfo.o ada/scn.o ada/sinput.o ada/sinput-l.o \
- ada/targparm.o ada/errout.o ada/style.o ada/stand.o ada/lib.o ada/uintp.o \
- ada/elists.o ada/nlists.o ada/stringt.o ada/snames.o ada/uname.o \
- ada/urealp.o \
+ ada/adaint.o \
+ ada/argv.o \
+ ada/exit.o \
+ ada/cio.o \
+ ada/cstreams.o \
+ ada/final.o \
+ ada/init.o \
+ ada/link.o \
+ ada/raise.o \
+ ada/tracebak.o \
+ ada/a-except.o \
+ ada/ada.o \
+ ada/ali-util.o \
+ ada/ali.o \
+ ada/alloc.o \
+ ada/atree.o \
+ ada/bcheck.o \
+ ada/binde.o \
+ ada/binderr.o \
+ ada/bindgen.o \
+ ada/bindusg.o \
+ ada/butil.o \
+ ada/casing.o \
+ ada/csets.o \
+ ada/debug.o \
+ ada/einfo.o \
+ ada/elists.o \
+ ada/fmap.o \
+ ada/fname.o \
+ ada/g-hesora.o \
+ ada/g-htable.o \
+ ada/g-os_lib.o \
+ ada/g-string.o \
+ ada/gnat.o \
+ ada/gnatbind.o \
+ ada/gnatvsn.o \
+ ada/hostparm.o \
+ ada/interfac.o \
+ ada/lib.o \
+ ada/namet.o \
+ ada/nlists.o \
+ ada/opt.o \
+ ada/osint-b.o \
+ ada/osint.o \
+ ada/output.o \
+ ada/rident.o \
+ ada/s-assert.o \
+ ada/s-carun8.o \
+ ada/s-casuti.o \
+ ada/s-crc32.o \
+ ada/s-except.o \
+ ada/s-exctab.o \
+ ada/s-htable.o \
+ ada/s-imgenu.o \
+ ada/s-mastop.o \
+ ada/s-memory.o \
+ ada/s-parame.o \
+ ada/s-secsta.o \
+ ada/s-soflin.o \
+ ada/s-sopco3.o \
+ ada/s-sopco4.o \
+ ada/s-sopco5.o \
+ ada/s-stache.o \
+ ada/s-stalib.o \
+ ada/s-stoele.o \
+ ada/s-strops.o \
+ ada/s-traceb.o \
+ ada/s-traent.o \
+ ada/s-unstyp.o \
+ ada/s-wchcnv.o \
+ ada/s-wchcon.o \
+ ada/s-wchjis.o \
+ ada/sdefault.o \
+ ada/sinfo.o \
+ ada/sinput.o \
+ ada/snames.o \
+ ada/stand.o \
+ ada/stringt.o \
+ ada/switch-b.o \
+ ada/switch.o \
+ ada/system.o \
+ ada/table.o \
+ ada/targparm.o \
+ ada/tree_io.o \
+ ada/types.o \
+ ada/uintp.o \
+ ada/uname.o \
+ ada/urealp.o \
+ ada/widechar.o \
$(EXTRA_GNATBIND_OBJS)
# List of extra object files linked in with various programs.
EXTRA_GNAT1_OBJS = prefix.o
EXTRA_GNATBIND_OBJS = prefix.o version.o
-# FIXME: handle with configure substitutions
-#ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(host))),)
-#
-#EXTRA_GNAT1_OBJS = prefix.o vmshandler.o
-#EXTRA_GNATBIND_OBJS = prefix.o vmshandler.o
-#
-#endif
-
# Language-independent object files.
ADA_BACKEND = $(BACKEND) attribs.o
@@ -213,8 +281,8 @@ gnatbind$(exeext): ada/b_gnatb.o $(CONFIG_H) $(GNATBIND_OBJS)
# use target-gcc target-gnatmake target-gnatbind target-gnatlink
gnattools: $(GCC_PARTS) $(CONFIG_H) prefix.o force
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
- ADA_INCLUDES="-I- -I../rts"\
- CC="../../xgcc -B../../" STAGE_PREFIX=../../ gnattools1
+ ADA_INCLUDES="-I- -I../rts"\
+ CC="../../xgcc -B../../" STAGE_PREFIX=../../ gnattools1
$(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools2
$(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools3
@@ -234,16 +302,22 @@ cross-gnattools: force
GNATBIND="gnatbind" \
GNATLINK="gnatlink" \
LIBGNAT="" \
- gnattools1-re gnattools2
+ gnattools1-re gnattools2 gnattools4
+
+rts-zfp: force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) GNATMAKE=../gnatmake-cross rts-zfp
+
+install-rts-zfp: force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) install-rts RTS_NAME=zfp
rts-none: force
- $(MAKE) -C ada $(FLAGS_TO_PASS) GNATMAKE=../gnatmake rts-none
+ $(MAKE) -C ada $(FLAGS_TO_PASS) GNATMAKE=../gnatmake-cross rts-none
install-rts-none: force
$(MAKE) -C ada $(FLAGS_TO_PASS) install-rts RTS_NAME=none
rts-ravenscar: force
- $(MAKE) -C ada $(FLAGS_TO_PASS) GNATMAKE=../gnatmake rts-ravenscar
+ $(MAKE) -C ada $(FLAGS_TO_PASS) GNATMAKE=../gnatmake-cross rts-ravenscar
install-rts-ravenscar: force
$(MAKE) -C ada $(FLAGS_TO_PASS) install-rts RTS_NAME=ravenscar
@@ -257,6 +331,15 @@ gnatlib: force
TRACE="$(TRACE)" \
gnatlib
+gnatlib-sjlj: force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) \
+ GNATLIBFLAGS="$(GNATLIBFLAGS)" \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
+ TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \
+ THREAD_KIND="$(THREAD_KIND)" \
+ TRACE="$(TRACE)" \
+ gnatlib-sjlj
+
gnatlib-shared: force
$(MAKE) -C ada $(FLAGS_TO_PASS) \
GNATLIBFLAGS="$(GNATLIBFLAGS)" \
@@ -272,10 +355,10 @@ gnatlib_and_tools: gnatlib gnattools
# use cross-gcc
gnat-cross: force
- $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) gnat-cross
+ make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp" \
+ $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) HOST_CFLAGS= HOST_CC=cc
gt-ada-decl.h gt-ada-trans.h gt-ada-utils.h gtype-ada.h : s-gtype ; @true
-
# Build hooks:
@@ -336,13 +419,30 @@ ada.all.cross:
then \
$(MV) gnatfind$(exeext) gnatfind-cross$(exeext); \
fi
+ -if [ -f gnatclean$(exeext) ] ; \
+ then \
+ $(MV) gnatclean$(exeext) gnatclean-cross$(exeext); \
+ fi
+ -if [ -f gnatsym$(exeext) ] ; \
+ then \
+ $(MV) gnatsym$(exeext) gnatsym-cross$(exeext); \
+ fi
+ -if [ -f gpr2make$(exeext) ] ; \
+ then \
+ $(MV) gpr2make$(exeext) gpr2make-cross$(exeext); \
+ fi
+ -if [ -f gprcmd$(exeext) ] ; \
+ then \
+ $(MV) gprcmd$(exeext) gprcmd-cross$(exeext); \
+ fi
ada.start.encap:
-ada.rest.encap:
+ada.rest.encap:
ada.tags: force
cd $(srcdir)/ada; etags *.c *.h *.ads *.adb
-
+ada.generated-manpages:
+
# Generate documentation.
#
# The generated Texinfo files for the User Guide are stored in
@@ -453,7 +553,8 @@ ada.install-normal:
# Install the binder program as $(target_noncanonical)-gnatbind
# and also as either gnatbind (if native) or $(tooldir)/bin/gnatbind
# likewise for gnatf, gnatchop, and gnatlink, gnatkr, gnatmake, gnat,
-# gnatprep, gnatbl, gnatls, gnatxref, gnatfind
+# gnatprep, gnatbl, gnatls, gnatxref, gnatfind, gnatname, gnatclean,
+# gnatsym
ada.install-common:
$(MKDIR) $(DESTDIR)$(bindir)
-if [ -f gnat1$(exeext) ] ; \
@@ -495,7 +596,7 @@ ada.install-common:
if [ -d $(DESTDIR)$(tooldir)/bin/. ] ; then \
rm -f $(DESTDIR)$(tooldir)/bin/gnatchop$(exeext); \
$(INSTALL_PROGRAM) gnatchop-cross$(exeext) $(DESTDIR)$(tooldir)/bin/gnatchop$(exeext); \
- fi; \
+ fi; \
else \
$(RM) $(DESTDIR)$(bindir)/gnatchop$(exeext); \
$(INSTALL_PROGRAM) gnatchop$(exeext) $(DESTDIR)$(bindir)/gnatchop$(exeext); \
@@ -650,6 +751,44 @@ ada.install-common:
$(INSTALL_PROGRAM) gnatfind$(exeext) $(DESTDIR)$(bindir)/gnatfind$(exeext); \
fi ; \
fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatclean-cross$(exeext) ] ; \
+ then \
+ $(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatclean$(exeext); \
+ $(INSTALL_PROGRAM) gnatclean-cross$(exeext) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatclean$(exeext); \
+ else \
+ $(RM) $(DESTDIR)$(bindir)/gnatclean$(exeext); \
+ $(INSTALL_PROGRAM) gnatclean$(exeext) $(DESTDIR)$(bindir)/gnatclean$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gpr2make$(exeext) ] ; \
+ then \
+ $(RM) $(DESTDIR)$(bindir)/gpr2make$(exeext); \
+ $(INSTALL_PROGRAM) gpr2make$(exeext) $(DESTDIR)$(bindir)/gpr2make$(exeext); \
+ fi ; \
+ fi
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gprcmd$(exeext) ] ; \
+ then \
+ $(RM) $(DESTDIR)$(bindir)/gprcmd$(exeext); \
+ $(INSTALL_PROGRAM) gprcmd$(exeext) $(DESTDIR)$(bindir)/gprcmd$(exeext); \
+ fi ; \
+ fi
+#
+# Gnatsym is only built on some platforms, including VMS
+#
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f gnatsym$(exeext) ] ; \
+ then \
+ $(RM) $(DESTDIR)$(bindir)/gnatsym$(exeext); \
+ $(INSTALL_PROGRAM) gnatsym$(exeext) $(DESTDIR)$(bindir)/gnatsym$(exeext); \
+ fi ; \
+ fi
#
# Gnatlbr is only used on VMS.
#
@@ -662,16 +801,26 @@ ada.install-common:
fi ; \
fi
#
-# Gnatdll is only use on Windows
+# Gnatdll is only used on Windows.
#
-if [ -f gnat1$(exeext) ] ; \
then \
- if [ -f gnatdll$(exeext) ] ; \
- then \
$(RM) $(DESTDIR)$(bindir)/gnatdll$(exeext); \
$(INSTALL_PROGRAM) gnatdll$(exeext) $(DESTDIR)$(bindir)/gnatdll$(exeext); \
+ fi
+#
+# vxaddr2line is only used for cross ports (it calls the underlying cross
+# addr2line).
+#
+ -if [ -f gnat1$(exeext) ] ; \
+ then \
+ if [ -f vxaddr2line$(exeext) ] ; \
+ then \
+ $(RM) $(DESTDIR)$(bindir)/vxaddr2line$(exeext); \
+ $(INSTALL_PROGRAM) vxaddr2line$(exeext) $(DESTDIR)$(bindir)/vxaddr2line$(exeext); \
fi ; \
fi
+
#
# Finally, install the library
#
@@ -681,7 +830,20 @@ ada.install-common:
fi
install-gnatlib:
- cd ada && $(MAKE) $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib$(LIBGNAT_TARGET)
+
+install-gnatlib-obj:
+ $(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) install-gnatlib-obj
+
+
+rts-cert: force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
+ TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \
+ GNATMAKE=../gnatmake-cross rts-cert RTS_NAME=cert
+
+install-rts-cert: force
+ $(MAKE) -C ada $(FLAGS_TO_PASS) install-rts RTS_NAME=none
ada.install-man:
@@ -702,13 +864,15 @@ ada.uninstall:
-$(RM) $(DESTDIR)$(bindir)/gnatprep$(exeext)
-$(RM) $(DESTDIR)$(bindir)/gnatpsta$(exeext)
-$(RM) $(DESTDIR)$(bindir)/gnatxref$(exeext)
+ -$(RM) $(DESTDIR)$(bindir)/gnatclean$(exeext)
+ -$(RM) $(DESTDIR)$(bindir)/gnatsym$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbind$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatbl$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatchop$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnat$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatfind$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatdll$(exeext)
- -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatkr(exeext)
+ -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatkr$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatlbr$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatlink$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatls$(exeext)
@@ -718,6 +882,8 @@ ada.uninstall:
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatprep$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatpsta$(exeext)
-$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatxref$(exeext)
+ -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatclean$(exeext)
+ -$(RM) $(DESTDIR)$(bindir)/$(target_noncanonical)-gnatsym$(exeext)
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatbind$(exeext)
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatbl$(exeext)
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatchop$(exeext)
@@ -734,6 +900,10 @@ ada.uninstall:
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatprep$(exeext)
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatpsta$(exeext)
-$(RM) $(DESTDIR)$(tooldir)/bin/gnatxref$(exeext)
+ -$(RM) $(DESTDIR)$(tooldir)/bin/gnatclean$(exeext)
+ -$(RM) $(DESTDIR)$(tooldir)/bin/gnatsym$(exeext)
+# Gnatlbr and Gnatchop are only used on VMS
+ -$(RM) $(DESTDIR)$(bindir)/gnatlbr$(exeext) $(DESTDIR)$(bindir)/gnatchop$(exeext)
# Clean hooks:
# A lot of the ancillary files are deleted by the main makefile.
@@ -761,6 +931,8 @@ ada.distclean:
-$(RM) gnatpsta$(exeext)
-$(RM) gnatfind$(exeext)
-$(RM) gnatxref$(exeext)
+ -$(RM) gnatclean$(exeext)
+ -$(RM) gnatsym$(exeext)
# Gnatlbr is only used on VMS
-$(RM) gnatlbr$(exeext)
-$(RM) ada/rts/*
@@ -855,11 +1027,11 @@ ada_extra_files : ada/treeprs.ads ada/einfo.h ada/sinfo.h ada/nmake.adb \
ada/nmake.ads
ada/b_gnat1.c : $(GNAT1_ADA_OBJS)
- $(GNATBIND) $(ADA_INCLUDES) -o ada/b_gnat1.c -n ada/gnat1drv.ali
+ $(GNATBIND) -C $(ADA_INCLUDES) -o ada/b_gnat1.c -n ada/gnat1drv.ali
ada/b_gnat1.o : ada/b_gnat1.c
ada/b_gnatb.c : $(GNATBIND_OBJS) ada/gnatbind.o ada/interfac.o
- $(GNATBIND) $(ADA_INCLUDES) -o ada/b_gnatb.c ada/gnatbind.ali
+ $(GNATBIND) -C $(ADA_INCLUDES) -o ada/b_gnatb.c ada/gnatbind.ali
ada/b_gnatb.o : ada/b_gnatb.c
ada/treeprs.ads : ada/treeprs.adt ada/sinfo.ads ada/xtreeprs.adb
@@ -929,32 +1101,58 @@ ada/sdefault.o : ada/sdefault.ads ada/sdefault.adb ada/types.ads \
ADA_TREE_H = ada/ada-tree.h ada/ada-tree.def
+# force debugging information on s-tasdeb.o so that it is always
+# possible to set conditional breakpoints on tasks.
+
+ada/s-tasdeb.o : ada/s-tasdeb.adb ada/s-tasdeb.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \
+ $< $(OUTPUT_OPTION)
+
+# force debugging information on s-vaflop.o so that it is always
+# possible to call the VAX float debug print routines.
+# force at least -O so that the inline assembly works.
+
+ada/s-vaflop.o : ada/s-vaflop.adb ada/s-vaflop.ads
+ $(CC) -c -O $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \
+ $(OUTPUT_OPTION) $<
+
# force debugging information on a-except.o so that it is always
# possible to set conditional breakpoints on exceptions.
# use -O1 otherwise gdb isn't able to get a full backtrace on mips targets.
ada/a-except.o : ada/a-except.adb ada/a-except.ads
- $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \
$(ADA_INCLUDES) $< $(OUTPUT_OPTION)
# force debugging information on s-assert.o so that it is always
# possible to set breakpoint on assert failures.
ada/s-assert.o : ada/s-assert.adb ada/s-assert.ads ada/a-except.ads
- $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 \
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 \
$(ADA_INCLUDES) $< $(OUTPUT_OPTION)
+# dependencies for windows specific tool (mdll)
+
+ada/mdll.o : ada/mdll.adb ada/mdll.ads ada/mdll-fil.ads ada/mdll-utl.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
+
+ada/mdll-fil.o : ada/mdll-fil.adb ada/mdll.ads ada/mdll-fil.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
+
+ada/mdll-utl.o : ada/mdll-utl.adb ada/mdll.ads ada/mdll-utl.ads ada/sdefault.ads ada/types.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
+
# force debugging information and no optimization on s-memory.o so that it
# is always possible to set breakpoint on __gnat_malloc and __gnat_free
# this is important for gnatmem using GDB. memtrack.o is built from
# memtrack.adb, and used by the post-mortem analysis with gnatmem.
ada/s-memory.o : ada/s-memory.adb ada/s-memory.ads ada/memtrack.o
- $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \
$(ADA_INCLUDES) $< $(OUTPUT_OPTION)
ada/memtrack.o : ada/memtrack.adb ada/s-memory.ads
- $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \
$(ADA_INCLUDES) $< $(OUTPUT_OPTION)
ada/adadecode.o : ada/adadecode.c $(CONFIG_H) $(SYSTEM_H) ada/adadecode.h
@@ -962,7 +1160,7 @@ ada/adaint.o : ada/adaint.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h
ada/argv.o : ada/argv.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h
ada/cstreams.o : ada/cstreams.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h
ada/exit.o : ada/exit.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h
-ada/adafinal.o : ada/adafinal.c $(CONFIG_H) $(SYSTEM_H) ada/raise.h
+ada/final.o : ada/final.c $(CONFIG_H) $(SYSTEM_H) ada/raise.h
ada/link.o : ada/link.c
ada/cio.o : ada/cio.c $(CONFIG_H) $(SYSTEM_H) ada/adaint.h
@@ -983,9 +1181,9 @@ ada/tracebak.o : ada/tracebak.c $(CONFIG_H) $(SYSTEM_H)
$(CC) -c $(ALL_CFLAGS) $(ALL_ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \
-fno-omit-frame-pointer $< $(OUTPUT_OPTION)
-ada/cuintp.o : ada/cuintp.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
- ada/ada.h ada/types.h ada/uintp.h ada/atree.h ada/stringt.h ada/elists.h \
- ada/nlists.h ada/fe.h ada/gigi.h
+ada/cuintp.o : ada/cuintp.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
+ $(TREE_H) ada/ada.h ada/types.h ada/uintp.h ada/atree.h ada/stringt.h \
+ ada/elists.h ada/nlists.h ada/fe.h ada/gigi.h
ada/decl.o : ada/decl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
flags.h toplev.h convert.h ada/ada.h ada/types.h ada/atree.h ada/nlists.h \
@@ -994,907 +1192,1496 @@ ada/decl.o : ada/decl.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
ada/misc.o : ada/misc.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
$(RTL_H) expr.h insn-codes.h insn-flags.h insn-config.h recog.h flags.h \
- diagnostic.h output.h except.h $(TM_P_H) langhooks.h debug.h $(LANGHOOKS_DEF_H) \
- libfuncs.h $(OPTABS_H) ada/ada.h ada/types.h ada/atree.h ada/nlists.h \
- ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h ada/stringt.h ada/uintp.h \
- ada/fe.h $(ADA_TREE_H) ada/gigi.h ada/adadecode.h opts.h options.h target.h
+ diagnostic.h output.h except.h $(TM_P_H) langhooks.h debug.h \
+ $(LANGHOOKS_DEF_H) libfuncs.h $(OPTABS_H) ada/ada.h ada/types.h \
+ ada/atree.h ada/nlists.h ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h \
+ ada/stringt.h ada/uintp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h \
+ ada/adadecode.h opts.h options.h target.h
ada/targtyps.o : ada/targtyps.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
ada/ada.h ada/types.h ada/atree.h ada/nlists.h ada/elists.h ada/uintp.h \
- ada/sinfo.h ada/einfo.h ada/namet.h ada/snames.h ada/stringt.h ada/urealp.h \
- ada/fe.h $(ADA_TREE_H) ada/gigi.h
+ ada/sinfo.h ada/einfo.h ada/namet.h ada/snames.h ada/stringt.h \
+ ada/urealp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h
-ada/trans.o : ada/trans.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
- $(RTL_H) flags.h ada/ada.h except.h ada/types.h ada/atree.h ada/nlists.h \
- ada/elists.h ada/uintp.h ada/sinfo.h ada/einfo.h ada/namet.h ada/snames.h \
- ada/stringt.h ada/urealp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h gt-ada-trans.h
+ada/trans.o : ada/trans.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
+ $(TREE_H) $(RTL_H) flags.h ada/ada.h except.h ada/types.h ada/atree.h \
+ ada/nlists.h ada/elists.h ada/uintp.h ada/sinfo.h ada/einfo.h ada/namet.h \
+ ada/snames.h ada/stringt.h ada/urealp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h \
+ gt-ada-trans.h
-ada/utils.o : ada/utils.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) $(TREE_H) \
- flags.h expr.h convert.h defaults.h ada/ada.h ada/types.h ada/atree.h \
- ada/nlists.h ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h ada/stringt.h \
- ada/uintp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h gt-ada-utils.h gtype-ada.h
+ada/utils.o : ada/utils.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
+ $(TREE_H) flags.h expr.h convert.h defaults.h ada/ada.h ada/types.h \
+ ada/atree.h ada/nlists.h ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h \
+ ada/stringt.h ada/uintp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h gt-ada-utils.h \
+ gtype-ada.h
ada/utils2.o : ada/utils2.c $(CONFIG_H) $(SYSTEM_H) coretypes.h $(TM_H) \
$(TREE_H) flags.h ada/ada.h ada/types.h ada/atree.h ada/nlists.h \
- ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h ada/snames.h ada/stringt.h \
- ada/uintp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h
+ ada/elists.h ada/sinfo.h ada/einfo.h ada/namet.h ada/snames.h \
+ ada/stringt.h ada/uintp.h ada/fe.h $(ADA_TREE_H) ada/gigi.h
#
# DO NOT PUT SPECIAL RULES BELOW, THIS SECTION IS UPDATED AUTOMATICALLY
#
# GNAT DEPENDENCIES
# regular dependencies
+ada/a-chahan.o : ada/ada.ads ada/a-charac.ads ada/a-chahan.ads \
+ ada/a-chahan.adb ada/a-chlat1.ads ada/a-string.ads ada/a-strmap.ads \
+ ada/a-stmaco.ads ada/system.ads ada/s-exctab.ads ada/s-secsta.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/unchconv.ads
+
ada/a-charac.o : ada/ada.ads ada/a-charac.ads ada/system.ads
ada/a-chlat1.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \
ada/system.ads
+ada/a-comlin.o : ada/ada.ads ada/a-comlin.ads ada/a-comlin.adb \
+ ada/system.ads ada/s-purexc.ads ada/s-secsta.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/unchconv.ads
+
ada/a-except.o : ada/ada.ads ada/a-except.ads ada/a-except.adb \
- ada/a-excpol.adb ada/a-uncdea.ads ada/gnat.ads ada/g-hesora.ads \
- ada/system.ads ada/s-exctab.ads ada/s-except.ads ada/s-mastop.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-stoele.adb ada/s-traceb.ads ada/unchconv.ads
+ ada/a-excach.adb ada/a-exexda.adb ada/a-exexpr.adb ada/a-exextr.adb \
+ ada/a-excpol.adb ada/a-exstat.adb ada/a-unccon.ads ada/a-uncdea.ads \
+ ada/interfac.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-except.ads ada/s-mastop.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-traceb.ads ada/s-unstyp.ads ada/unchconv.ads
+
+ada/a-filico.o : ada/ada.ads ada/a-except.ads ada/a-finali.ads \
+ ada/a-filico.ads ada/a-filico.adb ada/a-stream.ads ada/a-tags.ads \
+ ada/a-tags.adb ada/system.ads ada/s-exctab.ads ada/s-finimp.ads \
+ ada/s-finroo.ads ada/s-htable.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-stratt.ads ada/s-unstyp.ads ada/unchconv.ads
+
+ada/a-finali.o : ada/ada.ads ada/a-except.ads ada/a-finali.ads \
+ ada/a-finali.adb ada/a-stream.ads ada/a-tags.ads ada/a-tags.adb \
+ ada/system.ads ada/s-exctab.ads ada/s-finimp.ads ada/s-finroo.ads \
+ ada/s-htable.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-stratt.ads \
+ ada/s-unstyp.ads ada/unchconv.ads
+
+ada/a-ioexce.o : ada/ada.ads ada/a-ioexce.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/unchconv.ads
+
+ada/a-stmaco.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \
+ ada/a-string.ads ada/a-strmap.ads ada/a-stmaco.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/unchconv.ads
ada/a-stream.o : ada/ada.ads ada/a-except.ads ada/a-stream.ads \
- ada/a-tags.ads ada/a-tags.adb ada/gnat.ads ada/g-htable.ads ada/system.ads \
- ada/s-exctab.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/a-tags.ads ada/a-tags.adb ada/system.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/unchconv.ads
+
+ada/a-strfix.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \
+ ada/a-except.ads ada/a-string.ads ada/a-strfix.ads ada/a-strfix.adb \
+ ada/a-strmap.ads ada/a-strsea.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/unchconv.ads
+
+ada/a-string.o : ada/ada.ads ada/a-string.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/unchconv.ads
+
+ada/a-strmap.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \
+ ada/a-except.ads ada/a-string.ads ada/a-strmap.ads ada/a-strmap.adb \
+ ada/system.ads ada/s-bitops.ads ada/s-exctab.ads ada/s-secsta.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
ada/unchconv.ads
+ada/a-strsea.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \
+ ada/a-except.ads ada/a-string.ads ada/a-strmap.ads ada/a-strsea.ads \
+ ada/a-strsea.adb ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/unchconv.ads
+
ada/a-tags.o : ada/ada.ads ada/a-except.ads ada/a-tags.ads ada/a-tags.adb \
- ada/a-uncdea.ads ada/gnat.ads ada/g-htable.ads ada/g-htable.adb \
- ada/system.ads ada/s-exctab.ads ada/s-secsta.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/unchconv.ads
+ ada/a-uncdea.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-htable.adb ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/unchconv.ads
ada/ada.o : ada/ada.ads ada/system.ads
+ada/a-ioexce.o : ada/ada.ads ada/a-ioexce.ads
+
ada/ali-util.o : ada/ada.ads ada/a-except.ads ada/ali.ads ada/ali-util.ads \
- ada/ali-util.adb ada/alloc.ads ada/binderr.ads ada/casing.ads ada/debug.ads \
- ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads ada/gnatvsn.ads \
- ada/hostparm.ads ada/interfac.ads ada/namet.ads ada/opt.ads ada/osint.ads \
- ada/output.ads ada/rident.ads ada/system.ads ada/s-atacco.ads \
- ada/s-atacco.adb ada/s-assert.ads ada/s-crc32.ads ada/s-exctab.ads \
- ada/s-memory.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
+ ada/ali-util.adb ada/alloc.ads ada/binderr.ads ada/casing.ads \
+ ada/debug.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \
+ ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads \
+ ada/system.ads ada/s-assert.ads ada/s-crc32.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-memory.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/ali.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads ada/ali.ads \
ada/ali.adb ada/alloc.ads ada/butil.ads ada/casing.ads ada/debug.ads \
- ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/g-htable.adb \
- ada/g-os_lib.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
- ada/osint.ads ada/output.ads ada/rident.ads ada/system.ads ada/s-atacco.ads \
- ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \
+ ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/opt.ads ada/osint.ads ada/output.ads ada/rident.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \
+ ada/s-memory.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \
ada/unchconv.ads ada/unchdeal.ads
ada/alloc.o : ada/alloc.ads ada/system.ads
ada/atree.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads ada/alloc.ads \
ada/atree.ads ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads \
- ada/elists.ads ada/gnat.ads ada/g-htable.ads ada/g-htable.adb \
- ada/g-os_lib.ads ada/hostparm.ads ada/nlists.ads ada/opt.ads ada/output.ads \
- ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/system.ads ada/s-atacco.ads \
- ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads ada/s-imgenu.ads \
- ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/elists.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/nlists.ads \
+ ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-htable.adb ada/s-imgenu.ads ada/s-memory.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/back_end.o : ada/alloc.ads ada/atree.ads ada/back_end.ads \
- ada/back_end.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
- ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads ada/lib.ads ada/namet.ads \
+ ada/back_end.adb ada/casing.ads ada/debug.ads ada/einfo.ads \
+ ada/elists.ads ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads ada/namet.ads \
ada/nlists.ads ada/opt.ads ada/osint.ads ada/osint-c.ads ada/sinfo.ads \
- ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads ada/switch.ads \
- ada/switch-c.ads ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/s-wchcon.ads ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
+ ada/switch.ads ada/switch-c.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/bcheck.o : ada/ada.ads ada/a-except.ads ada/ali.ads ada/ali-util.ads \
- ada/alloc.ads ada/bcheck.ads ada/bcheck.adb ada/binderr.ads ada/butil.ads \
- ada/casing.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
- ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads \
- ada/output.ads ada/rident.ads ada/system.ads ada/s-exctab.ads \
+ ada/alloc.ads ada/bcheck.ads ada/bcheck.adb ada/binderr.ads \
+ ada/butil.ads ada/casing.ads ada/fname.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \
+ ada/rident.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
- ada/types.ads ada/unchconv.ads ada/unchdeal.ads
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/types.ads ada/unchconv.ads \
+ ada/unchdeal.ads
ada/binde.o : ada/ada.ads ada/a-except.ads ada/ali.ads ada/alloc.ads \
- ada/binde.ads ada/binde.adb ada/binderr.ads ada/butil.ads ada/casing.ads \
- ada/debug.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
- ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \
- ada/rident.ads ada/system.ads ada/s-atacco.ads ada/s-atacco.adb \
- ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \
- ada/unchconv.ads ada/unchdeal.ads
+ ada/binde.ads ada/binde.adb ada/binderr.ads ada/butil.ads \
+ ada/casing.ads ada/debug.ads ada/fname.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \
+ ada/rident.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/binderr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/binderr.ads \
- ada/binderr.adb ada/butil.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
+ ada/binderr.adb ada/butil.ads ada/gnat.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
ada/output.ads ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/s-wchcon.ads ada/table.ads ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/types.ads \
+ ada/unchconv.ads ada/unchdeal.ads
ada/bindgen.o : ada/ada.ads ada/a-except.ads ada/ali.ads ada/alloc.ads \
- ada/binde.ads ada/bindgen.ads ada/bindgen.adb ada/butil.ads ada/casing.ads \
- ada/fname.ads ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads \
- ada/g-os_lib.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
+ ada/binde.ads ada/bindgen.ads ada/bindgen.adb ada/butil.ads \
+ ada/casing.ads ada/debug.ads ada/fname.ads ada/gnat.ads \
+ ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
ada/osint.ads ada/osint-b.ads ada/output.ads ada/rident.ads \
- ada/sdefault.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \
- ada/s-sopco5.ads ada/s-wchcon.ads ada/table.ads ada/types.ads \
- ada/unchconv.ads ada/unchdeal.ads
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \
+ ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco5.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/bindusg.o : ada/bindusg.ads ada/bindusg.adb ada/gnat.ads \
- ada/g-os_lib.ads ada/osint.ads ada/output.ads ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads
+ ada/g-os_lib.ads ada/g-string.ads ada/osint.ads ada/output.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/butil.o : ada/alloc.ads ada/butil.ads ada/butil.adb ada/hostparm.ads \
ada/namet.ads ada/output.ads ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/table.ads ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads
+ ada/s-stalib.ads ada/s-unstyp.ads ada/table.ads ada/types.ads \
+ ada/unchconv.ads ada/unchdeal.ads
ada/casing.o : ada/alloc.ads ada/casing.ads ada/casing.adb ada/csets.ads \
- ada/hostparm.ads ada/namet.ads ada/opt.ads ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/types.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads
+ ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/namet.ads ada/opt.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads
ada/checks.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb ada/debug.ads \
- ada/einfo.ads ada/elists.ads ada/errout.ads ada/exp_ch2.ads \
- ada/exp_util.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
- ada/g-htable.ads ada/g-os_lib.ads ada/hostparm.ads ada/namet.ads \
- ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_eval.ads ada/sem_res.ads \
- ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinput.ads \
- ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads \
- ada/table.ads ada/targparm.ads ada/tbuild.ads ada/tree_io.ads \
- ada/ttypes.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/atree.adb ada/casing.ads ada/checks.ads ada/checks.adb \
+ ada/debug.ads ada/einfo.ads ada/elists.ads ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/exp_ch2.ads ada/exp_util.ads \
+ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/lib.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
+ ada/sem.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads \
+ ada/sem_warn.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \
+ ada/sprint.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/validsw.ads
ada/comperr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/casing.ads ada/comperr.ads ada/comperr.adb ada/debug.ads ada/einfo.ads \
- ada/errout.ads ada/fname.ads ada/gnat.ads ada/g-os_lib.ads ada/gnatvsn.ads \
- ada/lib.ads ada/namet.ads ada/osint.ads ada/output.ads ada/sdefault.ads \
- ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/sprint.ads ada/system.ads \
+ ada/casing.ads ada/comperr.ads ada/comperr.adb ada/debug.ads \
+ ada/einfo.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/fname.ads ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads ada/namet.ads \
+ ada/osint.ads ada/output.ads ada/sdefault.ads ada/sinfo.ads \
+ ada/sinput.ads ada/snames.ads ada/sprint.ads ada/system.ads \
ada/s-exctab.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/table.ads ada/treepr.ads \
- ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/table.ads ada/treepr.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
-ada/csets.o : ada/csets.ads ada/csets.adb ada/hostparm.ads ada/opt.ads \
- ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads \
+ada/csets.o : ada/csets.ads ada/csets.adb ada/gnat.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/cstand.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/csets.ads ada/cstand.ads ada/cstand.adb ada/debug.ads ada/einfo.ads \
- ada/get_targ.ads ada/hostparm.ads ada/layout.ads ada/namet.ads \
- ada/nlists.ads ada/nmake.ads ada/opt.ads ada/sem_mech.ads ada/sem_util.ads \
- ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads \
- ada/table.ads ada/tbuild.ads ada/ttypef.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/get_targ.ads ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/layout.ads ada/namet.ads ada/nlists.ads \
+ ada/nmake.ads ada/opt.ads ada/rident.ads ada/sem_mech.ads \
+ ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-imgenu.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/targparm.ads ada/tbuild.ads ada/ttypef.ads \
+ ada/ttypes.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
ada/debug.o : ada/debug.ads ada/debug.adb ada/system.ads
ada/debug_a.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/casing.ads ada/debug.ads ada/debug_a.ads ada/debug_a.adb ada/einfo.ads \
- ada/output.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/system.ads \
- ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/table.ads \
+ ada/casing.ads ada/debug.ads ada/debug_a.ads ada/debug_a.adb \
+ ada/einfo.ads ada/output.ads ada/sinfo.ads ada/sinput.ads \
+ ada/snames.ads ada/system.ads ada/s-exctab.ads ada/s-imgenu.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/table.ads \
ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
ada/urealp.ads
ada/einfo.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/einfo.ads ada/einfo.adb ada/namet.ads ada/nlists.ads ada/output.ads \
- ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/table.ads \
- ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-unstyp.ads ada/table.ads ada/types.ads \
+ ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/elists.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/debug.ads \
ada/elists.ads ada/elists.adb ada/gnat.ads ada/g-os_lib.ads \
- ada/hostparm.ads ada/opt.ads ada/output.ads ada/system.ads ada/s-atacco.ads \
- ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads \
+ ada/output.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \
+ ada/unchconv.ads ada/unchdeal.ads
+
+ada/err_vars.o : ada/alloc.ads ada/err_vars.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/table.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads
ada/errout.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/errout.adb ada/fname.ads ada/gnat.ads \
- ada/g-htable.ads ada/g-os_lib.ads ada/hostparm.ads ada/lib.ads \
- ada/namet.ads ada/nlists.ads ada/opt.ads ada/output.ads ada/scans.ads \
- ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads ada/style.ads \
- ada/system.ads ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads \
- ada/s-exctab.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \
- ada/uintp.ads ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/errout.adb \
+ ada/erroutc.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/lib.ads ada/namet.ads ada/nlists.ads ada/opt.ads ada/output.ads \
+ ada/scans.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads \
+ ada/style.ads ada/styleg.ads ada/styleg-c.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
+ ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
+
+ada/erroutc.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/casing.ads \
+ ada/debug.ads ada/err_vars.ads ada/erroutc.ads ada/erroutc.adb \
+ ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \
+ ada/rident.ads ada/sinput.ads ada/snames.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/targparm.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads
+
+ada/errutil.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/casing.ads \
+ ada/csets.ads ada/err_vars.ads ada/erroutc.ads ada/errutil.ads \
+ ada/errutil.adb ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/opt.ads ada/output.ads ada/scans.ads ada/sinput.ads ada/styleg.ads \
+ ada/styleg.adb ada/stylesw.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
ada/urealp.ads
ada/eval_fat.o : ada/alloc.ads ada/einfo.ads ada/eval_fat.ads \
- ada/eval_fat.adb ada/sem_util.ads ada/snames.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/table.ads \
- ada/targparm.ads ada/ttypef.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/eval_fat.adb ada/rident.ads ada/sem_util.ads ada/snames.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/table.ads ada/targparm.ads ada/ttypef.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/exp_aggr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/checks.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/exp_aggr.ads \
- ada/exp_aggr.adb ada/exp_ch3.ads ada/exp_ch7.ads ada/exp_util.ads \
- ada/expander.ads ada/freeze.ads ada/get_targ.ads ada/hostparm.ads \
+ ada/checks.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
+ ada/exp_aggr.ads ada/exp_aggr.adb ada/exp_ch3.ads ada/exp_ch7.ads \
+ ada/exp_util.ads ada/expander.ads ada/freeze.ads ada/get_targ.ads \
+ ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
ada/itypes.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/nmake.ads \
ada/opt.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
ada/sem_ch3.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads \
- ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads ada/tbuild.ads \
- ada/ttypes.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/tbuild.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
-ada/exp_attr.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
- ada/exp_attr.ads ada/exp_attr.adb ada/exp_ch2.ads ada/exp_ch9.ads \
- ada/exp_imgv.ads ada/exp_pakd.ads ada/exp_strm.ads ada/exp_tss.ads \
- ada/exp_util.ads ada/get_targ.ads ada/gnatvsn.ads ada/hostparm.ads \
+ada/exp_attr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
+ ada/checks.ads ada/einfo.ads ada/exp_attr.ads ada/exp_attr.adb \
+ ada/exp_ch2.ads ada/exp_ch9.ads ada/exp_imgv.ads ada/exp_pakd.ads \
+ ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads ada/get_targ.ads \
+ ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
ada/lib.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
- ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch7.ads \
- ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads \
- ada/sinfo.ads ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/tbuild.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \
- ada/validsw.ads
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads \
+ ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads \
+ ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/tbuild.ads ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/exp_ch11.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
- ada/errout.ads ada/exp_ch11.ads ada/exp_ch11.adb ada/exp_ch7.ads \
- ada/exp_util.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
- ada/hostparm.ads ada/inline.ads ada/lib.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
- ada/rtsfind.ads ada/sem.ads ada/sem_ch5.ads ada/sem_ch8.ads ada/sem_res.ads \
- ada/sem_util.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \
+ ada/exp_ch11.adb ada/exp_ch7.ads ada/exp_util.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/inline.ads ada/lib.ads ada/namet.ads \
+ ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_ch5.ads ada/sem_ch8.ads ada/sem_res.ads ada/sem_util.ads \
+ ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads \
ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
- ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
- ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/targparm.ads \
+ ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/exp_ch12.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
ada/exp_ch12.ads ada/exp_ch12.adb ada/exp_util.ads ada/namet.ads \
- ada/nlists.ads ada/nmake.ads ada/rtsfind.ads ada/sinfo.ads ada/snames.ads \
- ada/stand.ads ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/nlists.ads ada/nmake.ads ada/rtsfind.ads ada/sinfo.ads \
+ ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/table.ads ada/tbuild.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/exp_ch13.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
ada/elists.ads ada/exp_ch13.ads ada/exp_ch13.adb ada/exp_ch3.ads \
- ada/exp_ch6.ads ada/exp_imgv.ads ada/exp_util.ads ada/hostparm.ads \
- ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads \
- ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
- ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/exp_ch6.ads ada/exp_imgv.ads ada/exp_util.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/nlists.ads ada/nmake.ads ada/opt.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_util.ads \
+ ada/sinfo.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/tbuild.ads ada/types.ads \
+ ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
-ada/exp_ch2.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/elists.ads \
- ada/errout.ads ada/exp_ch2.ads ada/exp_ch2.adb ada/exp_smem.ads \
- ada/exp_util.ads ada/exp_vfpt.ads ada/hostparm.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/rtsfind.ads ada/sem.ads ada/sem_res.ads \
- ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
- ada/tbuild.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ada/exp_ch2.o : ada/alloc.ads ada/atree.ads ada/debug.ads ada/einfo.ads \
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_ch2.ads ada/exp_ch2.adb ada/exp_smem.ads ada/exp_util.ads \
+ ada/exp_vfpt.ads ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/rtsfind.ads ada/sem.ads ada/sem_eval.ads ada/sem_res.ads \
+ ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/snames.ads \
+ ada/stand.ads ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/tbuild.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
-ada/exp_ch3.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/exp_aggr.ads ada/exp_ch11.ads \
+ada/exp_ch3.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
+ ada/checks.ads ada/einfo.ads ada/elists.ads ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_ch11.ads \
ada/exp_ch3.ads ada/exp_ch3.adb ada/exp_ch4.ads ada/exp_ch7.ads \
ada/exp_ch9.ads ada/exp_disp.ads ada/exp_dist.ads ada/exp_smem.ads \
ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads ada/freeze.ads \
- ada/get_targ.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads \
- ada/sem_mech.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \
- ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
- ada/tbuild.ads ada/ttypes.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/get_targ.ads ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_mech.ads \
+ ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
+ ada/stand.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/tbuild.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
-ada/exp_ch4.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/exp_aggr.ads ada/exp_ch3.ads \
+ada/exp_ch4.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
+ ada/checks.ads ada/einfo.ads ada/elists.ads ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads ada/exp_ch3.ads \
ada/exp_ch4.ads ada/exp_ch4.adb ada/exp_ch7.ads ada/exp_ch9.ads \
ada/exp_disp.ads ada/exp_fixd.ads ada/exp_pakd.ads ada/exp_tss.ads \
- ada/exp_util.ads ada/exp_vfpt.ads ada/get_targ.ads ada/hostparm.ads \
- ada/inline.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
- ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads \
- ada/sem_ch13.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \
- ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/sinfo-cn.ads \
- ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
- ada/targparm.ads ada/tbuild.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
-
-ada/exp_ch5.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
- ada/exp_aggr.ads ada/exp_ch11.ads ada/exp_ch5.ads ada/exp_ch5.adb \
- ada/exp_ch7.ads ada/exp_dbug.ads ada/exp_pakd.ads ada/exp_util.ads \
- ada/get_targ.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_ch13.ads ada/sem_ch8.ads ada/sem_eval.ads \
- ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads \
- ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/s-wchcon.ads ada/table.ads ada/tbuild.ads ada/ttypes.ads ada/types.ads \
+ ada/exp_util.ads ada/exp_vfpt.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \
+ ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/rident.ads \
+ ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads ada/sem_ch13.ads \
+ ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
+ ada/sem_warn.ads ada/sinfo.ads ada/sinfo-cn.ads ada/snames.ads \
+ ada/stand.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/targparm.ads ada/tbuild.ads ada/ttypes.ads ada/types.ads \
ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \
ada/validsw.ads
+ada/exp_ch5.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
+ ada/checks.ads ada/einfo.ads ada/exp_aggr.ads ada/exp_ch11.ads \
+ ada/exp_ch5.ads ada/exp_ch5.adb ada/exp_ch7.ads ada/exp_dbug.ads \
+ ada/exp_pakd.ads ada/exp_util.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/nlists.ads ada/nmake.ads ada/opt.ads ada/restrict.ads \
+ ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch13.ads \
+ ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads \
+ ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/tbuild.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/validsw.ads
+
ada/exp_ch6.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/exp_ch11.ads ada/exp_ch2.ads \
- ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch6.adb ada/exp_ch7.ads \
- ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_disp.ads ada/exp_dist.ads \
- ada/exp_intr.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \
- ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-htable.ads \
- ada/g-os_lib.ads ada/hostparm.ads ada/inline.ads ada/lib.ads ada/namet.ads \
- ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch12.ads \
- ada/sem_ch13.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \
- ada/sem_dist.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \
- ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads \
- ada/table.ads ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_ch11.ads ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch6.ads \
+ ada/exp_ch6.adb ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_dbug.ads \
+ ada/exp_disp.ads ada/exp_dist.ads ada/exp_intr.ads ada/exp_pakd.ads \
+ ada/exp_tss.ads ada/exp_util.ads ada/fname.ads ada/freeze.ads \
+ ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \
+ ada/lib.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
+ ada/sem.ads ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch6.ads \
+ ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_res.ads \
+ ada/sem_util.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \
+ ada/stand.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/tbuild.ads \
+ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/exp_ch7.o : ada/alloc.ads ada/atree.ads ada/debug.ads ada/einfo.ads \
- ada/exp_ch11.ads ada/exp_ch7.ads ada/exp_ch7.adb ada/exp_ch9.ads \
- ada/exp_dbug.ads ada/exp_tss.ads ada/exp_util.ads ada/freeze.ads \
- ada/get_targ.ads ada/hostparm.ads ada/lib.ads ada/lib-xref.ads \
- ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
- ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch3.ads \
- ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_res.ads ada/sem_type.ads \
- ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/targparm.ads ada/tbuild.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \
+ ada/exp_ch7.ads ada/exp_ch7.adb ada/exp_ch9.ads ada/exp_dbug.ads \
+ ada/exp_tss.ads ada/exp_util.ads ada/freeze.ads ada/get_targ.ads \
+ ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nmake.ads \
+ ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
+ ada/rtsfind.ads ada/sem.ads ada/sem_ch3.ads ada/sem_ch7.ads \
+ ada/sem_ch8.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
+ ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/targparm.ads ada/tbuild.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/exp_ch8.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/exp_ch8.ads \
- ada/exp_ch8.adb ada/exp_dbug.ads ada/exp_util.ads ada/get_targ.ads \
- ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/opt.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_ch8.ads ada/sinfo.ads ada/snames.ads ada/stand.ads \
- ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ ada/exp_ch8.adb ada/exp_dbug.ads ada/exp_util.ads ada/freeze.ads \
+ ada/get_targ.ads ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/opt.ads \
+ ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch8.ads \
+ ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/targparm.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/exp_ch9.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/exp_ch11.ads ada/exp_ch3.ads \
- ada/exp_ch6.ads ada/exp_ch9.ads ada/exp_ch9.adb ada/exp_dbug.ads \
- ada/exp_smem.ads ada/exp_tss.ads ada/exp_util.ads ada/freeze.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_ch11.ads ada/exp_ch3.ads ada/exp_ch6.ads ada/exp_ch9.ads \
+ ada/exp_ch9.adb ada/exp_dbug.ads ada/exp_smem.ads ada/exp_tss.ads \
+ ada/exp_util.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
- ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
- ada/sem_ch11.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_elab.ads \
- ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads ada/sinput.ads \
- ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads \
- ada/table.ads ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
+ ada/sem.ads ada/sem_ch11.ads ada/sem_ch6.ads ada/sem_ch8.ads \
+ ada/sem_elab.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \
+ ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/tbuild.ads ada/tree_io.ads ada/types.ads \
+ ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
-ada/exp_code.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/errout.ads \
- ada/exp_code.ads ada/exp_code.adb ada/fname.ads ada/hostparm.ads \
- ada/lib.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
- ada/rtsfind.ads ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads \
- ada/snames.ads ada/stringt.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
+ada/exp_code.o : ada/alloc.ads ada/atree.ads ada/einfo.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_code.ads \
+ ada/exp_code.adb ada/fname.ads ada/gnat.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads ada/namet.ads \
+ ada/nlists.ads ada/nmake.ads ada/opt.ads ada/rtsfind.ads \
+ ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
+ ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
ada/tbuild.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
ada/unchdeal.ads ada/urealp.ads
-ada/exp_dbug.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \
- ada/alloc.ads ada/atree.ads ada/debug.ads ada/einfo.ads ada/exp_dbug.ads \
- ada/exp_dbug.adb ada/exp_util.ads ada/freeze.ads ada/get_targ.ads \
- ada/gnat.ads ada/g-htable.ads ada/g-htable.adb ada/g-os_lib.ads \
- ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/nmake.ads \
- ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem_eval.ads \
- ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
- ada/system.ads ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads \
- ada/s-exctab.ads ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ada/exp_dbug.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
+ ada/debug.ads ada/einfo.ads ada/exp_dbug.ads ada/exp_dbug.adb \
+ ada/get_targ.ads ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \
+ ada/nmake.ads ada/opt.ads ada/output.ads ada/sem_eval.ads \
+ ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads \
+ ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/exp_disp.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/exp_ch7.ads ada/exp_disp.ads \
- ada/exp_disp.adb ada/exp_tss.ads ada/exp_util.ads ada/fname.ads \
- ada/hostparm.ads ada/itypes.ads ada/lib.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/rtsfind.ads ada/sem_disp.ads ada/sem_res.ads \
- ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_ch7.ads ada/exp_disp.ads ada/exp_disp.adb ada/exp_tss.ads \
+ ada/exp_util.ads ada/fname.ads ada/gnat.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/itypes.ads ada/lib.ads \
+ ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/rtsfind.ads \
+ ada/sem_disp.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \
+ ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/exp_dist.o : ada/ada.ads ada/a-uncdea.ads ada/alloc.ads ada/atree.ads \
ada/einfo.ads ada/elists.ads ada/exp_dist.ads ada/exp_dist.adb \
- ada/exp_tss.ads ada/exp_util.ads ada/gnat.ads ada/g-htable.ads \
- ada/g-htable.adb ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch3.ads \
- ada/sem_ch8.ads ada/sem_dist.ads ada/sem_util.ads ada/sinfo.ads \
- ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/exp_strm.ads ada/exp_tss.ads ada/exp_util.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/lib.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/rtsfind.ads ada/sem.ads ada/sem_ch3.ads ada/sem_ch8.ads \
+ ada/sem_dist.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
+ ada/stand.ads ada/stringt.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/tbuild.ads \
+ ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
ada/exp_fixd.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
- ada/exp_fixd.ads ada/exp_fixd.adb ada/exp_util.ads ada/get_targ.ads \
- ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
- ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/exp_fixd.ads ada/exp_fixd.adb ada/exp_util.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/nlists.ads ada/nmake.ads ada/opt.ads ada/rtsfind.ads ada/sem.ads \
ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \
ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
- ada/tbuild.ads ada/ttypes.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/exp_imgv.o : ada/alloc.ads ada/atree.ads ada/casing.ads ada/checks.ads \
ada/einfo.ads ada/exp_imgv.ads ada/exp_imgv.adb ada/exp_util.ads \
- ada/get_targ.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/rtsfind.ads ada/sem_res.ads ada/sinfo.ads \
- ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads \
+ ada/get_targ.ads ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/rtsfind.ads ada/sem_res.ads ada/sinfo.ads ada/snames.ads \
+ ada/stand.ads ada/stringt.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
ada/table.ads ada/tbuild.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/exp_intr.o : ada/alloc.ads ada/atree.ads ada/casing.ads ada/einfo.ads \
- ada/errout.ads ada/exp_ch11.ads ada/exp_ch4.ads ada/exp_ch7.ads \
- ada/exp_ch9.ads ada/exp_code.ads ada/exp_fixd.ads ada/exp_intr.ads \
- ada/exp_intr.adb ada/exp_util.ads ada/hostparm.ads ada/itypes.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \
+ ada/exp_ch4.ads ada/exp_ch7.ads ada/exp_code.ads ada/exp_fixd.ads \
+ ada/exp_intr.ads ada/exp_intr.adb ada/exp_util.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/itypes.ads \
ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_eval.ads ada/sem_res.ads \
- ada/sem_util.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads \
- ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/tbuild.ads \
- ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_eval.ads \
+ ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads ada/sinput.ads \
+ ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/tbuild.ads ada/types.ads \
+ ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/exp_pakd.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
ada/exp_dbug.ads ada/exp_pakd.ads ada/exp_pakd.adb ada/exp_util.ads \
- ada/get_targ.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch13.ads \
- ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads \
- ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
- ada/targparm.ads ada/tbuild.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
+ ada/get_targ.ads ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch13.ads \
+ ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads \
+ ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/targparm.ads \
+ ada/tbuild.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/exp_prag.o : ada/alloc.ads ada/atree.ads ada/casing.ads ada/einfo.ads \
- ada/errout.ads ada/exp_ch11.ads ada/exp_prag.ads ada/exp_prag.adb \
- ada/exp_tss.ads ada/exp_util.ads ada/expander.ads ada/hostparm.ads \
- ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \
- ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \
+ ada/exp_prag.ads ada/exp_prag.adb ada/exp_tss.ads ada/exp_util.ads \
+ ada/expander.ads ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_eval.ads \
+ ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads ada/sinput.ads \
+ ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/targparm.ads ada/tbuild.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/exp_smem.o : ada/alloc.ads ada/atree.ads ada/einfo.ads \
- ada/exp_smem.ads ada/exp_smem.adb ada/exp_util.ads ada/hostparm.ads \
- ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads \
+ ada/exp_smem.ads ada/exp_smem.adb ada/exp_util.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/nlists.ads ada/nmake.ads ada/opt.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads \
ada/stringt.ads ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/s-wchcon.ads ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/tbuild.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/exp_strm.o : ada/alloc.ads ada/atree.ads ada/einfo.ads \
ada/exp_strm.ads ada/exp_strm.adb ada/exp_tss.ads ada/get_targ.ads \
ada/lib.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/rtsfind.ads \
- ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/table.ads ada/tbuild.ads \
- ada/ttypes.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/table.ads ada/tbuild.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/exp_tss.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/elists.ads \
ada/exp_tss.ads ada/exp_tss.adb ada/exp_util.ads ada/lib.ads \
ada/rtsfind.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ ada/s-unstyp.ads ada/table.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/exp_util.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/exp_ch11.ads ada/exp_ch7.ads \
- ada/exp_util.ads ada/exp_util.adb ada/get_targ.ads ada/hostparm.ads \
- ada/inline.ads ada/itypes.ads ada/lib.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads \
- ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
- ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_ch11.ads ada/exp_ch7.ads ada/exp_util.ads ada/exp_util.adb \
+ ada/get_targ.ads ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/inline.ads ada/itypes.ads ada/lib.ads \
+ ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/restrict.ads \
+ ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch8.ads \
+ ada/sem_eval.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \
+ ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
ada/s-wchcon.ads ada/table.ads ada/targparm.ads ada/tbuild.ads \
ada/ttypes.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
ada/exp_vfpt.o : ada/alloc.ads ada/atree.ads ada/einfo.ads \
ada/exp_vfpt.ads ada/exp_vfpt.adb ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/rtsfind.ads ada/sem_res.ads ada/sinfo.ads ada/snames.ads \
- ada/stand.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/table.ads ada/tbuild.ads ada/ttypef.ads ada/types.ads \
- ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/nmake.ads ada/rtsfind.ads ada/sem_res.ads ada/sinfo.ads \
+ ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/table.ads \
+ ada/tbuild.ads ada/ttypef.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/expander.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/elists.ads ada/errout.ads \
- ada/exp_aggr.ads ada/exp_attr.ads ada/exp_ch11.ads ada/exp_ch12.ads \
- ada/exp_ch13.ads ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch4.ads \
- ada/exp_ch5.ads ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch8.ads \
- ada/exp_ch9.ads ada/exp_prag.ads ada/expander.ads ada/expander.adb \
- ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads ada/opt.ads ada/output.ads \
- ada/sem.ads ada/sem_ch8.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
- ada/system.ads ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads \
- ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/elists.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_aggr.ads \
+ ada/exp_attr.ads ada/exp_ch11.ads ada/exp_ch12.ads ada/exp_ch13.ads \
+ ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch5.ads \
+ ada/exp_ch6.ads ada/exp_ch7.ads ada/exp_ch8.ads ada/exp_ch9.ads \
+ ada/exp_prag.ads ada/expander.ads ada/expander.adb ada/gnat.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch8.ads \
+ ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
ada/fmap.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads ada/alloc.ads \
ada/debug.ads ada/fmap.ads ada/fmap.adb ada/gnat.ads ada/g-htable.ads \
- ada/g-htable.adb ada/g-os_lib.ads ada/hostparm.ads ada/namet.ads \
- ada/opt.ads ada/osint.ads ada/output.ads ada/system.ads ada/s-atacco.ads \
- ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \
- ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \
+ ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads
+
+ada/fname-sf.o : ada/alloc.ads ada/casing.ads ada/fname.ads \
+ ada/fname-sf.ads ada/fname-sf.adb ada/fname-uf.ads ada/gnat.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/namet.ads ada/osint.ads \
+ ada/sfn_scan.ads ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/table.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/fname-uf.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \
ada/alloc.ads ada/casing.ads ada/debug.ads ada/fmap.ads ada/fname.ads \
ada/fname-uf.ads ada/fname-uf.adb ada/gnat.ads ada/g-htable.ads \
- ada/g-htable.adb ada/g-os_lib.ads ada/hostparm.ads ada/krunch.ads \
- ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/system.ads \
- ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads \
- ada/s-memory.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/krunch.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-htable.adb ada/s-memory.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
ada/unchdeal.ads ada/widechar.ads
ada/fname.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/debug.ads \
- ada/fname.ads ada/fname.adb ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads \
- ada/namet.ads ada/opt.ads ada/output.ads ada/system.ads ada/s-atacco.ads \
- ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
+ ada/fname.ads ada/fname.adb ada/gnat.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/opt.ads ada/output.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/freeze.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
- ada/errout.ads ada/exp_ch11.ads ada/exp_ch7.ads ada/exp_pakd.ads \
- ada/exp_util.ads ada/freeze.ads ada/freeze.adb ada/get_targ.ads \
- ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads ada/hostparm.ads \
- ada/layout.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
- ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads ada/sem_ch13.ads \
- ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_eval.ads \
- ada/sem_mech.ads ada/sem_prag.ads ada/sem_res.ads ada/sem_util.ads \
- ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \
+ ada/exp_ch7.ads ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads \
+ ada/freeze.ads ada/freeze.adb ada/get_targ.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/layout.ads ada/lib.ads ada/lib-xref.ads \
+ ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch6.ads ada/sem_ch7.ads \
+ ada/sem_ch8.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_prag.ads \
+ ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads ada/sinput.ads \
+ ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads ada/s-secsta.ads \
ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-wchcon.ads ada/table.ads ada/targparm.ads ada/tbuild.ads \
- ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/frontend.o : ada/alloc.ads ada/atree.ads ada/casing.ads ada/checks.ads \
- ada/cstand.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/exp_ch11.ads \
+ ada/cstand.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \
ada/exp_dbug.ads ada/fmap.ads ada/fname.ads ada/fname-uf.ads \
ada/frontend.ads ada/frontend.adb ada/get_targ.ads ada/gnat.ads \
- ada/g-os_lib.ads ada/hostparm.ads ada/inline.ads ada/lib.ads \
- ada/lib-load.ads ada/live.ads ada/namet.ads ada/nlists.ads ada/opt.ads \
- ada/osint.ads ada/output.ads ada/par.ads ada/rtsfind.ads ada/scn.ads \
- ada/sem.ads ada/sem_ch8.ads ada/sem_elab.ads ada/sem_prag.ads \
- ada/sem_warn.ads ada/sinfo.ads ada/sinput.ads ada/sinput-l.ads \
- ada/snames.ads ada/sprint.ads ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/inline.ads ada/lib.ads ada/lib-load.ads ada/live.ads ada/namet.ads \
+ ada/nlists.ads ada/opt.ads ada/osint.ads ada/output.ads ada/par.ads \
+ ada/prepcomp.ads ada/rtsfind.ads ada/scn.ads ada/scng.ads ada/sem.ads \
+ ada/sem_ch8.ads ada/sem_elab.ads ada/sem_prag.ads ada/sem_warn.ads \
+ ada/sinfo.ads ada/sinput.ads ada/sinput-l.ads ada/snames.ads \
+ ada/sprint.ads ada/style.ads ada/styleg.ads ada/styleg-c.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/tbuild.ads ada/types.ads \
+ ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/g-casuti.o : ada/gnat.ads ada/g-casuti.ads ada/g-casuti.adb \
+ ada/system.ads ada/s-casuti.ads
+
+ada/g-dirope.o : ada/ada.ads ada/a-charac.ads ada/a-chahan.ads \
+ ada/a-chlat1.ads ada/a-except.ads ada/a-finali.ads ada/a-filico.ads \
+ ada/a-stream.ads ada/a-string.ads ada/a-strfix.ads ada/a-strmap.ads \
+ ada/a-tags.ads ada/a-tags.adb ada/gnat.ads ada/g-dirope.ads \
+ ada/g-dirope.adb ada/g-os_lib.ads ada/g-string.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-finimp.ads ada/s-finroo.ads ada/s-htable.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-stratt.ads ada/s-strops.ads \
+ ada/s-unstyp.ads ada/unchconv.ads ada/unchdeal.ads
ada/g-hesora.o : ada/gnat.ads ada/g-hesora.ads ada/g-hesora.adb \
ada/system.ads
-ada/g-htable.o : ada/ada.ads ada/a-uncdea.ads ada/gnat.ads \
- ada/g-htable.ads ada/g-htable.adb ada/system.ads
+ada/g-htable.o : ada/gnat.ads ada/g-htable.ads ada/g-htable.adb \
+ ada/system.ads ada/s-htable.ads
ada/g-os_lib.o : ada/ada.ads ada/a-except.ads ada/gnat.ads \
- ada/g-os_lib.ads ada/g-os_lib.adb ada/system.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/unchconv.ads ada/unchdeal.ads
+ ada/g-os_lib.ads ada/g-os_lib.adb ada/g-string.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/unchconv.ads \
+ ada/unchdeal.ads
ada/g-speche.o : ada/gnat.ads ada/g-speche.ads ada/g-speche.adb \
ada/system.ads
+ada/g-string.o : ada/gnat.ads ada/g-string.ads ada/g-string.adb \
+ ada/system.ads ada/unchdeal.ads
+
ada/get_targ.o : ada/get_targ.ads ada/get_targ.adb ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads \
+ ada/unchconv.ads ada/unchdeal.ads
ada/gnat.o : ada/gnat.ads ada/system.ads
ada/gnat1drv.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/back_end.ads ada/casing.ads ada/comperr.ads ada/csets.ads ada/debug.ads \
- ada/einfo.ads ada/elists.ads ada/errout.ads ada/fname.ads ada/fname-uf.ads \
- ada/frontend.ads ada/get_targ.ads ada/gnat.ads ada/g-os_lib.ads \
- ada/gnat1drv.ads ada/gnat1drv.adb ada/gnatvsn.ads ada/hostparm.ads \
- ada/inline.ads ada/lib.ads ada/lib-writ.ads ada/namet.ads ada/nlists.ads \
- ada/opt.ads ada/osint.ads ada/output.ads ada/repinfo.ads ada/restrict.ads \
- ada/rident.ads ada/sem.ads ada/sem_ch13.ads ada/sinfo.ads ada/sinput.ads \
- ada/sinput-l.ads ada/snames.ads ada/sprint.ads ada/stringt.ads \
- ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads \
- ada/table.ads ada/targparm.ads ada/tree_gen.ads ada/treepr.ads \
- ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/usage.ads
+ ada/back_end.ads ada/casing.ads ada/comperr.ads ada/csets.ads \
+ ada/debug.ads ada/einfo.ads ada/elists.ads ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/fmap.ads ada/fname.ads \
+ ada/fname-uf.ads ada/frontend.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnat1drv.ads ada/gnat1drv.adb \
+ ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/lib.ads \
+ ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \
+ ada/opt.ads ada/osint.ads ada/output.ads ada/prepcomp.ads \
+ ada/repinfo.ads ada/restrict.ads ada/rident.ads ada/sem.ads \
+ ada/sem_ch12.ads ada/sem_ch13.ads ada/sem_ch8.ads ada/sem_eval.ads \
+ ada/sem_type.ads ada/sinfo.ads ada/sinput.ads ada/sinput-l.ads \
+ ada/snames.ads ada/sprint.ads ada/stringt.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/targparm.ads ada/tree_gen.ads \
+ ada/treepr.ads ada/ttypes.ads ada/types.ads ada/uintp.ads ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/usage.ads
ada/gnatbind.o : ada/ada.ads ada/a-except.ads ada/ali.ads ada/ali-util.ads \
- ada/alloc.ads ada/bcheck.ads ada/binde.ads ada/binderr.ads ada/bindgen.ads \
- ada/bindusg.ads ada/butil.ads ada/casing.ads ada/csets.ads ada/gnat.ads \
- ada/g-htable.ads ada/g-os_lib.ads ada/gnatbind.ads ada/gnatbind.adb \
- ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads \
- ada/osint-b.ads ada/output.ads ada/rident.ads ada/switch.ads \
- ada/switch-b.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/alloc.ads ada/bcheck.ads ada/binde.ads ada/binderr.ads \
+ ada/bindgen.ads ada/bindusg.ads ada/butil.ads ada/casing.ads \
+ ada/csets.ads ada/fmap.ads ada/gnat.ads ada/g-htable.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatbind.ads ada/gnatbind.adb \
+ ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
+ ada/osint.ads ada/osint-b.ads ada/output.ads ada/rident.ads \
+ ada/switch.ads ada/switch-b.ads ada/system.ads ada/s-assert.ads \
+ ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-strops.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/targparm.ads ada/types.ads ada/unchconv.ads \
+ ada/unchdeal.ads
+
+ada/gnatlink.o : ada/ada.ads ada/a-comlin.ads ada/a-except.ads ada/ali.ads \
+ ada/alloc.ads ada/casing.ads ada/debug.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatlink.ads \
+ ada/gnatlink.adb ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \
+ ada/i-cstrea.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \
+ ada/rident.ads ada/switch.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads ada/s-parame.ads \
ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-strops.ads ada/s-wchcon.ads ada/table.ads \
- ada/targparm.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads \
+ ada/s-sopco4.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
+ ada/unchdeal.ads
+
+ada/gnatmake.o : ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatmake.ads ada/gnatmake.adb ada/gnatvsn.ads ada/make.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/table.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/gnatvsn.o : ada/gnatvsn.ads ada/system.ads
ada/hlo.o : ada/hlo.ads ada/hlo.adb ada/output.ads ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads \
+ ada/unchconv.ads ada/unchdeal.ads
ada/hostparm.o : ada/hostparm.ads ada/system.ads
-ada/impunit.o : ada/alloc.ads ada/hostparm.ads ada/impunit.ads \
- ada/impunit.adb ada/lib.ads ada/namet.ads ada/opt.ads ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
+ada/i-cstrea.o : ada/interfac.ads ada/i-cstrea.ads ada/i-cstrea.adb \
+ ada/system.ads ada/s-parame.ads ada/unchconv.ads
+
+ada/impunit.o : ada/alloc.ads ada/gnat.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/impunit.ads ada/impunit.adb \
+ ada/lib.ads ada/namet.ads ada/opt.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/inline.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/errout.ads \
- ada/exp_ch11.ads ada/exp_ch7.ads ada/exp_tss.ads ada/fname.ads \
- ada/fname-uf.ads ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads \
- ada/inline.ads ada/inline.adb ada/lib.ads ada/namet.ads ada/nlists.ads \
- ada/opt.ads ada/output.ads ada/sem_ch10.ads ada/sem_ch12.ads \
- ada/sem_ch8.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads \
- ada/system.ads ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads \
- ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
- ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_ch11.ads \
+ ada/exp_ch7.ads ada/exp_tss.ads ada/fname.ads ada/fname-uf.ads \
+ ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/inline.ads ada/inline.adb ada/lib.ads \
+ ada/namet.ads ada/nlists.ads ada/opt.ads ada/output.ads \
+ ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch8.ads ada/sem_util.ads \
+ ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/interfac.o : ada/interfac.ads ada/system.ads
-ada/itypes.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/itypes.ads \
- ada/itypes.adb ada/namet.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
- ada/stand.ads ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ada/itypes.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/itypes.ads \
+ ada/itypes.adb ada/namet.ads ada/opt.ads ada/sem.ads ada/sem_util.ads \
+ ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
ada/krunch.o : ada/hostparm.ads ada/krunch.ads ada/krunch.adb \
- ada/system.ads ada/s-stoele.ads
+ ada/system.ads ada/s-stoele.ads ada/s-stoele.adb ada/unchconv.ads
ada/layout.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/exp_ch3.ads ada/exp_util.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
- ada/hostparm.ads ada/layout.ads ada/layout.adb ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/output.ads ada/repinfo.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_ch13.ads ada/sem_eval.ads ada/sem_util.ads \
- ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads \
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_ch3.ads ada/exp_util.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/layout.ads ada/layout.adb ada/namet.ads \
+ ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads ada/repinfo.ads \
+ ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch13.ads \
+ ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads ada/sinput.ads \
+ ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads ada/s-secsta.ads \
ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-wchcon.ads ada/table.ads ada/targparm.ads ada/tbuild.ads \
- ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/lib-load.o : ada/alloc.ads ada/atree.ads ada/casing.ads ada/debug.ads \
- ada/einfo.ads ada/errout.ads ada/fname.ads ada/fname-uf.ads ada/gnat.ads \
- ada/g-os_lib.ads ada/hostparm.ads ada/lib.ads ada/lib-load.ads \
- ada/lib-load.adb ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
- ada/osint.ads ada/osint-c.ads ada/output.ads ada/par.ads ada/scn.ads \
- ada/sinfo.ads ada/sinput.ads ada/sinput-l.ads ada/snames.ads ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
- ada/targparm.ads ada/tbuild.ads ada/types.ads ada/uintp.ads ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/einfo.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \
+ ada/lib-load.ads ada/lib-load.adb ada/namet.ads ada/nlists.ads \
+ ada/nmake.ads ada/opt.ads ada/osint.ads ada/osint-c.ads ada/output.ads \
+ ada/par.ads ada/rident.ads ada/scn.ads ada/scng.ads ada/sinfo.ads \
+ ada/sinput.ads ada/sinput-l.ads ada/snames.ads ada/style.ads \
+ ada/styleg.ads ada/styleg-c.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/targparm.ads ada/tbuild.ads ada/types.ads ada/uintp.ads \
+ ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/lib-util.o : ada/alloc.ads ada/gnat.ads ada/g-os_lib.ads \
- ada/hostparm.ads ada/lib.ads ada/lib-util.ads ada/lib-util.adb \
- ada/namet.ads ada/osint.ads ada/osint-c.ads ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/table.ads ada/types.ads \
+ ada/g-string.ads ada/hostparm.ads ada/lib.ads ada/lib-util.ads \
+ ada/lib-util.adb ada/namet.ads ada/osint.ads ada/osint-c.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-unstyp.ads ada/table.ads ada/types.ads \
ada/unchconv.ads ada/unchdeal.ads
-ada/lib-writ.o : ada/ali.ads ada/alloc.ads ada/atree.ads ada/casing.ads \
- ada/einfo.ads ada/errout.ads ada/fname.ads ada/fname-uf.ads ada/gnat.ads \
- ada/g-htable.ads ada/g-os_lib.ads ada/gnatvsn.ads ada/hostparm.ads \
- ada/lib.ads ada/lib-util.ads ada/lib-writ.ads ada/lib-writ.adb \
- ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/opt.ads ada/osint.ads \
- ada/osint-c.ads ada/par.ads ada/restrict.ads ada/rident.ads ada/scn.ads \
- ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stringt.ads ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
- ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ada/lib-writ.o : ada/ada.ads ada/a-except.ads ada/ali.ads ada/alloc.ads \
+ ada/atree.ads ada/casing.ads ada/debug.ads ada/einfo.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \
+ ada/fname-uf.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \
+ ada/lib-util.ads ada/lib-writ.ads ada/lib-writ.adb ada/lib-xref.ads \
+ ada/namet.ads ada/nlists.ads ada/opt.ads ada/osint.ads ada/osint-c.ads \
+ ada/output.ads ada/par.ads ada/restrict.ads ada/rident.ads ada/scn.ads \
+ ada/scng.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \
+ ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg-c.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
ada/lib-xref.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/errout.ads \
- ada/gnat.ads ada/g-hesora.ads ada/g-os_lib.ads ada/hostparm.ads ada/lib.ads \
- ada/lib-util.ads ada/lib-xref.ads ada/lib-xref.adb ada/namet.ads \
- ada/opt.ads ada/output.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \
- ada/stand.ads ada/system.ads ada/s-atacco.ads ada/s-atacco.adb \
- ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \
- ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \
- ada/widechar.ads
+ ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \
+ ada/g-hesora.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/lib.ads ada/lib-util.ads ada/lib-xref.ads \
+ ada/lib-xref.adb ada/namet.ads ada/opt.ads ada/output.ads \
+ ada/sem_prag.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \
+ ada/stand.ads ada/stringt.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/widechar.ads
ada/lib.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/casing.ads ada/debug.ads ada/einfo.ads ada/fname.ads ada/gnat.ads \
- ada/g-hesora.ads ada/g-os_lib.ads ada/hostparm.ads ada/lib.ads ada/lib.adb \
- ada/lib-list.adb ada/lib-sort.adb ada/namet.ads ada/opt.ads ada/output.ads \
- ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
- ada/system.ads ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads \
- ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
- ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/g-hesora.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
+ ada/lib-sort.adb ada/namet.ads ada/opt.ads ada/output.ads ada/sinfo.ads \
+ ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/live.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
- ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads ada/lib.ads ada/live.ads \
- ada/live.adb ada/nlists.ads ada/output.ads ada/sem_util.ads ada/sinfo.ads \
- ada/sinput.ads ada/snames.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-unstyp.ads \
- ada/table.ads ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/lib.ads ada/live.ads ada/live.adb ada/nlists.ads ada/output.ads \
+ ada/sem_util.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/table.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/make.o : ada/ada.ads ada/a-charac.ads ada/a-chahan.ads \
+ ada/a-chlat1.ads ada/a-comlin.ads ada/a-except.ads ada/a-finali.ads \
+ ada/a-filico.ads ada/a-stream.ads ada/a-string.ads ada/a-strmap.ads \
+ ada/a-tags.ads ada/a-tags.adb ada/ali.ads ada/ali-util.ads \
+ ada/alloc.ads ada/casing.ads ada/csets.ads ada/debug.ads \
+ ada/errutil.ads ada/fmap.ads ada/fname.ads ada/fname-sf.ads \
+ ada/fname-uf.ads ada/gnat.ads ada/g-dirope.ads ada/g-htable.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/make.ads ada/make.adb ada/makeusg.ads ada/mlib.ads ada/mlib-prj.ads \
+ ada/mlib-tgt.ads ada/mlib-utl.ads ada/namet.ads ada/opt.ads \
+ ada/osint.ads ada/osint-m.ads ada/output.ads ada/prj.ads ada/prj.adb \
+ ada/prj-attr.ads ada/prj-com.ads ada/prj-env.ads ada/prj-env.adb \
+ ada/prj-err.ads ada/prj-ext.ads ada/prj-pars.ads ada/prj-util.ads \
+ ada/rident.ads ada/scans.ads ada/scng.ads ada/sfn_scan.ads \
+ ada/sinput.ads ada/sinput-p.ads ada/snames.ads ada/styleg.ads \
+ ada/switch.ads ada/switch-m.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-finimp.ads ada/s-finroo.ads ada/s-htable.ads \
+ ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-stratt.ads \
+ ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
+ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
ada/unchdeal.ads ada/urealp.ads
+ada/makeusg.o : ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/makeusg.ads ada/makeusg.adb ada/osint.ads ada/output.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/usage.ads
+
ada/memtrack.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-memory.ads ada/memtrack.adb ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-traceb.ads ada/unchconv.ads
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-traceb.ads \
+ ada/unchconv.ads
+
+ada/mlib-fil.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \
+ ada/a-except.ads ada/a-string.ads ada/a-strfix.ads ada/a-strmap.ads \
+ ada/alloc.ads ada/casing.ads ada/gnat.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/mlib.ads ada/mlib-fil.ads ada/mlib-fil.adb \
+ ada/mlib-tgt.ads ada/osint.ads ada/prj.ads ada/scans.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-sopco3.ads \
+ ada/s-unstyp.ads ada/table.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/mlib-prj.o : ada/ada.ads ada/a-charac.ads ada/a-chahan.ads \
+ ada/a-chlat1.ads ada/a-except.ads ada/a-finali.ads ada/a-filico.ads \
+ ada/a-stream.ads ada/a-string.ads ada/a-strmap.ads ada/a-tags.ads \
+ ada/a-tags.adb ada/a-uncdea.ads ada/alloc.ads ada/casing.ads \
+ ada/debug.ads ada/gnat.ads ada/g-dirope.ads ada/g-htable.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/mlib.ads ada/mlib-fil.ads ada/mlib-prj.ads ada/mlib-prj.adb \
+ ada/mlib-tgt.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \
+ ada/prj.ads ada/prj-com.ads ada/scans.ads ada/sinput.ads \
+ ada/sinput-p.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-finimp.ads ada/s-finroo.ads ada/s-htable.ads ada/s-htable.adb \
+ ada/s-imgenu.ads ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-stratt.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
+
+ada/mlib-tgt.o : ada/alloc.ads ada/casing.ads ada/gnat.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/mlib.ads ada/mlib-tgt.ads \
+ ada/mlib-tgt.adb ada/osint.ads ada/prj.ads ada/scans.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-unstyp.ads ada/table.ads ada/types.ads \
+ ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/mlib-utl.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/casing.ads \
+ ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/mlib.ads ada/mlib-fil.ads ada/mlib-tgt.ads \
+ ada/mlib-utl.ads ada/mlib-utl.adb ada/namet.ads ada/opt.ads \
+ ada/osint.ads ada/output.ads ada/prj.ads ada/scans.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/types.ads \
+ ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/mlib.o : ada/ada.ads ada/a-charac.ads ada/a-chahan.ads \
+ ada/a-chlat1.ads ada/a-except.ads ada/a-finali.ads ada/a-filico.ads \
+ ada/a-stream.ads ada/a-string.ads ada/a-strmap.ads ada/a-tags.ads \
+ ada/a-tags.adb ada/alloc.ads ada/gnat.ads ada/g-dirope.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/mlib.ads ada/mlib.adb ada/mlib-utl.ads ada/namet.ads ada/opt.ads \
+ ada/osint.ads ada/output.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-finimp.ads ada/s-finroo.ads ada/s-htable.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-stratt.ads ada/s-sopco3.ads ada/s-sopco4.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/types.ads \
+ ada/unchconv.ads ada/unchdeal.ads
ada/namet.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/debug.ads \
- ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads ada/namet.ads ada/namet.adb \
- ada/opt.ads ada/output.ads ada/system.ads ada/s-atacco.ads ada/s-atacco.adb \
- ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-secsta.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/widechar.ads
+ ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/namet.adb ada/opt.ads ada/output.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \
+ ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/widechar.ads
ada/nlists.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/debug.ads ada/einfo.ads ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads \
- ada/nlists.ads ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads \
- ada/snames.ads ada/system.ads ada/s-atacco.ads ada/s-atacco.adb \
- ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \
- ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/debug.ads ada/einfo.ads ada/gnat.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/nlists.ads \
+ ada/nlists.adb ada/opt.ads ada/output.ads ada/sinfo.ads ada/snames.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/nmake.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/namet.ads \
ada/nlists.ads ada/nmake.ads ada/nmake.adb ada/sinfo.ads ada/snames.ads \
ada/stand.ads ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ ada/s-unstyp.ads ada/table.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
-ada/opt.o : ada/ada.ads ada/a-except.ads ada/gnat.ads ada/g-os_lib.ads \
- ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads ada/opt.adb ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/tree_io.ads \
- ada/types.ads ada/unchconv.ads ada/unchdeal.ads
+ada/opt.o : ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/opt.ads ada/opt.adb ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/osint-b.o : ada/alloc.ads ada/gnat.ads ada/g-os_lib.ads \
- ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/osint-b.ads \
- ada/osint-b.adb ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads ada/types.ads \
- ada/unchconv.ads ada/unchdeal.ads
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/opt.ads ada/osint.ads ada/osint-b.ads ada/osint-b.adb \
+ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/osint-c.o : ada/alloc.ads ada/gnat.ads ada/g-os_lib.ads \
- ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/osint-c.ads \
- ada/osint-c.adb ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
- ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/opt.ads ada/osint.ads ada/osint-c.ads ada/osint-c.adb \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/tree_io.ads ada/types.ads ada/unchconv.ads \
+ ada/unchdeal.ads
+
+ada/osint-m.o : ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/osint.ads ada/osint-m.ads ada/osint-m.adb ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads \
+ ada/unchconv.ads ada/unchdeal.ads
ada/osint.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads ada/alloc.ads \
- ada/debug.ads ada/fmap.ads ada/gnat.ads ada/g-htable.ads ada/g-htable.adb \
- ada/g-os_lib.ads ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads \
- ada/osint.adb ada/output.ads ada/sdefault.ads ada/system.ads \
- ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads \
- ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
+ ada/debug.ads ada/fmap.ads ada/gnat.ads ada/g-htable.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/namet.ads ada/opt.ads ada/osint.ads ada/osint.adb ada/output.ads \
+ ada/sdefault.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
ada/unchdeal.ads
-ada/output.o : ada/gnat.ads ada/g-os_lib.ads ada/output.ads ada/output.adb \
- ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/types.ads \
- ada/unchconv.ads ada/unchdeal.ads
+ada/output.o : ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/output.ads ada/output.adb ada/system.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads ada/unchconv.ads \
+ ada/unchdeal.ads
ada/par.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
- ada/errout.ads ada/fname.ads ada/fname-uf.ads ada/gnat.ads ada/g-os_lib.ads \
- ada/g-speche.ads ada/hostparm.ads ada/lib.ads ada/lib-load.ads \
- ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/osint.ads \
- ada/output.ads ada/par.ads ada/par.adb ada/par-ch10.adb ada/par-ch11.adb \
- ada/par-ch12.adb ada/par-ch13.adb ada/par-ch2.adb ada/par-ch3.adb \
- ada/par-ch4.adb ada/par-ch5.adb ada/par-ch6.adb ada/par-ch7.adb \
- ada/par-ch8.adb ada/par-ch9.adb ada/par-endh.adb ada/par-labl.adb \
- ada/par-load.adb ada/par-prag.adb ada/par-sync.adb ada/par-tchk.adb \
- ada/par-util.adb ada/scans.ads ada/scn.ads ada/sinfo.ads ada/sinfo-cn.ads \
- ada/sinput.ads ada/sinput-l.ads ada/snames.ads ada/stringt.ads \
- ada/style.ads ada/stylesw.ads ada/system.ads ada/s-atacco.ads \
- ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads ada/s-imgenu.ads \
- ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \
+ ada/fname-uf.ads ada/gnat.ads ada/g-os_lib.ads ada/g-speche.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \
+ ada/lib-load.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/osint.ads ada/output.ads ada/par.ads ada/par.adb ada/par-ch10.adb \
+ ada/par-ch11.adb ada/par-ch12.adb ada/par-ch13.adb ada/par-ch2.adb \
+ ada/par-ch3.adb ada/par-ch4.adb ada/par-ch5.adb ada/par-ch6.adb \
+ ada/par-ch7.adb ada/par-ch8.adb ada/par-ch9.adb ada/par-endh.adb \
+ ada/par-labl.adb ada/par-load.adb ada/par-prag.adb ada/par-sync.adb \
+ ada/par-tchk.adb ada/par-util.adb ada/scans.ads ada/scn.ads \
+ ada/scng.ads ada/sinfo.ads ada/sinfo-cn.ads ada/sinput.ads \
+ ada/sinput-l.ads ada/snames.ads ada/stringt.ads ada/style.ads \
+ ada/styleg.ads ada/styleg-c.ads ada/stylesw.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-imgenu.ads ada/s-memory.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+
+ada/prep.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/casing.ads \
+ ada/csets.ads ada/debug.ads ada/err_vars.ads ada/gnat.ads \
+ ada/g-dyntab.ads ada/g-dyntab.adb ada/g-hesorg.ads ada/g-hesorg.adb \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads ada/prep.ads \
+ ada/prep.adb ada/scans.ads ada/sinput.ads ada/snames.ads \
+ ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-carun8.ads \
+ ada/s-exctab.ads ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
+
+ada/prepcomp.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \
+ ada/alloc.ads ada/casing.ads ada/debug.ads ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/gnat.ads ada/g-dyntab.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/lib.ads ada/lib-writ.ads ada/namet.ads ada/opt.ads ada/osint.ads \
+ ada/output.ads ada/prep.ads ada/prepcomp.ads ada/prepcomp.adb \
+ ada/scans.ads ada/scn.ads ada/scng.ads ada/sinput.ads ada/sinput-l.ads \
+ ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg-c.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/prj-attr.o : ada/ada.ads ada/a-charac.ads ada/a-chahan.ads \
+ ada/a-except.ads ada/alloc.ads ada/casing.ads ada/debug.ads \
+ ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \
+ ada/prj.ads ada/prj-attr.ads ada/prj-attr.adb ada/scans.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-sopco3.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
+
+ada/prj-com.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \
+ ada/alloc.ads ada/casing.ads ada/debug.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \
+ ada/prj.ads ada/prj-com.ads ada/prj-com.adb ada/scans.ads \
+ ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/prj-dect.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/casing.ads \
+ ada/err_vars.ads ada/errutil.ads ada/gnat.ads ada/g-htable.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/namet.ads ada/osint.ads \
+ ada/prj.ads ada/prj-attr.ads ada/prj-com.ads ada/prj-dect.ads \
+ ada/prj-dect.adb ada/prj-err.ads ada/prj-strt.ads ada/prj-tree.ads \
+ ada/scans.ads ada/scng.ads ada/snames.ads ada/styleg.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-strops.ads ada/s-sopco3.ads ada/s-unstyp.ads ada/table.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
+
+ada/prj-env.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \
+ ada/a-except.ads ada/a-finali.ads ada/a-filico.ads ada/a-stream.ads \
+ ada/a-string.ads ada/a-strmap.ads ada/a-tags.ads ada/a-tags.adb \
+ ada/alloc.ads ada/casing.ads ada/debug.ads ada/gnat.ads \
+ ada/g-dirope.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
+ ada/osint.ads ada/output.ads ada/prj.ads ada/prj-com.ads \
+ ada/prj-env.ads ada/prj-env.adb ada/prj-util.ads ada/scans.ads \
+ ada/snames.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-finimp.ads ada/s-finroo.ads ada/s-htable.ads ada/s-memory.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-stratt.ads ada/s-strops.ads \
+ ada/s-sopco3.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/prj-err.o : ada/alloc.ads ada/casing.ads ada/csets.ads \
+ ada/err_vars.ads ada/errutil.ads ada/gnat.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \
+ ada/namet.ads ada/opt.ads ada/output.ads ada/prj.ads ada/prj-err.ads \
+ ada/prj-err.adb ada/scans.ads ada/scng.ads ada/scng.adb ada/sinput.ads \
+ ada/snames.ads ada/stringt.ads ada/styleg.ads ada/system.ads \
+ ada/s-crc32.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
+
+ada/prj-ext.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \
+ ada/alloc.ads ada/casing.ads ada/gnat.ads ada/g-htable.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/namet.ads ada/osint.ads \
+ ada/prj.ads ada/prj-com.ads ada/prj-ext.ads ada/prj-ext.adb \
+ ada/scans.ads ada/system.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-htable.adb ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
+
+ada/prj-nmsc.o : ada/ada.ads ada/a-charac.ads ada/a-chahan.ads \
+ ada/a-chlat1.ads ada/a-except.ads ada/a-finali.ads ada/a-filico.ads \
+ ada/a-stream.ads ada/a-string.ads ada/a-strfix.ads ada/a-strmap.ads \
+ ada/a-stmaco.ads ada/a-tags.ads ada/a-tags.adb ada/a-uncdea.ads \
+ ada/alloc.ads ada/casing.ads ada/err_vars.ads ada/errutil.ads \
+ ada/gnat.ads ada/g-casuti.ads ada/g-dirope.ads ada/g-htable.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/hostparm.ads ada/mlib.ads \
+ ada/mlib-tgt.ads ada/namet.ads ada/osint.ads ada/output.ads ada/prj.ads \
+ ada/prj-com.ads ada/prj-env.ads ada/prj-err.ads ada/prj-nmsc.ads \
+ ada/prj-nmsc.adb ada/prj-util.ads ada/scans.ads ada/scng.ads \
+ ada/sinput.ads ada/sinput-p.ads ada/snames.ads ada/styleg.ads \
+ ada/system.ads ada/s-assert.ads ada/s-casuti.ads ada/s-exctab.ads \
+ ada/s-finimp.ads ada/s-finroo.ads ada/s-htable.ads ada/s-htable.adb \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-stratt.ads ada/s-strops.ads \
+ ada/s-sopco3.ads ada/s-sopco5.ads ada/s-unstyp.ads ada/table.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
+
+ada/prj-pars.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/casing.ads \
+ ada/errutil.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/osint.ads ada/output.ads ada/prj.ads \
+ ada/prj-attr.ads ada/prj-com.ads ada/prj-err.ads ada/prj-pars.ads \
+ ada/prj-pars.adb ada/prj-part.ads ada/prj-proc.ads ada/prj-tree.ads \
+ ada/scans.ads ada/scng.ads ada/styleg.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/table.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/prj-part.o : ada/ada.ads ada/a-charac.ads ada/a-chahan.ads \
+ ada/a-chlat1.ads ada/a-except.ads ada/a-finali.ads ada/a-filico.ads \
+ ada/a-stream.ads ada/a-string.ads ada/a-strmap.ads ada/a-tags.ads \
+ ada/a-tags.adb ada/alloc.ads ada/casing.ads ada/debug.ads \
+ ada/err_vars.ads ada/errutil.ads ada/gnat.ads ada/g-dirope.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \
+ ada/prj.ads ada/prj-attr.ads ada/prj-com.ads ada/prj-dect.ads \
+ ada/prj-err.ads ada/prj-part.ads ada/prj-part.adb ada/prj-tree.ads \
+ ada/scans.ads ada/scng.ads ada/sinput.ads ada/sinput-p.ads \
+ ada/styleg.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-finimp.ads ada/s-finroo.ads ada/s-htable.ads ada/s-memory.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-stratt.ads ada/s-strops.ads \
+ ada/s-sopco3.ads ada/s-sopco4.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/prj-proc.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \
+ ada/alloc.ads ada/casing.ads ada/err_vars.ads ada/errutil.ads \
+ ada/gnat.ads ada/g-casuti.ads ada/g-htable.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/opt.ads ada/osint.ads ada/output.ads ada/prj.ads ada/prj-attr.ads \
+ ada/prj-com.ads ada/prj-err.ads ada/prj-ext.ads ada/prj-nmsc.ads \
+ ada/prj-proc.ads ada/prj-proc.adb ada/prj-tree.ads ada/scans.ads \
+ ada/scng.ads ada/styleg.ads ada/system.ads ada/s-assert.ads \
+ ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb \
+ ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-strops.ads \
+ ada/s-sopco3.ads ada/s-sopco5.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
+
+ada/prj-strt.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/casing.ads \
+ ada/debug.ads ada/err_vars.ads ada/errutil.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \
+ ada/prj.ads ada/prj-attr.ads ada/prj-com.ads ada/prj-err.ads \
+ ada/prj-strt.ads ada/prj-strt.adb ada/prj-tree.ads ada/scans.ads \
+ ada/scng.ads ada/snames.ads ada/styleg.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/prj-tree.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \
+ ada/alloc.ads ada/casing.ads ada/debug.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/opt.ads ada/osint.ads ada/output.ads ada/prj.ads \
+ ada/prj-attr.ads ada/prj-com.ads ada/prj-tree.ads ada/prj-tree.adb \
+ ada/scans.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
+
+ada/prj-util.o : ada/ada.ads ada/a-uncdea.ads ada/alloc.ads ada/casing.ads \
+ ada/gnat.ads ada/g-casuti.ads ada/g-htable.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/namet.ads ada/osint.ads ada/output.ads ada/prj.ads \
+ ada/prj-com.ads ada/prj-util.ads ada/prj-util.adb ada/scans.ads \
+ ada/system.ads ada/s-casuti.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-secsta.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/table.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/prj.o : ada/ada.ads ada/a-charac.ads ada/a-chahan.ads ada/a-except.ads \
+ ada/alloc.ads ada/casing.ads ada/debug.ads ada/errutil.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \
+ ada/prj.ads ada/prj.adb ada/prj-attr.ads ada/prj-com.ads \
+ ada/prj-env.ads ada/prj-err.ads ada/scans.ads ada/scng.ads \
+ ada/snames.ads ada/styleg.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-memory.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-strops.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/repinfo.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/casing.ads ada/debug.ads ada/einfo.ads ada/gnat.ads ada/g-os_lib.ads \
- ada/hostparm.ads ada/lib.ads ada/namet.ads ada/opt.ads ada/output.ads \
- ada/repinfo.ads ada/repinfo.adb ada/sinfo.ads ada/sinput.ads ada/snames.ads \
- ada/system.ads ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads \
- ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-wchcon.ads \
+ ada/casing.ads ada/debug.ads ada/einfo.ads ada/gnat.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/lib.ads ada/namet.ads ada/opt.ads ada/output.ads ada/repinfo.ads \
+ ada/repinfo.adb ada/sinfo.ads ada/sinput.ads ada/snames.ads \
+ ada/stand.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/restrict.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/casing.ads ada/einfo.ads ada/errout.ads ada/exp_util.ads ada/fname.ads \
- ada/fname-uf.ads ada/hostparm.ads ada/lib.ads ada/namet.ads ada/opt.ads \
- ada/restrict.ads ada/restrict.adb ada/rident.ads ada/rtsfind.ads \
- ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \
- ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
- ada/targparm.ads ada/tbuild.ads ada/types.ads ada/uintp.ads ada/uname.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/casing.ads ada/einfo.ads ada/err_vars.ads ada/errout.ads \
+ ada/erroutc.ads ada/exp_util.ads ada/fname.ads ada/fname-uf.ads \
+ ada/hostparm.ads ada/lib.ads ada/namet.ads ada/restrict.ads \
+ ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/sinfo.ads \
+ ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/table.ads ada/tbuild.ads ada/types.ads \
+ ada/uintp.ads ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/rident.o : ada/rident.ads ada/system.ads
ada/rtsfind.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
- ada/fname.ads ada/fname-uf.ads ada/hostparm.ads ada/lib.ads \
- ada/lib-load.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
- ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
- ada/rtsfind.adb ada/sem.ads ada/sem_ch7.ads ada/sem_util.ads ada/sinfo.ads \
- ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads \
- ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads ada/uname.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \
+ ada/fname-uf.ads ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/lib.ads ada/lib-load.ads ada/namet.ads \
+ ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads ada/rtsfind.ads \
+ ada/rtsfind.adb ada/sem.ads ada/sem_ch7.ads ada/sem_util.ads \
+ ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/tbuild.ads ada/types.ads ada/uintp.ads ada/uname.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/s-assert.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-assert.ads ada/s-assert.adb ada/s-exctab.ads ada/s-stalib.ads \
ada/unchconv.ads
+ada/s-bitops.o : ada/system.ads ada/s-bitops.ads ada/s-bitops.adb \
+ ada/s-purexc.ads ada/s-unstyp.ads ada/unchconv.ads
+
+ada/s-carun8.o : ada/system.ads ada/s-carun8.ads ada/s-carun8.adb \
+ ada/unchconv.ads
+
+ada/s-casuti.o : ada/system.ads ada/s-casuti.ads ada/s-casuti.adb
+
ada/s-crc32.o : ada/interfac.ads ada/system.ads ada/s-crc32.ads \
ada/s-crc32.adb
ada/s-except.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-except.ads ada/s-stalib.ads ada/unchconv.ads
-ada/s-exctab.o : ada/ada.ads ada/a-uncdea.ads ada/gnat.ads \
- ada/g-htable.ads ada/g-htable.adb ada/system.ads ada/s-exctab.ads \
- ada/s-exctab.adb ada/s-stalib.ads ada/unchconv.ads
+ada/s-exctab.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-exctab.adb ada/s-htable.ads \
+ ada/s-htable.adb ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/unchconv.ads
+
+ada/s-finimp.o : ada/ada.ads ada/a-except.ads ada/a-stream.ads \
+ ada/a-tags.ads ada/a-tags.adb ada/a-unccon.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-finimp.ads ada/s-finimp.adb ada/s-finroo.ads \
+ ada/s-htable.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-stratt.ads \
+ ada/s-sopco3.ads ada/s-unstyp.ads ada/unchconv.ads
+
+ada/s-finroo.o : ada/ada.ads ada/a-except.ads ada/a-stream.ads \
+ ada/a-tags.ads ada/a-tags.adb ada/system.ads ada/s-exctab.ads \
+ ada/s-finroo.ads ada/s-finroo.adb ada/s-htable.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/unchconv.ads
+
+ada/s-htable.o : ada/ada.ads ada/a-uncdea.ads ada/system.ads \
+ ada/s-htable.ads ada/s-htable.adb
ada/s-imgenu.o : ada/system.ads ada/s-imgenu.ads ada/s-imgenu.adb \
- ada/s-secsta.ads ada/s-stoele.ads ada/unchconv.ads
+ ada/s-secsta.ads ada/s-stoele.ads ada/s-stoele.adb ada/unchconv.ads
ada/s-mastop.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-except.ads ada/s-mastop.ads ada/s-mastop.adb ada/s-stalib.ads \
- ada/s-stoele.ads ada/unchconv.ads
+ ada/s-stoele.ads ada/s-stoele.adb ada/unchconv.ads
ada/s-memory.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-memory.ads ada/s-memory.adb ada/s-parame.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/unchconv.ads
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/unchconv.ads
ada/s-parame.o : ada/system.ads ada/s-parame.ads ada/s-parame.adb
+ada/s-purexc.o : ada/system.ads ada/s-purexc.ads
+
ada/s-secsta.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-parame.ads ada/s-secsta.ads ada/s-secsta.adb ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/unchconv.ads \
- ada/unchdeal.ads
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/unchconv.ads ada/unchdeal.ads
ada/s-soflin.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-except.ads ada/s-mastop.ads ada/s-parame.ads ada/s-secsta.ads \
ada/s-soflin.ads ada/s-soflin.adb ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/unchconv.ads
+ ada/s-stoele.ads ada/s-stoele.adb ada/unchconv.ads
ada/s-sopco3.o : ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \
- ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco3.adb
+ ada/s-stoele.adb ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco3.adb \
+ ada/unchconv.ads
ada/s-sopco4.o : ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \
- ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco4.adb
+ ada/s-stoele.adb ada/s-sopco3.ads ada/s-sopco4.ads ada/s-sopco4.adb \
+ ada/unchconv.ads
ada/s-sopco5.o : ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \
- ada/s-sopco4.ads ada/s-sopco5.ads ada/s-sopco5.adb
+ ada/s-stoele.adb ada/s-sopco4.ads ada/s-sopco5.ads ada/s-sopco5.adb \
+ ada/unchconv.ads
ada/s-stache.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-parame.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stache.adb \
@@ -1902,13 +2689,22 @@ ada/s-stache.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-stalib.o : ada/ada.ads ada/a-except.ads ada/system.ads \
ada/s-memory.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stalib.adb ada/s-stoele.ads ada/unchconv.ads
+ ada/s-stalib.adb ada/s-stoele.ads ada/s-stoele.adb ada/unchconv.ads
ada/s-stoele.o : ada/system.ads ada/s-stoele.ads ada/s-stoele.adb \
ada/unchconv.ads
+ada/s-stratt.o : ada/ada.ads ada/a-except.ads ada/a-ioexce.ads \
+ ada/a-stream.ads ada/a-tags.ads ada/a-tags.adb ada/system.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-secsta.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-stratt.ads ada/s-stratt.adb \
+ ada/s-unstyp.ads ada/unchconv.ads
+
+ada/s-strcom.o : ada/system.ads ada/s-strcom.ads ada/s-strcom.adb \
+ ada/unchconv.ads
+
ada/s-strops.o : ada/system.ads ada/s-secsta.ads ada/s-stoele.ads \
- ada/s-strops.ads ada/s-strops.adb
+ ada/s-stoele.adb ada/s-strops.ads ada/s-strops.adb ada/unchconv.ads
ada/s-traceb.o : ada/system.ads ada/s-traceb.ads ada/s-traceb.adb
@@ -1921,589 +2717,760 @@ ada/s-wchcon.o : ada/system.ads ada/s-wchcon.ads
ada/s-wchjis.o : ada/system.ads ada/s-wchjis.ads ada/s-wchjis.adb
-ada/scans.o : ada/scans.ads ada/scans.adb ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
+ada/scans.o : ada/alloc.ads ada/scans.ads ada/scans.adb ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/table.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/scn.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/casing.ads ada/csets.ads ada/einfo.ads ada/errout.ads ada/hostparm.ads \
- ada/interfac.ads ada/namet.ads ada/opt.ads ada/scans.ads ada/scn.ads \
- ada/scn.adb ada/scn-nlit.adb ada/scn-slit.adb ada/sinfo.ads ada/sinput.ads \
- ada/snames.ads ada/stringt.ads ada/style.ads ada/system.ads ada/s-crc32.ads \
- ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads \
- ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads ada/widechar.ads
+ ada/casing.ads ada/csets.ads ada/einfo.ads ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/gnat.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads ada/namet.ads \
+ ada/opt.ads ada/scans.ads ada/scn.ads ada/scn.adb ada/scng.ads \
+ ada/scng.adb ada/sinfo.ads ada/sinput.ads ada/snames.ads \
+ ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg-c.ads \
+ ada/stylesw.ads ada/system.ads ada/s-crc32.ads ada/s-exctab.ads \
+ ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
+
+ada/scng.o : ada/alloc.ads ada/casing.ads ada/csets.ads ada/err_vars.ads \
+ ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/interfac.ads ada/namet.ads ada/opt.ads ada/scans.ads ada/scng.ads \
+ ada/scng.adb ada/sinput.ads ada/snames.ads ada/stringt.ads \
+ ada/styleg.ads ada/stylesw.ads ada/system.ads ada/s-crc32.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/widechar.ads
ada/sem.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/errout.ads ada/expander.ads \
- ada/fname.ads ada/gnat.ads ada/g-os_lib.ads ada/hlo.ads ada/hostparm.ads \
- ada/inline.ads ada/lib.ads ada/lib-load.ads ada/namet.ads ada/nlists.ads \
- ada/opt.ads ada/output.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \
+ ada/debug.ads ada/debug_a.ads ada/einfo.ads ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/expander.ads ada/fname.ads \
+ ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hlo.ads ada/hostparm.ads ada/inline.ads ada/lib.ads \
+ ada/lib-load.ads ada/namet.ads ada/nlists.ads ada/opt.ads \
+ ada/output.ads ada/sem.ads ada/sem.adb ada/sem_attr.ads \
ada/sem_ch10.ads ada/sem_ch11.ads ada/sem_ch12.ads ada/sem_ch13.ads \
ada/sem_ch2.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads \
ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_ch9.ads \
ada/sem_prag.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
- ada/stand.ads ada/system.ads ada/s-atacco.ads ada/s-atacco.adb \
- ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \
- ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/stand.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_aggr.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/exp_util.ads ada/freeze.ads ada/gnat.ads \
- ada/g-speche.ads ada/hostparm.ads ada/itypes.ads ada/namet.ads \
- ada/nlists.ads ada/nmake.ads ada/opt.ads ada/rtsfind.ads ada/sem.ads \
- ada/sem_aggr.ads ada/sem_aggr.adb ada/sem_cat.ads ada/sem_ch13.ads \
- ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \
- ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
- ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/s-wchcon.ads ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads \
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_util.ads ada/freeze.ads ada/gnat.ads ada/g-speche.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/itypes.ads \
+ ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nmake.ads \
+ ada/opt.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_aggr.ads \
+ ada/sem_aggr.adb ada/sem_cat.ads ada/sem_ch13.ads ada/sem_ch8.ads \
+ ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
+ ada/sem_warn.ads ada/sinfo.ads ada/snames.ads ada/stand.ads \
+ ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/targparm.ads ada/tbuild.ads ada/types.ads ada/uintp.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_attr.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \
- ada/a-except.ads ada/alloc.ads ada/atree.ads ada/casing.ads ada/checks.ads \
- ada/einfo.ads ada/errout.ads ada/eval_fat.ads ada/exp_tss.ads \
- ada/exp_util.ads ada/expander.ads ada/freeze.ads ada/get_targ.ads \
- ada/hostparm.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
+ ada/a-except.ads ada/alloc.ads ada/atree.ads ada/casing.ads \
+ ada/checks.ads ada/einfo.ads ada/err_vars.ads ada/errout.ads \
+ ada/erroutc.ads ada/eval_fat.ads ada/exp_tss.ads ada/exp_util.ads \
+ ada/expander.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \
+ ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sdefault.ads \
ada/sem.ads ada/sem_attr.ads ada/sem_attr.adb ada/sem_cat.ads \
ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads \
ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads \
- ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
- ada/targparm.ads ada/tbuild.ads ada/ttypef.ads ada/ttypes.ads ada/types.ads \
+ ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/targparm.ads \
+ ada/tbuild.ads ada/ttypef.ads ada/ttypes.ads ada/types.ads \
ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \
ada/widechar.ads
-ada/sem_case.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/errout.ads \
- ada/gnat.ads ada/g-hesora.ads ada/hostparm.ads ada/namet.ads ada/nlists.ads \
- ada/opt.ads ada/sem.ads ada/sem_case.ads ada/sem_case.adb ada/sem_eval.ads \
- ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads \
- ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
- ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ada/sem_case.o : ada/alloc.ads ada/atree.ads ada/einfo.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \
+ ada/g-hesora.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/sem.ads \
+ ada/sem_case.ads ada/sem_case.adb ada/sem_eval.ads ada/sem_res.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
+ ada/stand.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/tbuild.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
ada/sem_cat.o : ada/alloc.ads ada/atree.ads ada/debug.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/exp_tss.ads ada/fname.ads \
- ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/opt.ads \
- ada/sem.ads ada/sem_cat.ads ada/sem_cat.adb ada/sem_util.ads ada/sinfo.ads \
- ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_tss.ads ada/fname.ads ada/gnat.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads ada/namet.ads \
+ ada/nlists.ads ada/opt.ads ada/sem.ads ada/sem_cat.ads ada/sem_cat.adb \
+ ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
+ ada/stand.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
ada/urealp.ads
ada/sem_ch10.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/casing.ads ada/debug.ads ada/einfo.ads ada/errout.ads ada/exp_util.ads \
- ada/fname.ads ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads \
- ada/hostparm.ads ada/impunit.ads ada/inline.ads ada/lib.ads \
- ada/lib-load.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
- ada/rtsfind.ads ada/sem.ads ada/sem_ch10.ads ada/sem_ch10.adb \
- ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_dist.ads \
- ada/sem_prag.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
- ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads ada/stand.ads ada/style.ads \
- ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/s-wchcon.ads ada/table.ads ada/tbuild.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ ada/casing.ads ada/debug.ads ada/einfo.ads ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/exp_util.ads ada/fname.ads \
+ ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/impunit.ads \
+ ada/inline.ads ada/lib.ads ada/lib-load.ads ada/lib-xref.ads \
+ ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_ch10.ads ada/sem_ch10.adb ada/sem_ch6.ads ada/sem_ch7.ads \
+ ada/sem_ch8.ads ada/sem_dist.ads ada/sem_prag.ads ada/sem_util.ads \
+ ada/sem_warn.ads ada/sinfo.ads ada/sinfo-cn.ads ada/sinput.ads \
+ ada/snames.ads ada/stand.ads ada/style.ads ada/styleg.ads \
+ ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/tbuild.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
+ ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
-ada/sem_ch11.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/errout.ads \
- ada/hostparm.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_ch11.ads ada/sem_ch11.adb ada/sem_ch5.ads \
- ada/sem_ch8.ads ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \
- ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ada/sem_ch11.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \
+ ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_ch11.ads ada/sem_ch11.adb ada/sem_ch5.ads ada/sem_ch8.ads \
+ ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
+ ada/stand.ads ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/types.ads \
+ ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_ch12.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads \
ada/alloc.ads ada/atree.ads ada/casing.ads ada/debug.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/expander.ads ada/fname.ads \
- ada/fname-uf.ads ada/freeze.ads ada/gnat.ads ada/g-htable.ads \
- ada/g-htable.adb ada/g-os_lib.ads ada/hostparm.ads ada/inline.ads \
- ada/lib.ads ada/lib-load.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
- ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads ada/sem_ch10.ads \
- ada/sem_ch12.ads ada/sem_ch12.adb ada/sem_ch13.ads ada/sem_ch3.ads \
- ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_elab.ads \
- ada/sem_elim.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \
- ada/sem_util.ads ada/sinfo.ads ada/sinfo-cn.ads ada/sinput.ads \
- ada/sinput-l.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
- ada/system.ads ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads \
- ada/s-exctab.ads ada/s-memory.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/expander.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \
+ ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads ada/lib.ads \
+ ada/lib-load.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \
+ ada/nmake.ads ada/opt.ads ada/output.ads ada/restrict.ads \
+ ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads \
+ ada/sem_ch10.ads ada/sem_ch12.ads ada/sem_ch12.adb ada/sem_ch13.ads \
+ ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch8.ads \
+ ada/sem_elab.ads ada/sem_elim.ads ada/sem_eval.ads ada/sem_res.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo-cn.ads \
+ ada/sinput.ads ada/sinput-l.ads ada/snames.ads ada/stand.ads \
+ ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_ch13.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/checks.ads ada/debug.ads ada/einfo.ads ada/errout.ads ada/exp_tss.ads \
- ada/exp_util.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
- ada/g-os_lib.ads ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/output.ads ada/rtsfind.ads ada/sem.ads \
- ada/sem_ch13.ads ada/sem_ch13.adb ada/sem_ch8.ads ada/sem_eval.ads \
- ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads \
- ada/snames.ads ada/stand.ads ada/system.ads ada/s-atacco.ads \
- ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/checks.ads ada/debug.ads ada/einfo.ads ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/exp_tss.ads ada/exp_util.ads \
+ ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \
+ ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
+ ada/rtsfind.ads ada/sem.ads ada/sem_ch13.ads ada/sem_ch13.adb \
+ ada/sem_ch8.ads ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \
+ ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/table.adb ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
-ada/sem_ch2.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/errout.ads \
- ada/hostparm.ads ada/namet.ads ada/opt.ads ada/restrict.ads ada/rident.ads \
- ada/sem_ch2.ads ada/sem_ch2.adb ada/sem_ch8.ads ada/sinfo.ads \
- ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/types.ads ada/uintp.ads \
+ada/sem_ch2.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/gnat.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
+ ada/restrict.ads ada/rident.ads ada/sem_ch2.ads ada/sem_ch2.adb \
+ ada/sem_ch8.ads ada/sinfo.ads ada/snames.ads ada/stand.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/types.ads ada/uintp.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_ch3.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/eval_fat.ads ada/exp_ch3.ads \
- ada/exp_dist.ads ada/exp_util.ads ada/freeze.ads ada/get_targ.ads \
- ada/gnat.ads ada/g-hesora.ads ada/g-htable.ads ada/g-os_lib.ads \
- ada/hostparm.ads ada/itypes.ads ada/layout.ads ada/lib.ads ada/lib-xref.ads \
- ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
- ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
- ada/sem_case.ads ada/sem_case.adb ada/sem_cat.ads ada/sem_ch13.ads \
- ada/sem_ch3.ads ada/sem_ch3.adb ada/sem_ch6.ads ada/sem_ch7.ads \
- ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_elim.ads \
- ada/sem_eval.ads ada/sem_mech.ads ada/sem_res.ads ada/sem_smem.ads \
- ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads ada/sinput.ads \
- ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads \
- ada/table.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads ada/types.ads \
- ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/eval_fat.ads ada/exp_ch3.ads ada/exp_dist.ads ada/exp_util.ads \
+ ada/freeze.ads ada/get_targ.ads ada/gnat.ads ada/g-hesora.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/itypes.ads ada/layout.ads ada/lib.ads \
+ ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
+ ada/sem.ads ada/sem_case.ads ada/sem_case.adb ada/sem_cat.ads \
+ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch3.adb ada/sem_ch6.ads \
+ ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
+ ada/sem_elim.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_res.ads \
+ ada/sem_smem.ads ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \
+ ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \
+ ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/tbuild.ads ada/tree_io.ads \
+ ada/ttypes.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
ada/sem_ch4.o : ada/alloc.ads ada/atree.ads ada/debug.ads ada/einfo.ads \
- ada/errout.ads ada/exp_util.ads ada/gnat.ads ada/g-speche.ads \
- ada/hostparm.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads \
- ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads ada/restrict.ads \
- ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads ada/sem_ch3.ads \
- ada/sem_ch4.ads ada/sem_ch4.adb ada/sem_ch8.ads ada/sem_dist.ads \
- ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
- ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_util.ads \
+ ada/gnat.ads ada/g-speche.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads \
+ ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_cat.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch4.adb \
+ ada/sem_ch8.ads ada/sem_dist.ads ada/sem_eval.ads ada/sem_res.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
+ ada/stand.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
ada/tbuild.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
ada/unchdeal.ads ada/urealp.ads
ada/sem_ch5.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
- ada/errout.ads ada/exp_util.ads ada/expander.ads ada/freeze.ads \
- ada/gnat.ads ada/g-hesora.ads ada/hostparm.ads ada/lib.ads ada/lib-xref.ads \
- ada/namet.ads ada/nlists.ads ada/opt.ads ada/rtsfind.ads ada/sem.ads \
- ada/sem_case.ads ada/sem_case.adb ada/sem_ch3.ads ada/sem_ch5.ads \
- ada/sem_ch5.adb ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads \
- ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \
- ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
- ada/tbuild.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_util.ads \
+ ada/expander.ads ada/freeze.ads ada/gnat.ads ada/g-hesora.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \
+ ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_case.ads \
+ ada/sem_case.adb ada/sem_ch3.ads ada/sem_ch5.ads ada/sem_ch5.adb \
+ ada/sem_ch8.ads ada/sem_disp.ads ada/sem_eval.ads ada/sem_res.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
+ ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/targparm.ads ada/tbuild.ads ada/types.ads \
+ ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_ch6.o : ada/alloc.ads ada/atree.ads ada/casing.ads ada/checks.ads \
- ada/debug.ads ada/einfo.ads ada/elists.ads ada/errout.ads ada/exp_ch7.ads \
- ada/expander.ads ada/freeze.ads ada/hostparm.ads ada/inline.ads ada/lib.ads \
- ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
- ada/output.ads ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads ada/sem_ch12.ads \
+ ada/debug.ads ada/einfo.ads ada/elists.ads ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/exp_ch7.ads ada/expander.ads \
+ ada/freeze.ads ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/inline.ads ada/lib.ads ada/lib-xref.ads \
+ ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
+ ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads ada/sem_ch12.ads \
ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch5.ads ada/sem_ch6.ads \
ada/sem_ch6.adb ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
ada/sem_elim.ads ada/sem_eval.ads ada/sem_mech.ads ada/sem_prag.ads \
ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \
- ada/sinfo.ads ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads ada/stand.ads \
- ada/stringt.ads ada/style.ads ada/stylesw.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/sinfo.ads ada/sinfo-cn.ads ada/sinput.ads ada/snames.ads \
+ ada/stand.ads ada/stringt.ads ada/style.ads ada/styleg.ads \
+ ada/styleg-c.ads ada/stylesw.ads ada/system.ads ada/s-assert.ads \
+ ada/s-carun8.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/tbuild.ads ada/types.ads \
+ ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \
+ ada/validsw.ads
ada/sem_ch7.o : ada/alloc.ads ada/atree.ads ada/casing.ads ada/debug.ads \
- ada/einfo.ads ada/elists.ads ada/errout.ads ada/exp_dbug.ads \
- ada/exp_disp.ads ada/get_targ.ads ada/hostparm.ads ada/inline.ads \
- ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nmake.ads \
- ada/opt.ads ada/output.ads ada/sem.ads ada/sem_cat.ads ada/sem_ch12.ads \
- ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads ada/sem_ch7.adb \
- ada/sem_ch8.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
- ada/sinput.ads ada/snames.ads ada/stand.ads ada/style.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ ada/einfo.ads ada/elists.ads ada/err_vars.ads ada/errout.ads \
+ ada/erroutc.ads ada/exp_dbug.ads ada/exp_disp.ads ada/get_targ.ads \
+ ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/inline.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads \
+ ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads ada/sem.ads \
+ ada/sem_cat.ads ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch6.ads \
+ ada/sem_ch7.ads ada/sem_ch7.adb ada/sem_ch8.ads ada/sem_util.ads \
+ ada/sem_warn.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \
+ ada/stand.ads ada/style.ads ada/styleg.ads ada/styleg-c.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/types.ads \
+ ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_ch8.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/debug.ads ada/einfo.ads ada/elists.ads ada/errout.ads ada/exp_util.ads \
- ada/fname.ads ada/freeze.ads ada/gnat.ads ada/g-os_lib.ads ada/g-speche.ads \
- ada/hostparm.ads ada/inline.ads ada/lib.ads ada/lib-load.ads \
- ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
- ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
- ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch4.ads ada/sem_ch6.ads \
- ada/sem_ch8.ads ada/sem_ch8.adb ada/sem_res.ads ada/sem_type.ads \
- ada/sem_util.ads ada/sinfo.ads ada/sinfo-cn.ads ada/snames.ads \
- ada/stand.ads ada/style.ads ada/system.ads ada/s-atacco.ads \
- ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/debug.ads ada/einfo.ads ada/elists.ads ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/exp_util.ads ada/fname.ads \
+ ada/freeze.ads ada/gnat.ads ada/g-os_lib.ads ada/g-speche.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/inline.ads \
+ ada/lib.ads ada/lib-load.ads ada/lib-xref.ads ada/namet.ads \
+ ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_cat.ads ada/sem_ch12.ads ada/sem_ch3.ads ada/sem_ch4.ads \
+ ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_ch8.adb ada/sem_res.ads \
+ ada/sem_type.ads ada/sem_util.ads ada/sinfo.ads ada/sinfo-cn.ads \
+ ada/snames.ads ada/stand.ads ada/style.ads ada/styleg.ads \
+ ada/styleg-c.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/sem_ch9.o : ada/alloc.ads ada/atree.ads ada/checks.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/exp_ch9.ads ada/hostparm.ads \
- ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_ch3.ads ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch8.ads \
- ada/sem_ch9.ads ada/sem_ch9.adb ada/sem_eval.ads ada/sem_res.ads \
- ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads \
- ada/snames.ads ada/stand.ads ada/style.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
- ada/tbuild.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_ch9.ads ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/itypes.ads ada/lib.ads ada/lib-xref.ads \
+ ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/restrict.ads \
+ ada/rident.ads ada/rtsfind.ads ada/sem.ads ada/sem_ch3.ads \
+ ada/sem_ch5.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_ch9.ads \
+ ada/sem_ch9.adb ada/sem_eval.ads ada/sem_res.ads ada/sem_type.ads \
+ ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/snames.ads \
+ ada/stand.ads ada/style.ads ada/styleg.ads ada/styleg-c.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/tbuild.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/sem_disp.o : ada/alloc.ads ada/atree.ads ada/debug.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/exp_ch7.ads ada/exp_disp.ads \
- ada/exp_tss.ads ada/hostparm.ads ada/nlists.ads ada/opt.ads ada/output.ads \
- ada/sem.ads ada/sem_ch6.ads ada/sem_disp.ads ada/sem_disp.adb \
- ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
- ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/s-wchcon.ads ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_ch7.ads ada/exp_disp.ads ada/exp_tss.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/nlists.ads \
+ ada/opt.ads ada/output.ads ada/sem.ads ada/sem_ch6.ads ada/sem_disp.ads \
+ ada/sem_disp.adb ada/sem_eval.ads ada/sem_util.ads ada/sinfo.ads \
+ ada/snames.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/sem_dist.o : ada/alloc.ads ada/atree.ads ada/casing.ads ada/einfo.ads \
- ada/errout.ads ada/exp_dist.ads ada/exp_tss.ads ada/hostparm.ads \
- ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_dist.ads ada/sem_dist.adb ada/sem_res.ads \
- ada/sem_util.ads ada/sinfo.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
- ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/s-wchcon.ads ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads \
- ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_dist.ads \
+ ada/exp_tss.ads ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/rtsfind.ads ada/sem.ads ada/sem_dist.ads ada/sem_dist.adb \
+ ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
+ ada/stand.ads ada/stringt.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_elab.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \
- ada/elists.ads ada/errout.ads ada/exp_util.ads ada/expander.ads \
- ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
- ada/hostparm.ads ada/lib.ads ada/lib-load.ads ada/namet.ads ada/nlists.ads \
- ada/nmake.ads ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads \
- ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads ada/sem_ch7.ads ada/sem_ch8.ads \
- ada/sem_elab.ads ada/sem_elab.adb ada/sem_res.ads ada/sem_util.ads \
- ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \
- ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads \
- ada/s-imgenu.ads ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/tbuild.ads ada/tree_io.ads ada/types.ads \
- ada/uintp.ads ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_util.ads ada/expander.ads ada/fname.ads ada/gnat.ads \
+ ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/lib.ads ada/lib-load.ads ada/namet.ads \
+ ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_cat.ads ada/sem_ch7.ads ada/sem_ch8.ads ada/sem_elab.ads \
+ ada/sem_elab.adb ada/sem_res.ads ada/sem_util.ads ada/sinfo.ads \
+ ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
+ ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tbuild.ads \
+ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_elim.o : ada/ada.ads ada/a-uncdea.ads ada/alloc.ads ada/atree.ads \
- ada/einfo.ads ada/errout.ads ada/gnat.ads ada/g-htable.ads ada/g-htable.adb \
- ada/namet.ads ada/nlists.ads ada/sem_elim.ads ada/sem_elim.adb \
- ada/sinfo.ads ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/table.ads ada/types.ads ada/uintp.ads \
+ ada/einfo.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/gnat.ads ada/g-htable.ads ada/hostparm.ads ada/namet.ads \
+ ada/nlists.ads ada/sem_elim.ads ada/sem_elim.adb ada/sinfo.ads \
+ ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-htable.ads ada/s-htable.adb ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/table.ads ada/types.ads ada/uintp.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_eval.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/checks.ads ada/debug.ads ada/einfo.ads ada/elists.ads ada/errout.ads \
- ada/eval_fat.ads ada/exp_util.ads ada/hostparm.ads ada/namet.ads \
- ada/nlists.ads ada/nmake.ads ada/opt.ads ada/rtsfind.ads ada/sem.ads \
- ada/sem_cat.ads ada/sem_ch8.ads ada/sem_eval.ads ada/sem_eval.adb \
- ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \
- ada/sinfo.ads ada/snames.ads ada/stand.ads ada/stringt.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
- ada/tbuild.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/checks.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \
+ ada/exp_util.ads ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
+ ada/rtsfind.ads ada/sem.ads ada/sem_cat.ads ada/sem_ch8.ads \
+ ada/sem_eval.ads ada/sem_eval.adb ada/sem_res.ads ada/sem_type.ads \
+ ada/sem_util.ads ada/sem_warn.ads ada/sinfo.ads ada/snames.ads \
+ ada/stand.ads ada/stringt.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/tbuild.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
-ada/sem_intr.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/errout.ads \
- ada/fname.ads ada/lib.ads ada/namet.ads ada/sem_eval.ads ada/sem_intr.ads \
- ada/sem_intr.adb ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
- ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/table.ads ada/targparm.ads ada/types.ads ada/uintp.ads \
+ada/sem_intr.o : ada/alloc.ads ada/atree.ads ada/einfo.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \
+ ada/hostparm.ads ada/lib.ads ada/namet.ads ada/rident.ads \
+ ada/sem_eval.ads ada/sem_intr.ads ada/sem_intr.adb ada/sem_util.ads \
+ ada/sinfo.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/table.ads ada/targparm.ads ada/types.ads ada/uintp.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_maps.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/debug.ads ada/einfo.ads ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads \
- ada/namet.ads ada/opt.ads ada/output.ads ada/sem_maps.ads ada/sem_maps.adb \
- ada/sinfo.ads ada/snames.ads ada/system.ads ada/s-atacco.ads \
- ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/debug.ads ada/einfo.ads ada/gnat.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/opt.ads ada/output.ads ada/sem_maps.ads ada/sem_maps.adb \
+ ada/sinfo.ads ada/snames.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
-ada/sem_mech.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/errout.ads \
- ada/hostparm.ads ada/namet.ads ada/nlists.ads ada/opt.ads ada/sem.ads \
- ada/sem_mech.ads ada/sem_mech.adb ada/sem_util.ads ada/sinfo.ads \
- ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/targparm.ads \
+ada/sem_mech.o : ada/alloc.ads ada/atree.ads ada/einfo.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/nlists.ads ada/opt.ads ada/rident.ads ada/sem.ads ada/sem_mech.ads \
+ ada/sem_mech.adb ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
+ ada/stand.ads ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/targparm.ads \
ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
ada/urealp.ads
ada/sem_prag.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
- ada/errout.ads ada/exp_dist.ads ada/expander.ads ada/fname.ads \
- ada/get_targ.ads ada/gnat.ads ada/g-speche.ads ada/hostparm.ads ada/lib.ads \
- ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/exp_dist.ads \
+ ada/expander.ads ada/fname.ads ada/get_targ.ads ada/gnat.ads \
+ ada/g-speche.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/lib.ads ada/lib-writ.ads ada/lib-xref.ads ada/namet.ads \
+ ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
- ada/sem_ch13.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_elim.ads \
- ada/sem_eval.ads ada/sem_intr.ads ada/sem_mech.ads ada/sem_prag.ads \
- ada/sem_prag.adb ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads \
- ada/sem_vfpt.ads ada/sinfo.ads ada/sinfo-cn.ads ada/sinput.ads \
- ada/snames.ads ada/stand.ads ada/stringt.ads ada/stylesw.ads ada/system.ads \
- ada/s-exctab.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
- ada/targparm.ads ada/tbuild.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/validsw.ads
+ ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch8.ads ada/sem_disp.ads \
+ ada/sem_elim.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_mech.ads \
+ ada/sem_prag.ads ada/sem_prag.adb ada/sem_res.ads ada/sem_type.ads \
+ ada/sem_util.ads ada/sem_vfpt.ads ada/sinfo.ads ada/sinfo-cn.ads \
+ ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
+ ada/stylesw.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/targparm.ads ada/tbuild.ads ada/ttypes.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads ada/validsw.ads
ada/sem_res.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/debug_a.ads \
- ada/einfo.ads ada/elists.ads ada/errout.ads ada/exp_ch7.ads \
- ada/exp_util.ads ada/expander.ads ada/freeze.ads ada/gnat.ads \
- ada/g-htable.ads ada/g-os_lib.ads ada/hostparm.ads ada/itypes.ads \
- ada/lib.ads ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nmake.ads \
- ada/opt.ads ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
- ada/sem.ads ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads \
- ada/sem_ch4.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads \
- ada/sem_dist.ads ada/sem_elab.ads ada/sem_eval.ads ada/sem_intr.ads \
- ada/sem_res.ads ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads \
- ada/sem_warn.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads \
+ ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads \
+ ada/debug_a.ads ada/einfo.ads ada/elists.ads ada/err_vars.ads \
+ ada/errout.ads ada/erroutc.ads ada/exp_ch7.ads ada/exp_util.ads \
+ ada/expander.ads ada/freeze.ads ada/gnat.ads ada/g-htable.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/itypes.ads ada/lib.ads ada/lib-xref.ads ada/namet.ads \
+ ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/sem.ads \
+ ada/sem_aggr.ads ada/sem_attr.ads ada/sem_cat.ads ada/sem_ch4.ads \
+ ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads \
+ ada/sem_elab.ads ada/sem_eval.ads ada/sem_intr.ads ada/sem_res.ads \
+ ada/sem_res.adb ada/sem_type.ads ada/sem_util.ads ada/sem_warn.ads \
+ ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads \
ada/stringt.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
- ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
- ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
+ ada/s-htable.ads ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/targparm.ads \
+ ada/tbuild.ads ada/tree_io.ads ada/types.ads ada/uintp.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
-ada/sem_smem.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/errout.ads \
+ada/sem_smem.o : ada/alloc.ads ada/atree.ads ada/einfo.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/hostparm.ads \
ada/namet.ads ada/sem_smem.ads ada/sem_smem.adb ada/sinfo.ads \
ada/snames.ads ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
- ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ ada/s-unstyp.ads ada/table.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_type.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/debug.ads ada/einfo.ads ada/errout.ads ada/gnat.ads ada/g-os_lib.ads \
- ada/hostparm.ads ada/lib.ads ada/namet.ads ada/opt.ads ada/output.ads \
- ada/sem.ads ada/sem_ch6.ads ada/sem_ch8.ads ada/sem_type.ads \
- ada/sem_type.adb ada/sem_util.ads ada/sinfo.ads ada/snames.ads \
- ada/stand.ads ada/system.ads ada/s-atacco.ads ada/s-atacco.adb \
- ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \
- ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/debug.ads ada/einfo.ads ada/err_vars.ads ada/errout.ads \
+ ada/erroutc.ads ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads ada/namet.ads ada/opt.ads \
+ ada/output.ads ada/sem.ads ada/sem_ch6.ads ada/sem_ch8.ads \
+ ada/sem_type.ads ada/sem_type.adb ada/sem_util.ads ada/sinfo.ads \
+ ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/sem_util.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
- ada/errout.ads ada/exp_util.ads ada/freeze.ads ada/get_targ.ads \
- ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads ada/hostparm.ads ada/lib.ads \
- ada/lib-xref.ads ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads \
- ada/output.ads ada/restrict.ads ada/rident.ads ada/rtsfind.ads \
- ada/scans.ads ada/scn.ads ada/sem.ads ada/sem_ch8.ads ada/sem_eval.ads \
+ ada/atree.adb ada/casing.ads ada/checks.ads ada/debug.ads ada/einfo.ads \
+ ada/elists.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/exp_util.ads ada/fname.ads ada/freeze.ads ada/get_targ.ads \
+ ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads ada/lib-xref.ads \
+ ada/namet.ads ada/nlists.ads ada/nmake.ads ada/opt.ads ada/output.ads \
+ ada/restrict.ads ada/rident.ads ada/rtsfind.ads ada/scans.ads \
+ ada/scn.ads ada/scng.ads ada/sem.ads ada/sem_ch8.ads ada/sem_eval.ads \
ada/sem_res.ads ada/sem_type.ads ada/sem_util.ads ada/sem_util.adb \
- ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
- ada/style.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads \
+ ada/stringt.ads ada/style.ads ada/styleg.ads ada/styleg-c.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads \
ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
- ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads \
- ada/targparm.ads ada/tbuild.ads ada/tree_io.ads ada/ttypes.ads \
- ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/targparm.ads ada/tbuild.ads \
+ ada/tree_io.ads ada/ttypes.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
-ada/sem_vfpt.o : ada/alloc.ads ada/cstand.ads ada/einfo.ads \
- ada/hostparm.ads ada/namet.ads ada/opt.ads ada/sem_vfpt.ads \
- ada/sem_vfpt.adb ada/snames.ads ada/stand.ads ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
+ada/sem_vfpt.o : ada/alloc.ads ada/cstand.ads ada/einfo.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/opt.ads ada/rident.ads ada/sem_vfpt.ads ada/sem_vfpt.adb \
+ ada/snames.ads ada/stand.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
ada/targparm.ads ada/ttypef.ads ada/types.ads ada/uintp.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_warn.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/atree.adb ada/casing.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
- ada/errout.ads ada/fname.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
- ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/opt.ads \
- ada/output.ads ada/sem.ads ada/sem_util.ads ada/sem_warn.ads \
- ada/sem_warn.adb ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads \
- ada/system.ads ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads \
- ada/s-exctab.ads ada/s-imgenu.ads ada/s-memory.ads ada/s-secsta.ads \
+ ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/fname.ads \
+ ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads ada/namet.ads \
+ ada/nlists.ads ada/opt.ads ada/output.ads ada/sem.ads ada/sem_ch8.ads \
+ ada/sem_util.ads ada/sem_warn.ads ada/sem_warn.adb ada/sinfo.ads \
+ ada/sinput.ads ada/snames.ads ada/stand.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-htable.ads ada/s-imgenu.ads \
+ ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
+
+ada/sfn_scan.o : ada/ada.ads ada/a-except.ads ada/sfn_scan.ads \
+ ada/sfn_scan.adb ada/system.ads ada/s-exctab.ads ada/s-secsta.ads \
ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads \
- ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/s-stoele.adb ada/unchconv.ads
ada/sinfo-cn.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/sinfo.ads \
ada/sinfo-cn.ads ada/sinfo-cn.adb ada/snames.ads ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/table.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/table.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/sinfo.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/sinfo.ads \
ada/sinfo.adb ada/snames.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/table.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/table.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
-ada/sinput-d.o : ada/alloc.ads ada/casing.ads ada/gnat.ads \
- ada/g-os_lib.ads ada/osint.ads ada/osint-c.ads ada/sinput.ads \
- ada/sinput-d.ads ada/sinput-d.adb ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/table.ads ada/types.ads ada/unchconv.ads \
+ada/sinput-c.o : ada/ada.ads ada/a-unccon.ads ada/alloc.ads ada/casing.ads \
+ ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/sinput.ads \
+ ada/sinput-c.ads ada/sinput-c.adb ada/system.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/types.ads ada/unchconv.ads \
ada/unchdeal.ads
+ada/sinput-d.o : ada/alloc.ads ada/casing.ads ada/gnat.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/osint.ads ada/osint-c.ads \
+ ada/sinput.ads ada/sinput-d.ads ada/sinput-d.adb ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/table.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads
+
ada/sinput-l.o : ada/alloc.ads ada/atree.ads ada/casing.ads ada/debug.ads \
- ada/einfo.ads ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads ada/namet.ads \
- ada/opt.ads ada/osint.ads ada/output.ads ada/scans.ads ada/scn.ads \
- ada/sinfo.ads ada/sinput.ads ada/sinput-l.ads ada/sinput-l.adb \
- ada/snames.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/einfo.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/gnat.ads ada/g-dyntab.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
+ ada/osint.ads ada/output.ads ada/prep.ads ada/prepcomp.ads \
+ ada/scans.ads ada/scn.ads ada/scng.ads ada/sinfo.ads ada/sinput.ads \
+ ada/sinput-l.ads ada/sinput-l.adb ada/snames.ads ada/style.ads \
+ ada/styleg.ads ada/styleg-c.ads ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
+
+ada/sinput-p.o : ada/alloc.ads ada/casing.ads ada/errutil.ads ada/gnat.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/prj.ads ada/prj-err.ads \
+ ada/scans.ads ada/scng.ads ada/sinput.ads ada/sinput-c.ads \
+ ada/sinput-p.ads ada/sinput-p.adb ada/styleg.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/table.ads \
+ ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/urealp.ads
ada/sinput.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/casing.ads \
- ada/debug.ads ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads ada/namet.ads \
- ada/opt.ads ada/output.ads ada/sinput.ads ada/sinput.adb ada/system.ads \
- ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads \
- ada/s-memory.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads
+ ada/debug.ads ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
+ ada/output.ads ada/sinput.ads ada/sinput.adb ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/snames.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/debug.ads \
- ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
- ada/output.ads ada/snames.ads ada/snames.adb ada/system.ads \
- ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads \
- ada/s-memory.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads
+ ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \
+ ada/snames.ads ada/snames.adb ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/sprint.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
- ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/hostparm.ads \
- ada/lib.ads ada/namet.ads ada/nlists.ads ada/opt.ads ada/output.ads \
- ada/rtsfind.ads ada/sinfo.ads ada/sinput.ads ada/sinput-d.ads \
- ada/snames.ads ada/sprint.ads ada/sprint.adb ada/stand.ads ada/stringt.ads \
+ ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \
+ ada/namet.ads ada/nlists.ads ada/opt.ads ada/output.ads ada/rtsfind.ads \
+ ada/sinfo.ads ada/sinput.ads ada/sinput-d.ads ada/snames.ads \
+ ada/sprint.ads ada/sprint.adb ada/stand.ads ada/stringt.ads \
ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-imgenu.ads \
ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
- ada/s-stoele.ads ada/s-wchcon.ads ada/table.ads ada/types.ads ada/uintp.ads \
- ada/uname.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/types.ads ada/uintp.ads ada/uname.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
-ada/stand.o : ada/alloc.ads ada/gnat.ads ada/g-os_lib.ads ada/namet.ads \
- ada/stand.ads ada/stand.adb ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/table.ads ada/tree_io.ads ada/types.ads \
- ada/unchconv.ads ada/unchdeal.ads
+ada/stand.o : ada/alloc.ads ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/namet.ads ada/stand.ads ada/stand.adb ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/table.ads \
+ ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/stringt.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/debug.ads \
- ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
- ada/output.ads ada/stringt.ads ada/stringt.adb ada/system.ads \
- ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads ada/s-exctab.ads \
- ada/s-memory.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
- ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads
+ ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/output.ads \
+ ada/stringt.ads ada/stringt.adb ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/table.adb ada/tree_io.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/style.o : ada/alloc.ads ada/atree.ads ada/casing.ads ada/csets.ads \
- ada/einfo.ads ada/errout.ads ada/hostparm.ads ada/namet.ads ada/opt.ads \
- ada/scans.ads ada/scn.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \
- ada/stand.ads ada/style.ads ada/style.adb ada/stylesw.ads ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads \
+ ada/einfo.ads ada/err_vars.ads ada/errout.ads ada/erroutc.ads \
+ ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/namet.ads ada/opt.ads ada/scans.ads ada/sinfo.ads ada/sinput.ads \
+ ada/snames.ads ada/stand.ads ada/style.ads ada/styleg.ads \
+ ada/styleg.adb ada/styleg-c.ads ada/styleg-c.adb ada/stylesw.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/styleg-c.o : ada/alloc.ads ada/atree.ads ada/casing.ads ada/csets.ads \
+ ada/einfo.ads ada/err_vars.ads ada/namet.ads ada/sinfo.ads \
+ ada/sinput.ads ada/snames.ads ada/stand.ads ada/styleg.ads \
+ ada/styleg-c.ads ada/styleg-c.adb ada/stylesw.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/table.ads \
ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
ada/urealp.ads
-ada/stylesw.o : ada/hostparm.ads ada/opt.ads ada/stylesw.ads \
- ada/stylesw.adb ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
+ada/styleg.o : ada/alloc.ads ada/casing.ads ada/csets.ads ada/err_vars.ads \
+ ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/opt.ads ada/scans.ads ada/sinput.ads ada/styleg.ads ada/styleg.adb \
+ ada/stylesw.ads ada/system.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/types.ads \
+ ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/stylesw.o : ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/opt.ads ada/stylesw.ads ada/stylesw.adb \
+ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
ada/s-wchcon.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/switch-b.o : ada/ada.ads ada/a-except.ads ada/debug.ads ada/gnat.ads \
- ada/g-os_lib.ads ada/hostparm.ads ada/opt.ads ada/osint.ads ada/switch.ads \
- ada/switch-b.ads ada/switch-b.adb ada/system.ads ada/s-exctab.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-wchcon.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/opt.ads ada/osint.ads ada/switch.ads ada/switch-b.ads \
+ ada/switch-b.adb ada/system.ads ada/s-exctab.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/types.ads ada/unchconv.ads \
+ ada/unchdeal.ads
ada/switch-c.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/debug.ads \
- ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads ada/lib.ads ada/opt.ads \
- ada/osint.ads ada/stylesw.ads ada/switch.ads ada/switch-c.ads \
- ada/switch-c.adb ada/system.ads ada/s-exctab.ads ada/s-soflin.ads \
- ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-wchcon.ads \
- ada/table.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/validsw.ads
+ ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/lib.ads ada/opt.ads ada/osint.ads ada/prepcomp.ads \
+ ada/stylesw.ads ada/switch.ads ada/switch-c.ads ada/switch-c.adb \
+ ada/system.ads ada/s-exctab.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/types.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/validsw.ads
+
+ada/switch-m.o : ada/ada.ads ada/a-except.ads ada/debug.ads ada/gnat.ads \
+ ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads \
+ ada/opt.ads ada/osint.ads ada/output.ads ada/switch.ads \
+ ada/switch-m.ads ada/switch-m.adb ada/system.ads ada/s-assert.ads \
+ ada/s-exctab.ads ada/s-memory.ads ada/s-secsta.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/switch.o : ada/ada.ads ada/a-except.ads ada/switch.ads ada/switch.adb \
- ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/types.ads \
- ada/unchconv.ads ada/unchdeal.ads
+ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/system.o : ada/system.ads
-ada/table.o : ada/debug.ads ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads \
- ada/opt.ads ada/output.ads ada/system.ads ada/s-atacco.ads ada/s-atacco.adb \
- ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads
+ada/table.o : ada/debug.ads ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads ada/output.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/tree_io.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads
-ada/targparm.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/casing.ads \
- ada/namet.ads ada/output.ads ada/sinput.ads ada/sinput-l.ads ada/system.ads \
- ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads ada/table.ads \
- ada/targparm.ads ada/targparm.adb ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads
+ada/targparm.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/csets.ads \
+ ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/namet.ads ada/opt.ads ada/osint.ads ada/output.ads \
+ ada/rident.ads ada/system.ads ada/s-exctab.ads ada/s-imgenu.ads \
+ ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/s-wchcon.ads \
+ ada/table.ads ada/targparm.ads ada/targparm.adb ada/types.ads \
+ ada/unchconv.ads ada/unchdeal.ads
ada/tbuild.o : ada/alloc.ads ada/atree.ads ada/einfo.ads ada/lib.ads \
- ada/namet.ads ada/nlists.ads ada/nmake.ads ada/restrict.ads ada/rident.ads \
- ada/sinfo.ads ada/snames.ads ada/stand.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-stoele.ads ada/table.ads \
- ada/tbuild.ads ada/tbuild.adb ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/namet.ads ada/nlists.ads ada/nmake.ads ada/restrict.ads \
+ ada/rident.ads ada/sinfo.ads ada/snames.ads ada/stand.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/table.ads \
+ ada/tbuild.ads ada/tbuild.adb ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
+
+ada/tempdir.o : ada/ada.ads ada/a-charac.ads ada/a-chlat1.ads \
+ ada/a-except.ads ada/a-finali.ads ada/a-filico.ads ada/a-stream.ads \
+ ada/a-string.ads ada/a-strmap.ads ada/a-tags.ads ada/a-tags.adb \
+ ada/alloc.ads ada/gnat.ads ada/g-dirope.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/namet.ads \
+ ada/opt.ads ada/output.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-finimp.ads ada/s-finroo.ads ada/s-htable.ads ada/s-secsta.ads \
+ ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
+ ada/s-stoele.adb ada/s-stratt.ads ada/s-sopco3.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/tempdir.ads ada/tempdir.adb \
+ ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/tree_gen.o : ada/alloc.ads ada/atree.ads ada/casing.ads ada/einfo.ads \
- ada/elists.ads ada/fname.ads ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads \
- ada/lib.ads ada/namet.ads ada/nlists.ads ada/opt.ads ada/osint.ads \
- ada/osint-c.ads ada/repinfo.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \
+ ada/elists.ads ada/fname.ads ada/gnat.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/lib.ads \
+ ada/namet.ads ada/nlists.ads ada/opt.ads ada/osint.ads ada/osint-c.ads \
+ ada/repinfo.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \
ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/tree_gen.ads \
- ada/tree_gen.adb ada/types.ads ada/uintp.ads ada/unchconv.ads \
- ada/unchdeal.ads ada/urealp.ads
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads \
+ ada/tree_gen.ads ada/tree_gen.adb ada/types.ads ada/uintp.ads \
+ ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/tree_io.o : ada/ada.ads ada/a-except.ads ada/debug.ads ada/gnat.ads \
- ada/g-os_lib.ads ada/output.ads ada/system.ads ada/s-exctab.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/tree_io.ads ada/tree_io.adb ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads
+ ada/g-os_lib.ads ada/g-string.ads ada/output.ads ada/system.ads \
+ ada/s-exctab.ads ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads \
+ ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads ada/tree_io.ads \
+ ada/tree_io.adb ada/types.ads ada/unchconv.ads ada/unchdeal.ads
ada/treepr.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/atree.ads \
ada/casing.ads ada/csets.ads ada/debug.ads ada/einfo.ads ada/elists.ads \
- ada/lib.ads ada/namet.ads ada/nlists.ads ada/output.ads ada/sem_mech.ads \
- ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/stand.ads ada/stringt.ads \
- ada/system.ads ada/s-exctab.ads ada/s-imgenu.ads ada/s-secsta.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/table.ads ada/treepr.ads ada/treepr.adb ada/treeprs.ads ada/types.ads \
- ada/uintp.ads ada/uname.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ ada/lib.ads ada/namet.ads ada/nlists.ads ada/output.ads \
+ ada/sem_mech.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \
+ ada/stand.ads ada/stringt.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-imgenu.ads ada/s-secsta.ads ada/s-soflin.ads ada/s-stache.ads \
+ ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-unstyp.ads \
+ ada/table.ads ada/treepr.ads ada/treepr.adb ada/treeprs.ads \
+ ada/types.ads ada/uintp.ads ada/uname.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
ada/treeprs.o : ada/alloc.ads ada/sinfo.ads ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/table.ads ada/treeprs.ads \
- ada/types.ads ada/uintp.ads ada/unchconv.ads ada/unchdeal.ads \
- ada/urealp.ads
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/table.ads \
+ ada/treeprs.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads
ada/ttypef.o : ada/system.ads ada/ttypef.ads
ada/ttypes.o : ada/get_targ.ads ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/ttypes.ads ada/types.ads ada/unchconv.ads \
- ada/unchdeal.ads
-
-ada/types.o : ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/types.ads ada/types.adb ada/unchconv.ads \
- ada/unchdeal.ads
+ ada/s-stalib.ads ada/s-unstyp.ads ada/ttypes.ads ada/types.ads \
+ ada/unchconv.ads ada/unchdeal.ads
-ada/uintp.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/debug.ads \
- ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads ada/opt.ads ada/output.ads \
- ada/system.ads ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads \
- ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
- ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads
+ada/types.o : ada/system.ads ada/s-assert.ads ada/s-carun8.ads \
+ ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads ada/types.ads \
+ ada/types.adb ada/unchconv.ads ada/unchdeal.ads
+
+ada/uintp.o : ada/ada.ads ada/a-except.ads ada/a-uncdea.ads ada/alloc.ads \
+ ada/debug.ads ada/gnat.ads ada/g-htable.ads ada/g-os_lib.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/opt.ads \
+ ada/output.ads ada/system.ads ada/s-assert.ads ada/s-exctab.ads \
+ ada/s-htable.ads ada/s-htable.adb ada/s-memory.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/uintp.adb \
+ ada/unchconv.ads ada/unchdeal.ads
ada/uname.o : ada/alloc.ads ada/atree.ads ada/casing.ads ada/einfo.ads \
- ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads ada/output.ads \
- ada/sinfo.ads ada/sinput.ads ada/snames.ads ada/system.ads ada/s-assert.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/table.ads ada/types.ads ada/uintp.ads \
+ ada/hostparm.ads ada/lib.ads ada/namet.ads ada/nlists.ads \
+ ada/output.ads ada/sinfo.ads ada/sinput.ads ada/snames.ads \
+ ada/system.ads ada/s-assert.ads ada/s-exctab.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/table.ads ada/types.ads ada/uintp.ads \
ada/uname.ads ada/uname.adb ada/unchconv.ads ada/unchdeal.ads \
ada/urealp.ads
ada/urealp.o : ada/ada.ads ada/a-except.ads ada/alloc.ads ada/debug.ads \
- ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads ada/opt.ads ada/output.ads \
- ada/system.ads ada/s-atacco.ads ada/s-atacco.adb ada/s-assert.ads \
- ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads ada/s-wchcon.ads \
- ada/table.ads ada/table.adb ada/tree_io.ads ada/types.ads ada/uintp.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb
+ ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/opt.ads ada/output.ads ada/system.ads \
+ ada/s-assert.ads ada/s-exctab.ads ada/s-memory.ads ada/s-stalib.ads \
+ ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
+ ada/tree_io.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/urealp.ads ada/urealp.adb
-ada/usage.o : ada/alloc.ads ada/gnat.ads ada/g-os_lib.ads ada/hostparm.ads \
- ada/namet.ads ada/osint.ads ada/output.ads ada/system.ads ada/s-exctab.ads \
- ada/s-stalib.ads ada/s-wchcon.ads ada/table.ads ada/types.ads \
- ada/unchconv.ads ada/unchdeal.ads ada/usage.ads ada/usage.adb
+ada/usage.o : ada/alloc.ads ada/gnat.ads ada/g-os_lib.ads ada/g-string.ads \
+ ada/hostparm.ads ada/namet.ads ada/osint.ads ada/output.ads \
+ ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
+ ada/s-wchcon.ads ada/table.ads ada/types.ads ada/unchconv.ads \
+ ada/unchdeal.ads ada/usage.ads ada/usage.adb
-ada/validsw.o : ada/hostparm.ads ada/opt.ads ada/system.ads \
- ada/s-exctab.ads ada/s-stalib.ads ada/s-wchcon.ads ada/types.ads \
+ada/validsw.o : ada/gnat.ads ada/g-string.ads ada/gnatvsn.ads \
+ ada/hostparm.ads ada/opt.ads ada/system.ads ada/s-exctab.ads \
+ ada/s-stalib.ads ada/s-unstyp.ads ada/s-wchcon.ads ada/types.ads \
ada/unchconv.ads ada/unchdeal.ads ada/validsw.ads ada/validsw.adb
-ada/widechar.o : ada/ada.ads ada/a-except.ads ada/hostparm.ads \
- ada/interfac.ads ada/opt.ads ada/system.ads ada/s-exctab.ads \
- ada/s-soflin.ads ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads \
- ada/s-wchcnv.ads ada/s-wchcnv.adb ada/s-wchcon.ads ada/s-wchjis.ads \
- ada/types.ads ada/unchconv.ads ada/unchdeal.ads ada/widechar.ads \
- ada/widechar.adb
+ada/widechar.o : ada/ada.ads ada/a-except.ads ada/gnat.ads \
+ ada/g-string.ads ada/gnatvsn.ads ada/hostparm.ads ada/interfac.ads \
+ ada/opt.ads ada/system.ads ada/s-exctab.ads ada/s-soflin.ads \
+ ada/s-stache.ads ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb \
+ ada/s-unstyp.ads ada/s-wchcnv.ads ada/s-wchcnv.adb ada/s-wchcon.ads \
+ ada/s-wchjis.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads \
+ ada/widechar.ads ada/widechar.adb
# end of regular dependencies
diff --git a/gcc/ada/Makefile.adalib b/gcc/ada/Makefile.adalib
index 873d2ff8c5f..ba084dcfbbd 100644
--- a/gcc/ada/Makefile.adalib
+++ b/gcc/ada/Makefile.adalib
@@ -10,7 +10,7 @@
# $ cd adalib
#
# 2. Copy this Makefile from the standard Adalib directory, e.g.
-# $ cp /usr/local/gnat/lib/gcc-lib/<target>/2.8.1/adalib/Makefile.adalib .
+# $ cp /usr/local/gnat/lib/gcc-lib/<target>/<version>/adalib/Makefile.adalib .
#
# 3. If needed (e.g for pragma Normalize_Scalars), create a gnat.adc
# containing the configuration pragmas you want to use to build the library
@@ -19,14 +19,14 @@
# relevant to the GNAT run time.
#
# 4. Determine the values of the following MACROS
-# ROOT (location of GNAT installation, e.g /usr/local)
+# ROOT (location of GNAT installation, e.g /usr/local/gnat)
# and optionnally
# CFLAGS (back end compilation flags such as -g -O2)
# ADAFLAGS (front end compilation flags such as -gnatpgn)
# *beware* the minimum value for this MACRO is -gnatpg
# for proper compilation of the GNAT library
# 5a. If you are using a native compile, call make
-# e.g. $ make -f Makefile.adalib ROOT=/usr/local CFLAGS="-g -O0"
+# e.g. $ make -f Makefile.adalib ROOT=/usr/local/gnat CFLAGS="-g -O0"
#
# 5b. If you are using a cross compiler, you need to define two additional
# MACROS:
@@ -41,15 +41,20 @@
# in place of the original one. This can be achieved for instance by
# updating the value of the environment variable ADA_OBJECTS_PATH
-SHELL=sh
PWD_COMMAND=$${PWDCMD-pwd}
-
CC = gcc
AR = ar
-GNAT_ROOT = $(shell cd $(ROOT);${PWD_COMMAND})/
+
+ifeq ($(strip $(filter-out %sh,$(SHELL))),)
+ GNAT_ROOT = $(shell cd $(ROOT);${PWD_COMMAND})/
+else
+ GNAT_ROOT = $(ROOT)/
+endif
+
target = $(shell $(CC) -dumpmachine)
version = $(shell $(CC) -dumpversion)
ADA_INCLUDE_PATH = $(GNAT_ROOT)lib/gcc-lib/$(target)/$(version)/adainclude/
+GCC_INCLUDE_PATH = $(GNAT_ROOT)lib/gcc-lib/$(target)/$(version)/gcc-include/
ADA_OBJECTS_PATH = $(GNAT_ROOT)lib/gcc-lib/$(target)/$(version)/adalib/
vpath %.adb $(ADA_INCLUDE_PATH)
@@ -58,27 +63,32 @@ vpath %.c $(ADA_INCLUDE_PATH)
vpath %.h $(ADA_INCLUDE_PATH)
CFLAGS = -O2
+GNATLIBCFLAGS = -DIN_RTS=1 -DIN_GCC=1 -fexceptions
ADAFLAGS = -gnatpgn
-ALL_ADAFLAGS = $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) -I.
+ALL_ADAFLAGS = $(CFLAGS) $(ADAFLAGS) -I.
FORCE_DEBUG_ADAFLAGS = -g
-INCLUDES = -I$(ADA_INCLUDE_PATH)
+INCLUDES = -I$(ADA_INCLUDE_PATH) -I$(GCC_INCLUDE_PATH)/include \
+-I$(GCC_INCLUDE_PATH)/gcc/config -I$(GCC_INCLUDE_PATH)/gcc \
+-I$(GCC_INCLUDE_PATH)/gcc/ada -I$(GCC_INCLUDE_PATH)
# Say how to compile Ada programs.
.SUFFIXES: .ada .adb .ads
.c.o:
- $(CC) -c $(CFLAGS) $(ADA_CFLAGS) $(INCLUDES) $<
+ $(CC) -c $(CFLAGS) $(GNATLIBCFLAGS) $(INCLUDES) $<
.adb.o:
$(CC) -c $(ALL_ADAFLAGS) $<
.ads.o:
$(CC) -c $(ALL_ADAFLAGS) $<
-GNAT_OBJS :=$(filter-out prefix.o __%,$(shell $(AR) t $(ADA_OBJECTS_PATH)libgnat.a))
+GNAT_OBJS :=$(filter-out __%,$(shell $(AR) t $(ADA_OBJECTS_PATH)libgnat.a))
GNARL_OBJS:=$(filter-out __%,$(shell $(AR) t $(ADA_OBJECTS_PATH)libgnarl.a))
OBJS := $(GNAT_OBJS) $(GNARL_OBJS)
-all: libgnat.a libgnarl.a
+all: libgnat.a libgnarl.a delete_objects g-trasym.o
chmod 0444 *.ali *.a
+
+delete_objects:
rm *.o
libgnat.a: $(GNAT_OBJS)
@@ -102,14 +112,11 @@ s-vaflop.o: s-vaflop.adb
s-memory.o: s-memory.adb s-memory.ads
$(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) $<
-a-init.o: a-init.c a-ada.h a-types.h a-raise.h
- $(CC) -c $(CFLAGS) $(ADA_CFLAGS) \
- $(ALL_CPPFLAGS) $(INCLUDES) -fexceptions $<
+s-traceb.o: s-traceb.adb
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -fno-optimize-sibling-calls $(ADA_INCLUDES) $<
-a-traceb.o: a-traceb.c
- $(CC) -c $(CFLAGS) $(ADA_CFLAGS) \
+tracebak.o: tracebak.c
+ $(CC) -c $(CFLAGS) $(GNATLIBCFLAGS) \
$(ALL_CPPFLAGS) $(INCLUDES) -fno-omit-frame-pointer $<
-prefix.o: prefix.c gansidecl.h
- $(CC) -c $(CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \
- -DPREFIX=\"$(GNAT_ROOT)\" $<
+.PHONY: delete_objects
diff --git a/gcc/ada/Makefile.generic b/gcc/ada/Makefile.generic
new file mode 100644
index 00000000000..9847e892183
--- /dev/null
+++ b/gcc/ada/Makefile.generic
@@ -0,0 +1,409 @@
+# Generic Makefile to support compilation for multiple languages.
+# See also Makefile.prolog
+#
+# Copyright (C) 2001-2003 ACT-Europe
+
+# This Makefile provides a very generic framework of the following
+# functionalities:
+#
+# Multi-language support (currently any combination of Ada/C/C++ supported)
+# Automatic handling of source dependencies
+# Handling of various C/C++ compilers
+# Handling of Ada sources using the GNAT toolchain
+# Complete build process (compile/bind/link)
+# Individual compilation (on a file, or on a language)
+# Handling of an object directory
+
+# Here are the rules that can be used from the command line:
+#
+# build: complete compile/bind/link process
+# compile: compile all files that are not up-to-date
+# link: bind/link
+# ada: compile all Ada files that are not up-to-date
+# c: ditto for C files
+# c++: ditto for C++ files
+# <ada file>: compile the specified file if needed.
+# <object file>: compile the corresponding C/C++ source file if needed.
+# clean: remove all temporary files
+
+# This Makefile expects the following variables to be set by the caller
+# (typically another Makefile):
+#
+# ADA_SPEC extension of Ada spec files (optional, default to .ads)
+# ADA_BODY extension of Ada body files (optional, default to .adb)
+# C_EXT extension of C files (optional, default to .c)
+# CXX_EXT extension of C++ files (optional, default to .cc)
+# OBJ_EXT extension of object files (optional, default to .o)
+# SRC_DIRS blank separated list of source directories
+# C_SRCS explicit list of C sources (optional)
+# C_SRCS_DEFINED if set, indicates that C_SRCS is already set
+# CXX_SRCS explicit list of C++ sources (optional)
+# CXX_SRCS_DEFINED is set, indicates that CXX_SRCS is already set
+# OBJ_DIR a single directory where object files should be put
+# EXEC_DIR a single directory where executables should be put (optional)
+# LANGUAGES a blank separated list of languages supported, e.g "ada c"
+# the current list of recognized languages is: ada, c, c++
+# CC name of the C compiler (optional, default to gcc)
+# CXX name of the C++ compiler (optional, default to gcc)
+# AR_CMD command to create an archive (optional, default to "ar rc")
+# AR_EXT file extension of an archive (optional, default to ".a")
+# GNATMAKE name of the GNAT builder (optional, default to "gnatmake")
+# ADAFLAGS additional Ada compilation switches, e.g "-gnatf" (optional)
+# CFLAGS default C compilation switches, e.g "-O2 -g" (optional)
+# CXXFLAGS default C++ compilation switches (optional)
+# LIBS libraries to link with (optional)
+# LDFLAGS linker switches (optional)
+# ADA_SOURCES list of main Ada sources (optional)
+# EXEC name of the final executable (optional)
+# MAIN language of the main program (optional)
+# PROJECT_FILE name of the project file, without the .gpr extension
+# DEPS_PROJECTS list of project dependencies (optional)
+
+# Set the source search path for C and C++ if needed
+
+ifndef MAIN
+ MAIN=ada
+endif
+
+ifndef ADA_SPEC
+ ADA_SPEC=.ads
+endif
+
+ifndef ADA_BODY
+ ADA_BODY=.adb
+endif
+
+ifndef CC
+ CC=gcc
+endif
+
+ifndef CXX
+ CXX=gcc
+endif
+
+ifndef CXX_EXT
+ CXX_EXT=.cc
+endif
+
+vpath %$(C_EXT) $(SRC_DIRS)
+vpath %$(CXX_EXT) $(SRC_DIRS)
+
+ifndef OBJ_EXT
+ OBJ_EXT=.o
+endif
+
+ifndef AR_EXT
+ AR_EXT=.a
+endif
+
+ifndef AR_CMD
+ AR_CMD=ar rc
+endif
+
+ifndef GNATMAKE
+ GNATMAKE=gnatmake
+endif
+
+ifeq ($(EXEC_DIR),)
+ EXEC_DIR=$(OBJ_DIR)
+endif
+
+# Set the object search path
+
+vpath %$(OBJ_EXT) $(OBJ_DIR)
+vpath %$(AR_EXT) $(OBJ_DIR)
+
+# A target can't have a character ':' otherwise it will confuse make. We
+# replace ':' by a pipe character. Note that there is less chance than a pipe
+# character be part of a pathname on UNIX and this character can't be used in
+# a pathname on Windows.
+
+clean_deps = $(subst :,|,$(DEPS_PROJECTS:%=clean_%))
+compile_deps = $(subst :,|,$(DEPS_PROJECTS:%=compile_%))
+ada_deps = $(subst :,|,$(DEPS_PROJECTS:%=ada_%))
+c_deps = $(subst :,|,$(DEPS_PROJECTS:%=c_%))
+c++_deps = $(subst :,|,$(DEPS_PROJECTS:%=c++_%))
+
+# Default target is to build (compile/bind/link)
+all: build
+
+clean: $(clean_deps) internal-clean
+build: $(compile_deps) internal-compile internal-build
+compile: $(compile_deps) internal-compile $(ADA_SOURCES)
+ada: $(ada_deps) internal-ada
+c: $(c_deps) internal-c
+c++: $(c++deps) internal-c++
+
+$(clean_deps): force
+ @$(MAKE) -C $(dir $(subst |,:,$(@:clean_%=%))) -f Makefile.$(notdir $@) internal-clean
+
+$(compile_deps): force
+ @$(MAKE) -C $(dir $(subst |,:,$(@:compile_%=%))) -f Makefile.$(notdir $@) internal-compile
+
+$(ada_deps): force
+ @$(MAKE) -C $(dir $(subst |,:,$(@:ada_%=%))) -f Makefile.$(notdir $@) internal-ada
+
+$(c_deps): force
+ @$(MAKE) -C $(dir $(subst |,:,$(@:c_%=%))) -f Makefile.$(notdir $@) internal-c
+
+$(c++_deps): force
+ @$(MAKE) -C $(dir $(subst |,:,$(@:c++_%=%))) -f Makefile.$(notdir $@) internal-c++
+
+ifneq ($(EXEC),)
+ EXEC_RULE=-o $(EXEC)
+endif
+
+PROJECT_BASE = $(notdir $(PROJECT_FILE))
+
+# Set C/C++ linker command & target
+
+ifeq ($(filter c++,$(LANGUAGES)),c++)
+ LINKER = $(CXX)
+
+ ifeq ($(filter ada,$(LANGUAGES)),ada)
+ # C++ and Ada mixed
+ LINKER = $(OBJ_DIR)/c++linker
+ LARGS = --LINK=$(LINKER)
+
+ ifeq ($(strip $(filter-out %gcc %g++,$(CXX))),)
+ # Case of GNU C++ and GNAT
+
+$(LINKER): Makefile.$(PROJECT_BASE)
+ @echo \#!/bin/sh > $(LINKER)
+ @echo unset BINUTILS_ROOT >> $(LINKER)
+ @echo unset GCC_ROOT >> $(LINKER)
+ @echo $(CXX) $$\* >> $(LINKER)
+ @chmod +x $(LINKER)
+
+ else
+$(LINKER): Makefile.$(PROJECT_BASE)
+ @echo \#!/bin/sh > $(LINKER)
+ @echo $(CXX) $$\* $(shell gcc -print-libgcc-file-name) >> $(LINKER)
+ @chmod +x $(LINKER)
+ endif
+ endif
+else
+ ifeq ($(strip $(LANGUAGES)),c)
+ # Case of C only
+ LINKER = $(CC)
+ endif
+endif
+
+C_INCLUDES := $(foreach name,$(SRC_DIRS),-I$(name))
+ALL_CFLAGS = $(CFLAGS) $(C_INCLUDES) $(DEP_CFLAGS)
+ALL_CXXFLAGS = $(CXXFLAGS) $(C_INCLUDES) $(DEP_CFLAGS)
+LDFLAGS := $(LIBS) $(LDFLAGS)
+
+# Compute list of objects based on languages
+
+ifeq ($(strip $(filter c,$(LANGUAGES))),c)
+ # Compute list of C sources automatically unless already specified
+
+ ifndef C_SRCS_DEFINED
+ ifndef C_SRCS
+ C_SRCS := \
+ $(foreach name,$(SRC_DIRS),$(notdir $(wildcard $(name)/*$(C_EXT))))
+ endif
+ endif
+
+ C_OBJECTS := $(C_SRCS:$(C_EXT)=$(OBJ_EXT))
+ OBJECTS += $(C_OBJECTS)
+endif
+
+ifeq ($(strip $(filter c++,$(LANGUAGES))),c++)
+ # Compute list of C++ sources automatically unless already specified
+
+ ifndef CXX_SRCS_DEFINED
+ ifndef CXX_SRCS
+ CXX_SRCS := \
+ $(foreach name,$(SRC_DIRS),$(notdir $(wildcard $(name)/*$(CXX_EXT))))
+ endif
+ endif
+
+ CXX_OBJECTS := $(CXX_SRCS:$(CXX_EXT)=$(OBJ_EXT))
+ OBJECTS += $(CXX_OBJECTS)
+endif
+
+OBJ_FILES := $(foreach name,$(OBJECTS),$(OBJ_DIR)/$(name))
+
+# To handle C/C++ dependencies, we associate a small file for each
+# source that will list the dependencies as a make rule, so that we can then
+# include these rules in this makefile, and recompute them on a file by file
+# basis
+
+DEP_FILES := $(OBJ_FILES:$(OBJ_EXT)=.d)
+
+# Ada compilations are taken care of automatically, so do not mess with Ada
+# objects, only with main sources.
+
+ifeq ($(strip $(OBJECTS)),)
+internal-compile:
+
+else
+internal-compile: lib$(PROJECT_BASE)$(AR_EXT)
+
+lib$(PROJECT_BASE)$(AR_EXT): $(OBJECTS)
+ @echo creating archive file for $(PROJECT_BASE)
+ cd $(OBJ_DIR); $(AR_CMD) $@ $(strip $(OBJECTS))
+ -ranlib $(OBJ_DIR)/$@
+endif
+
+# Linking rules
+
+# There are three cases:
+#
+# - C/C++ sources
+#
+# - Ada/C/C++, main program is in Ada
+#
+# - Ada/C/C++, main program is in C/C++
+
+ifeq ($(strip $(filter-out c c++,$(LANGUAGES))),)
+# link with C/C++
+link: $(EXEC_DIR)/$(EXEC)
+$(EXEC_DIR)/$(EXEC): $(OBJ_FILES)
+ $(LINKER) $(OBJ_FILES) -o $(EXEC_DIR)/$(EXEC) $(LDFLAGS)
+
+internal-build: internal-compile link
+
+else
+ifeq ($(strip $(filter-out c c++ ada,$(LANGUAGES))),)
+# link with Ada/C/C++
+
+ifeq ($(MAIN),ada)
+# Ada main
+link: $(LINKER) force
+ $(GNATMAKE) -b -l -P$(PROJECT_FILE) $(ADA_SOURCES) \
+ -largs $(LARGS) $(LDFLAGS)
+
+internal-build: $(LINKER) force
+ @echo $(GNATMAKE) -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
+ @$(GNATMAKE) -P$(PROJECT_FILE) $(EXEC_RULE) $(ADA_SOURCES) $(ADAFLAGS) \
+ -largs $(LARGS) $(LDFLAGS)
+
+else
+# C/C++ main
+# The trick here is to force gnatmake to bind/link, even if there is no
+# Ada main program. To achieve this effect, we use the -z switch, which is
+# close enough to our needs, and the usual -n gnatbind switch and --LINK=
+# gnatlink switch.
+
+link: $(LINKER) force
+ $(GNATMAKE) $(EXEC_RULE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) \
+ -bargs -n -largs $(LARGS) $(LDFLAGS)
+
+internal-build: $(LINKER) force
+ @echo $(GNATMAKE) -z -P$(PROJECT_FILE) $(ADA_SOURCES) $(EXEC_RULE) $(ADAFLAGS)
+ @$(GNATMAKE) $(EXEC_RULE) -z \
+ -P$(PROJECT_FILE) $(ADA_SOURCES) $(ADAFLAGS) \
+ -bargs -n \
+ -largs $(LARGS) $(LDFLAGS)
+endif
+
+else
+# unknown set of languages, fail
+link:
+ @echo do not know how to link with the following languages: $(LANGUAGES)
+ exit 1
+endif
+endif
+
+# Automatic handling of dependencies
+
+ifeq ($(strip $(filter-out %gcc %g++,$(CC) $(CXX))),)
+# Compiler is GCC, take avantage of the preprocessor option -MD
+DEP_CFLAGS = -Wp,-MD,$(OBJ_DIR)/$(*F).d
+
+define post-compile
+ @gprcmd deps $(OBJ_EXT) $(OBJ_DIR)/$(*F).d gcc
+endef
+
+# Default rule to create dummy dependency files the first time
+
+$(OBJ_DIR)/%.d:
+ @echo $(*F)$(OBJ_EXT): > $@
+
+else
+# Compiler unknown, use a more general approach based on the output of $(CC) -M
+
+DEP_FLAGS = -M
+DEP_CFLAGS =
+
+define post-compile
+endef
+
+$(OBJ_DIR)/%.d: %$(C_EXT)
+ @$(CC) $(DEP_FLAGS) $(ALL_CFLAGS) $< > $@
+ @gprcmd deps $(OBJ_EXT) $@
+
+$(OBJ_DIR)/%.d: %$(CXX_EXT)
+ @$(CXX) $(DEP_FLAGS) $(ALL_CXXFLAGS) $< > $@
+ @gprcmd deps $(OBJ_EXT) $@
+endif
+
+ifneq ($(DEP_FILES),)
+-include $(DEP_FILES)
+endif
+
+# Compilation rules
+
+# File rules
+
+# Compile C files individually
+%$(OBJ_EXT) : %$(C_EXT)
+ @echo $(CC) -c $(CFLAGS) $< -o $(OBJ_DIR)/$@
+ifndef FAKE_COMPILE
+ @$(CC) -c $(ALL_CFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(post-compile)
+endif
+
+# Compile C++ files individually
+%$(OBJ_EXT) : %$(CXX_EXT)
+ @echo $(CXX) -c $(CXXFLAGS) $< -o $(OBJ_DIR)/$@
+ifndef FAKE_COMPILE
+ @$(CXX) -c $(ALL_CXXFLAGS) $< -o $(OBJ_DIR)/$@
+ @$(post-compile)
+endif
+
+# Compile Ada body files individually
+%$(ADA_BODY) : force
+ $(GNATMAKE) -c -P$(PROJECT_FILE) $@ $(ADAFLAGS)
+
+# Compile Ada spec files individually
+%$(ADA_SPEC) : force
+ $(GNATMAKE) -c -P$(PROJECT_FILE) $@ $(ADAFLAGS)
+
+# Languages rules
+
+# Compile all Ada files in the project
+internal-ada :
+ $(GNATMAKE) -c -P$(PROJECT_FILE) $(ADAFLAGS)
+
+# Compile all C files in the project
+internal-c : $(C_OBJECTS)
+
+# Compile all C++ files in the project
+internal-c++ : $(CXX_OBJECTS)
+
+.PHONY: force internal-clean internal-build internal-compile internal-ada internal-c internal-c++ build compile clean ada c c++
+
+internal-clean:
+ @echo $(RM) $(OBJ_DIR)/*$(OBJ_EXT)
+ @$(RM) $(OBJ_DIR)/*$(OBJ_EXT)
+ @echo $(RM) $(OBJ_DIR)/*.ali
+ @$(RM) $(OBJ_DIR)/*.ali
+ @echo $(RM) $(OBJ_DIR)/b~*
+ @$(RM) $(OBJ_DIR)/b~*
+ @echo $(RM) $(OBJ_DIR)/b_*
+ @$(RM) $(OBJ_DIR)/b_*
+ @echo $(RM) $(OBJ_DIR)/*$(AR_EXT)
+ @$(RM) $(OBJ_DIR)/*$(AR_EXT)
+ @echo $(RM) $(OBJ_DIR)/*.d
+ @$(RM) $(OBJ_DIR)/*.d
+ifneq ($(EXEC),)
+ @echo $(RM) $(EXEC_DIR)/$(EXEC)
+ @$(RM) $(EXEC_DIR)/$(EXEC)
+endif
+
+force:
+
diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in
index b96584367db..3ffc2a1a800 100644
--- a/gcc/ada/Makefile.in
+++ b/gcc/ada/Makefile.in
@@ -19,7 +19,7 @@
#Boston, MA 02111-1307, USA.
# The makefile built from this file lives in the language subdirectory.
-# It's purpose is to provide support for:
+# Its purpose is to provide support for:
#
# 1) recursion where necessary, and only then (building .o's), and
# 2) building and debugging cc1 from the language subdirectory, and
@@ -89,13 +89,27 @@ X_ADAFLAGS =
T_ADAFLAGS =
CC = cc
-# Let the configure setting prevail only if CC hasn't been overridden
-# to xgcc by the top level Makefile (in a later stage of bootstrap).
-ifeq ($(findstring xgcc, $(CC)),)
-ADAC = @ADAC@
-else
-ADAC = $(CC)
-endif
+BISON = bison
+BISONFLAGS =
+ECHO = echo
+LEX = flex
+LEXFLAGS =
+CHMOD = chmod
+LN = ln
+LN_S = ln -s
+CP = cp -p
+MV = mv -f
+RM = rm -f
+RMDIR = rm -rf
+MKDIR = mkdir -p
+AR = ar
+AR_FLAGS = rc
+LS = ls
+# How to invoke ranlib.
+RANLIB = ranlib
+# Test to use to see whether ranlib exists on the system.
+RANLIB_TEST = [ -f /usr/bin/ranlib -o -f /bin/ranlib ]
+CC = cc
BISON = bison
BISONFLAGS =
@@ -120,7 +134,7 @@ PWD_COMMAND = $${PWDCMD-pwd}
INSTALL_DATA_DATE = cp -p
MAKEINFO = makeinfo
TEXI2DVI = texi2dvi
-GNATBIND = $(STAGE_PREFIX)gnatbind -C
+GNATBIND = $(STAGE_PREFIX)gnatbind
GNATBIND_FLAGS = -static -x
ADA_CFLAGS =
ADAFLAGS = -W -Wall -gnatpg -gnata
@@ -130,6 +144,13 @@ GNATLIBFLAGS = -gnatpg
GNATLIBCFLAGS = -g -O2
GNATLIBCFLAGS_FOR_C = $(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS) -fexceptions \
-DIN_RTS
+ADAFLAGS = -W -Wall -gnatpg -gnata
+SOME_ADAFLAGS =-gnata
+FORCE_DEBUG_ADAFLAGS = -g
+GNATLIBFLAGS = -gnatpg
+GNATLIBCFLAGS = -g -O2
+GNATLIBCFLAGS_FOR_C = $(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS) -fexceptions \
+ -DIN_RTS
ALL_ADA_CFLAGS = $(X_ADA_CFLAGS) $(T_ADA_CFLAGS) $(ADA_CFLAGS)
ALL_ADAFLAGS = $(CFLAGS) $(ALL_ADA_CFLAGS) $(X_ADAFLAGS) $(T_ADAFLAGS) \
$(ADAFLAGS)
@@ -139,6 +160,9 @@ THREAD_KIND = native
THREADSLIB =
GMEM_LIB =
MISCLIB =
+SYMLIB =
+SYMDEPS = $(LIBINTL_DEP)
+OUTPUT_OPTION = @OUTPUT_OPTION@
objext = .o
exeext =
@@ -146,15 +170,6 @@ arext = .a
soext = .so
shext =
-HOST_CC=$(CC)
-HOST_CFLAGS=$(ALL_CFLAGS)
-HOST_CLIB=$(CLIB)
-HOST_LDFLAGS=$(LDFLAGS)
-HOST_CPPFLAGS=$(ALL_CPPFLAGS)
-HOST_ALLOCA=$(ALLOCA)
-HOST_MALLOC=$(MALLOC)
-HOST_OBSTACK=$(OBSTACK)
-
# Define this as & to perform parallel make on a Sequent.
# Note that this has some bugs, and it seems currently necessary
# to compile all the gen* files first by hand to avoid erroneous results.
@@ -184,7 +199,7 @@ host_canonical=@host@
# Directory where sources are, from where we are.
srcdir = @srcdir@
-VPATH = @srcdir@
+VPATH = $(srcdir)
fsrcdir := $(shell cd $(srcdir);${PWD_COMMAND})
fsrcpfx := $(shell cd $(srcdir);${PWD_COMMAND})/
@@ -192,25 +207,29 @@ fcurdir := $(shell ${PWD_COMMAND})
fcurpfx := $(shell ${PWD_COMMAND})/
# Top build directory, relative to here.
-top_builddir = ..
+top_builddir = ../..
# Internationalization library.
-INTLLIBS = @INTLLIBS@
-INTLDEPS = @INTLDEPS@
+LIBINTL = @LIBINTL@
+LIBINTL_DEP = @LIBINTL_DEP@
# Any system libraries needed just for GNAT.
SYSLIBS = @GNAT_LIBEXC@
# List of extra object files linked in with various programs.
-EXTRA_GNATTOOLS_OBJS = ../prefix.o
+EXTRA_GNATTOOLS_OBJS = ../../prefix.o ../../version.o
# List extra gnattools
EXTRA_GNATTOOLS =
+# List of target dependent sources, overridden below as necessary
+TARGET_ADA_SRCS =
+
+# Type of tools build we are doing; default is not compiling tools.
+TOOLSCASE =
+
# End of variables for you to override.
-# Definition of `all' is here so that new rules inserted by sed
-# do not specify the default target.
all: all.indirect
# This tells GNU Make version 3 not to put all variables in the environment.
@@ -253,10 +272,9 @@ LIBIBERTY = ../../libiberty/libiberty.a
# How to link with both our special library facilities
# and the system's installed libraries.
-LIBS = $(INTLLIBS) $(LIBIBERTY) $(SYSLIBS)
-LIBDEPS = $(INTLDEPS) $(LIBIBERTY)
-TOOLS_LIBS = ../../prefix.o ../../version.o $(LIBGNAT) \
- ../../../libiberty/libiberty.a $(SYSLIBS)
+LIBS = $(LIBINTL) $(LIBIBERTY) $(SYSLIBS)
+LIBDEPS = $(LIBINTL_DEP) $(LIBIBERTY)
+TOOLS_LIBS = $(LIBGNAT) $(EXTRA_GNATTOOLS_OBJS) ../../../libiberty/libiberty.a $(SYSLIBS)
# Specify the directories to be searched for header files.
# Both . and srcdir are used, in that order,
@@ -267,23 +285,29 @@ INCLUDES = -I- -I. -I.. -I$(srcdir) -I$(srcdir)/.. -I$(srcdir)/../config \
ADA_INCLUDES = -I- -I. -I$(srcdir)
-INCLUDES_FOR_SUBDIR = -I. -I.. -I../.. -I$(fsrcdir) \
- -I$(fsrcdir)/.. -I$(fsrcdir)/../config -I$(fsrcdir)/../../include
+INCLUDES_FOR_SUBDIR = -I. -I.. -I../.. -I$(fsrcdir) -I$(fsrcdir)/../config \
+ -I$(fsrcdir)/../../include -I$(fsrcdir)/..
ADA_INCLUDES_FOR_SUBDIR = -I. -I$(fsrcdir)
# Avoid a lot of time thinking about remaking Makefile.in and *.def.
.SUFFIXES: .in .def
# Say how to compile Ada programs.
-.SUFFIXES: .ada .adb .ads
+.SUFFIXES: .ada .adb .ads .asm
# Always use -I$(srcdir)/config when compiling.
+.asm.o:
+ $(CC) -c -x assembler $< $(OUTPUT_OPTION)
+
.c.o:
- $(CC) -c $(ALL_CFLAGS) $(ALL_ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $<
+ $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) $< \
+ $(OUTPUT_OPTION)
+
.adb.o:
- $(ADAC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $<
+ $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
+
.ads.o:
- $(ADAC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $<
+ $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
# how to regenerate this file
Makefile: ../config.status $(srcdir)/Makefile.in $(srcdir)/../version.c
@@ -298,25 +322,25 @@ Makefile: ../config.status $(srcdir)/Makefile.in $(srcdir)/../version.c
# Lists of files for various purposes.
-# Object files for gnat executables
GNATLINK_OBJS = gnatlink.o link.o \
ali.o alloc.o butil.o casing.o csets.o debug.o fmap.o fname.o gnatvsn.o \
- hostparm.o namet.o opt.o osint.o output.o rident.o sdefault.o stylesw.o \
- switch.o table.o tree_io.o types.o validsw.o widechar.o
+ hostparm.o namet.o opt.o osint.o output.o rident.o sdefault.o \
+ stylesw.o switch.o table.o tree_io.o types.o validsw.o widechar.o
-GNATMAKE_OBJS = ali.o ali-util.o \
- alloc.o atree.o binderr.o butil.o casing.o csets.o debug.o einfo.o elists.o \
- errout.o fmap.o fname.o fname-uf.o fname-sf.o \
+GNATMAKE_OBJS = ctrl_c.o ali.o ali-util.o s-casuti.o \
+ alloc.o atree.o binderr.o butil.o casing.o csets.o debug.o elists.o einfo.o\
+ erroutc.o errutil.o err_vars.o fmap.o fname.o fname-uf.o fname-sf.o \
gnatmake.o gnatvsn.o hostparm.o krunch.o lib.o make.o makeusg.o \
mlib.o mlib-fil.o mlib-prj.o mlib-tgt.o mlib-utl.o \
namet.o nlists.o opt.o osint.o osint-m.o output.o \
- prj.o prj-attr.o prj-com.o prj-dect.o prj-env.o prj-ext.o prj-nmsc.o \
+ prj.o prj-attr.o prj-com.o prj-dect.o prj-env.o prj-err.o prj-ext.o prj-nmsc.o \
prj-pars.o prj-part.o prj-proc.o prj-strt.o prj-tree.o prj-util.o \
- rident.o scans.o scn.o sdefault.o sfn_scan.o sinfo.o sinfo-cn.o \
- sinput.o sinput-l.o sinput-p.o \
- snames.o stand.o stringt.o style.o stylesw.o validsw.o switch.o switch-m.o \
- switch-c.o table.o targparm.o tree_io.o types.o \
- uintp.o uname.o urealp.o usage.o widechar.o
+ rident.o scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o \
+ sinfo.o sinput.o sinput-c.o sinput-p.o \
+ snames.o stand.o stringt.o styleg.o stylesw.o validsw.o switch.o switch-m.o \
+ table.o targparm.o tempdir.o tree_io.o types.o \
+ uintp.o uname.o urealp.o usage.o widechar.o \
+ $(EXTRA_GNATMAKE_OBJS)
# Convert the target variable into a space separated list of architecture,
# manufacturer, and operating system and assign each of those to its own
@@ -356,13 +380,26 @@ s-taspri.ads<5ntaspri.ads
SO_OPTS = -Wl,-soname,
# Default gnatlib-shared target.
-# This is needed on some targets to use a different gnatlib-shared target, e.g
-# gnatlib-shared-dual
-GNATLIB_SHARED = gnatlib-shared-default
+# By default, equivalent to gnatlib.
+# Set to gnatlib-shared-default, gnatlib-shared-dual, or a platform specific
+# target when supported.
+GNATLIB_SHARED = gnatlib
# default value for gnatmake's target dependent file
MLIB_TGT = mlib-tgt
+# By default, do not distribute prefix.o (in libgccprefix), since it is only
+# needed by external GNAT tools such as gnatdist and Glide.
+# Override this variable on native platforms when needed.
+PREFIX_OBJS =
+
+# To avoid duplicate code, use this variable to set PREFIX_OBJS when needed:
+PREFIX_REAL_OBJS = ../prefix.o \
+ ../../libiberty/concat.o \
+ ../../libiberty/xmalloc.o \
+ ../../libiberty/xstrdup.o \
+ ../../libiberty/xexit.o
+
# $(filter-out PATTERN...,TEXT) removes all PATTERN words from TEXT.
# $(strip STRING) removes leading and trailing spaces from STRING.
# If what's left is null then it's a match.
@@ -411,6 +448,7 @@ ifeq ($(strip $(filter-out %86 interix%,$(arch) $(osys))),)
s-tpopsp.adb<7stpopsp.adb
THREADSLIB = -lgthreads -lmalloc
+ PREFIX_OBJS=$(PREFIX_REAL_OBJS)
endif
# sysv5uw is SCO UnixWare 7
@@ -434,6 +472,7 @@ ifeq ($(strip $(filter-out %86 sysv5uw%,$(arch) $(osys))),)
g-soliop.ads<31soliop.ads
THREADSLIB = -lthread
+ PREFIX_OBJS=$(PREFIX_REAL_OBJS)
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
@@ -451,7 +490,9 @@ ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),)
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
s-osprim.adb<5zosprim.adb \
+ s-parame.ads<5zparame.ads \
s-taprop.adb<5ztaprop.adb \
+ s-tpopsp.adb<5ztpopsp.adb \
s-taspri.ads<5ztaspri.ads \
s-vxwork.ads<5avxwork.ads \
g-soccon.ads<3zsoccon.ads \
@@ -475,14 +516,18 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),)
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
s-osprim.adb<5zosprim.adb \
+ s-parame.ads<5zparame.ads \
s-taprop.adb<5ztaprop.adb \
s-taspri.ads<5ztaspri.ads \
+ s-tpopsp.adb<5ztpopsp.adb \
s-vxwork.ads<5kvxwork.ads \
g-soccon.ads<3zsoccon.ads \
g-socthi.ads<3zsocthi.ads \
g-socthi.adb<3zsocthi.adb \
system.ads<5ksystem.ads
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<5zml-tgt.adb
+
EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
@@ -496,7 +541,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),)
endif
endif
-ifeq ($(strip $(filter-out powerpc% wrs vx%,$(targ))),)
+ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),)
LIBGNAT_TARGET_PAIRS = \
a-sytaco.ads<4zsytaco.ads \
a-sytaco.adb<4zsytaco.adb \
@@ -508,18 +553,197 @@ ifeq ($(strip $(filter-out powerpc% wrs vx%,$(targ))),)
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
s-osprim.adb<5zosprim.adb \
+ s-parame.ads<5zparame.ads \
s-taprop.adb<5ztaprop.adb \
s-taspri.ads<5ztaspri.ads \
+ s-tpopsp.adb<5ztpopsp.adb \
s-vxwork.ads<5pvxwork.ads \
g-soccon.ads<3zsoccon.ads \
g-socthi.ads<3zsocthi.ads \
g-socthi.adb<3zsocthi.adb \
system.ads<5ysystem.ads
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<5zml-tgt.adb
+
+ EXTRA_HIE_NONE_TARGET_PAIRS= \
+ system.ads<50system.ads
+
EXTRA_RAVEN_SOURCES=i-vxwork.ads s-vxwork.ads
EXTRA_RAVEN_OBJS=i-vxwork.o s-vxwork.o
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
+ HIE_RAVEN_TARGET_PAIRS=\
+ $(HIE_NONE_TARGET_PAIRS) \
+ a-reatim.ads<1areatim.ads \
+ a-reatim.adb<1areatim.adb \
+ a-retide.adb<1aretide.adb \
+ a-interr.adb<1ainterr.adb \
+ s-interr.ads<1sinterr.ads \
+ s-interr.adb<1sinterr.adb \
+ s-taskin.ads<1staskin.ads \
+ s-taskin.adb<1staskin.adb \
+ s-tarest.adb<1starest.adb \
+ s-tposen.ads<1stposen.ads \
+ s-tposen.adb<1stposen.adb \
+ s-osinte.adb<1sosinte.adb \
+ s-taprop.ads<1staprop.ads \
+ s-taprop.adb<1staprop.adb \
+ s-taprob.ads<1staprob.ads \
+ s-taprob.adb<1staprob.adb \
+ a-sytaco.ads<1asytaco.ads \
+ a-sytaco.adb<1asytaco.adb \
+ a-intnam.ads<4zintnam.ads \
+ s-osinte.ads<5zosinte.ads \
+ s-parame.ads<5zparame.ads \
+ s-taspri.ads<5ztaspri.ads \
+ s-vxwork.ads<5pvxwork.ads \
+ a-taside.adb<1ataside.adb \
+
+ CERT_LEVEL_B_TARGET_PAIRS=\
+ a-tags.adb<1atags.adb \
+ a-except.adb<2aexcept.adb \
+ a-except.ads<2aexcept.ads \
+ a-excach.adb<2aexcach.adb \
+ i-c.ads<1ic.ads \
+ g-io.adb<2gio.adb \
+ s-init.ads<2sinit.ads \
+ s-init.adb<5zinit.adb \
+ s-memory.adb<2smemory.adb \
+ s-memory.ads<2smemory.ads \
+ s-osinte.ads<2sosinte.ads \
+ s-secsta.ads<2ssecsta.ads \
+ s-secsta.adb<2ssecsta.adb \
+ s-soflin.adb<2ssoflin.adb \
+ s-soflin.ads<2ssoflin.ads \
+ s-stalib.adb<1sstalib.adb \
+ s-stalib.ads<1sstalib.ads \
+ s-thrini.ads<2sthrini.ads \
+ s-thrini.adb<5zthrini.adb \
+ s-tiitho.adb<5ztiitho.adb \
+ s-traceb.adb<2straceb.adb \
+ s-traceb.ads<2straceb.ads \
+ system.ads<5isystem.ads
+
+ ifeq ($(strip $(filter-out yes,$(TRACE))),)
+ LIBGNAT_TARGET_PAIRS += \
+ s-traces.adb<7straces.adb \
+ s-trafor.adb<7strafor.adb \
+ s-trafor.ads<7strafor.ads \
+ s-tratas.adb<7stratas.adb \
+ s-tfsetr.adb<5ztfsetr.adb
+ endif
+endif
+
+
+ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-sytaco.ads<4zsytaco.ads \
+ a-sytaco.adb<4zsytaco.adb \
+ a-intnam.ads<4zintnam.ads \
+ a-numaux.ads<4znumaux.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-interr.adb<5zinterr.adb \
+ s-intman.adb<5zintman.adb \
+ s-osinte.adb<5zosinte.adb \
+ s-osinte.ads<5zosinte.ads \
+ s-osprim.adb<5zosprim.adb \
+ s-parame.ads<5yparame.ads \
+ s-taprop.adb<5ztaprop.adb \
+ s-taspri.ads<5ztaspri.ads \
+ s-tpopsp.adb<5ztpopsp.adb \
+ s-vxwork.ads<5pvxwork.ads \
+ g-soccon.ads<3zsoccon.ads \
+ g-socthi.ads<3zsocthi.ads \
+ g-socthi.adb<3zsocthi.adb \
+ system.ads<5ysystem.ads
+
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<5zml-tgt.adb
+
+ EXTRA_HIE_NONE_TARGET_PAIRS= \
+ system.ads<50system.ads
+
+ EXTRA_RAVEN_SOURCES=i-vxwork.ads s-vxwork.ads
+ EXTRA_RAVEN_OBJS=i-vxwork.o s-vxwork.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
+ EXTRA_GNATRTL_TASKING_OBJS=i-vthrea.o s-tpae65.o s-vxwork.o
+ HIE_RAVEN_TARGET_PAIRS=\
+ $(HIE_NONE_TARGET_PAIRS) \
+ a-reatim.ads<1areatim.ads \
+ a-reatim.adb<1areatim.adb \
+ a-retide.adb<1aretide.adb \
+ a-interr.adb<1ainterr.adb \
+ s-interr.ads<1sinterr.ads \
+ s-interr.adb<1sinterr.adb \
+ s-taskin.ads<1staskin.ads \
+ s-taskin.adb<1staskin.adb \
+ s-tarest.adb<1starest.adb \
+ s-tposen.ads<1stposen.ads \
+ s-tposen.adb<1stposen.adb \
+ s-osinte.adb<1sosinte.adb \
+ s-taprop.ads<1staprop.ads \
+ s-taprop.adb<1staprop.adb \
+ s-taprob.ads<1staprob.ads \
+ s-taprob.adb<1staprob.adb \
+ a-sytaco.ads<1asytaco.ads \
+ a-sytaco.adb<1asytaco.adb \
+ a-intnam.ads<4zintnam.ads \
+ s-osinte.ads<5zosinte.ads \
+ s-parame.ads<5zparame.ads \
+ s-taspri.ads<5ztaspri.ads \
+ s-vxwork.ads<5pvxwork.ads \
+ a-taside.adb<1ataside.adb \
+
+ CERT_LEVEL_B_TARGET_PAIRS=\
+ a-tags.adb<1atags.adb \
+ a-except.adb<2aexcept.adb \
+ a-except.ads<2aexcept.ads \
+ a-excach.adb<2aexcach.adb \
+ i-c.ads<1ic.ads \
+ g-io.adb<2gio.adb \
+ s-init.ads<2sinit.ads \
+ s-init.adb<5zinit.adb \
+ s-memory.adb<2smemory.adb \
+ s-memory.ads<2smemory.ads \
+ s-osinte.ads<2sosinte.ads \
+ s-secsta.ads<2ssecsta.ads \
+ s-secsta.adb<2ssecsta.adb \
+ s-soflin.adb<2ssoflin.adb \
+ s-soflin.ads<2ssoflin.ads \
+ s-stalib.adb<1sstalib.adb \
+ s-stalib.ads<1sstalib.ads \
+ s-thrini.ads<2sthrini.ads \
+ s-thrini.adb<5zthrini.adb \
+ s-tiitho.adb<5ytiitho.adb \
+ s-traceb.adb<2straceb.adb \
+ s-traceb.ads<2straceb.ads \
+ system.ads<5isystem.ads
+
+ ifeq ($(strip $(filter-out yes,$(TRACE))),)
+ LIBGNAT_TARGET_PAIRS += \
+ s-traces.adb<7straces.adb \
+ s-trafor.adb<7strafor.adb \
+ s-trafor.ads<7strafor.ads \
+ s-tratas.adb<7stratas.adb \
+ s-tfsetr.adb<5ztfsetr.adb
+ endif
+endif
+
+ifeq ($(strip $(filter-out powerpc% unknown elf,$(targ))),)
+ EXTRA_HIE_NONE_TARGET_PAIRS= \
+ system.ads<59system.ads
+
+ LIBGNAT_TARGET_PAIRS = \
+ $(HIE_NONE_TARGET_PAIRS) \
+ $(EXTRA_HIE_NONE_TARGET_PAIRS)
+endif
+
+ifeq ($(strip $(filter-out sparc% unknown elf,$(targ))),)
+ EXTRA_HIE_NONE_TARGET_PAIRS= \
+ system.ads<5rsystem.ads
+
+ LIBGNAT_TARGET_PAIRS = \
+ $(HIE_NONE_TARGET_PAIRS) \
+ $(EXTRA_HIE_NONE_TARGET_PAIRS)
endif
ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
@@ -534,12 +758,47 @@ ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
s-osprim.adb<5zosprim.adb \
+ s-parame.ads<5zparame.ads \
s-taprop.adb<5ztaprop.adb \
- s-taspri.ads<7staspri.ads \
+ s-taspri.ads<5ztaspri.ads \
+ s-tpopsp.adb<5ztpopsp.adb \
s-vxwork.ads<5svxwork.ads \
- system.ads<5ysystem.ads
+ g-soccon.ads<3zsoccon.ads \
+ g-socthi.ads<3zsocthi.ads \
+ g-socthi.adb<3zsocthi.adb \
+ system.ads<5csystem.ads \
+
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<5zml-tgt.adb
+
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
+ EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
+endif
+
+ifeq ($(strip $(filter-out xscale% coff wrs vx%,$(targ))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-sytaco.ads<4zsytaco.ads \
+ a-sytaco.adb<4zsytaco.adb \
+ a-intnam.ads<4zintnam.ads \
+ a-numaux.ads<4znumaux.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-interr.adb<5zinterr.adb \
+ s-intman.adb<5zintman.adb \
+ s-osinte.adb<5zosinte.adb \
+ s-osinte.ads<5zosinte.ads \
+ s-osprim.adb<5zosprim.adb \
+ s-parame.ads<5zparame.ads \
+ s-taprop.adb<5ztaprop.adb \
+ s-taspri.ads<5ztaspri.ads \
+ s-tpopsp.adb<5ztpopsp.adb \
+ s-vxwork.ads<5xvxwork.ads \
+ g-soccon.ads<3zsoccon.ads \
+ g-socthi.ads<3zsocthi.ads \
+ g-socthi.adb<3zsocthi.adb \
+ system.ads<5rsystem.ads
+
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<5zml-tgt.adb
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
endif
@@ -555,39 +814,49 @@ ifeq ($(strip $(filter-out mips% wrs vx%,$(targ))),)
s-osinte.adb<5zosinte.adb \
s-osinte.ads<5zosinte.ads \
s-osprim.adb<5zosprim.adb \
+ s-parame.ads<5zparame.ads \
s-taprop.adb<5ztaprop.adb \
- s-taspri.ads<7staspri.ads \
+ s-taspri.ads<5ztaspri.ads \
+ s-tpopsp.adb<5ztpopsp.adb \
s-vxwork.ads<5mvxwork.ads \
- system.ads<5zsystem.ads
+ g-soccon.ads<3zsoccon.ads \
+ g-socthi.ads<3zsocthi.ads \
+ g-socthi.adb<3zsocthi.adb \
+ system.ads<5msystem.ads
+
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<5zml-tgt.adb
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
endif
-ifeq ($(strip $(filter-out sparc sun solaris2% sunos5%,$(targ))),)
+ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4sintnam.ads \
s-inmaop.adb<7sinmaop.adb \
s-intman.adb<5sintman.adb \
s-osinte.adb<5sosinte.adb \
s-osinte.ads<5sosinte.ads \
- s-osprim.adb<5posprim.adb \
+ s-osprim.adb<5sosprim.adb \
s-parame.adb<5sparame.adb \
s-taprop.adb<5staprop.adb \
s-tasinf.adb<5stasinf.adb \
s-tasinf.ads<5stasinf.ads \
s-taspri.ads<5staspri.ads \
- s-tpopse.adb<5stpopse.adb \
+ s-tpopsp.adb<5stpopsp.adb \
g-soccon.ads<3ssoccon.ads \
g-soliop.ads<3ssoliop.ads \
system.ads<5ssystem.ads
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<5sml-tgt.adb
+
THREADSLIB = -lposix4 -lthread
MISCLIB = -lposix4 -lnsl -lsocket
- SYMLIB = -laddr2line -lbfd $(INTLLIBS)
+ SYMLIB = -laddr2line -lbfd $(LIBINTL)
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
+ PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
@@ -597,7 +866,7 @@ ifeq ($(strip $(filter-out sparc sun solaris2% sunos5%,$(targ))),)
s-intman.adb<5sintman.adb \
s-osinte.adb<7sosinte.adb \
s-osinte.ads<5tosinte.ads \
- s-osprim.adb<5posprim.adb \
+ s-osprim.adb<5sosprim.adb \
s-taprop.adb<7staprop.adb \
s-taspri.ads<7staspri.ads \
s-tpopsp.adb<7stpopsp.adb \
@@ -615,7 +884,7 @@ ifeq ($(strip $(filter-out sparc sun solaris2% sunos5%,$(targ))),)
s-intman.adb<7sintman.adb \
s-osinte.adb<5iosinte.adb \
s-osinte.ads<54osinte.ads \
- s-osprim.adb<5posprim.adb \
+ s-osprim.adb<5sosprim.adb \
s-taprop.adb<7staprop.adb \
s-taspri.ads<7staspri.ads \
s-tpopsp.adb<5atpopsp.adb \
@@ -625,6 +894,25 @@ ifeq ($(strip $(filter-out sparc sun solaris2% sunos5%,$(targ))),)
THREADSLIB = -lposix4 -lpthread
endif
+
+ ifeq ($(strip $(filter-out m64,$(THREAD_KIND))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4sintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<5sintman.adb \
+ s-osinte.adb<5sosinte.adb \
+ s-osinte.ads<5sosinte.ads \
+ s-osprim.adb<5sosprim.adb \
+ s-parame.adb<5sparame.adb \
+ s-taprop.adb<5staprop.adb \
+ s-tasinf.adb<5stasinf.adb \
+ s-tasinf.ads<5stasinf.ads \
+ s-taspri.ads<5staspri.ads \
+ s-tpopsp.adb<5stpopsp.adb \
+ g-soccon.ads<3ssoccon.ads \
+ g-soliop.ads<3ssoliop.ads \
+ system.ads<5usystem.ads
+ endif
endif
ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),)
@@ -637,13 +925,13 @@ ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),)
s-mastop.adb<5omastop.adb \
s-osinte.adb<5sosinte.adb \
s-osinte.ads<5sosinte.ads \
- s-osprim.adb<5posprim.adb \
+ s-osprim.adb<5sosprim.adb \
s-parame.adb<5sparame.adb \
s-taprop.adb<5staprop.adb \
s-tasinf.adb<5stasinf.adb \
s-tasinf.ads<5stasinf.ads \
s-taspri.ads<5staspri.ads \
- s-tpopse.adb<5etpopse.adb \
+ s-tpopsp.adb<5stpopsp.adb \
g-soccon.ads<3ssoccon.ads \
g-soliop.ads<3ssoliop.ads \
system.ads<5esystem.ads
@@ -652,6 +940,7 @@ ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),)
MISCLIB = -lposix4 -lnsl -lsocket
SO_OPTS = -Wl,-h,
GNATLIB_SHARED = gnatlib-shared-dual
+ PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
endif
@@ -669,13 +958,15 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
s-taprop.adb<5itaprop.adb \
s-taspri.ads<5itaspri.ads \
s-tpopsp.adb<5atpopsp.adb \
+ s-parame.adb<5lparame.adb \
system.ads<5lsystem.ads
TOOLS_TARGET_PAIRS = mlib-tgt.adb<5lml-tgt.adb
- SYMLIB = -laddr2line -lbfd $(INTLLIBS)
+ SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
+ PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
@@ -696,22 +987,6 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
THREADSLIB = -lgthreads -lmalloc
endif
-
- ifeq ($(strip $(filter-out rt-linux RT-LINUX,$(THREAD_KIND))),)
- LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<4nintnam.ads \
- s-inmaop.adb<5ninmaop.adb \
- s-intman.adb<5nintman.adb \
- s-osinte.adb<5qosinte.adb \
- s-osinte.ads<5qosinte.ads \
- s-osprim.adb<5qosprim.adb \
- s-stache.adb<5qstache.adb \
- s-taprop.adb<5qtaprop.adb \
- s-taspri.ads<5qtaspri.ads \
- system.ads<5lsystem.ads
-
- RT_FLAGS = -D__RT__
- endif
endif
ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
@@ -721,7 +996,7 @@ ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
s-inmaop.adb<7sinmaop.adb \
s-intman.adb<5fintman.adb \
s-mastop.adb<5gmastop.adb \
- s-osinte.adb<5aosinte.adb \
+ s-osinte.adb<5fosinte.adb \
s-osinte.ads<5fosinte.ads \
s-osprim.adb<7sosprim.adb \
s-proinf.adb<5gproinf.adb \
@@ -729,11 +1004,13 @@ ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
s-taprop.adb<5ftaprop.adb \
s-tasinf.ads<5ftasinf.ads \
s-taspri.ads<7staspri.ads \
+ s-tpopsp.adb<7stpopsp.adb \
s-traceb.adb<7straceb.adb \
g-soccon.ads<3gsoccon.ads \
system.ads<5gsystem.ads
THREADSLIB = -lpthread
+ GNATLIB_SHARED = gnatlib-shared-default
else
LIBGNAT_TARGET_PAIRS = \
@@ -742,7 +1019,7 @@ ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
s-interr.adb<5ginterr.adb \
s-intman.adb<5gintman.adb \
s-mastop.adb<5gmastop.adb \
- s-osinte.adb<5aosinte.adb \
+ s-osinte.adb<5fosinte.adb \
s-osinte.ads<5gosinte.ads \
s-osprim.adb<7sosprim.adb \
s-proinf.adb<5gproinf.adb \
@@ -758,9 +1035,11 @@ ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
THREADSLIB = -lathread
endif
+ TOOLS_TARGET_PAIRS = mlib-tgt.adb<5gml-tgt.adb
TGT_LIB = -lexc
MISCLIB = -lexc
SO_OPTS = -Wl,-all,-set_version,sgi1.0,-update_registry,../so_locations,-soname,
+ PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
endif
@@ -780,6 +1059,8 @@ ifeq ($(strip $(filter-out hppa% hp hpux10%,$(targ))),)
s-tpopsp.adb<7stpopsp.adb \
g-soccon.ads<3hsoccon.ads \
system.ads<5hsystem.ads
+
+ PREFIX_OBJS = $(PREFIX_REAL_OBJS)
endif
ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),)
@@ -798,12 +1079,16 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),)
g-soccon.ads<3hsoccon.ads \
system.ads<5hsystem.ads
+ TOOLS_TARGET_PAIRS = mlib-tgt.adb<5hml-tgt.adb
TGT_LIB = /usr/lib/libcl.a
- THREADSLIB = -lpthread -lc_r
- SYMLIB = -laddr2line -lbfd $(INTLLIBS)
+ THREADSLIB = -lpthread
+ SYMLIB = -laddr2line -lbfd $(LIBINTL)
+ GMEM_LIB = gmemlib
soext = .sl
SO_OPTS = -Wl,+h,
+ PREFIX_OBJS = $(PREFIX_REAL_OBJS)
GNATLIB_SHARED = gnatlib-shared-dual
+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
ifeq ($(strip $(filter-out dce DCE,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
@@ -818,6 +1103,7 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),)
s-osprim.adb<7sosprim.adb \
s-taprop.adb<5htaprop.adb \
s-taspri.ads<5htaspri.ads \
+ s-tpopsp.adb<7stpopsp.adb \
g-soccon.ads<3hsoccon.ads \
system.ads<5hsystem.ads
@@ -826,7 +1112,7 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),)
endif
endif
-ifeq ($(strip $(filter-out ibm aix4%,$(manu) $(osys))),)
+ifeq ($(strip $(filter-out ibm aix%,$(manu) $(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4cintnam.ads \
s-inmaop.adb<7sinmaop.adb \
@@ -841,6 +1127,8 @@ ifeq ($(strip $(filter-out ibm aix4%,$(manu) $(osys))),)
system.ads<5bsystem.ads
THREADSLIB = -lpthreads
+ PREFIX_OBJS=$(PREFIX_REAL_OBJS)
+
ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4cintnam.ads \
@@ -857,6 +1145,11 @@ ifeq ($(strip $(filter-out ibm aix4%,$(manu) $(osys))),)
THREADSLIB = -lgthreads -lmalloc
endif
+
+ TOOLS_TARGET_PAIRS = mlib-tgt.adb<5bml-tgt.adb
+ GMEM_LIB = gmemlib
+ SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
+
endif
ifeq ($(strip $(filter-out lynxos,$(osys))),)
@@ -868,20 +1161,32 @@ ifeq ($(strip $(filter-out lynxos,$(osys))),)
s-mastop.adb<5omastop.adb \
s-inmaop.adb<7sinmaop.adb \
s-intman.adb<7sintman.adb \
+ s-osinte.adb<56osinte.adb \
+ s-osinte.ads<56osinte.ads \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<56taprop.adb \
+ s-taspri.ads<56taspri.ads \
+ s-tpopsp.adb<56tpopsp.adb \
+ system.ads<58system.ads
+
+ PREFIX_OBJS=$(PREFIX_REAL_OBJS)
+
+ else
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<42intnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<7sintman.adb \
s-osinte.adb<52osinte.adb \
s-osinte.ads<52osinte.ads \
s-osprim.adb<7sosprim.adb \
s-taprop.adb<7staprop.adb \
s-taspri.ads<7staspri.ads \
s-tpopsp.adb<7stpopsp.adb \
- system.ads<52system.ads
+ system.ads<57system.ads
ifeq ($(strip $(filter-out pthread PTHREAD,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
- a-numaux.adb<86numaux.adb \
- a-numaux.ads<86numaux.ads \
a-intnam.ads<42intnam.ads \
- s-mastop.adb<5omastop.adb \
s-inmaop.adb<7sinmaop.adb \
s-intman.adb<7sintman.adb \
s-osinte.adb<56osinte.adb \
@@ -889,26 +1194,14 @@ ifeq ($(strip $(filter-out lynxos,$(osys))),)
s-osprim.adb<7sosprim.adb \
s-taprop.adb<56taprop.adb \
s-taspri.ads<56taspri.ads \
- s-tpopsp.adb<5atpopsp.adb \
- system.ads<52system.ads
+ s-tpopsp.adb<56tpopsp.adb \
+ system.ads<57system.ads
endif
- else
- LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<42intnam.ads \
- s-inmaop.adb<7sinmaop.adb \
- s-intman.adb<7sintman.adb \
- s-osinte.adb<56osinte.adb \
- s-osinte.ads<56osinte.ads \
- s-osprim.adb<7sosprim.adb \
- s-taprop.adb<56taprop.adb \
- s-taspri.ads<56taspri.ads \
- s-tpopsp.adb<5atpopsp.adb \
- system.ads<52system.ads
endif
endif
-ifeq ($(strip $(filter-out rtems rtemself rtemsaout rtemscoff,$(osys))),)
+ifeq ($(strip $(filter-out rtems%,$(osys))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4rintnam.ads \
s-inmaop.adb<7sinmaop.adb \
@@ -922,19 +1215,6 @@ ifeq ($(strip $(filter-out rtems rtemself rtemsaout rtemscoff,$(osys))),)
s-tpopsp.adb<5rtpopsp.adb
endif
-ifeq ($(strip $(filter-out go32 msdos,$(osys))),)
- LIBGNAT_TARGET_PAIRS = \
- a-intnam.ads<4dintnam.ads \
- s-inmaop.adb<7sinmaop.adb \
- s-intman.adb<7sintman.adb \
- s-osinte.adb<7sosinte.adb \
- s-osinte.ads<5dosinte.ads \
- s-osprim.adb<7sosprim.adb \
- s-taprop.adb<7staprop.adb \
- s-taspri.ads<7staspri.ads \
- s-tpopsp.adb<7stpopsp.adb
-endif
-
ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4aintnam.ads \
@@ -952,20 +1232,27 @@ ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
g-soccon.ads<3asoccon.ads \
system.ads<5asystem.ads
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<5aml-tgt.adb
+
+ GMEM_LIB=gmemlib
+ SYMLIB = -laddr2line -lbfd $(LIBINTL)
THREADSLIB = -lpthread -lmach -lexc -lrt
- SYMLIB = -laddr2line -lbfd $(INTLLIBS)
+ PREFIX_OBJS = $(PREFIX_REAL_OBJS)
+ GNATLIB_SHARED = gnatlib-shared-default
LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
endif
ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(host))),)
-EXTRA_GNAT1_OBJS = ../prefix.o vmshandler.o
-EXTRA_GNATBIND_OBJS = ../prefix.o vmshandler.o
+soext = .exe
-endif
+.SUFFIXES: .sym
-ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),)
+.o.sym:
+ @ gnu:[bin]vmssymvec $<
+endif
+ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(targ))),)
ifeq ($(strip $(filter-out alpha64% dec vms% openvms% alphavms%,$(targ))),)
LIBGNAT_TARGET_PAIRS_AUX =
else
@@ -984,7 +1271,11 @@ endif
a-calend.ads<4vcalend.ads \
a-excpol.adb<4wexcpol.adb \
a-intnam.ads<4vintnam.ads \
- g-enblsp.adb<3venblsp.adb \
+ g-expect.adb<3vexpect.adb \
+ g-soccon.ads<3vsoccon.ads \
+ g-socthi.ads<3vsocthi.ads \
+ g-socthi.adb<3vsocthi.adb \
+ g-trasym.adb<3vtrasym.adb \
i-cstrea.adb<6vcstrea.adb \
i-cpp.adb<6vcpp.adb \
interfac.ads<6vinterf.ads \
@@ -999,17 +1290,28 @@ endif
s-osprim.ads<5vosprim.ads \
s-taprop.adb<5vtaprop.adb \
s-taspri.ads<5vtaspri.ads \
+ s-tpopsp.adb<7stpopsp.adb \
s-tpopde.adb<5vtpopde.adb \
s-tpopde.ads<5vtpopde.ads \
+ s-traent.adb<5vtraent.adb \
+ s-traent.ads<5vtraent.ads \
s-vaflop.adb<5vvaflop.adb \
system.ads<5xsystem.ads \
$(LIBGNAT_TARGET_PAIRS_AUX)
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<5vml-tgt.adb
+
GNATLIB_SHARED=gnatlib-shared-vms
EXTRA_LIBGNAT_SRCS=vmshandler.asm
EXTRA_LIBGNAT_OBJS=vmshandler.o
EXTRA_GNATRTL_TASKING_OBJS=s-tpopde.o
- EXTRA_GNATTOOLS_OBJS = ../prefix.o vmshandler.o
+ EXTRA_GNATTOOLS = \
+ ../../gnatlbr$(exeext) \
+ ,,/../gnatsym$(exeext)
+ # This command transforms (YYYYMMDD) into YY,MMDD
+ GSMATCH_VERSION := $(shell grep "^ *Gnat_Version_String" $(fsrcpfx)gnatvsn.ads | sed -e 's/.*(\(.*\)).*/\1/' -e 's/\(..\)\(..\)\(....\)/\2,\3/')
+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/' -e 's/\./_/g'))
+ TOOLS_LIBS_LO := --for-linker=sys\\$$\$$library:trace.exe
endif
ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
@@ -1035,11 +1337,39 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
g-soliop.ads<3wsoliop.ads \
system.ads<5wsystem.ads
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<5wml-tgt.adb
MISCLIB = -lwsock32
- SYMLIB = -laddr2line -lbfd $(INTLLIBS)
+ SYMLIB = -laddr2line -lbfd -liberty $(LIBINTL)
GMEM_LIB = gmemlib
+ PREFIX_OBJS = $(PREFIX_REAL_OBJS)
EXTRA_GNATTOOLS = ../../gnatdll$(exeext)
+ GNAT_WRAPPER_TOOL = ../../gnat_wrapper$(exeext)
+ EXTRA_GNATMAKE_OBJS = mdll.o mdll-utl.o mdll-fil.o
EXTRA_GNATRTL_NONTASKING_OBJS = g-regist.o
+ soext = .dll
+ GNATLIB_SHARED = gnatlib-shared-win32
+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
+endif
+
+ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<4lintnam.ads \
+ s-inmaop.adb<7sinmaop.adb \
+ s-intman.adb<5lintman.adb \
+ s-osinte.ads<5iosinte.ads \
+ s-osinte.adb<5iosinte.adb \
+ s-osprim.adb<7sosprim.adb \
+ s-taprop.adb<5itaprop.adb \
+ s-tpopsp.adb<5atpopsp.adb \
+ s-taspri.ads<5itaspri.ads \
+ system.ads<55system.ads
+
+ TOOLS_TARGET_PAIRS=mlib-tgt.adb<5lml-tgt.adb
+ MISCLIB=
+ THREADSLIB=-lpthread
+ GNATLIB_SHARED=gnatlib-shared-dual
+ PREFIX_OBJS=$(PREFIX_REAL_OBJS)
+ LIBRARY_VERSION := $(strip $(shell grep Library_Version $(fsrcpfx)gnatvsn.ads | sed -e 's/.*GNAT Lib v\(.*\)[ "].*/\1/'))
endif
# The runtime library for gnat comprises two directories. One contains the
@@ -1052,409 +1382,41 @@ endif
# go into the directory. The pthreads emulation is built in the threads
# subdirectory and copied.
LIBGNAT_SRCS = ada.h adaint.c adaint.h argv.c cio.c cstreams.c \
- errno.c exit.c cal.c \
+ errno.c exit.c cal.c ctrl_c.c \
raise.h raise.c sysdep.c types.h aux-io.c init.c \
- adafinal.c tracebak.c expect.c mkdir.c $(EXTRA_LIBGNAT_SRCS)
+ final.c tracebak.c tb-alvms.c tb-alvxw.c expect.c mkdir.c socket.c \
+ $(EXTRA_LIBGNAT_SRCS)
-LIBGNAT_OBJS = adaint.o argv.o cio.o cstreams.o errno.o exit.o \
- raise.o sysdep.o aux-io.o init.o cal.o adafinal.o \
- tracebak.o expect.o mkdir.o $(EXTRA_LIBGNAT_OBJS)
+LIBGNAT_OBJS = adaint.o argv.o cio.o cstreams.o ctrl_c.o errno.o exit.o \
+ raise.o sysdep.o aux-io.o init.o cal.o final.o \
+ tracebak.o expect.o mkdir.o socket.o $(EXTRA_LIBGNAT_OBJS)
# NOTE ??? - when the -I option for compiling Ada code is made to work,
# the library installation will change and there will be a
# GNAT_RTL_SRCS. Right now we count on being able to build GNATRTL_OBJS
# from ADA_INCLUDE_SRCS.
-# Objects needed only for tasking
-GNATRTL_TASKING_OBJS= \
- a-dynpri.o \
- a-interr.o \
- a-intsig.o \
- a-intnam.o \
- a-reatim.o \
- a-retide.o \
- a-sytaco.o \
- a-taside.o \
- g-thread.o \
- s-asthan.o \
- s-inmaop.o \
- s-interr.o \
- s-intman.o \
- s-osinte.o \
- s-proinf.o \
- s-taenca.o \
- s-taprob.o \
- s-taprop.o \
- s-tarest.o \
- s-tasdeb.o \
- s-tasinf.o \
- s-tasini.o \
- s-taskin.o \
- s-taspri.o \
- s-tasque.o \
- s-tasres.o \
- s-tasren.o \
- s-tassta.o \
- s-tasuti.o \
- s-taasde.o \
- s-tadeca.o \
- s-tadert.o \
- s-tataat.o \
- s-tpinop.o \
- s-tpoben.o \
- s-tpobop.o \
- s-tposen.o \
- s-tratas.o $(EXTRA_GNATRTL_TASKING_OBJS)
-
-# Objects needed for non-tasking.
-GNATRTL_NONTASKING_OBJS= \
- a-caldel.o \
- a-calend.o \
- a-chahan.o \
- a-charac.o \
- a-chlat1.o \
- a-chlat9.o \
- a-colien.o \
- a-colire.o \
- a-comlin.o \
- a-cwila1.o \
- a-cwila9.o \
- a-decima.o \
- a-einuoc.o \
- a-except.o \
- a-exctra.o \
- a-filico.o \
- a-finali.o \
- a-flteio.o \
- a-fwteio.o \
- a-inteio.o \
- a-ioexce.o \
- a-iwteio.o \
- a-lfteio.o \
- a-lfwtio.o \
- a-liteio.o \
- a-liwtio.o \
- a-llftio.o \
- a-llfwti.o \
- a-llitio.o \
- a-lliwti.o \
- a-ncelfu.o \
- a-nlcefu.o \
- a-nlcoty.o \
- a-nlelfu.o \
- a-nllcef.o \
- a-nllcty.o \
- a-nllefu.o \
- a-nscefu.o \
- a-nscoty.o \
- a-nselfu.o \
- a-nucoty.o \
- a-nuelfu.o \
- a-nuflra.o \
- a-numaux.o \
- a-numeri.o \
- a-sfteio.o \
- a-sfwtio.o \
- a-siteio.o \
- a-siwtio.o \
- a-ssicst.o \
- a-ssitio.o \
- a-ssiwti.o \
- a-stmaco.o \
- a-strbou.o \
- a-stream.o \
- a-strfix.o \
- a-string.o \
- a-strmap.o \
- a-strsea.o \
- a-strunb.o \
- a-ststio.o \
- a-stunau.o \
- a-stwibo.o \
- a-stwifi.o \
- a-stwima.o \
- a-stwise.o \
- a-stwiun.o \
- a-suteio.o \
- a-swuwti.o \
- a-swmwco.o \
- a-tags.o \
- a-teioed.o \
- a-textio.o \
- a-ticoau.o \
- a-tideau.o \
- a-tienau.o \
- a-tiflau.o \
- a-tigeau.o \
- a-tiinau.o \
- a-timoau.o \
- a-tiocst.o \
- a-titest.o \
- a-witeio.o \
- a-wtcoau.o \
- a-wtcstr.o \
- a-wtdeau.o \
- a-wtedit.o \
- a-wtenau.o \
- a-wtflau.o \
- a-wtgeau.o \
- a-wtinau.o \
- a-wtmoau.o \
- a-wttest.o \
- ada.o \
- calendar.o \
- g-awk.o \
- g-busora.o \
- g-calend.o \
- g-casuti.o \
- g-catiio.o \
- g-cgi.o \
- g-cgicoo.o \
- g-cgideb.o \
- g-comlin.o \
- g-crc32.o \
- g-curexc.o \
- g-debuti.o \
- g-debpoo.o \
- g-diopit.o \
- g-dirope.o \
- g-except.o \
- g-exctra.o \
- g-expect.o \
- g-flocon.o \
- g-hesora.o \
- g-htable.o \
- g-io.o \
- g-io_aux.o \
- g-locfil.o \
- g-md5.o \
- g-moreex.o \
- g-os_lib.o \
- g-regexp.o \
- g-regpat.o \
- g-soccon.o \
- g-socket.o \
- g-socthi.o \
- g-soliop.o \
- g-souinf.o \
- g-speche.o \
- g-spipat.o \
- g-spitbo.o \
- g-sptabo.o \
- g-sptain.o \
- g-sptavs.o \
- g-tasloc.o \
- g-traceb.o \
- gnat.o \
- i-c.o \
- i-cexten.o \
- i-cobol.o \
- i-cpp.o \
- i-cstrea.o \
- i-cstrin.o \
- i-fortra.o \
- i-pacdec.o \
- interfac.o \
- ioexcept.o \
- machcode.o \
- s-addima.o \
- s-arit64.o \
- s-assert.o \
- s-auxdec.o \
- s-bitops.o \
- s-chepoo.o \
- s-crc32.o \
- s-direio.o \
- s-errrep.o \
- s-except.o \
- s-exctab.o \
- s-exnflt.o \
- s-exngen.o \
- s-exnint.o \
- s-exnlfl.o \
- s-exnlin.o \
- s-exnllf.o \
- s-exnlli.o \
- s-exnsfl.o \
- s-exnsin.o \
- s-exnssi.o \
- s-expflt.o \
- s-expgen.o \
- s-expint.o \
- s-explfl.o \
- s-explin.o \
- s-expllf.o \
- s-explli.o \
- s-expllu.o \
- s-expmod.o \
- s-expsfl.o \
- s-expsin.o \
- s-expssi.o \
- s-expuns.o \
- s-fatflt.o \
- s-fatlfl.o \
- s-fatllf.o \
- s-fatsfl.o \
- s-ficobl.o \
- s-fileio.o \
- s-finimp.o \
- s-finroo.o \
- s-fore.o \
- s-imgbiu.o \
- s-imgboo.o \
- s-imgcha.o \
- s-imgdec.o \
- s-imgenu.o \
- s-imgint.o \
- s-imgllb.o \
- s-imglld.o \
- s-imglli.o \
- s-imgllu.o \
- s-imgllw.o \
- s-imgrea.o \
- s-imguns.o \
- s-imgwch.o \
- s-imgwiu.o \
- s-io.o \
- s-gloloc.o \
- s-maccod.o \
- s-mantis.o \
- s-mastop.o \
- s-osprim.o \
- s-pack03.o \
- s-pack05.o \
- s-pack06.o \
- s-pack07.o \
- s-pack09.o \
- s-pack10.o \
- s-pack11.o \
- s-pack12.o \
- s-pack13.o \
- s-pack14.o \
- s-pack15.o \
- s-pack17.o \
- s-pack18.o \
- s-pack19.o \
- s-pack20.o \
- s-pack21.o \
- s-pack22.o \
- s-pack23.o \
- s-pack24.o \
- s-pack25.o \
- s-pack26.o \
- s-pack27.o \
- s-pack28.o \
- s-pack29.o \
- s-pack30.o \
- s-pack31.o \
- s-pack33.o \
- s-pack34.o \
- s-pack35.o \
- s-pack36.o \
- s-pack37.o \
- s-pack38.o \
- s-pack39.o \
- s-pack40.o \
- s-pack41.o \
- s-pack42.o \
- s-pack43.o \
- s-pack44.o \
- s-pack45.o \
- s-pack46.o \
- s-pack47.o \
- s-pack48.o \
- s-pack49.o \
- s-pack50.o \
- s-pack51.o \
- s-pack52.o \
- s-pack53.o \
- s-pack54.o \
- s-pack55.o \
- s-pack56.o \
- s-pack57.o \
- s-pack58.o \
- s-pack59.o \
- s-pack60.o \
- s-pack61.o \
- s-pack62.o \
- s-pack63.o \
- s-parame.o \
- s-parint.o \
- s-pooglo.o \
- s-pooloc.o \
- s-poosiz.o \
- s-powtab.o \
- s-rpc.o \
- s-scaval.o \
- s-secsta.o \
- s-sequio.o \
- s-shasto.o \
- s-sopco3.o \
- s-sopco4.o \
- s-sopco5.o \
- s-stache.o \
- s-stalib.o \
- s-stoele.o \
- s-stopoo.o \
- s-stratt.o \
- s-strops.o \
- s-soflin.o \
- s-memory.o \
- s-traceb.o \
- s-traces.o \
- s-unstyp.o \
- s-vaflop.o \
- s-valboo.o \
- s-valcha.o \
- s-valdec.o \
- s-valenu.o \
- s-valint.o \
- s-vallld.o \
- s-vallli.o \
- s-valllu.o \
- s-valrea.o \
- s-valuns.o \
- s-valuti.o \
- s-valwch.o \
- s-vercon.o \
- s-vmexta.o \
- s-wchcnv.o \
- s-wchcon.o \
- s-wchjis.o \
- s-wchstw.o \
- s-wchwts.o \
- s-widboo.o \
- s-widcha.o \
- s-widenu.o \
- s-widlli.o \
- s-widllu.o \
- s-widwch.o \
- s-wwdcha.o \
- s-wwdenu.o \
- s-wwdwch.o \
- system.o \
- text_io.o $(EXTRA_GNATRTL_NONTASKING_OBJS)
-
-GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) g-trasym.o
+# GNATRTL_NONTASKING_OBJS and GNATRTL_TASKING_OBJS can be found in
+# the following include file:
+
+include $(fsrcdir)/Makefile.rtl
+
+GNATRTL_OBJS = $(GNATRTL_NONTASKING_OBJS) $(GNATRTL_TASKING_OBJS) \
+ g-trasym.o memtrack.o
# Files which are suitable in no run time/hi integrity mode
-HIE_SOURCES = \
+COMPILABLE_HIE_SOURCES= \
system.ads \
ada.ads \
- a-unccon.ads \
- a-uncdea.ads \
gnat.ads \
g-souinf.ads \
interfac.ads \
+ i-c.ads \
s-stoele.ads \
s-stoele.adb \
- unchconv.ads \
- unchdeal.ads \
s-maccod.ads \
s-unstyp.ads \
- s-fatgen.ads \
- s-fatgen.adb \
s-fatflt.ads \
s-fatlfl.ads \
s-fatllf.ads \
@@ -1462,7 +1424,24 @@ HIE_SOURCES = \
s-secsta.ads \
s-secsta.adb \
a-tags.ads \
- a-tags.adb $(EXTRA_HIE_SOURCES)
+ a-tags.adb \
+ a-except.ads \
+ a-except.adb $(EXTRA_HIE_SOURCES)
+
+NON_COMPILABLE_HIE_SOURCES= \
+ a-unccon.ads \
+ a-uncdea.ads \
+ s-fatgen.adb \
+ s-fatgen.ads \
+ unchconv.ads \
+ s-atacco.ads \
+ s-atacco.adb \
+ unchdeal.ads
+
+
+HIE_SOURCES = $(NON_COMPILABLE_HIE_SOURCES) $(COMPILABLE_HIE_SOURCES)
+
+# Object to generate for the HI run time
HIE_OBJS = \
system.o \
@@ -1483,11 +1462,11 @@ HIE_OBJS = \
# Files which are needed in ravenscar mode
-RAVEN_SOURCES = \
- $(HIE_SOURCES) \
+COMPILABLE_RAVEN_SOURCES = \
+$(COMPILABLE_HIE_SOURCES) \
s-parame.ads \
s-parame.adb \
- g-except.ads \
+ s-purexc.ads \
s-osinte.ads \
s-osinte.adb \
s-tasinf.ads \
@@ -1512,14 +1491,22 @@ RAVEN_SOURCES = \
s-tposen.adb \
s-tasres.ads \
s-tarest.ads \
- s-tarest.adb $(EXTRA_RAVEN_SOURCES)
+ s-tarest.adb \
+ a-sytaco.ads \
+ a-sytaco.adb \
+ a-taside.ads \
+ a-taside.adb $(EXTRA_RAVEN_SOURCES)
+
+NON_COMPILABLE_RAVEN_SOURCES= $(NON_COMPILABLE_HIE_SOURCES)
+
+RAVEN_SOURCES = $(NON_COMPILABLE_RAVEN_SOURCES) $(COMPILABLE_RAVEN_SOURCES)
# Objects to generate for the ravenscar run time
RAVEN_OBJS = \
$(HIE_OBJS) \
s-parame.o \
- g-except.o \
+ s-purexc.o \
s-osinte.o \
s-tasinf.o \
s-taspri.o \
@@ -1533,22 +1520,95 @@ RAVEN_OBJS = \
s-taprob.o \
s-tposen.o \
s-tasres.o \
- s-tarest.o $(EXTRA_RAVEN_OBJS)
+ s-tarest.o \
+ a-sytaco.o \
+ a-taside.o $(EXTRA_RAVEN_OBJS)
+
+
+# Files which are needed for the cert level B runtime
+
+COMPILABLE_CERT_LEVEL_B_SOURCES = \
+$(COMPILABLE_HIE_SOURCES) \
+ a-except.adb \
+ a-except.ads \
+ a-exctra.ads \
+ a-exctra.adb \
+ s-init.adb \
+ s-init.ads \
+ s-memory.adb \
+ s-memory.ads \
+ s-osinte.ads \
+ s-soflin.adb \
+ s-soflin.ads \
+ s-stalib.adb \
+ s-stalib.ads \
+ s-thrini.adb \
+ s-thrini.ads \
+ s-assert.adb \
+ s-assert.ads \
+ s-exnint.adb \
+ s-exnint.ads \
+ s-strops.adb \
+ s-strops.ads \
+ s-thread.adb \
+ s-thread.ads \
+ s-traceb.adb \
+ s-traceb.ads \
+ s-traent.ads \
+ s-traent.adb \
+ g-debuti.ads \
+ g-debuti.adb \
+ g-io.adb \
+ g-io.ads \
+ $(EXTRA_CERT_LEVEL_B_SOURCES)
+
+NON_COMPILABLE_CERT_LEVEL_B_SOURCES= \
+ a-excach.adb \
+ s-tiitho.adb \
+ $(NON_COMPILABLE_HIE_SOURCES)
+
+CERT_LEVEL_B_SOURCES = \
+$(NON_COMPILABLE_CERT_LEVEL_B_SOURCES) \
+$(COMPILABLE_CERT_LEVEL_B_SOURCES)
+
+# Objects to generate for the cert level B run time
+
+CERT_LEVEL_B_OBJS = \
+ $(HIE_OBJS) \
+ a-except.o \
+ a-excach.o \
+ s-init.o \
+ s-memory.o \
+ s-soflin.o \
+ s-stalib.o \
+ s-tiitho.o \
+ s-thrini.o \
+ s-traceb.o \
+ s-assert.o \
+ s-exnint.o \
+ s-strops.o \
+ s-thread.o \
+ g-debuti.o \
+ g-io.o \
+ $(EXTRA_CERT_LEVEL_B_OBJS)
+
+# C files for the cert level B run time (without the .c extension)
+
+CERT_LEVEL_B_C_FILES = \
+2raise \
+$(EXTRA_CERT_LEVEL_B_C_FILES)
# Default run time files
-ADA_INCLUDE_DIR = $(libsubdir)/adainclude
-ADA_RTL_OBJ_DIR = $(libsubdir)/adalib
-
ADA_INCLUDE_SRCS =\
ada.ads calendar.ads directio.ads gnat.ads interfac.ads ioexcept.ads \
machcode.ads text_io.ads unchconv.ads unchdeal.ads \
- sequenio.ads system.ads Makefile.adalib memtrack.adb \
+ sequenio.ads system.ads Makefile.adalib Makefile.prolog Makefile.generic \
+ memtrack.adb \
a-*.adb a-*.ads g-*.ad? i-*.ad? \
s-[a-o]*.adb s-[p-z]*.adb \
s-[a-o]*.ads s-[p-z]*.ads
-# Language-independent object files.
LIBGNAT=../rts/libgnat.a
TOOLS_FLAGS_TO_PASS= \
"CC=$(CC)" \
@@ -1559,14 +1619,14 @@ TOOLS_FLAGS_TO_PASS= \
"ADA_INCLUDES=$(ADA_INCLUDES) $(ADA_INCLUDES_FOR_SUBDIR)"\
"libsubdir=$(libsubdir)" \
"exeext=$(exeext)" \
+ "fsrcdir=$(fsrcdir)" \
"srcdir=$(fsrcdir)" \
- "VPATH=$(fsrcdir)" \
"TOOLS_LIBS=$(TOOLS_LIBS) $(TGT_LIB)" \
"GNATMAKE=$(GNATMAKE)" \
"GNATLINK=$(GNATLINK)" \
"GNATBIND=$(GNATBIND)"
-# Build directory for the tools. Let's copy the target dependent
+# Build directory for the tools. Let's copy the target-dependent
# sources using the same mechanism as for gnatlib. The other sources are
# accessed using the vpath directive below
@@ -1599,7 +1659,7 @@ ifeq ($(TOOLSCASE),cross)
vpath %.h ../
endif
-# gnatmake/link tools cannot always be built with gnatmake/link for bootstrap
+# gnatmake/link tools cannot always be built with gnatmake/link for bootstrap
# reasons: gnatmake should be built with a recent compiler, a recent compiler
# may not generate ALI files compatible with an old gnatmake so it is important
# to be able to build gnatmake without a version of gnatmake around. Once
@@ -1610,7 +1670,7 @@ gnattools1: ../stamp-tools ../stamp-gnatlib
TOOLSCASE=native \
../../gnatmake$(exeext) ../../gnatlink$(exeext) ../../gnatbl$(exeext)
-# gnatmake/link can be build with recent gnatmake/link if they are available.
+# gnatmake/link can be built with recent gnatmake/link if they are available.
# This is especially convenient for building cross tools or for rebuilding
# the tools when the original bootstrap has already be done.
gnattools1-re: ../stamp-tools
@@ -1624,79 +1684,123 @@ gnattools2: ../stamp-tools
../../gnatchop$(exeext) ../../gnat$(exeext) ../../gnatkr$(exeext) \
../../gnatls$(exeext) ../../gnatprep$(exeext) \
../../gnatpsta$(exeext) ../../gnatxref$(exeext) \
- ../../gnatfind$(exeext) ../../gnatname$(exeext)
+ ../../gnatfind$(exeext) ../../gnatname$(exeext) \
+ ../../gnatclean$(exeext) \
+ ../../gprcmd$(exeext) ../../gpr2make$(exeext) \
+ $(GNAT_WRAPPER_TOOL)
# These tools are only built for the native version.
gnattools3: ../stamp-tools
# $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \
-# TOOLSCASE=native \
-# top_builddir=../.. ../../gnatmem$(exeext) $(EXTRA_GNATTOOLS)
+# TOOLSCASE=native top_builddir=../../.. \
+# ../../gnatmem$(exeext) $(EXTRA_GNATTOOLS)
-../../gnatchop$(exeext):
+# those tools are only built for the cross version
+gnattools4: ../stamp-tools
+ $(MAKE) -C tools -f ../Makefile $(TOOLS_FLAGS_TO_PASS) \
+ TOOLSCASE=cross top_buildir=../../.. \
+ ../../vxaddr2line$(exeext)
+
+../../gnatchop$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatchop --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatchop
$(GNATLINK) -v gnatchop -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
$(TOOLS_LIBS)
-../../gnat$(exeext):
+../../gnat$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatcmd --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatcmd
- $(GNATLINK) -v gnatcmd -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(GNATLINK) -v gnatcmd -o $@ --GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS)
-../../gnatkr$(exeext):
+../../gnatkr$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatkr --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatkr
$(GNATLINK) -v gnatkr -o $@ --GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS)
-../../gnatls$(exeext):
+../../gnatls$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatls --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatls
$(GNATLINK) -v gnatls -o $@ --GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS)
-../../gnatname$(exeext):
+../../gnatname$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatname --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatname
$(GNATLINK) -v gnatname -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(TOOLS_LIBS)
+
+../../gpr2make$(exeext): ../stamp-tools
+ $(GNATMAKE) -c $(ADA_INCLUDES) gpr2make --GCC="$(CC) $(ALL_ADAFLAGS)"
+ $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gpr2make
+ $(GNATLINK) -v gpr2make -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
+ $(TOOLS_LIBS)
-../../gnatprep$(exeext):
+../../gnatprep$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatprep --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatprep
$(GNATLINK) -v gnatprep -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(TOOLS_LIBS)
-../../gnatpsta$(exeext): deftarg.o
+../../gnatpsta$(exeext): deftarg.o ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatpsta --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatpsta
$(GNATLINK) -v gnatpsta -o $@ --GCC="$(CC) $(ADA_INCLUDES)"\
../targtyps.o deftarg.o $(TOOLS_LIBS)
-../../gnatxref$(exeext):
+../../gnatxref$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatxref --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatxref
$(GNATLINK) -v gnatxref -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
+ $(TOOLS_LIBS)
-../../gnatfind$(exeext):
+../../gnatfind$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatfind --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatfind
$(GNATLINK) -v gnatfind -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
- $(TOOLS_LIBS)
-
-../../gnatmem$(exeext): gmem.o $(SYMDEPS)
- $(GNATMAKE) -c $(ADA_INCLUDES) gnatmem --GCC="$(CC) $(ALL_ADAFLAGS)"
- $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatmem
- $(GNATLINK) -v gnatmem -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
+ $(TOOLS_LIBS)
+
+../../gnatclean$(exeext): ../stamp-tools
+ $(GNATMAKE) -c $(ADA_INCLUDES) gnatclean --GCC="$(CC) $(ALL_ADAFLAGS)"
+ $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatclean
+ $(GNATLINK) -v gnatclean -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
+ $(TOOLS_LIBS)
+
+../../gnatsym$(exeext): ../stamp-tools
+ $(GNATMAKE) -c $(ADA_INCLUDES) gnatsym --GCC="$(CC) $(ALL_ADAFLAGS)"
+ $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatsym
+ $(GNATLINK) -v gnatsym -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
+ $(TOOLS_LIBS)
+
+../../gnatmem$(exeext): ../stamp-tools gmem.o $(SYMDEPS)
+ifeq ($(GMEM_LIB),gmemlib)
+ $(GNATMAKE) -c $(ADA_INCLUDES) gnatmem --GCC="$(CC) $(ALL_ADAFLAGS)"
+ $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatmem
+ $(GNATLINK) -v gnatmem -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
gmem.o $(SYMLIB) $(TOOLS_LIBS)
+endif
-../../gnatdll$(exeext):
+../../gnatdll$(exeext): ../stamp-tools
$(GNATMAKE) -c $(ADA_INCLUDES) gnatdll --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) $(GNATBIND_FLAGS) gnatdll
$(GNATLINK) -v gnatdll -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
$(TOOLS_LIBS)
-gnatmake-re:
+../../gnat_wrapper$(exeext): ../stamp-tools
+ $(GNATMAKE) -c -O2 -gnatpn $(ADA_INCLUDES) gnat_wrapper --GCC="$(CC) $(ALL_ADAFLAGS)"
+ $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnat_wrapper
+ $(GNATLINK) -v gnat_wrapper -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
+ $(TOOLS_LIBS)
+
+../../gprcmd$(exeext): ../stamp-tools
+ $(GNATMAKE) -c $(ADA_INCLUDES) gprcmd --GCC="$(CC) $(ALL_ADAFLAGS)"
+ $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gprcmd
+ $(GNATLINK) -v gprcmd -o $@ --GCC="$(CC) $(ADA_INCLUDES)" $(TOOLS_LIBS)
+
+../../vxaddr2line$(exeext): ../stamp-tools
+ $(GNATMAKE) -c $(ADA_INCLUDES) vxaddr2line --GCC="$(CC) $(ALL_ADAFLAGS)"
+ $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) vxaddr2line
+ $(GNATLINK) -v vxaddr2line -o $@ --GCC="$(CC) $(ADA_INCLUDES)" $(CLIB)
+
+gnatmake-re: ../stamp-tools
$(GNATMAKE) $(ADA_INCLUDES) -u sdefault --GCC="$(CC) $(MOST_ADA_FLAGS)"
$(GNATMAKE) -c $(ADA_INCLUDES) gnatmake --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatmake
@@ -1705,17 +1809,17 @@ gnatmake-re:
# Note the use of the "mv" command in order to allow gnatlink to be linked with
# with the former version of gnatlink itself which cannot override itself.
-gnatlink-re: link.o
+gnatlink-re: ../stamp-tools link.o
$(GNATMAKE) -c $(ADA_INCLUDES) gnatlink --GCC="$(CC) $(ALL_ADAFLAGS)"
$(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatlink
$(GNATLINK) -v gnatlink -o ../../gnatlinknew$(exeext) \
- --GCC="$(CC) $(ADA_INCLUDES)" link.o $(TOOLS_LIBS)
+ --GCC="$(CC) $(ADA_INCLUDES)" link.o $(TOOLS_LIBS)
$(MV) ../../gnatlinknew$(exeext) ../../gnatlink$(exeext)
-
# Needs to be built with CC=gcc
# Since the RTL should be built with the latest compiler, remove the
# stamp target in the parent directory whenever gnat1 is rebuilt
+
# Likewise for the tools
../../gnatmake$(exeext): $(P) b_gnatm.o $(GNATMAKE_OBJS)
$(CC) $(ALL_CFLAGS) $(LDFLAGS) -o $@ b_gnatm.o $(GNATMAKE_OBJS) \
@@ -1729,8 +1833,8 @@ gnatlink-re: link.o
$(CC) -o $@ $(ALL_CFLAGS) $(LDFLAGS) gnatbl.o $(TOOLS_LIBS)
gnatbl.o: gnatbl.c adaint.h
- $(CC) $(ALL_CFLAGS) $(INCLUDES) -c $<
-
+ $(CC) $(ALL_CFLAGS) $(INCLUDES) -c $< $(OUTPUT_OPTION)
+
../stamp-gnatlib:
@if [ ! -f stamp-gnatlib ] ; \
then \
@@ -1746,30 +1850,40 @@ install-gnatlib: ../stamp-gnatlib
# deleting the right one.
-$(MKDIR) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
-$(MKDIR) $(DESTDIR)$(ADA_INCLUDE_DIR)
+ -$(MKDIR) $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
$(RMDIR) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
$(RMDIR) $(DESTDIR)$(ADA_INCLUDE_DIR)
+ $(RMDIR) $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
-$(MKDIR) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
-$(MKDIR) $(DESTDIR)$(ADA_INCLUDE_DIR)
- -$(INSTALL_DATA) rts/Makefile.adalib $(DESTDIR)$(ADA_RTL_OBJ_DIR)
+ -$(MKDIR) $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
+ -$(INSTALL_DATA) rts/Makefile.prolog $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
+ -$(INSTALL_DATA) rts/Makefile.generic $(DESTDIR)$(ADA_SHARE_MAKE_DIR)
for file in rts/*.ali; do \
$(INSTALL_DATA) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
done
+ -$(INSTALL_DATA) rts/g-trasym$(objext) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
-for file in rts/*$(arext);do \
$(INSTALL_DATA) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
done
+# Install the shared libraries, if any, using $(INSTALL) instead
+# of $(INSTALL_DATA). The latter may force a mode inappropriate
+# for shared libraries on some targets, e.g. on HP-UX where the x
+# permission is required.
ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),)
-for file in rts/lib*$(soext);do \
- $(INSTALL_DATA) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
+ $(INSTALL) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
done
else
- -for file in rts/lib*-**$(soext);do \
- $(INSTALL_DATA) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
+ -for file in rts/lib*-*$(soext);do \
+ $(INSTALL) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
done
endif
- -( cd $(DESTDIR)$(ADA_RTL_OBJ_DIR) && \
- $(LN_S) libgnat-*$(soext) libgnat$(soext) )
- -( cd $(DESTDIR)$(ADA_RTL_OBJ_DIR) && \
- $(LN_S) libgnarl-*$(soext) libgnarl$(soext) )
+ if [ -f rts/libgnat-*$(soext) ]; then \
+ (cd $(DESTDIR)$(ADA_RTL_OBJ_DIR) && \
+ $(LN_S) libgnat-*$(soext) libgnat$(soext) && \
+ $(LN_S) libgnarl-*$(soext) libgnarl$(soext)) \
+ fi
# This copy must be done preserving the date on the original file.
for file in rts/*.adb rts/*.ads; do \
$(INSTALL_DATA_DATE) $$file $(DESTDIR)$(ADA_INCLUDE_DIR); \
@@ -1824,22 +1938,24 @@ endif
# is guaranteed to overflow the buffer.
gnatlib: ../stamp-gnatlib1 ../stamp-gnatlib2
-# ../xgcc -B../ -dD -E ../tconfig.h $(INCLUDES) > rts/tconfig.h
$(MAKE) -C rts CC="../../xgcc -B../../" \
INCLUDES="$(INCLUDES_FOR_SUBDIR) -I./../.." \
CFLAGS="$(GNATLIBCFLAGS_FOR_C)" \
- srcdir=$(fsrcdir) VPATH=$(fsrcdir) \
- -f ../Makefile $(LIBGNAT_OBJS) prefix.o
+ srcdir=$(fsrcdir) \
+ -f ../Makefile $(LIBGNAT_OBJS)
$(MAKE) -C rts CC="../../xgcc -B../../" \
- ADA_INCLUDES="$(ADA_INCLUDES_FOR_SUBDIR)" \
- CFLAGS="$(GNATLIBCFLAGS)" ADA_CFLAGS="$(GNATLIBCFLAGS)" \
+ ADA_INCLUDES="" \
+ CFLAGS="$(GNATLIBCFLAGS)" \
ADAFLAGS="$(GNATLIBFLAGS)" \
- srcdir=$(fsrcdir) VPATH=$(fsrcdir) \
+ srcdir=$(fsrcdir) \
-f ../Makefile \
$(GNATRTL_OBJS)
$(RM) rts/libgnat$(arext) rts/libgnarl$(arext)
$(AR) $(AR_FLAGS) rts/libgnat$(arext) \
- $(addprefix rts/,$(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS) prefix.o)
+ $(addprefix rts/,$(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS))
+ ifneq ($(PREFIX_OBJS),)
+ $(AR) $(AR_FLAGS) rts/libgccprefix$(arext) $(PREFIX_OBJS);
+ endif
if $(RANLIB_TEST) ; then $(RANLIB) rts/libgnat$(arext); else true; fi
$(AR) $(AR_FLAGS) rts/libgnarl$(arext) \
$(addprefix rts/,$(GNATRTL_TASKING_OBJS))
@@ -1856,11 +1972,11 @@ HIE_NONE_TARGET_PAIRS=\
a-tags.adb<1atags.adb \
s-secsta.ads<1ssecsta.ads \
s-secsta.adb<1ssecsta.adb \
- i-c.ads<1ic.ads
+ i-c.ads<1ic.ads $(EXTRA_HIE_NONE_TARGET_PAIRS)
-HIE_SUBST:='s/High_Integrity_Mode.*/High_Integrity_Mode : constant Boolean := True;/'
# This target needs RTS_NAME, RTS_SRCS, RTS_TARGET_PAIRS to be set properly
-# it creates a rts with the proper structure and the right target dependent srcs
+# it creates a rts with the proper structure and the right target
+# dependant srcs
prepare-rts:
$(RMDIR) rts-$(RTS_NAME)
$(MKDIR) rts-$(RTS_NAME)
@@ -1868,110 +1984,89 @@ prepare-rts:
$(MKDIR) rts-$(RTS_NAME)/adalib
$(MKDIR) rts-$(RTS_NAME)/adainclude
$(CHMOD) u+w rts-$(RTS_NAME)/*
- $(LN) $(fsrcpfx)$(RTS_NAME).gpr rts-$(RTS_NAME)
+# Generate the project file
+ $(ECHO) "project $(RTS_NAME) is" > rts-$(RTS_NAME)/$(RTS_NAME).gpr
+ $(ECHO) " for Source_Dirs use (\"adainclude\");" \
+ >> rts-$(RTS_NAME)/$(RTS_NAME).gpr
+ $(ECHO) " for Object_Dir use \"adalib\";" \
+ >> rts-$(RTS_NAME)/$(RTS_NAME).gpr
+ $(ECHO) " for Source_List_File use " \
+ >>rts-$(RTS_NAME)/$(RTS_NAME).gpr
+ $(ECHO) " \"rts-$(RTS_NAME)_source_list.txt\";" \
+ >>rts-$(RTS_NAME)/$(RTS_NAME).gpr
+ $(ECHO) " package Builder is" >>rts-$(RTS_NAME)/$(RTS_NAME).gpr
+ $(ECHO) " for Default_Switches (\"Ada\") use (\"-a\");" \
+ >>rts-$(RTS_NAME)/$(RTS_NAME).gpr
+ $(ECHO) " end Builder;" >>rts-$(RTS_NAME)/$(RTS_NAME).gpr
+ $(ECHO) " package Compiler is" >> rts-$(RTS_NAME)/$(RTS_NAME).gpr
+ $(ECHO) " for Default_Switches (\"Ada\") use (\"-nostdinc\");" \
+ >>rts-$(RTS_NAME)/$(RTS_NAME).gpr
+ $(ECHO) " end Compiler;" >>rts-$(RTS_NAME)/$(RTS_NAME).gpr
+ $(ECHO) "end $(RTS_NAME);" >>rts-$(RTS_NAME)/$(RTS_NAME).gpr
+
+ $(foreach f, $(COMPILABLE_SOURCES), \
+ $(ECHO) $(f) >> \
+ rts-$(RTS_NAME)/rts-$(RTS_NAME)_source_list.txt ;) true
# Copy target independent sources
$(foreach f,$(RTS_SRCS), \
- $(LN) $(fsrcpfx)$(f) rts-$(RTS_NAME)/adainclude ;) true
+ $(CP) $(fsrcpfx)$(f) rts-$(RTS_NAME)/adainclude/ ;) true
# Remove files to be replaced by target dependent sources
$(RM) $(foreach PAIR,$(RTS_TARGET_PAIRS), \
rts-$(RTS_NAME)/adainclude/$(word 1,$(subst <, ,$(PAIR))))
# Copy new target dependent sources
$(foreach PAIR,$(RTS_TARGET_PAIRS), \
- $(LN) $(fsrcpfx)$(word 2,$(subst <, ,$(PAIR))) \
+ $(CP) $(fsrcpfx)$(word 2,$(subst <, ,$(PAIR))) \
rts-$(RTS_NAME)/adainclude/$(word 1,$(subst <, ,$(PAIR)));)
-# change system.High_Integrity_Mode to true for the none & ravenscar rts
- ifeq ($(filter-out none ravenscar,$(RTS_NAME)),)
- sed -e $(HIE_SUBST) rts-$(RTS_NAME)/adainclude/system.ads \
- > dummy
- $(MV) dummy rts-$(RTS_NAME)/adainclude/system.ads
- endif
install-rts: force
$(CP) -r rts-$(RTS_NAME) $(DESTDIR)$(libsubdir)/
+rts-zfp: force
+ $(MAKE) $(FLAGS_TO_PASS) prepare-rts \
+ RTS_NAME=zfp RTS_SRCS="$(HIE_SOURCES)" \
+ RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)" \
+ COMPILABLE_SOURCES="$(COMPILABLE_HIE_SOURCES)"
+ -$(GNATMAKE) -Prts-zfp/zfp.gpr --GCC="../../../xgcc -B../../../"
+ $(RM) rts-zfp/adalib/*.o
+ $(CHMOD) a-wx rts-zfp/adalib/*.ali
+
+rts-cert: force
+# First compile the Ada files ...
+ $(MAKE) $(FLAGS_TO_PASS) prepare-rts \
+ RTS_NAME=cert RTS_SRCS="$(CERT_LEVEL_B_SOURCES)" \
+ RTS_TARGET_PAIRS="$(CERT_LEVEL_B_TARGET_PAIRS)" \
+ COMPILABLE_SOURCES="$(COMPILABLE_CERT_LEVEL_B_SOURCES)"
+ -$(GNATMAKE) -Prts-cert/cert.gpr --GCC="../../../xgcc -B../../../"
+ $(CHMOD) a-wx rts-cert/adalib/*.ali
+# ... then the C files. This section will eventually be removed.
+ $(foreach f,$(CERT_LEVEL_B_C_FILES), \
+ $(CP) $(fsrcpfx)$(f).c rts-cert/adainclude/ ;)
+ cd rts-cert/adalib ; \
+ $(foreach f,$(CERT_LEVEL_B_C_FILES), \
+ ../../../$(GCC_FOR_TARGET) -B../../../ $(TARGET_LIBGCC2_CFLAGS) \
+ $(ALL_CFLAGS) $(GNATLIBCFLAGS_FOR_C) -c ../adainclude/$(f).c \
+ -I../adainclude $(INCLUDES_FOR_SUBDIR) -I../../../ ;) \
+ $(AR) $(AR_FLAGS) libgnat$(arext) \
+ $(addsuffix .o,$(CERT_LEVEL_B_C_FILES))
+
rts-none: force
$(MAKE) $(FLAGS_TO_PASS) prepare-rts \
RTS_NAME=none RTS_SRCS="$(HIE_SOURCES)" \
- RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)"
- -$(GNATMAKE) -Prts-none/none.gpr
+ RTS_TARGET_PAIRS="$(HIE_NONE_TARGET_PAIRS)" \
+ COMPILABLE_SOURCES="$(COMPILABLE_HIE_SOURCES)"
+ -$(GNATMAKE) -Prts-none/none.gpr --GCC="../../../xgcc -B../../../"
$(RM) rts-none/adalib/*.o
$(CHMOD) a-wx rts-none/adalib/*.ali
rts-ravenscar: force
$(MAKE) $(FLAGS_TO_PASS) prepare-rts \
RTS_NAME=ravenscar RTS_SRCS="$(RAVEN_SOURCES)" \
- RTS_TARGET_PAIRS="$(HIE_RAVEN_TARGET_PAIRS)"
- -$(GNATMAKE) -Prts-ravenscar/none.gpr
+ RTS_TARGET_PAIRS="$(HIE_RAVEN_TARGET_PAIRS)" \
+ COMPILABLE_SOURCES="$(COMPILABLE_RAVEN_SOURCES)"
+ -$(GNATMAKE) -Prts-ravenscar/ravenscar.gpr \
+ --GCC="../../../xgcc -B../../../"
$(CHMOD) a-wx rts-ravenscar/adalib/*.ali
-internal-hielib: ../stamp-gnatlib1
- sed -e 's/High_Integrity_Mode.*/High_Integrity_Mode : constant Boolean := True;/' rts/system.ads > rts/s.ads
- $(MV) rts/s.ads rts/system.ads
- $(MAKE) -C rts CC="../../xgcc -B../../" \
- ADA_INCLUDES="$(ADA_INCLUDES_FOR_SUBDIR)" \
- CFLAGS="$(GNATLIBCFLAGS)" \
- ADAFLAGS="$(GNATLIBFLAGS)" \
- srcdir=$(fsrcdir) VPATH=$(fsrcdir) \
- -f ../Makefile \
- $(HIE_OBJS)
- $(CHMOD) a-wx rts/*.ali
- $(RM) $(addprefix rts/,$(HIE_OBJS))
- touch ../stamp-gnatlib
-
-hielib:
- $(MAKE) ADA_INCLUDE_SRCS="$(HIE_SOURCES)" LIBGNAT_SRCS="" \
- LIBGNAT_TARGET_PAIRS="a-except.ads<1aexcept.ads \
- a-except.adb<1aexcept.adb \
- a-tags.adb<1atags.adb \
- s-secsta.ads<1ssecsta.ads \
- s-secsta.adb<1ssecsta.adb \
- i-c.ads<1ic.ads" internal-hielib
-
-internal-ravenlib: ../stamp-gnatlib1
- sed -e 's/High_Integrity_Mode.*/High_Integrity_Mode : constant Boolean := True;/' rts/system.ads > rts/s.ads
- $(MV) rts/s.ads rts/system.ads
- $(MAKE) -C rts CC="../../xgcc -B../../" \
- ADA_INCLUDES="$(ADA_INCLUDES_FOR_SUBDIR)" \
- CFLAGS="$(GNATLIBCFLAGS)" \
- ADAFLAGS="$(GNATLIBFLAGS)" \
- srcdir=$(fsrcdir) VPATH=$(fsrcdir) \
- -f ../Makefile \
- $(RAVEN_OBJS)
- $(CHMOD) a-wx rts/*.ali
- touch ../stamp-gnatlib
-
-# Target for building a ravenscar run time for VxWorks/Cert PPC
-ravenppclib:
- $(MAKE) ADA_INCLUDE_SRCS="$(RAVEN_SOURCES)" LIBGNAT_SRCS="" \
- LIBGNAT_TARGET_PAIRS="a-except.ads<1aexcept.ads \
- a-except.adb<1aexcept.adb \
- a-tags.adb<1atags.adb \
- s-secsta.ads<1ssecsta.ads \
- s-secsta.adb<1ssecsta.adb \
- i-c.ads<1ic.ads \
- a-reatim.ads<1areatim.ads \
- a-reatim.adb<1areatim.adb \
- a-retide.adb<1aretide.adb \
- a-interr.adb<1ainterr.adb \
- s-interr.ads<1sinterr.ads \
- s-interr.adb<1sinterr.adb \
- s-taskin.ads<1staskin.ads \
- s-taskin.adb<1staskin.adb \
- s-tarest.adb<1starest.adb \
- s-tposen.ads<1stposen.ads \
- s-tposen.adb<1stposen.adb \
- s-osinte.adb<1sosinte.adb \
- s-taprop.ads<1staprop.ads \
- s-taprop.adb<1staprop.adb \
- a-sytaco.ads<1asytaco.ads \
- a-sytaco.adb<1asytaco.adb \
- a-intnam.ads<4zintnam.ads \
- s-osinte.adb<5zosinte.adb \
- s-osinte.ads<5zosinte.ads \
- s-taspri.ads<5ztaspri.ads \
- s-vxwork.ads<5pvxwork.ads \
- system.ads<5ysystem.ads" internal-ravenlib
-
# Warning: this target assumes that LIBRARY_VERSION has been set correctly.
gnatlib-shared-default:
$(MAKE) $(FLAGS_TO_PASS) \
@@ -1996,15 +2091,38 @@ gnatlib-shared-dual:
GNATLIBFLAGS="$(GNATLIBFLAGS)" \
GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
THREAD_KIND="$(THREAD_KIND)" \
- gnatlib
- $(MV) rts/libgnat$(arext) rts/libgnarl$(arext) .
+ gnatlib-shared-default
+ $(MV) rts/libgna*$(soext) .
$(RM) ../stamp-gnatlib2
$(MAKE) $(FLAGS_TO_PASS) \
GNATLIBFLAGS="$(GNATLIBFLAGS)" \
GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
THREAD_KIND="$(THREAD_KIND)" \
- gnatlib-shared-default
- $(MV) libgnat$(arext) libgnarl$(arext) rts
+ gnatlib
+ $(MV) libgna*$(soext) rts
+
+# Note that on Win32 the auto-import does not work for DLL, so on the
+# platform we have a specific setup. The libgnat.dll contains only
+# non-tasking objects and libgnarl.dll contains tasking and non-tasking
+# objects. A tasking program must be linked with libgnarl.dll only.
+gnatlib-shared-win32:
+ $(MAKE) $(FLAGS_TO_PASS) \
+ GNATLIBFLAGS="$(GNATLIBFLAGS)" \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS) $(TARGET_LIBGCC2_CFLAGS)" \
+ THREAD_KIND="$(THREAD_KIND)" \
+ gnatlib
+ $(RM) rts/libgnat$(soext) rts/libgnarl$(soext)
+ cd rts; ../../xgcc -B../../ -shared $(TARGET_LIBGCC2_CFLAGS) \
+ -o libgnat-$(LIBRARY_VERSION)$(soext) \
+ $(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS) \
+ $(SO_OPTS)libgnat-$(LIBRARY_VERSION)$(soext) $(MISCLIB)
+ cd rts; ../../xgcc -B../../ -shared $(TARGET_LIBGCC2_CFLAGS) \
+ -o libgnarl-$(LIBRARY_VERSION)$(soext) \
+ $(GNATRTL_TASKING_OBJS) \
+ $(SO_OPTS)libgnarl-$(LIBRARY_VERSION)$(soext) \
+ $(THREADSLIB) -Wl,libgnat-$(LIBRARY_VERSION)$(soext)
+ cd rts; $(LN_S) libgnat-$(LIBRARY_VERSION)$(soext) libgnat$(soext)
+ cd rts; $(LN_S) libgnarl-$(LIBRARY_VERSION)$(soext) libgnarl$(soext)
gnatlib-shared-vms:
$(MAKE) $(FLAGS_TO_PASS) \
@@ -2012,23 +2130,28 @@ gnatlib-shared-vms:
GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
THREAD_KIND="$(THREAD_KIND)" \
gnatlib
- $(RM) rts/libgnat$(soext) rts/libgnarl$(soext)
- rm -f rts/*.sym rts/gnatlib_symvec.opt
- make -C rts -f ../Makefile.vms \
- $(patsubst %.obj,%.sym,$(LIBGNAT_OBJS) $(GNATRTL_NONTASKING_OBJS))
- append /new [.rts]*.sym [.rts]gnatlib_symvec.opt
- ../xgcc.exe -g -B../ -nostartfiles -shared --for-linker=/noinform \
- -o rts/libgnat.exe rts/libgnat.olb \
- --for-linker=rts/gnatlib_symvec.opt \
- --for-linker=gsmatch=equal,YY,MMDD
- rm -f rts/*.sym rts/gnatlib_symvec.opt
- make -C rts -f ../Makefile.vms \
- $(patsubst %.obj,%.sym,$(GNATRTL_TASKING_OBJS))
- append /new [.rts]*.sym [.rts]gnatlib_symvec.opt
- ../xgcc.exe -g -B../ -nostartfiles -shared --for-linker=/noinform \
- -o rts/libgnarl.exe rts/libgnarl.olb rts/libgnat.exe \
- --for-linker=rts/gnatlib_symvec.opt \
- --for-linker=gsmatch=equal,YY,MMDD
+ $(RM) rts/libgnat*$(soext) rts/libgnarl*$(soext)
+ cd rts && echo "case_sensitive=yes" > SYMVEC_$$$$.opt && \
+ objdump --syms $(LIBGNAT_OBJS) $(GNATRTL_NONTASKING_OBJS) | \
+ $(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \
+ echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \
+ ../../xgcc -g -B../../ -nostartfiles -shared -shared-libgcc \
+ -o libgnat_s$(soext) libgnat.a \
+ sys\$$library:trace.exe \
+ --for-linker=/noinform \
+ --for-linker=SYMVEC_$$$$.opt \
+ --for-linker=gsmatch=equal,$(GSMATCH_VERSION)
+ cd rts && echo "case_sensitive=yes" > SYMVEC_$$$$.opt && \
+ objdump --syms $(GNATRTL_TASKING_OBJS) | \
+ $(SHLIB_SYMVEC) >> SYMVEC_$$$$.opt && \
+ echo "case_sensitive=NO" >> SYMVEC_$$$$.opt && \
+ ../../xgcc -g -B../../ -nostartfiles -shared -shared-libgcc \
+ -o libgnarl_s$(soext) \
+ libgnarl.a libgnat_s$(soext) \
+ sys\$$library:trace.exe \
+ --for-linker=/noinform \
+ --for-linker=SYMVEC_$$$$.opt \
+ --for-linker=gsmatch=equal,$(GSMATCH_VERSION)
gnatlib-shared:
$(MAKE) $(FLAGS_TO_PASS) \
@@ -2038,82 +2161,57 @@ gnatlib-shared:
TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \
$(GNATLIB_SHARED)
+gnatlib-sjlj: ../stamp-gnatlib1
+ sed -e 's/ZCX_By_Default.*/ZCX_By_Default : constant Boolean := False;/' rts/system.ads > rts/s.ads
+ $(MV) rts/s.ads rts/system.ads
+ $(MAKE) $(FLAGS_TO_PASS) \
+ GNATLIBFLAGS="$(GNATLIBFLAGS)" \
+ GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
+ THREAD_KIND="$(THREAD_KIND)" \
+ TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" gnatlib
+
# .s files for cross-building
gnat-cross: force
- make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp" \
- HOST_CFLAGS= HOST_CC=cc
+ make $(GNAT1_ADA_OBJS) CC="gcc -B../stage1/" CFLAGS="-S -gnatp"
# Compiling object files from source files.
-# Ada language specific files.
+# Note that dependencies on obstack.h are not written
+# because that file is not part of GCC.
+# Dependencies on gvarargs.h are not written
+# because all that file does, when not compiling with GCC,
+# is include the system varargs.h.
b_gnatl.c : $(GNATLINK_OBJS)
- $(GNATBIND) $(ADA_INCLUDES) -o b_gnatl.c gnatlink.ali
+ $(GNATBIND) -C $(ADA_INCLUDES) -o b_gnatl.c gnatlink.ali
b_gnatl.o : b_gnatl.c
b_gnatm.c : $(GNATMAKE_OBJS)
- $(GNATBIND) $(ADA_INCLUDES) -o b_gnatm.c gnatmake.ali
+ $(GNATBIND) -C $(ADA_INCLUDES) -o b_gnatm.c gnatmake.ali
b_gnatm.o : b_gnatm.c
-# force debugging information on s-tasdeb.o so that it is always
-# possible to set conditional breakpoints on tasks.
-
-s-tasdeb.o : s-tasdeb.adb s-tasdeb.ads
- $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) $<
-
-# force debugging information on s-vaflop.o so that it is always
-# possible to call the VAX float debug print routines.
-# force at least -O so that the inline assembly works.
-
-s-vaflop.o : s-vaflop.adb s-vaflop.ads
- $(ADAC) -c -O $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) \
- $(ADA_INCLUDES) $<
-
-# force debugging information on a-except.o so that it is always
-# possible to set conditional breakpoints on exceptions.
-# use -O1 otherwise gdb isn't able to get a full backtrace on mips targets.
-
-a-except.o : a-except.adb a-except.ads
- $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \
- $(ADA_INCLUDES) $<
-
-# force debugging information on s-assert.o so that it is always
-# possible to set breakpoint on assert failures.
-
-s-assert.o : s-assert.adb s-assert.ads a-except.ads
- $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O2 \
- $(ADA_INCLUDES) $<
-
-mdll.o : mdll.adb mdll.ads mdll-file.ads mdll-utl.ads
- $(CC) -c $(ALL_ADAFLAGS) -O2 $(ADA_INCLUDES) $<
-
-mdll-fil.o : mdll-fil.adb mdll.ads mdll-fil.ads
- $(CC) -c $(ALL_ADAFLAGS) -O2 $(ADA_INCLUDES) $<
-
-mdll-utl.o : mdll-utl.adb mdll.ads mdll-utl.ads sdefault.ads types.ads
- $(CC) -c $(ALL_ADAFLAGS) -O2 $(ADA_INCLUDES) $<
-
-# force debugging information and no optimization on s-memory.o so that it
-# is always possible to set breakpoint on __gnat_malloc and __gnat_free
-# this is important for gnatmem using GDB. memtrack.o is built from
-# memtrack.adb, and used by the post-mortem analysis with gnatmem.
-
-s-memory.o : s-memory.adb s-memory.ads memtrack.o
- $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \
- $(ADA_INCLUDES) $<
-
-memtrack.o : memtrack.adb s-memory.ads
- $(ADAC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \
- $(ADA_INCLUDES) $<
+ADA_INCLUDE_DIR = $(libsubdir)/adainclude
+ADA_RTL_OBJ_DIR = $(libsubdir)/adalib
+ADA_SHARE_MAKE_DIR = $(prefix)/share/make
-# Need to keep the frame pointer in this file to pop the stack properly on
-# some targets.
+# force no sibling call optimization on s-traceb.o so the number of stack
+# frames to be skipped when computing a call chain is not modified by
+# optimization. However we can do that only when building the runtime
+# (not the compiler) because the -fno-optimize-sibling-calls exists
+# only in GCC 3.
-traceb.o : traceb.c
- $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 $(ADA_INCLUDES) \
- $<
+ifneq (,$(findstring xgcc,$(CC)))
+NO_SIBLING_ADAFLAGS=-fno-optimize-sibling-calls
+else
+NO_SIBLING_ADAFLAGS=
+endif
+s-traceb.o : s-traceb.adb
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) \
+ $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) \
+ $< $(OUTPUT_OPTION)
+adadecode.o : adadecode.c adadecode.h
aux-io.o : aux-io.c
argv.o : argv.c
cal.o : cal.c
@@ -2121,40 +2219,30 @@ deftarg.o : deftarg.c
errno.o : errno.c
exit.o : raise.h exit.c
expect.o : expect.c
-adafinal.o : raise.h adafinal.c
+final.o : raise.h final.c
gmem.o : gmem.c
link.o : link.c
mkdir.o : mkdir.c
+socket.o : socket.c
sysdep.o : sysdep.c
cio.o : cio.c
- $(CC) -c $(ALL_CFLAGS) $(ALL_ADA_CFLAGS) $(RT_FLAGS) \
- $(ALL_CPPFLAGS) $(INCLUDES) $<
+ $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \
+ $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
init.o : init.c ada.h types.h raise.h
- $(CC) -c $(ALL_CFLAGS) $(ALL_ADA_CFLAGS) $(RT_FLAGS) \
- $(ALL_CPPFLAGS) $(INCLUDES) $<
+ $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \
+ $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
raise.o : raise.c raise.h
- $(CC) -c $(ALL_CFLAGS) $(ALL_ADA_CFLAGS) $(RT_FLAGS) \
- $(ALL_CPPFLAGS) $(INCLUDES) $<
+ $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(RT_FLAGS) \
+ $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
# Need to keep the frame pointer in this file to pop the stack properly on
# some targets.
-tracebak.o : tracebak.c
- $(CC) -c $(ALL_CFLAGS) $(ALL_ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \
- -fno-omit-frame-pointer $<
-
-targtyps.o : targtyps.c $(CONFIG_H) ada.h types.h atree.h nlists.h elists.h \
- uintp.h sinfo.h einfo.h namet.h snames.h stringt.h urealp.h fe.h \
- $(ADA_TREE_H) gigi.h
-
-# Rule to compile prefix.o for the run-time.
-
-prefix.o : $(srcdir)/../prefix.c
- $(CC) -c $(ALL_CFLAGS) $(ALL_ADA_CFLAGS) $(RT_FLAGS) \
- $(ALL_CPPFLAGS) $(INCLUDES) -I$(srcdir)/../.. -I../.. \
- -DPREFIX=\"$(prefix)\" $<
+tracebak.o : tracebak.c tb-alvms.c tb-alvxw.c
+ $(CC) -c $(ALL_CFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) $(INCLUDES) \
+ -fno-omit-frame-pointer $< $(OUTPUT_OPTION)
# In GNU Make, ignore whether `stage*' exists.
.PHONY: stage1 stage2 stage3 stage4 clean realclean TAGS bootstrap
@@ -2164,16 +2252,8 @@ force:
# Gnatlbr is only used on VMS
-GNATLBR_RTL_C_OBJS = adaint.o argv.o cio.o cstreams.o exit.o adafinal.o init.o \
- raise.o sysdep.o tracebak.o
-GNATLBR_C_OBJS = $(GNATLBR_RTL_C_OBJS)
-
-../gnatlbr$(exeext):: sdefault.o $(GNATLBR_C_OBJS) $(EXTRA_GNATTOOLS_OBJS)
- $(RM) $@
-../gnatlbr$(exeext):: force
- $(GNATMAKE) -a --GCC="$(CC)" $(ALL_ADAFLAGS) $(ADA_INCLUDES) \
- --GNATBIND="$(GNATBIND)" --GNATLINK="$(GNATLINK)" \
- -nostdlib $(fsrcpfx)gnatlbr -o $@ \
- -largs --GCC="$(CC) $(ALL_CFLAGS) $(LDFLAGS)" \
- $(GNATLBR_C_OBJS) $(EXTRA_GNATTOOLS_OBJS)
-
+../../gnatlbr$(exeext): ../../prefix.o
+ $(GNATMAKE) -c $(ADA_INCLUDES) gnatlbr --GCC="$(CC) $(ALL_ADAFLAGS)"
+ $(GNATBIND) $(ADA_INCLUDES) $(GNATBIND_FLAGS) gnatlbr
+ $(GNATLINK) -v gnatlbr -o $@ --GCC="$(CC) $(ADA_INCLUDES)" \
+ $(TOOLS_LIBS)
diff --git a/gcc/ada/Makefile.prolog b/gcc/ada/Makefile.prolog
new file mode 100644
index 00000000000..5766fa98ae1
--- /dev/null
+++ b/gcc/ada/Makefile.prolog
@@ -0,0 +1,47 @@
+# Makefile included at the beginning of the makefiles generated by gpr2make
+# to support compilation for multiple languages.
+# See also Makefile.generic
+#
+# Copyright (C) 2001-2002 ACT-Europe
+
+# all reserved variables are saved in <VAR>.saved
+
+BASE_DIR.saved := $(BASE_DIR)
+C_EXT.saved:=$(C_EXT)
+CXX_EXT.saved:=$(CXX_EXT)
+OBJ_EXT.saved:=$(OBJ_EXT)
+SRC_DIRS.saved:=$(SRC_DIRS)
+C_SRCS.saved:=$(C_SRCS)
+CXX_SRCS.saved:=$(CXX_SRCS)
+OBJ_DIR.saved:=$(OBJ_DIR)
+LANGUAGES.saved:=$(LANGUAGES)
+CC.saved:=$(CC)
+CXX.saved:=$(CXX)
+AR_CMD.saved:=$(AR_CMD)
+AR_EXT.saved:=$(AR_EXT)
+GNATMAKE.saved:=$(GNATMAKE)
+ADAFLAGS.saved:=$(ADAFLAGS)
+CFLAGS.saved:=$(CFLAGS)
+CXXFLAGS.saved:=$(CXXFLAGS)
+LIBS.saved:=$(LIBS)
+LDFLAGS.saved:=$(LDFLAGS)
+ADA_SOURCES.saved:=$(ADA_SOURCES)
+EXEC.saved:=$(EXEC)
+EXEC_DIR.saved:=$(EXEC_DIR)
+MAIN.saved:=$(MAIN)
+PROJECT_FILE.saved:=$(PROJECT_FILE)
+DEPS_PROJECTS.saved:=$(DEPS_PROJECTS)
+
+# Default settings
+
+LANGUAGES:=ada
+C_EXT:=.c
+CXX_EXT:=.cc
+AR_EXT=.a
+OBJ_EXT=.o
+
+# Default target is to build (compile/bind/link)
+# Target build is defined in Makefile.generic
+
+default: build
+
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
new file mode 100644
index 00000000000..f44db99ba00
--- /dev/null
+++ b/gcc/ada/Makefile.rtl
@@ -0,0 +1,448 @@
+# Makefile.rtl for GNU Ada Compiler (GNAT).
+# Copyright (C) 2002 Free Software Foundation, Inc.
+
+#This file is part of GCC.
+
+#GCC is free software; you can redistribute it and/or modify
+#it under the terms of the GNU General Public License as published by
+#the Free Software Foundation; either version 2, or (at your option)
+#any later version.
+
+#GCC is distributed in the hope that it will be useful,
+#but WITHOUT ANY WARRANTY; without even the implied warranty of
+#MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+#GNU General Public License for more details.
+
+#You should have received a copy of the GNU General Public License
+#along with GCC; see the file COPYING. If not, write to
+#the Free Software Foundation, 59 Temple Place - Suite 330,
+#Boston, MA 02111-1307, USA.
+
+# This makefile fragment is included into the ada Makefile (both Unix
+# and NT and VMS versions).
+
+# It's purpose is to allow the separate maintainence of the list of
+# GNATRTL objects, which frequently changes.
+
+# Objects needed only for tasking
+GNATRTL_TASKING_OBJS= \
+ a-dynpri$(objext) \
+ a-interr$(objext) \
+ a-intsig$(objext) \
+ a-intnam$(objext) \
+ a-reatim$(objext) \
+ a-retide$(objext) \
+ a-sytaco$(objext) \
+ a-tasatt$(objext) \
+ a-taside$(objext) \
+ g-boubuf$(objext) \
+ g-boumai$(objext) \
+ g-semaph$(objext) \
+ g-thread$(objext) \
+ s-asthan$(objext) \
+ s-inmaop$(objext) \
+ s-interr$(objext) \
+ s-intman$(objext) \
+ s-osinte$(objext) \
+ s-proinf$(objext) \
+ s-taenca$(objext) \
+ s-taprob$(objext) \
+ s-taprop$(objext) \
+ s-tarest$(objext) \
+ s-tasdeb$(objext) \
+ s-tasinf$(objext) \
+ s-tasini$(objext) \
+ s-taskin$(objext) \
+ s-taspri$(objext) \
+ s-tasque$(objext) \
+ s-tasres$(objext) \
+ s-tasren$(objext) \
+ s-tassta$(objext) \
+ s-tasuti$(objext) \
+ s-taasde$(objext) \
+ s-tadeca$(objext) \
+ s-tadert$(objext) \
+ s-tataat$(objext) \
+ s-tpinop$(objext) \
+ s-tpoben$(objext) \
+ s-tpobop$(objext) \
+ s-tposen$(objext) \
+ s-tratas$(objext) $(EXTRA_GNATRTL_TASKING_OBJS)
+
+# Objects needed for non-tasking.
+GNATRTL_NONTASKING_OBJS= \
+ a-caldel$(objext) \
+ a-calend$(objext) \
+ a-chahan$(objext) \
+ a-charac$(objext) \
+ a-chlat1$(objext) \
+ a-chlat9$(objext) \
+ a-colien$(objext) \
+ a-colire$(objext) \
+ a-comlin$(objext) \
+ a-cwila1$(objext) \
+ a-cwila9$(objext) \
+ a-decima$(objext) \
+ a-diocst$(objext) \
+ a-direio$(objext) \
+ a-einuoc$(objext) \
+ a-except$(objext) \
+ a-exctra$(objext) \
+ a-filico$(objext) \
+ a-finali$(objext) \
+ a-flteio$(objext) \
+ a-fwteio$(objext) \
+ a-inteio$(objext) \
+ a-ioexce$(objext) \
+ a-iwteio$(objext) \
+ a-lfteio$(objext) \
+ a-lfwtio$(objext) \
+ a-liteio$(objext) \
+ a-liwtio$(objext) \
+ a-llftio$(objext) \
+ a-llfwti$(objext) \
+ a-llitio$(objext) \
+ a-lliwti$(objext) \
+ a-ncelfu$(objext) \
+ a-ngcefu$(objext) \
+ a-ngcoty$(objext) \
+ a-ngelfu$(objext) \
+ a-nlcefu$(objext) \
+ a-nlcoty$(objext) \
+ a-nlelfu$(objext) \
+ a-nllcef$(objext) \
+ a-nllcty$(objext) \
+ a-nllefu$(objext) \
+ a-nscefu$(objext) \
+ a-nscoty$(objext) \
+ a-nselfu$(objext) \
+ a-nucoty$(objext) \
+ a-nudira$(objext) \
+ a-nuelfu$(objext) \
+ a-nuflra$(objext) \
+ a-numaux$(objext) \
+ a-numeri$(objext) \
+ a-sequio$(objext) \
+ a-sfteio$(objext) \
+ a-sfwtio$(objext) \
+ a-siocst$(objext) \
+ a-siteio$(objext) \
+ a-siwtio$(objext) \
+ a-ssicst$(objext) \
+ a-ssitio$(objext) \
+ a-ssiwti$(objext) \
+ a-stmaco$(objext) \
+ a-storio$(objext) \
+ a-strbou$(objext) \
+ a-stream$(objext) \
+ a-strfix$(objext) \
+ a-string$(objext) \
+ a-strmap$(objext) \
+ a-strsea$(objext) \
+ a-strsup$(objext) \
+ a-strunb$(objext) \
+ a-ststio$(objext) \
+ a-stunau$(objext) \
+ a-stwibo$(objext) \
+ a-stwifi$(objext) \
+ a-stwima$(objext) \
+ a-stwise$(objext) \
+ a-stwisu$(objext) \
+ a-stwiun$(objext) \
+ a-suteio$(objext) \
+ a-swuwti$(objext) \
+ a-swmwco$(objext) \
+ a-tags$(objext) \
+ a-teioed$(objext) \
+ a-textio$(objext) \
+ a-ticoau$(objext) \
+ a-ticoio$(objext) \
+ a-tideau$(objext) \
+ a-tideio$(objext) \
+ a-tienau$(objext) \
+ a-tienio$(objext) \
+ a-tifiio$(objext) \
+ a-tiflau$(objext) \
+ a-tiflio$(objext) \
+ a-tigeau$(objext) \
+ a-tiinau$(objext) \
+ a-tiinio$(objext) \
+ a-timoau$(objext) \
+ a-timoio$(objext) \
+ a-tiocst$(objext) \
+ a-titest$(objext) \
+ a-unccon$(objext) \
+ a-uncdea$(objext) \
+ a-witeio$(objext) \
+ a-wtcoau$(objext) \
+ a-wtcoio$(objext) \
+ a-wtcstr$(objext) \
+ a-wtdeau$(objext) \
+ a-wtdeio$(objext) \
+ a-wtedit$(objext) \
+ a-wtenau$(objext) \
+ a-wtenio$(objext) \
+ a-wtfiio$(objext) \
+ a-wtflau$(objext) \
+ a-wtflio$(objext) \
+ a-wtgeau$(objext) \
+ a-wtinau$(objext) \
+ a-wtinio$(objext) \
+ a-wtmoau$(objext) \
+ a-wtmoio$(objext) \
+ a-wttest$(objext) \
+ ada$(objext) \
+ calendar$(objext) \
+ g-arrspl$(objext) \
+ g-awk$(objext) \
+ g-bubsor$(objext) \
+ g-busora$(objext) \
+ g-busorg$(objext) \
+ g-calend$(objext) \
+ g-casuti$(objext) \
+ g-catiio$(objext) \
+ g-cgi$(objext) \
+ g-cgicoo$(objext) \
+ g-cgideb$(objext) \
+ g-comlin$(objext) \
+ g-comver$(objext) \
+ g-crc32$(objext) \
+ g-ctrl_c$(objext) \
+ g-curexc$(objext) \
+ g-debuti$(objext) \
+ g-debpoo$(objext) \
+ g-diopit$(objext) \
+ g-dirope$(objext) \
+ g-dyntab$(objext) \
+ g-except$(objext) \
+ g-excact$(objext) \
+ g-exctra$(objext) \
+ g-expect$(objext) \
+ g-flocon$(objext) \
+ g-heasor$(objext) \
+ g-hesora$(objext) \
+ g-hesorg$(objext) \
+ g-htable$(objext) \
+ g-io$(objext) \
+ g-io_aux$(objext) \
+ g-locfil$(objext) \
+ g-md5$(objext) \
+ g-memdum$(objext) \
+ g-moreex$(objext) \
+ g-os_lib$(objext) \
+ g-perhas$(objext) \
+ g-pehage$(objext) \
+ g-regexp$(objext) \
+ g-regpat$(objext) \
+ g-soccon$(objext) \
+ g-socket$(objext) \
+ g-socthi$(objext) \
+ g-soliop$(objext) \
+ g-souinf$(objext) \
+ g-speche$(objext) \
+ g-spipat$(objext) \
+ g-spitbo$(objext) \
+ g-sptabo$(objext) \
+ g-sptain$(objext) \
+ g-sptavs$(objext) \
+ g-string$(objext) \
+ g-strspl$(objext) \
+ g-table$(objext) \
+ g-tasloc$(objext) \
+ g-traceb$(objext) \
+ g-wistsp$(objext) \
+ gnat$(objext) \
+ i-c$(objext) \
+ i-cexten$(objext) \
+ i-cobol$(objext) \
+ i-cpoint$(objext) \
+ i-cpp$(objext) \
+ i-cstrea$(objext) \
+ i-cstrin$(objext) \
+ i-fortra$(objext) \
+ i-pacdec$(objext) \
+ interfac$(objext) \
+ ioexcept$(objext) \
+ machcode$(objext) \
+ s-addima$(objext) \
+ s-arit64$(objext) \
+ s-assert$(objext) \
+ s-atacco$(objext) \
+ s-auxdec$(objext) \
+ s-bitops$(objext) \
+ s-boarop$(objext) \
+ s-carsi8$(objext) \
+ s-carun8$(objext) \
+ s-casi16$(objext) \
+ s-casi32$(objext) \
+ s-casi64$(objext) \
+ s-casuti$(objext) \
+ s-caun16$(objext) \
+ s-caun32$(objext) \
+ s-caun64$(objext) \
+ s-chepoo$(objext) \
+ s-crc32$(objext) \
+ s-direio$(objext) \
+ s-errrep$(objext) \
+ s-except$(objext) \
+ s-exctab$(objext) \
+ s-exnint$(objext) \
+ s-exnllf$(objext) \
+ s-exnlli$(objext) \
+ s-expint$(objext) \
+ s-explli$(objext) \
+ s-expllu$(objext) \
+ s-expmod$(objext) \
+ s-expuns$(objext) \
+ s-fatflt$(objext) \
+ s-fatgen$(objext) \
+ s-fatlfl$(objext) \
+ s-fatllf$(objext) \
+ s-fatsfl$(objext) \
+ s-ficobl$(objext) \
+ s-fileio$(objext) \
+ s-finimp$(objext) \
+ s-finroo$(objext) \
+ s-fore$(objext) \
+ s-geveop$(objext) \
+ s-htable$(objext) \
+ s-imgbiu$(objext) \
+ s-imgboo$(objext) \
+ s-imgcha$(objext) \
+ s-imgdec$(objext) \
+ s-imgenu$(objext) \
+ s-imgint$(objext) \
+ s-imgllb$(objext) \
+ s-imglld$(objext) \
+ s-imglli$(objext) \
+ s-imgllu$(objext) \
+ s-imgllw$(objext) \
+ s-imgrea$(objext) \
+ s-imguns$(objext) \
+ s-imgwch$(objext) \
+ s-imgwiu$(objext) \
+ s-io$(objext) \
+ s-gloloc$(objext) \
+ s-maccod$(objext) \
+ s-mantis$(objext) \
+ s-mastop$(objext) \
+ s-osprim$(objext) \
+ s-pack03$(objext) \
+ s-pack05$(objext) \
+ s-pack06$(objext) \
+ s-pack07$(objext) \
+ s-pack09$(objext) \
+ s-pack10$(objext) \
+ s-pack11$(objext) \
+ s-pack12$(objext) \
+ s-pack13$(objext) \
+ s-pack14$(objext) \
+ s-pack15$(objext) \
+ s-pack17$(objext) \
+ s-pack18$(objext) \
+ s-pack19$(objext) \
+ s-pack20$(objext) \
+ s-pack21$(objext) \
+ s-pack22$(objext) \
+ s-pack23$(objext) \
+ s-pack24$(objext) \
+ s-pack25$(objext) \
+ s-pack26$(objext) \
+ s-pack27$(objext) \
+ s-pack28$(objext) \
+ s-pack29$(objext) \
+ s-pack30$(objext) \
+ s-pack31$(objext) \
+ s-pack33$(objext) \
+ s-pack34$(objext) \
+ s-pack35$(objext) \
+ s-pack36$(objext) \
+ s-pack37$(objext) \
+ s-pack38$(objext) \
+ s-pack39$(objext) \
+ s-pack40$(objext) \
+ s-pack41$(objext) \
+ s-pack42$(objext) \
+ s-pack43$(objext) \
+ s-pack44$(objext) \
+ s-pack45$(objext) \
+ s-pack46$(objext) \
+ s-pack47$(objext) \
+ s-pack48$(objext) \
+ s-pack49$(objext) \
+ s-pack50$(objext) \
+ s-pack51$(objext) \
+ s-pack52$(objext) \
+ s-pack53$(objext) \
+ s-pack54$(objext) \
+ s-pack55$(objext) \
+ s-pack56$(objext) \
+ s-pack57$(objext) \
+ s-pack58$(objext) \
+ s-pack59$(objext) \
+ s-pack60$(objext) \
+ s-pack61$(objext) \
+ s-pack62$(objext) \
+ s-pack63$(objext) \
+ s-parame$(objext) \
+ s-parint$(objext) \
+ s-pooglo$(objext) \
+ s-pooloc$(objext) \
+ s-poosiz$(objext) \
+ s-powtab$(objext) \
+ s-purexc$(objext) \
+ s-rident$(objext) \
+ s-rpc$(objext) \
+ s-scaval$(objext) \
+ s-secsta$(objext) \
+ s-sequio$(objext) \
+ s-shasto$(objext) \
+ s-sopco3$(objext) \
+ s-sopco4$(objext) \
+ s-sopco5$(objext) \
+ s-stache$(objext) \
+ s-stalib$(objext) \
+ s-stoele$(objext) \
+ s-stopoo$(objext) \
+ s-stratt$(objext) \
+ s-strops$(objext) \
+ s-soflin$(objext) \
+ s-memory$(objext) \
+ s-memcop$(objext) \
+ s-traceb$(objext) \
+ s-traces$(objext) \
+ s-traent$(objext) \
+ s-unstyp$(objext) \
+ s-vaflop$(objext) \
+ s-valboo$(objext) \
+ s-valcha$(objext) \
+ s-valdec$(objext) \
+ s-valenu$(objext) \
+ s-valint$(objext) \
+ s-vallld$(objext) \
+ s-vallli$(objext) \
+ s-valllu$(objext) \
+ s-valrea$(objext) \
+ s-valuns$(objext) \
+ s-valuti$(objext) \
+ s-valwch$(objext) \
+ s-veboop$(objext) \
+ s-vector$(objext) \
+ s-vercon$(objext) \
+ s-vmexta$(objext) \
+ s-wchcnv$(objext) \
+ s-wchcon$(objext) \
+ s-wchjis$(objext) \
+ s-wchstw$(objext) \
+ s-wchwts$(objext) \
+ s-widboo$(objext) \
+ s-widcha$(objext) \
+ s-widenu$(objext) \
+ s-widlli$(objext) \
+ s-widllu$(objext) \
+ s-widwch$(objext) \
+ s-wwdcha$(objext) \
+ s-wwdenu$(objext) \
+ s-wwdwch$(objext) \
+ system$(objext) \
+ text_io$(objext) $(EXTRA_GNATRTL_NONTASKING_OBJS)
diff --git a/gcc/ada/a-caldel.adb b/gcc/ada/a-caldel.adb
index ee9903a2558..baf763de467 100644
--- a/gcc/ada/a-caldel.adb
+++ b/gcc/ada/a-caldel.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2001 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/a-caldel.ads b/gcc/ada/a-caldel.ads
index 541e6af423f..c2ea1a8aa3a 100644
--- a/gcc/ada/a-caldel.ads
+++ b/gcc/ada/a-caldel.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/a-charac.ads b/gcc/ada/a-charac.ads
index ef378895425..6aca8404a47 100644
--- a/gcc/ada/a-charac.ads
+++ b/gcc/ada/a-charac.ads
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
@@ -13,7 +13,6 @@
-- --
------------------------------------------------------------------------------
-
package Ada.Characters is
pragma Pure (Characters);
diff --git a/gcc/ada/a-colien.ads b/gcc/ada/a-colien.ads
index 21247953ef9..0be92686670 100644
--- a/gcc/ada/a-colien.ads
+++ b/gcc/ada/a-colien.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,6 +31,12 @@
-- --
------------------------------------------------------------------------------
+-- Note: Services offered by this package are guaranteed to be platform
+-- independent as long as no call to GNAT.OS_Lib.Setenv or to C putenv
+-- routine is done. On some platforms the services below will report new
+-- environment variables (e.g. Windows) on some others it will not
+-- (e.g. GNU/Linux and Solaris).
+
package Ada.Command_Line.Environment is
function Environment_Count return Natural;
diff --git a/gcc/ada/a-comlin.adb b/gcc/ada/a-comlin.adb
index b3a31ce3747..fe96ff9d852 100644
--- a/gcc/ada/a-comlin.adb
+++ b/gcc/ada/a-comlin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -31,7 +31,8 @@
-- --
------------------------------------------------------------------------------
-with System;
+with System; use System;
+
package body Ada.Command_Line is
function Arg_Count return Natural;
@@ -43,6 +44,15 @@ package body Ada.Command_Line is
function Len_Arg (Arg_Num : Integer) return Integer;
pragma Import (C, Len_Arg, "__gnat_len_arg");
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Initialized return Boolean;
+ -- Checks to ensure that gnat_argc and gnat_argv have been properly
+ -- initialized. Returns false if not, or if argv / argc are
+ -- unsupported on the target (e.g. VxWorks).
+
--------------
-- Argument --
--------------
@@ -76,6 +86,11 @@ package body Ada.Command_Line is
function Argument_Count return Natural is
begin
+ if not Initialized then
+ -- RM A.15 (11)
+ return 0;
+ end if;
+
if Remove_Args = null then
return Arg_Count - 1;
else
@@ -83,16 +98,35 @@ package body Ada.Command_Line is
end if;
end Argument_Count;
+ -----------------
+ -- Initialized --
+ -----------------
+
+ function Initialized return Boolean is
+ gnat_argv : System.Address;
+ pragma Import (C, gnat_argv, "gnat_argv");
+
+ begin
+ return gnat_argv /= System.Null_Address;
+ end Initialized;
+
------------------
-- Command_Name --
------------------
function Command_Name return String is
- Arg : aliased String (1 .. Len_Arg (0));
-
begin
- Fill_Arg (Arg'Address, 0);
- return Arg;
+ if not Initialized then
+ return "";
+ end if;
+
+ declare
+ Arg : aliased String (1 .. Len_Arg (0));
+
+ begin
+ Fill_Arg (Arg'Address, 0);
+ return Arg;
+ end;
end Command_Name;
end Ada.Command_Line;
diff --git a/gcc/ada/a-diocst.adb b/gcc/ada/a-diocst.adb
index fabaf689475..0e5d99afa95 100644
--- a/gcc/ada/a-diocst.adb
+++ b/gcc/ada/a-diocst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -63,17 +63,21 @@ package body Ada.Direct_IO.C_Streams is
procedure Open
(File : in out File_Type;
- Mode : in File_Mode;
- C_Stream : in FILEs;
- Form : in String := "")
+ Mode : File_Mode;
+ C_Stream : FILEs;
+ Form : String := "";
+ Name : String := "")
is
- File_Control_Block : DIO.Direct_AFCB;
+ Dummy_File_Control_Block : DIO.Direct_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => To_FCB (Mode),
- Name => "",
+ Name => Name,
Form => Form,
Amethod => 'D',
Creat => False,
diff --git a/gcc/ada/a-diocst.ads b/gcc/ada/a-diocst.ads
index e9679065879..339703c31eb 100644
--- a/gcc/ada/a-diocst.ads
+++ b/gcc/ada/a-diocst.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -47,9 +47,10 @@ package Ada.Direct_IO.C_Streams is
procedure Open
(File : in out File_Type;
- Mode : in File_Mode;
- C_Stream : in ICS.FILEs;
- Form : in String := "");
+ Mode : File_Mode;
+ C_Stream : ICS.FILEs;
+ Form : String := "";
+ Name : String := "");
-- Create new file from existing stream
end Ada.Direct_IO.C_Streams;
diff --git a/gcc/ada/a-direio.adb b/gcc/ada/a-direio.adb
index 20d44df0eba..310e24f6102 100644
--- a/gcc/ada/a-direio.adb
+++ b/gcc/ada/a-direio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1998 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- --
@@ -48,7 +48,7 @@ use type System.Direct_IO.Count;
package body Ada.Direct_IO is
- Zeroes : System.Storage_Elements.Storage_Array :=
+ Zeroes : constant System.Storage_Elements.Storage_Array :=
(1 .. System.Storage_Elements.Storage_Offset (Bytes) => 0);
-- Buffer used to fill out partial records.
@@ -60,7 +60,6 @@ package body Ada.Direct_IO is
subtype AP is FCB.AFCB_Ptr;
subtype FP is DIO.File_Type;
- subtype DCount is DIO.Count;
subtype DPCount is DIO.Positive_Count;
function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode);
diff --git a/gcc/ada/a-excach.adb b/gcc/ada/a-excach.adb
new file mode 100644
index 00000000000..c582dac8328
--- /dev/null
+++ b/gcc/ada/a-excach.adb
@@ -0,0 +1,71 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- ADA.EXCEPTIONS.CALL_CHAIN --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Traceback;
+
+separate (Ada.Exceptions)
+procedure Call_Chain (Excep : EOA) is
+
+ Exception_Tracebacks : Integer;
+ pragma Import (C, Exception_Tracebacks, "__gl_exception_tracebacks");
+ -- Boolean indicating whether tracebacks should be stored in exception
+ -- occurrences.
+
+begin
+
+ if Exception_Tracebacks /= 0 and Excep.Num_Tracebacks = 0 then
+
+ -- If Exception_Tracebacks = 0 then the program was not
+ -- compiled for storing tracebacks in exception occurrences
+ -- (-bargs -E switch) so that we do not generate them.
+ --
+ -- If Excep.Num_Tracebacks /= 0 then this is a reraise, no need
+ -- to store a new (wrong) chain.
+
+ -- We ask System.Traceback.Call_Chain to skip 3 frames to ensure that
+ -- itself, ourselves and our caller are not part of the result. Our
+ -- caller is always an exception propagation actor that we don't want
+ -- to see, and it may be part of a separate subunit which pulls it
+ -- outside the AAA/ZZZ range.
+
+ System.Traceback.Call_Chain
+ (Traceback => Excep.Tracebacks'Address,
+ Max_Len => Max_Tracebacks,
+ Len => Excep.Num_Tracebacks,
+ Exclude_Min => Code_Address_For_AAA,
+ Exclude_Max => Code_Address_For_ZZZ,
+ Skip_Frames => 3);
+
+ end if;
+
+end Call_Chain;
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;
diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads
index c9a0b11e1f8..6510f339dcd 100644
--- a/gcc/ada/a-except.ads
+++ b/gcc/ada/a-except.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -41,6 +41,7 @@ pragma Polling (Off);
with System;
with System.Standard_Library;
+with System.Traceback_Entries;
package Ada.Exceptions is
@@ -113,7 +114,7 @@ private
subtype Code_Loc is System.Address;
-- Code location used in building exception tables and for call
- -- addresses when propagating an exception (also traceback table)
+ -- addresses when propagating an exception.
-- Values of this type are created by using Label'Address or
-- extracted from machine states using Get_Code_Loc.
@@ -162,11 +163,6 @@ private
-- calls to Raise_Exception_Always if it can determine this is the case.
-- The Export allows this routine to be accessed from Pure units.
- procedure Raise_No_Msg (E : Exception_Id);
- pragma No_Return (Raise_No_Msg);
- -- Raises an exception with no message with given exception id value.
- -- Abort is deferred before the raise call.
-
procedure Raise_From_Signal_Handler
(E : Exception_Id;
M : SSL.Big_String_Ptr);
@@ -186,15 +182,6 @@ private
-- some other way ask the operating system to return here rather than
-- to the original location.
- procedure Raise_With_C_Msg
- (E : Exception_Id;
- M : SSL.Big_String_Ptr);
- pragma Export (Ada, Raise_With_C_Msg, "ada__exceptions__raise_with_c_msg");
- pragma No_Return (Raise_With_C_Msg);
- -- Raises an exception with with given exception id value and message.
- -- M is a null terminated string with the message to be raised. Abort
- -- is deferred before the raise call.
-
procedure Reraise_Occurrence_Always (X : Exception_Occurrence);
pragma No_Return (Reraise_Occurrence_Always);
-- This differs from Raise_Occurrence only in that the caller guarantees
@@ -209,43 +196,6 @@ private
-- occurrence. This is used in generated code when it is known
-- that abort is already deferred.
- procedure SDP_Table_Build
- (SDP_Addresses : System.Address;
- SDP_Count : Natural;
- Elab_Addresses : System.Address;
- Elab_Addr_Count : Natural);
- pragma Export (C, SDP_Table_Build, "__gnat_SDP_Table_Build");
- -- This is the routine that is called to build and sort the list of
- -- subprogram descriptor pointers. In the normal case it is called
- -- once at the start of execution, but it can also be called as part
- -- of the explicit initialization routine (adainit) when there is no
- -- Ada main program. In particular, in the case where multiple Ada
- -- libraries are present, this routine can be called more than once
- -- for each library, in which case it augments the previously set
- -- table with the new entries specified by the parameters.
- --
- -- SDP_Addresses Address of the start of the list of addresses of
- -- __gnat_unit_name__SDP values constructed for each
- -- unit, (see System.Exceptions).
- --
- -- SDP_Count Number of entries in SDP_Addresses
- --
- -- Elab_Addresses Address of the start of a list of addresses of
- -- generated Ada elaboration routines, as well as
- -- one extra entry for the generated main program.
- -- These are used to generate the dummy SDP's that
- -- mark the outer scope.
- --
- -- Elab_Addr_Count Number of entries in Elab_Addresses
-
- procedure Break_Start;
- pragma Export (C, Break_Start, "__gnat_break_start");
- -- This is a dummy procedure that is called at the start of execution.
- -- Its sole purpose is to provide a well defined point for the placement
- -- of a main program breakpoint. We put the routine in Ada.Exceptions so
- -- that the standard mechanism of always stepping up from breakpoints
- -- within Ada.Exceptions leaves us sitting in the main program.
-
-----------------------
-- Polling Interface --
-----------------------
@@ -275,10 +225,12 @@ private
-- Exception_Occurrence --
--------------------------
+ package TBE renames System.Traceback_Entries;
+
Max_Tracebacks : constant := 50;
-- Maximum number of trace backs stored in exception occurrence
- type Tracebacks_Array is array (1 .. Max_Tracebacks) of Code_Loc;
+ type Tracebacks_Array is array (1 .. Max_Tracebacks) of TBE.Traceback_Entry;
-- Traceback array stored in exception occurrence
type Exception_Occurrence is record
@@ -318,6 +270,11 @@ private
Tracebacks : Tracebacks_Array;
-- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks))
+
+ Private_Data : System.Address := System.Null_Address;
+ -- Field used by low level exception mechanism to store specific data.
+ -- Currently used by the GCC exception mechanism to store a pointer to
+ -- a GNAT_GCC_Exception.
end record;
function "=" (Left, Right : Exception_Occurrence) return Boolean
@@ -339,6 +296,7 @@ private
Exception_Raised => False,
Pid => 0,
Num_Tracebacks => 0,
- Tracebacks => (others => Null_Loc));
+ Tracebacks => (others => TBE.Null_TB_Entry),
+ Private_Data => System.Null_Address);
end Ada.Exceptions;
diff --git a/gcc/ada/a-excpol.adb b/gcc/ada/a-excpol.adb
index 4eab88272d0..feb6d53b9b6 100644
--- a/gcc/ada/a-excpol.adb
+++ b/gcc/ada/a-excpol.adb
@@ -28,7 +28,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/a-exctra.adb b/gcc/ada/a-exctra.adb
index 00a3092e9a3..4028f4443c0 100644
--- a/gcc/ada/a-exctra.adb
+++ b/gcc/ada/a-exctra.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -37,13 +37,13 @@
package body Ada.Exceptions.Traceback is
- function Tracebacks
- (E : Exception_Occurrence)
- return GNAT.Traceback.Tracebacks_Array
- is
+ ----------------
+ -- Tracebacks --
+ ----------------
+
+ function Tracebacks (E : Exception_Occurrence) return Tracebacks_Array is
begin
- return
- GNAT.Traceback.Tracebacks_Array (E.Tracebacks (1 .. E.Num_Tracebacks));
+ return Tracebacks_Array (E.Tracebacks (1 .. E.Num_Tracebacks));
end Tracebacks;
end Ada.Exceptions.Traceback;
diff --git a/gcc/ada/a-exctra.ads b/gcc/ada/a-exctra.ads
index 622db08c778..97a110f2cf2 100644
--- a/gcc/ada/a-exctra.ads
+++ b/gcc/ada/a-exctra.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -35,20 +35,23 @@
-- --
------------------------------------------------------------------------------
--- This package is part of the support for tracebacks on exceptions. It is
--- used ONLY from GNAT.Traceback.Symbolic and is provided to get access to
--- the tracebacks in an exception occurrence. It may not be used directly
--- from the Ada hierarchy (since it references GNAT.Traceback).
+-- This package is part of the support for tracebacks on exceptions.
-with GNAT.Traceback;
+with System.Traceback_Entries;
package Ada.Exceptions.Traceback is
- function Tracebacks
- (E : Exception_Occurrence)
- return GNAT.Traceback.Tracebacks_Array;
+ package TBE renames System.Traceback_Entries;
+
+ subtype Code_Loc is System.Address;
+ -- Code location in executing program
+
+ type Tracebacks_Array is array (Positive range <>) of TBE.Traceback_Entry;
+ -- A traceback array is an array of traceback entries.
+
+ function Tracebacks (E : Exception_Occurrence) return Tracebacks_Array;
-- This function extracts the traceback information from an exception
-- occurrence, and returns it formatted in the manner required for
- -- processing in GNAT.Traceback. See g-traceb.ads for details.
+ -- processing in GNAT.Traceback. See g-traceb.ads for further details.
end Ada.Exceptions.Traceback;
diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb
new file mode 100644
index 00000000000..b88d643092f
--- /dev/null
+++ b/gcc/ada/a-exexda.adb
@@ -0,0 +1,526 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- ADA.EXCEPTIONS.EXCEPTION_DATA --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements; use System.Storage_Elements;
+
+separate (Ada.Exceptions)
+package body Exception_Data is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ 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.
+
+ 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 occurence 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
+
+ -------------------
+ -- 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
+ Last : constant Natural := Integer'Min (Ptr + S'Length, Info'Last);
+
+ begin
+ Info (Ptr + 1 .. Last) := S;
+ Ptr := Last;
+ 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 (TBE.PC_For (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;
+
+ ---------------------------
+ -- 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;
+
+
+ -------------------------
+ -- Set_Exception_C_Msg --
+ -------------------------
+
+ procedure Set_Exception_C_Msg
+ (Id : Exception_Id;
+ Msg1 : Big_String_Ptr;
+ Line : Integer := 0;
+ Msg2 : Big_String_Ptr := null)
+ is
+ Excep : constant EOA := Get_Current_Excep.all;
+ Val : Integer := Line;
+ Remind : Integer;
+ Size : Integer := 1;
+ Ptr : Natural;
+
+ begin
+ Exception_Propagation.Setup_Exception (Excep, Excep);
+ 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
+
+ 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;
+
+ -----------------------
+ -- Set_Exception_Msg --
+ -----------------------
+
+ procedure Set_Exception_Msg
+ (Id : Exception_Id;
+ Message : String)
+ is
+ Len : constant Natural :=
+ Natural'Min (Message'Length, Exception_Msg_Max_Length);
+ First : constant Integer := Message'First;
+ Excep : constant EOA := Get_Current_Excep.all;
+
+ begin
+ Exception_Propagation.Setup_Exception (Excep, Excep);
+ Excep.Exception_Raised := False;
+ Excep.Msg_Length := Len;
+ Excep.Msg (1 .. Len) := Message (First .. First + Len - 1);
+ Excep.Id := Id;
+ Excep.Num_Tracebacks := 0;
+ Excep.Pid := Local_Partition_ID;
+ Excep.Cleanup_Flag := False;
+
+ end Set_Exception_Msg;
+
+ ----------------------------------
+ -- 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;
+
+ procedure Tailored_Exception_Information
+ (X : Exception_Occurrence;
+ Buff : in out String;
+ Last : in out Integer)
+ is
+ begin
+ Append_Info_String (Basic_Exception_Information (X), Buff, Last);
+ Append_Info_String (Tailored_Exception_Traceback (X), Buff, Last);
+ end Tailored_Exception_Information;
+
+end Exception_Data;
diff --git a/gcc/ada/a-exexpr.adb b/gcc/ada/a-exexpr.adb
new file mode 100644
index 00000000000..3d8e44c41d9
--- /dev/null
+++ b/gcc/ada/a-exexpr.adb
@@ -0,0 +1,525 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- ADA.EXCEPTIONS.EXCEPTION_PROPAGATION --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Interfaces;
+
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+
+pragma Warnings (Off);
+-- Since several constructs give warnings in 3.14a1, including unreferenced
+-- variables and pragma Unreferenced itself.
+
+separate (Ada.Exceptions)
+package body Exception_Propagation is
+
+ ------------------------------------------------
+ -- 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
+ (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 Convention (C, Unwind_Reason_Code);
+
+ -- Phase identifiers
+
+ type Unwind_Action is
+ (UA_SEARCH_PHASE,
+ UA_CLEANUP_PHASE,
+ UA_HANDLER_FRAME,
+ UA_FORCE_UNWIND);
+
+ for Unwind_Action use
+ (UA_SEARCH_PHASE => 1,
+ UA_CLEANUP_PHASE => 2,
+ UA_HANDLER_FRAME => 4,
+ UA_FORCE_UNWIND => 8);
+
+ pragma Convention (C, Unwind_Action);
+
+ -- Mandatory common header for any exception object handled by the
+ -- GCC unwinding runtime.
+
+ subtype Exception_Class is Interfaces.Unsigned_64;
+
+ GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#;
+ -- "GNU-Ada\0"
+
+ 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;
+ -- The C++ ABI mandates the common exception header to be at least
+ -- doubleword aligned, and the libGCC implementation actually makes it
+ -- maximally aligned (see unwind.h). We need to match this because:
+
+ -- 1/ We pass pointers to such headers down to the underlying
+ -- libGCC unwinder,
+
+ -- and
+
+ -- 2/ The GNAT_GCC_Exception record below starts with this common
+ -- common header and has a C counterpart which needs to be laid
+ -- out identically in raise.c. If the alignment of the C and Ada
+ -- common headers mismatch, their size may also differ, and the
+ -- layouts may not match anymore.
+
+ ---------------------------------------------------------------
+ -- GNAT specific entities to deal with the GCC eh circuitry --
+ ---------------------------------------------------------------
+
+ -- 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;
+ -- ABI Exception header first.
+
+ Id : Exception_Id;
+ -- GNAT Exception identifier. This is used by the personality
+ -- routine to determine if the context it examines contains a
+ -- handler for the exception beeing propagated.
+
+ Handled_By_Others : Boolean;
+ -- Is this exception handled by "when others" ? This is used by the
+ -- personality routine to determine if an "others" handler in the
+ -- context it examines may catch the exception beeing propagated.
+
+ N_Cleanups_To_Trigger : Integer;
+ -- Number of cleanup only frames encountered in SEARCH phase.
+ -- This is used to control the forced unwinding triggered when
+ -- no handler has been found.
+
+ Next_Exception : EOA;
+ -- Used to create a linked list of exception occurrences.
+ end record;
+
+ pragma Convention (C, GNAT_GCC_Exception);
+
+ type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception;
+
+ function To_GNAT_GCC_Exception is new
+ Unchecked_Conversion (System.Address, GNAT_GCC_Exception_Access);
+
+ procedure Free is new Unchecked_Deallocation
+ (GNAT_GCC_Exception, GNAT_GCC_Exception_Access);
+
+ procedure Free is new Unchecked_Deallocation
+ (Exception_Occurrence, EOA);
+
+ function Remove
+ (Top : EOA;
+ Excep : GNAT_GCC_Exception_Access)
+ return Boolean;
+ -- Remove Excep from the stack starting at Top.
+ -- Return True if Excep was found and removed, false otherwise.
+
+ -- Hooks called when entering/leaving an exception handler for a given
+ -- occurrence, aimed at handling the stack of active occurrences. The
+ -- calls are generated by gigi in tree_transform/N_Exception_Handler.
+
+ procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
+ pragma Export (C, Begin_Handler, "__gnat_begin_handler");
+
+ procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access);
+ pragma Export (C, End_Handler, "__gnat_end_handler");
+
+ function CleanupUnwind_Handler
+ (UW_Version : Integer;
+ UW_Phases : Unwind_Action;
+ UW_Eclass : Exception_Class;
+ UW_Exception : access GNAT_GCC_Exception;
+ UW_Context : System.Address;
+ UW_Argument : System.Address)
+ return Unwind_Reason_Code;
+ -- Hook called at each step of the forced unwinding we perform to
+ -- trigger cleanups found during the propagation of an unhandled
+ -- exception.
+
+ -- GCC runtime functions used. These are C non-void functions, actually,
+ -- but we ignore the return values. See raise.c as to why we are using
+ -- __gnat stubs for these.
+
+ procedure Unwind_RaiseException
+ (UW_Exception : access GNAT_GCC_Exception);
+ pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException");
+
+ procedure Unwind_ForcedUnwind
+ (UW_Exception : access GNAT_GCC_Exception;
+ UW_Handler : System.Address;
+ UW_Argument : System.Address);
+ pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind");
+
+ ------------
+ -- Remove --
+ ------------
+
+ function Remove
+ (Top : EOA;
+ Excep : GNAT_GCC_Exception_Access)
+ return Boolean
+ is
+ Prev : GNAT_GCC_Exception_Access := null;
+ Iter : EOA := Top;
+ GCC_Exception : GNAT_GCC_Exception_Access;
+
+ begin
+ -- Pop stack
+
+ loop
+ pragma Assert (Iter.Private_Data /= System.Null_Address);
+
+ GCC_Exception := To_GNAT_GCC_Exception (Iter.Private_Data);
+
+ if GCC_Exception = Excep then
+ if Prev = null then
+
+ -- Special case for the top of the stack: shift the contents
+ -- of the next item to the top, since top is at a fixed
+ -- location and can't be changed.
+
+ Iter := GCC_Exception.Next_Exception;
+
+ if Iter = null then
+
+ -- Stack is now empty
+
+ Top.Private_Data := System.Null_Address;
+
+ else
+ Save_Occurrence_And_Private (Top.all, Iter.all);
+ Free (Iter);
+ end if;
+
+ else
+ Prev.Next_Exception := GCC_Exception.Next_Exception;
+ Free (Iter);
+ end if;
+
+ Free (GCC_Exception);
+
+ return True;
+ end if;
+
+ exit when GCC_Exception.Next_Exception = null;
+
+ Prev := GCC_Exception;
+ Iter := GCC_Exception.Next_Exception;
+ end loop;
+
+ return False;
+ end Remove;
+
+ ---------------------------
+ -- CleanupUnwind_Handler --
+ ---------------------------
+
+ function CleanupUnwind_Handler
+ (UW_Version : Integer;
+ UW_Phases : Unwind_Action;
+ UW_Eclass : Exception_Class;
+ UW_Exception : access GNAT_GCC_Exception;
+ UW_Context : System.Address;
+ UW_Argument : System.Address)
+ return Unwind_Reason_Code
+ is
+ begin
+ -- Terminate as soon as we know there is nothing more to run. The
+ -- count is maintained by the personality routine.
+
+ if UW_Exception.N_Cleanups_To_Trigger = 0 then
+ Unhandled_Exception_Terminate;
+ end if;
+
+ -- We know there is at least one cleanup further up. Return so that it
+ -- is searched and entered, after which Unwind_Resume will be called
+ -- and this hook will gain control (with an updated count) again.
+
+ return URC_NO_REASON;
+ end CleanupUnwind_Handler;
+
+ ---------------------
+ -- Setup_Exception --
+ ---------------------
+
+ -- Push the current exception occurrence on the stack before overriding it.
+
+ procedure Setup_Exception
+ (Excep : EOA;
+ Current : EOA;
+ Reraised : Boolean := False)
+ is
+ Top : constant EOA := Current;
+ Next : EOA;
+ GCC_Exception : GNAT_GCC_Exception_Access;
+
+ -- Note that we make no use of the Reraised indication at this point.
+
+ -- The information is still passed around just in case of future needs,
+ -- since we've already switched between using/not-using it a number of
+ -- times.
+
+ begin
+ -- If the current exception is not live, the stack is empty and there
+ -- is nothing to do. Note that the stack always appears empty for
+ -- mechanisms that do not require one. For the mechanism we implement
+ -- in this unit, the initial Private_Data allocation for an occurrence
+ -- is issued by Propagate_Exception.
+
+ if Top.Private_Data = System.Null_Address then
+ return;
+ end if;
+
+ -- Shift the contents of the Top of the stack in a freshly allocated
+ -- entry, which leaves the room in the fixed Top entry available for the
+ -- occurrence about to be propagated.
+
+ Next := new Exception_Occurrence;
+ Save_Occurrence_And_Private (Next.all, Top.all);
+
+ -- Allocate Private_Data for the occurrence about to be propagated
+ -- and link everything together.
+
+ GCC_Exception := new GNAT_GCC_Exception;
+ GCC_Exception.Next_Exception := Next;
+
+ Top.Private_Data := GCC_Exception.all'Address;
+
+ end Setup_Exception;
+
+ -------------------
+ -- Begin_Handler --
+ -------------------
+
+ procedure Begin_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
+ begin
+ -- Every necessary operation related to the occurrence stack has
+ -- already been performed by Propagate_Exception. This hook remains for
+ -- potential future necessity in optimizing the overall scheme, as well
+ -- a useful debugging tool.
+ null;
+ end Begin_Handler;
+
+ -----------------
+ -- End_Handler --
+ -----------------
+
+ procedure End_Handler (GCC_Exception : GNAT_GCC_Exception_Access) is
+ Removed : Boolean;
+
+ begin
+ Removed := Remove (Get_Current_Excep.all, GCC_Exception);
+ pragma Assert (Removed);
+ end End_Handler;
+
+ -------------------------
+ -- Propagate_Exception --
+ -------------------------
+
+ -- Build an object suitable for the libgcc processing and call
+ -- Unwind_RaiseException to actually throw, taking care of handling
+ -- the two phase scheme it implements.
+
+ procedure Propagate_Exception (From_Signal_Handler : Boolean) is
+ Excep : EOA := Get_Current_Excep.all;
+ GCC_Exception : GNAT_GCC_Exception_Access;
+
+ begin
+ if Excep.Private_Data = System.Null_Address then
+ GCC_Exception := new GNAT_GCC_Exception;
+ Excep.Private_Data := GCC_Exception.all'Address;
+ else
+ GCC_Exception := To_GNAT_GCC_Exception (Excep.Private_Data);
+ end if;
+
+ -- Fill in the useful flags for the personality routine called for each
+ -- frame via Unwind_RaiseException below.
+
+ GCC_Exception.Id := Excep.Id;
+ GCC_Exception.Handled_By_Others := not Excep.Id.Not_Handled_By_Others;
+ GCC_Exception.N_Cleanups_To_Trigger := 0;
+
+ -- Compute the backtrace for this occurrence if the corresponding
+ -- binder option has been set. Call_Chain takes care of the reraise
+ -- case.
+
+ -- ??? Using Call_Chain here means we are going to walk up the stack
+ -- once only for backtracing purposes before doing it again for the
+ -- propagation per se.
+
+ -- The first inspection is much lighter, though, as it only requires
+ -- partial unwinding of each frame. Additionally, although we could use
+ -- the personality routine to record the addresses while propagating,
+ -- this method has two drawbacks:
+
+ -- 1) the trace is incomplete if the exception is handled since we
+ -- don't walk past the frame with the handler,
+
+ -- and
+
+ -- 2) we would miss the frames for which our personality routine is not
+ -- called, e.g. if C or C++ calls are on the way.
+
+ Call_Chain (Excep);
+
+ -- Perform a standard raise first. If a regular handler is found, it
+ -- will be entered after all the intermediate cleanups have run. If
+ -- there is no regular handler, control will get back to after the
+ -- call, with N_Cleanups_To_Trigger set to the number of frames with
+ -- cleanups found on the way up, and none of these already run.
+
+ Unwind_RaiseException (GCC_Exception);
+
+ -- If we get here we know the exception is not handled, as otherwise
+ -- Unwind_RaiseException arranges for the handler to be entered. Take
+ -- the necessary steps to enable the debugger to gain control while the
+ -- stack is still intact.
+
+ Notify_Unhandled_Exception;
+
+ -- Now, if cleanups have been found, run a forced unwind to trigger
+ -- them. Control should not resume there, as the unwinding hook calls
+ -- Unhandled_Exception_Terminate as soon as the last cleanup has been
+ -- triggered.
+
+ if GCC_Exception.N_Cleanups_To_Trigger /= 0 then
+ Unwind_ForcedUnwind (GCC_Exception,
+ CleanupUnwind_Handler'Address,
+ System.Null_Address);
+ end if;
+
+ -- We get here when there is no handler or cleanup to be run at
+ -- all. The debugger has been notified before the second step above.
+
+ Unhandled_Exception_Terminate;
+ end Propagate_Exception;
+
+ -----------
+ -- Notes --
+ -----------
+
+ -- The current model implemented for the stack of occurrences is a
+ -- simplification of previous attempts, which all prooved to be flawed or
+ -- would have needed significant additional circuitry to be made to work
+ -- correctly.
+
+ -- We now represent every propagation by a new entry on the stack, which
+ -- means that an exception occurrence may appear more than once (e.g. when
+ -- it is reraised during the course of its own handler).
+
+ -- This may seem overcostly compared to the C++ model as implemented in
+ -- the g++ v3 libstd. This is actually understandable when one considers
+ -- the extra variations of possible run-time configurations induced by the
+ -- freedom offered by the Save_Occurrence/Reraise_Occurrence public
+ -- interface.
+
+ -- The basic point is that arranging for an occurrence to always appear at
+ -- most once on the stack requires a way to determine if a given occurence
+ -- is already there, which is not as easy as it might seem.
+
+ -- An attempt was made to use the Private_Data pointer for this purpose.
+ -- It did not work because:
+
+ -- 1/ The Private_Data has to be saved by Save_Occurrence to be usable
+ -- as a key in case of a later reraise,
+
+ -- 2/ There is no easy way to synchronize End_Handler for an occurrence
+ -- and the data attached to potential copies, so these copies may end
+ -- up pointing to stale data. Moreover ...
+
+ -- 3/ The same address may be reused for different occurrences, which
+ -- defeats the idea of using it as a key.
+
+ -- The example below illustrates:
+
+ -- Saved_CE : Exception_Occurrence;
+ --
+ -- begin
+ -- raise Constraint_Error;
+ -- exception
+ -- when CE: others =>
+ -- Save_Occurrence (Saved_CE, CE); <= Saved_CE.PDA = CE.PDA
+ -- end;
+ --
+ -- <= Saved_CE.PDA is stale (!)
+ --
+ -- begin
+ -- raise Program_Error; <= Saved_CE.PDA = PE.PDA (!!)
+ -- exception
+ -- when others =>
+ -- Reraise_Occurrence (Saved_CE);
+ -- end;
+
+ -- Not releasing the Private_Data via End_Handler could be an option,
+ -- but making this to work while still avoiding memory leaks is far
+ -- from trivial.
+
+ -- The current scheme has the advantage of beeing simple, and induces
+ -- extra costs only in reraise cases which is acceptable.
+
+end Exception_Propagation;
diff --git a/gcc/ada/a-exextr.adb b/gcc/ada/a-exextr.adb
new file mode 100644
index 00000000000..0ddb2934885
--- /dev/null
+++ b/gcc/ada/a-exextr.adb
@@ -0,0 +1,327 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- ADA.EXCEPTIONS.EXCEPTION_TRACES --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+
+separate (Ada.Exceptions)
+package body Exception_Traces is
+
+ Nline : constant String := String'(1 => ASCII.LF);
+ -- Convenient shortcut
+
+ type Exception_Action is access procedure (E : Exception_Occurrence);
+ Global_Action : Exception_Action := null;
+ pragma Export
+ (Ada, Global_Action, "__gnat_exception_actions_global_action");
+ -- Global action, executed whenever an exception is raised. Changing the
+ -- export name must be coordinated with code in g-excact.adb.
+
+ Raise_Hook_Initialized : Boolean := False;
+ pragma Export
+ (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized");
+
+ function To_Action is new Unchecked_Conversion
+ (Raise_Action, Exception_Action);
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean);
+ -- Factorizes the common processing for Notify_Handled_Exception and
+ -- Notify_Unhandled_Exception. Is_Unhandled is set to True only in the
+ -- latter case because Notify_Handled_Exception may be called for an
+ -- actually unhandled occurrence in the Front-End-SJLJ case.
+
+ 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.
+
+ ---------------------------------
+ -- Debugger Interface Routines --
+ ---------------------------------
+
+ -- 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 Unhandled_Exception;
+ pragma Export (C, Unhandled_Exception, "__gnat_unhandled_exception");
+ -- Hook for GDB to support "break exception unhandled".
+
+ -- For "break exception", GDB uses __gnat_raise_nodefer_with_msg, which
+ -- is not in this section because it fullfills other purposes than a mere
+ -- debugger interface.
+
+ --------------------------------
+ -- Import Run-Time C Routines --
+ --------------------------------
+
+ -- The purpose of the following pragma Import 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 Propagate_Exceptions;
+
+ procedure Unhandled_Terminate;
+ pragma No_Return (Unhandled_Terminate);
+ pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate");
+ -- Perform system dependent shutdown code
+
+ ----------------------
+ -- Notify_Exception --
+ ----------------------
+
+ procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean) is
+ begin
+ -- Output the exception information required by the Exception_Trace
+ -- configuration. Take care not to output information about internal
+ -- exceptions.
+
+ -- ??? In the Front-End 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 not Excep.Id.Not_Handled_By_Others
+ and then
+ (Exception_Trace = Every_Raise
+ or else (Exception_Trace = Unhandled_Raise and then Is_Unhandled))
+ then
+ To_Stderr (Nline);
+
+ if Is_Unhandled then
+ To_Stderr ("Unhandled ");
+ end if;
+
+ To_Stderr ("Exception raised");
+ To_Stderr (Nline);
+ To_Stderr (Tailored_Exception_Information (Excep.all));
+ end if;
+
+ -- Call the user-specific actions
+ -- ??? We should presumably look at the reraise status here.
+
+ if Raise_Hook_Initialized
+ and then Exception_Data_Ptr (Excep.Id).Raise_Hook /= null
+ then
+ To_Action (Exception_Data_Ptr (Excep.Id).Raise_Hook) (Excep.all);
+ end if;
+
+ if Global_Action /= null then
+ Global_Action (Excep.all);
+ end if;
+ end Notify_Exception;
+
+ ------------------------------
+ -- Notify_Handled_Exception --
+ ------------------------------
+
+ procedure Notify_Handled_Exception is
+ begin
+ Notify_Exception (Get_Current_Excep.all, Is_Unhandled => False);
+ end Notify_Handled_Exception;
+
+ --------------------------------
+ -- Notify_Unhandled_Exception --
+ --------------------------------
+
+ procedure Notify_Unhandled_Exception is
+ begin
+ Notify_Exception (Get_Current_Excep.all, Is_Unhandled => True);
+ Unhandled_Exception;
+ end Notify_Unhandled_Exception;
+
+ -------------------------
+ -- Unhandled_Exception --
+ -------------------------
+
+ procedure Unhandled_Exception is
+ begin
+ null;
+ end Unhandled_Exception;
+
+ -----------------------------------
+ -- Unhandled_Exception_Terminate --
+ -----------------------------------
+
+ 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 := Excep.Msg (1 .. Excep.Msg_Length);
+
+ Max_Static_Exc_Info : constant := 1024;
+ -- That should be enough for most exception information cases
+ -- eventhough tailorising introduces some uncertainty. the
+ -- name+message should not exceed 320 chars, so that leaves at
+ -- least 35 backtrace slots (each slot needs 19 chars for
+ -- representing a 64 bit address).
+ -- And what happens on overflow ???
+
+ subtype Exc_Info_Type is String (1 .. Max_Static_Exc_Info);
+ type Str_Ptr is access Exc_Info_Type;
+ Exc_Info : Str_Ptr;
+ Exc_Info_Last : Natural := 0;
+ -- Buffer that is allocated to store the tailored exception
+ -- information while Adafinal is run. This buffer is allocated
+ -- on the heap only when it is needed. It is better to allocate
+ -- on the heap than on the stack since stack overflows are more
+ -- common that heap overflows.
+
+ -- Start of processing for Unhandled_Exception_Terminate
+
+ begin
+ -- First allocate & store the exception info in a buffer when
+ -- we know it will be needed. This needs to be done before
+ -- Adafinal because it implicitly uses the secondary stack.
+
+ if Excep.Id.Full_Name.all (1) /= '_'
+ and then Excep.Num_Tracebacks /= 0
+ then
+ Exc_Info := new Exc_Info_Type;
+ if Exc_Info /= null then
+ Tailored_Exception_Information
+ (Excep.all, Exc_Info.all, Exc_Info_Last);
+ end if;
+ end if;
+
+ -- Let's shutdown the runtime now. The rest of the procedure
+ -- needs to be careful not to use anything that would require
+ -- runtime support. In particular, function returing strings
+ -- are banned since the sec stack is not functional anymore
+
+ System.Standard_Library.Adafinal;
+
+ -- 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 Excep.Id.Full_Name.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 (Excep.Id.Full_Name.all (1 .. Excep.Id.Name_Length - 1));
+
+ if Msg'Length /= 0 then
+ To_Stderr (" : ");
+ To_Stderr (Msg);
+ end if;
+
+ To_Stderr (Nline);
+
+ else
+ -- Traceback exists
+
+ -- Note we can have this whole information output twice if
+ -- this occurrence gets reraised up to here.
+
+ To_Stderr (Nline);
+ To_Stderr ("Execution terminated by unhandled exception");
+ To_Stderr (Nline);
+ To_Stderr (Exc_Info (1 .. Exc_Info_Last));
+ end if;
+
+ Unhandled_Terminate;
+ end Unhandled_Exception_Terminate;
+
+ ---------------
+ -- 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;
+
+
+ ------------------------------------
+ -- Handling GNAT.Exception_Traces --
+ ------------------------------------
+
+ -- The bulk of exception traces output is centralized in Notify_Exception,
+ -- for both the Handled and Unhandled cases. Extra task specific output is
+ -- triggered in the task wrapper for unhandled occurrences in tasks. It is
+ -- not performed in this unit to avoid dragging dependencies against the
+ -- tasking units here.
+
+ -- We used to rely on the output performed by Unhanded_Exception_Terminate
+ -- for the case of an unhandled occurrence in the environment thread, and
+ -- the task wrapper was responsible for the whole output in the tasking
+ -- case.
+
+ -- This initial scheme had a drawback: the output from Terminate only
+ -- occurs after finalization is done, which means possibly never if some
+ -- tasks keep hanging around.
+
+ -- The first "presumably obvious" fix consists in moving the Terminate
+ -- output before the finalization. It has not been retained because it
+ -- introduces annoying changes in output orders when the finalization
+ -- itself issues outputs, this also in "regular" cases not resorting to
+ -- Exception_Traces.
+
+ -- Today's solution has the advantage of simplicity and better isolates
+ -- the Exception_Traces machinery.
+
+ -- It currently outputs the information about unhandled exceptions twice
+ -- in the environment thread, once in the notification routine and once in
+ -- the termination routine. Avoiding the second output is possible but so
+ -- far has been considered undesirable. It would mean changing the order
+ -- of outputs between the two runs with or without exception traces, while
+ -- it seems preferrable to only have additional outputs in the former
+ -- case.
+
+end Exception_Traces;
diff --git a/gcc/ada/a-exstat.adb b/gcc/ada/a-exstat.adb
new file mode 100644
index 00000000000..e840418c7e7
--- /dev/null
+++ b/gcc/ada/a-exstat.adb
@@ -0,0 +1,255 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- ADA.EXCEPTIONS.STREAM_ATTRIBUTES --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Exception_Table; use System.Exception_Table;
+with System.Storage_Elements; use System.Storage_Elements;
+
+separate (Ada.Exceptions)
+package body Stream_Attributes 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;
+
+ ------------------
+ -- EO_To_String --
+ ------------------
+
+ -- 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;
+
+ -------------------
+ -- 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;
+
+ ------------------
+ -- String_To_EO --
+ ------------------
+
+ function String_To_EO (S : String) return Exception_Occurrence is
+ From : Natural;
+ To : Integer;
+
+ X : aliased 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");
+
+ -- The following junk raise of Program_Error is required because
+ -- this is a No_Return function, and unfortunately Raise_Exception
+ -- can return (this particular call can't, but the back end is not
+ -- clever enough to know that).
+
+ raise Program_Error;
+ 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) :=
+ TBE.TB_Entry_For (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;
+
+end Stream_Attributes;
diff --git a/gcc/ada/a-filico.adb b/gcc/ada/a-filico.adb
index 745ba8475b2..7f953bff653 100644
--- a/gcc/ada/a-filico.adb
+++ b/gcc/ada/a-filico.adb
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
diff --git a/gcc/ada/a-interr.adb b/gcc/ada/a-interr.adb
index 5ab89c18b67..72e42a8f8a7 100644
--- a/gcc/ada/a-interr.adb
+++ b/gcc/ada/a-interr.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2001 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/a-intsig.adb b/gcc/ada/a-intsig.adb
index a2451afe6e2..44e658a4328 100644
--- a/gcc/ada/a-intsig.adb
+++ b/gcc/ada/a-intsig.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,10 +27,10 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
---
+
with System.Interrupt_Management.Operations;
package body Ada.Interrupts.Signal is
diff --git a/gcc/ada/a-intsig.ads b/gcc/ada/a-intsig.ads
index 5340da13345..750466951b8 100644
--- a/gcc/ada/a-intsig.ads
+++ b/gcc/ada/a-intsig.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,10 +27,10 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
---
+
-- This package encapsulates the procedures for generating interrupts
-- by user programs and avoids importing low level children of System
-- (e.g. System.Interrupt_Management.Operations), or defining an interface
diff --git a/gcc/ada/a-ngcefu.adb b/gcc/ada/a-ngcefu.adb
index 6dbf9be9897..672218a54c6 100644
--- a/gcc/ada/a-ngcefu.adb
+++ b/gcc/ada/a-ngcefu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -305,6 +305,8 @@ package body Ada.Numerics.Generic_Complex_Elementary_Functions is
Result : Complex;
begin
+ -- For very small argument, sin (x) = x.
+
if abs Re (X) < Square_Root_Epsilon and then
abs Im (X) < Square_Root_Epsilon
then
@@ -321,6 +323,8 @@ package body Ada.Numerics.Generic_Complex_Elementary_Functions is
elsif Im (Result) < -PI_2 then
Set_Im (Result, -(PI + Im (X)));
end if;
+
+ return Result;
end if;
Result := -Complex_I * Log (Complex_I * X + Sqrt (1.0 - X * X));
@@ -479,16 +483,15 @@ package body Ada.Numerics.Generic_Complex_Elementary_Functions is
---------
function Exp (X : Complex) return Complex is
- EXP_RE_X : Real'Base := Exp (Re (X));
+ EXP_RE_X : constant Real'Base := Exp (Re (X));
begin
return Compose_From_Cartesian (EXP_RE_X * Cos (Im (X)),
EXP_RE_X * Sin (Im (X)));
end Exp;
-
function Exp (X : Imaginary) return Complex is
- ImX : Real'Base := Im (X);
+ ImX : constant Real'Base := Im (X);
begin
return Compose_From_Cartesian (Cos (ImX), Sin (ImX));
diff --git a/gcc/ada/a-ngcoty.adb b/gcc/ada/a-ngcoty.adb
index 88969061317..c5b27699910 100644
--- a/gcc/ada/a-ngcoty.adb
+++ b/gcc/ada/a-ngcoty.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -54,12 +54,12 @@ package body Ada.Numerics.Generic_Complex_Types is
-- If either component overflows, try to scale.
if abs (X) > R'Last then
- X := R' (4.0) * (R'(Left.Re / 2.0) * R'(Right.Re / 2.0)
+ X := R'(4.0) * (R'(Left.Re / 2.0) * R'(Right.Re / 2.0)
- R'(Left.Im / 2.0) * R'(Right.Im / 2.0));
end if;
if abs (Y) > R'Last then
- Y := R' (4.0) * (R'(Left.Re / 2.0) * R'(Right.Im / 2.0)
+ Y := R'(4.0) * (R'(Left.Re / 2.0) * R'(Right.Im / 2.0)
- R'(Left.Im / 2.0) * R'(Right.Re / 2.0));
end if;
@@ -152,7 +152,7 @@ package body Ada.Numerics.Generic_Complex_Types is
Exp := Exp / 2;
end loop;
- return R ' (1.0) / Result;
+ return R'(1.0) / Result;
exception
@@ -163,7 +163,7 @@ package body Ada.Numerics.Generic_Complex_Types is
end "**";
function "**" (Left : Imaginary; Right : Integer) return Complex is
- M : R := R (Left) ** Right;
+ M : constant R := R (Left) ** Right;
begin
case Right mod 4 is
when 0 => return (M, 0.0);
@@ -619,7 +619,6 @@ package body Ada.Numerics.Generic_Complex_Types is
return abs (X.Im);
end if;
-
elsif Im2 = 0.0 then
return abs (X.Re);
diff --git a/gcc/ada/a-ngelfu.adb b/gcc/ada/a-ngelfu.adb
index d7ae2c8dc2e..c7c526eb32f 100644
--- a/gcc/ada/a-ngelfu.adb
+++ b/gcc/ada/a-ngelfu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -53,20 +53,13 @@ package body Ada.Numerics.Generic_Elementary_Functions is
subtype T is Float_Type'Base;
subtype Double is Aux.Double;
- Two_Pi : constant T := 2.0 * Pi;
- Half_Pi : constant T := Pi / 2.0;
- Fourth_Pi : constant T := Pi / 4.0;
+ Two_Pi : constant T := 2.0 * Pi;
+ Half_Pi : constant T := Pi / 2.0;
- Epsilon : constant T := 2.0 ** (1 - T'Model_Mantissa);
- IEpsilon : constant T := 2.0 ** (T'Model_Mantissa - 1);
- Log_Epsilon : constant T := T (1 - T'Model_Mantissa) * Log_Two;
Half_Log_Epsilon : constant T := T (1 - T'Model_Mantissa) * Half_Log_Two;
Log_Inverse_Epsilon : constant T := T (T'Model_Mantissa - 1) * Log_Two;
Sqrt_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa);
- DEpsilon : constant Double := Double (Epsilon);
- DIEpsilon : constant Double := Double (IEpsilon);
-
-----------------------
-- Local Subprograms --
-----------------------
@@ -563,7 +556,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is
function Cosh (X : Float_Type'Base) return Float_Type'Base is
Lnv : constant Float_Type'Base := 8#0.542714#;
V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4;
- Y : Float_Type'Base := abs X;
+ Y : constant Float_Type'Base := abs X;
Z : Float_Type'Base;
begin
@@ -622,7 +615,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is
else
T := T / Cycle * Two_Pi;
- return Cos (T) / Sin (T);
+ return Cos (T) / Sin (T);
end if;
end Cot;
@@ -861,7 +854,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is
-- an exact value in those cases. It is not clear that
-- this is worth the extra test though.
- return Float_Type'Base (Aux.Sin (Double (T / Cycle * Two_Pi)));
+ return Float_Type'Base (Aux.Sin (Double (T / Cycle * Two_Pi)));
end Sin;
----------
@@ -871,7 +864,7 @@ package body Ada.Numerics.Generic_Elementary_Functions is
function Sinh (X : Float_Type'Base) return Float_Type'Base is
Lnv : constant Float_Type'Base := 8#0.542714#;
V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4;
- Y : Float_Type'Base := abs X;
+ Y : constant Float_Type'Base := abs X;
F : constant Float_Type'Base := Y * Y;
Z : Float_Type'Base;
@@ -1011,8 +1004,8 @@ package body Ada.Numerics.Generic_Elementary_Functions is
Half_Ln3 : constant Float_Type'Base := 0.54930_61443;
P, Q, R : Float_Type'Base;
- Y : Float_Type'Base := abs X;
- G : Float_Type'Base := Y * Y;
+ Y : constant Float_Type'Base := abs X;
+ G : constant Float_Type'Base := Y * Y;
Float_Type_Digits_15_Or_More : constant Boolean :=
Float_Type'Digits > 14;
diff --git a/gcc/ada/a-nudira.adb b/gcc/ada/a-nudira.adb
index 298aecc986c..f3ef91afdf6 100644
--- a/gcc/ada/a-nudira.adb
+++ b/gcc/ada/a-nudira.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1999 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- --
@@ -53,6 +53,10 @@ package body Ada.Numerics.Discrete_Random is
type Pointer is access all State;
Need_64 : constant Boolean := Rst'Pos (Rst'Last) > Int'Last;
+ -- Set if we need more than 32 bits in the result. In practice we will
+ -- only use the meaningful 48 bits of any 64 bit number generated, since
+ -- if more than 48 bits are required, we split the computation into two
+ -- separate parts, since the algorithm does not behave above 48 bits.
-----------------------
-- Local Subprograms --
@@ -109,7 +113,7 @@ package body Ada.Numerics.Discrete_Random is
Temp := Temp + Genp.Q;
end if;
- TF := Offs + (Flt (Temp) * Flt (Genp.P) + Flt (Genp.X1)) * Genp.Scl;
+ TF := Offs + (Flt (Temp) * Flt (Genp.P) + Flt (Genp.X1)) * Genp.Scl;
-- Pathological, but there do exist cases where the rounding implicit
-- in calculating the scale factor will cause rounding to 'Last + 1.
@@ -124,7 +128,6 @@ package body Ada.Numerics.Discrete_Random is
else
return Rst'Val (Int (TF));
end if;
-
end Random;
-----------
@@ -144,7 +147,7 @@ package body Ada.Numerics.Discrete_Random is
X2 := Square_Mod_N (X2, K2);
end loop;
- -- eliminate effects of small Initiators.
+ -- Eliminate effects of small Initiators
Genp.all :=
(X1 => X1,
diff --git a/gcc/ada/a-nudira.ads b/gcc/ada/a-nudira.ads
index 291d8457ef9..58314e03250 100644
--- a/gcc/ada/a-nudira.ads
+++ b/gcc/ada/a-nudira.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -52,6 +52,15 @@ generic
package Ada.Numerics.Discrete_Random is
+ -- The algorithm used here is reliable from a required statistical point
+ -- of view only up to 48 bits. We try to behave reasonably in the case
+ -- of larger types, but we can't guarantee the required properties.
+ -- So generate a warning for these (slightly) dubious cases.
+
+ pragma Compile_Time_Warning
+ (Result_Subtype'Size > 48,
+ "statistical properties not guaranteed for size '> 48");
+
-- Basic facilities.
type Generator is limited private;
@@ -77,7 +86,9 @@ private
subtype Int is Interfaces.Integer_32;
subtype Rst is Result_Subtype;
- type Flt is digits 14;
+ -- We prefer to use 14 digits for Flt, but some targets are more limited
+
+ type Flt is digits Positive'Min (14, Long_Long_Float'Digits);
RstF : constant Flt := Flt (Rst'Pos (Rst'First));
RstL : constant Flt := Flt (Rst'Pos (Rst'Last));
diff --git a/gcc/ada/a-nuflra.adb b/gcc/ada/a-nuflra.adb
index e637e5d3042..14d74593af0 100644
--- a/gcc/ada/a-nuflra.adb
+++ b/gcc/ada/a-nuflra.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -213,7 +213,6 @@ package body Ada.Numerics.Float_Random is
X2 := Square_Mod_N (X2, K2);
end loop;
-
Genp.all :=
(X1 => X1,
X2 => X2,
@@ -238,10 +237,11 @@ package body Ada.Numerics.Float_Random is
------------------
function Square_Mod_N (X, N : Int) return Int is
- Temp : Flt := Flt (X) * Flt (X);
- Div : Int := Int (Temp / Flt (N));
+ Temp : constant Flt := Flt (X) * Flt (X);
+ Div : Int;
begin
+ Div := Int (Temp / Flt (N));
Div := Int (Temp - Flt (Div) * Flt (N));
if Div < 0 then
diff --git a/gcc/ada/a-nuflra.ads b/gcc/ada/a-nuflra.ads
index 3ebb822e5c6..dacdd7c5eff 100644
--- a/gcc/ada/a-nuflra.ads
+++ b/gcc/ada/a-nuflra.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -43,8 +43,7 @@
-- excellent randomness properties. For further details, see the
-- paper "Fast Generation of Trustworthy Random Numbers", by Robert
-- Eachus, which describes both the algorithm and the efficient
--- implementation approach used here. This paper is available at
--- the Ada Core Technologies web site (http://www.gnat.com).
+-- implementation approach used here.
with Interfaces;
@@ -75,7 +74,10 @@ package Ada.Numerics.Float_Random is
private
type Int is new Interfaces.Integer_32;
- type Flt is digits 14;
+
+ -- We prefer to use 14 digits for Flt, but some targets are more limited
+
+ type Flt is digits Positive'Min (14, Long_Long_Float'Digits);
K1 : constant := 94_833_359;
K1F : constant := 94_833_359.0;
diff --git a/gcc/ada/a-reatim.adb b/gcc/ada/a-reatim.adb
index 15969d7d456..352119ac5f6 100644
--- a/gcc/ada/a-reatim.adb
+++ b/gcc/ada/a-reatim.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2002, Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,8 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -184,7 +185,7 @@ package body Ada.Real_Time is
if T_Val < 0.5 then
SC := 0;
else
- SC := Seconds_Count (Time_Span' (T_Val - 0.5));
+ SC := Seconds_Count (Time_Span'(T_Val - 0.5));
end if;
if T < 0.0 then
diff --git a/gcc/ada/a-reatim.ads b/gcc/ada/a-reatim.ads
index 43203481d51..ae5249f457c 100644
--- a/gcc/ada/a-reatim.ads
+++ b/gcc/ada/a-reatim.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -47,9 +47,9 @@ package Ada.Real_Time is
type Time_Span is private;
Time_Span_First : constant Time_Span;
- Time_Span_Last : constant Time_Span;
- Time_Span_Zero : constant Time_Span;
- Time_Span_Unit : constant Time_Span;
+ Time_Span_Last : constant Time_Span;
+ Time_Span_Zero : constant Time_Span;
+ Time_Span_Unit : constant Time_Span;
Tick : constant Time_Span;
function Clock return Time;
diff --git a/gcc/ada/a-retide.ads b/gcc/ada/a-retide.ads
index ecee2546283..29e2e8d6c47 100644
--- a/gcc/ada/a-retide.ads
+++ b/gcc/ada/a-retide.ads
@@ -1,4 +1,4 @@
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1999, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/a-sequio.adb b/gcc/ada/a-sequio.adb
index eedcbaad685..90b543a7b03 100644
--- a/gcc/ada/a-sequio.adb
+++ b/gcc/ada/a-sequio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1999, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -183,15 +183,21 @@ package body Ada.Sequential_IO is
RsizS : constant SSE.Storage_Offset :=
SSE.Storage_Offset (Rsiz - 1);
- subtype SA is SSE.Storage_Array (0 .. RsizS);
+ type SA is new SSE.Storage_Array (0 .. RsizS);
+
+ for SA'Alignment use Standard'Maximum_Alignment;
+ -- We will perform an unchecked conversion of a pointer-to-SA
+ -- into pointer-to-Element_Type. We need to ensure that the
+ -- source is always at least as strictly aligned as the target.
+
type SAP is access all SA;
type ItemP is access all Element_Type;
pragma Warnings (Off);
- -- We have to turn warnings off for this function, because
- -- it gets analyzed for all types, including ones which
- -- can't possibly come this way, and for which the size
- -- of the access types differs.
+ -- We have to turn warnings off for function To_ItemP,
+ -- because it gets analyzed for all types, including ones
+ -- which can't possibly come this way, and for which the
+ -- size of the access types differs.
function To_ItemP is new Unchecked_Conversion (SAP, ItemP);
diff --git a/gcc/ada/a-siocst.adb b/gcc/ada/a-siocst.adb
index 23a73c62859..36899453f1a 100644
--- a/gcc/ada/a-siocst.adb
+++ b/gcc/ada/a-siocst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -63,17 +63,21 @@ package body Ada.Sequential_IO.C_Streams is
procedure Open
(File : in out File_Type;
- Mode : in File_Mode;
- C_Stream : in FILEs;
- Form : in String := "")
+ Mode : File_Mode;
+ C_Stream : FILEs;
+ Form : String := "";
+ Name : String := "")
is
- File_Control_Block : SIO.Sequential_AFCB;
+ Dummy_File_Control_Block : SIO.Sequential_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => To_FCB (Mode),
- Name => "",
+ Name => Name,
Form => Form,
Amethod => 'Q',
Creat => False,
diff --git a/gcc/ada/a-siocst.ads b/gcc/ada/a-siocst.ads
index bd1a9601f7b..ab8fe13f21d 100644
--- a/gcc/ada/a-siocst.ads
+++ b/gcc/ada/a-siocst.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -47,9 +47,10 @@ package Ada.Sequential_IO.C_Streams is
procedure Open
(File : in out File_Type;
- Mode : in File_Mode;
- C_Stream : in ICS.FILEs;
- Form : in String := "");
+ Mode : File_Mode;
+ C_Stream : ICS.FILEs;
+ Form : String := "";
+ Name : String := "");
-- Create new file from existing stream
end Ada.Sequential_IO.C_Streams;
diff --git a/gcc/ada/a-ssicst.adb b/gcc/ada/a-ssicst.adb
index e9cefcf0426..3f572be897a 100644
--- a/gcc/ada/a-ssicst.adb
+++ b/gcc/ada/a-ssicst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -61,17 +61,21 @@ package body Ada.Streams.Stream_IO.C_Streams is
procedure Open
(File : in out File_Type;
- Mode : in File_Mode;
- C_Stream : in FILEs;
- Form : in String := "")
+ Mode : File_Mode;
+ C_Stream : FILEs;
+ Form : String := "";
+ Name : String := "")
is
- File_Control_Block : Stream_AFCB;
+ Dummy_File_Control_Block : Stream_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => To_FCB (Mode),
- Name => "",
+ Name => Name,
Form => Form,
Amethod => 'S',
Creat => False,
diff --git a/gcc/ada/a-ssicst.ads b/gcc/ada/a-ssicst.ads
index 198597e1ca5..98166e71d3b 100644
--- a/gcc/ada/a-ssicst.ads
+++ b/gcc/ada/a-ssicst.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -46,9 +46,10 @@ package Ada.Streams.Stream_IO.C_Streams is
procedure Open
(File : in out File_Type;
- Mode : in File_Mode;
- C_Stream : in ICS.FILEs;
- Form : in String := "");
+ Mode : File_Mode;
+ C_Stream : ICS.FILEs;
+ Form : String := "";
+ Name : String := "");
-- Create new file from existing stream
end Ada.Streams.Stream_IO.C_Streams;
diff --git a/gcc/ada/a-strbou.adb b/gcc/ada/a-strbou.adb
index 68351dc445d..886c03ff68a 100644
--- a/gcc/ada/a-strbou.adb
+++ b/gcc/ada/a-strbou.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -31,123 +31,11 @@
-- --
------------------------------------------------------------------------------
-with Ada.Strings.Maps; use Ada.Strings.Maps;
-with Ada.Strings.Search;
-
package body Ada.Strings.Bounded is
package body Generic_Bounded_Length is
---------
- -- "&" --
- ---------
-
- function "&"
- (Left : in Bounded_String;
- Right : in Bounded_String)
- return Bounded_String
- is
- Result : Bounded_String;
- Llen : constant Length_Range := Left.Length;
- Rlen : constant Length_Range := Right.Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen > Max_Length then
- raise Ada.Strings.Length_Error;
- else
- Result.Length := Nlen;
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
- end if;
-
- return Result;
- end "&";
-
- function "&"
- (Left : in Bounded_String;
- Right : in String)
- return Bounded_String
- is
- Result : Bounded_String;
- Llen : constant Length_Range := Left.Length;
-
- Nlen : constant Natural := Llen + Right'Length;
-
- begin
- if Nlen > Max_Length then
- raise Ada.Strings.Length_Error;
- else
- Result.Length := Nlen;
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1 .. Nlen) := Right;
- end if;
- return Result;
- end "&";
-
- function "&"
- (Left : in String;
- Right : in Bounded_String)
- return Bounded_String
- is
- Result : Bounded_String;
- Llen : constant Length_Range := Left'Length;
- Rlen : constant Length_Range := Right.Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen > Max_Length then
- raise Ada.Strings.Length_Error;
- else
- Result.Length := Nlen;
- Result.Data (1 .. Llen) := Left;
- Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
- end if;
-
- return Result;
- end "&";
-
- function "&"
- (Left : in Bounded_String;
- Right : in Character)
- return Bounded_String
- is
- Result : Bounded_String;
- Llen : constant Length_Range := Left.Length;
-
- begin
- if Llen = Max_Length then
- raise Ada.Strings.Length_Error;
- else
- Result.Length := Llen + 1;
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Result.Length) := Right;
- end if;
-
- return Result;
- end "&";
-
- function "&"
- (Left : in Character;
- Right : in Bounded_String)
- return Bounded_String
- is
- Result : Bounded_String;
- Rlen : Length_Range := Right.Length;
-
- begin
- if Rlen = Max_Length then
- raise Ada.Strings.Length_Error;
- else
- Result.Length := Rlen + 1;
- Result.Data (1) := Left;
- Result.Data (2 .. Result.Length) := Right.Data (1 .. Rlen);
- end if;
-
- return Result;
- end "&";
-
- ---------
-- "*" --
---------
@@ -156,20 +44,8 @@ package body Ada.Strings.Bounded is
Right : in Character)
return Bounded_String
is
- Result : Bounded_String;
-
begin
- if Left > Max_Length then
- raise Ada.Strings.Length_Error;
- else
- Result.Length := Left;
-
- for J in 1 .. Left loop
- Result.Data (J) := Right;
- end loop;
- end if;
-
- return Result;
+ return Times (Left, Right, Max_Length);
end "*";
function "*"
@@ -177,1158 +53,10 @@ package body Ada.Strings.Bounded is
Right : in String)
return Bounded_String
is
- Result : Bounded_String;
- Pos : Positive := 1;
- Rlen : constant Natural := Right'Length;
- Nlen : constant Natural := Left * Rlen;
-
begin
- if Nlen > Max_Length then
- raise Ada.Strings.Index_Error;
- else
- Result.Length := Nlen;
-
- if Nlen > 0 then
- for J in 1 .. Left loop
- Result.Data (Pos .. Pos + Rlen - 1) := Right;
- Pos := Pos + Rlen;
- end loop;
- end if;
- end if;
-
- return Result;
+ return Times (Left, Right, Max_Length);
end "*";
- function "*"
- (Left : in Natural;
- Right : in Bounded_String)
- return Bounded_String
- is
- Result : Bounded_String;
- Pos : Positive := 1;
- Rlen : constant Length_Range := Right.Length;
- Nlen : constant Natural := Left * Rlen;
-
- begin
- if Nlen > Max_Length then
- raise Ada.Strings.Length_Error;
-
- else
- Result.Length := Nlen;
-
- if Nlen > 0 then
- for J in 1 .. Left loop
- Result.Data (Pos .. Pos + Rlen - 1) :=
- Right.Data (1 .. Rlen);
- Pos := Pos + Rlen;
- end loop;
- end if;
- end if;
-
- return Result;
- end "*";
-
- ---------
- -- "<" --
- ---------
-
- function "<" (Left, Right : in Bounded_String) return Boolean is
- begin
- return Left.Data (1 .. Left.Length) < Right.Data (1 .. Right.Length);
- end "<";
-
- function "<"
- (Left : in Bounded_String;
- Right : in String)
- return Boolean
- is
- begin
- return Left.Data (1 .. Left.Length) < Right;
- end "<";
-
- function "<"
- (Left : in String;
- Right : in Bounded_String)
- return Boolean
- is
- begin
- return Left < Right.Data (1 .. Right.Length);
- end "<";
-
- ----------
- -- "<=" --
- ----------
-
- function "<=" (Left, Right : in Bounded_String) return Boolean is
- begin
- return Left.Data (1 .. Left.Length) <= Right.Data (1 .. Right.Length);
- end "<=";
-
- function "<="
- (Left : in Bounded_String;
- Right : in String)
- return Boolean
- is
- begin
- return Left.Data (1 .. Left.Length) <= Right;
- end "<=";
-
- function "<="
- (Left : in String;
- Right : in Bounded_String)
- return Boolean
- is
- begin
- return Left <= Right.Data (1 .. Right.Length);
- end "<=";
-
- ---------
- -- "=" --
- ---------
-
- function "=" (Left, Right : in Bounded_String) return Boolean is
- begin
- return Left.Length = Right.Length
- and then Left.Data (1 .. Left.Length) =
- Right.Data (1 .. Right.Length);
- end "=";
-
- function "=" (Left : in Bounded_String; Right : in String)
- return Boolean is
- begin
- return Left.Length = Right'Length
- and then Left.Data (1 .. Left.Length) = Right;
- end "=";
-
- function "=" (Left : in String; Right : in Bounded_String)
- return Boolean is
- begin
- return Left'Length = Right.Length
- and then Left = Right.Data (1 .. Right.Length);
- end "=";
-
- ---------
- -- ">" --
- ---------
-
- function ">" (Left, Right : in Bounded_String) return Boolean is
- begin
- return Left.Data (1 .. Left.Length) > Right.Data (1 .. Right.Length);
- end ">";
-
- function ">"
- (Left : in Bounded_String;
- Right : in String)
- return Boolean
- is
- begin
- return Left.Data (1 .. Left.Length) > Right;
- end ">";
-
- function ">"
- (Left : in String;
- Right : in Bounded_String)
- return Boolean
- is
- begin
- return Left > Right.Data (1 .. Right.Length);
- end ">";
-
- ----------
- -- ">=" --
- ----------
-
- function ">=" (Left, Right : in Bounded_String) return Boolean is
- begin
- return Left.Data (1 .. Left.Length) >= Right.Data (1 .. Right.Length);
- end ">=";
-
- function ">="
- (Left : in Bounded_String;
- Right : in String)
- return Boolean
- is
- begin
- return Left.Data (1 .. Left.Length) >= Right;
- end ">=";
-
- function ">="
- (Left : in String;
- Right : in Bounded_String)
- return Boolean
- is
- begin
- return Left >= Right.Data (1 .. Right.Length);
- end ">=";
-
- ------------
- -- Append --
- ------------
-
- -- Case of Bounded_String and Bounded_String
-
- function Append
- (Left, Right : in Bounded_String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_String
- is
- Result : Bounded_String;
- Llen : constant Length_Range := Left.Length;
- Rlen : constant Length_Range := Right.Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen <= Max_Length then
- Result.Length := Nlen;
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Llen >= Max_Length then -- only case is Llen = Max_Length
- Result.Data := Left.Data;
-
- else
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1 .. Max_Length) :=
- Right.Data (1 .. Max_Length - Llen);
- end if;
-
- when Strings.Left =>
- if Rlen >= Max_Length then -- only case is Rlen = Max_Length
- Result.Data := Right.Data;
-
- else
- Result.Data (1 .. Max_Length - Rlen) :=
- Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
- Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
- Right.Data (1 .. Rlen);
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Append;
-
- procedure Append
- (Source : in out Bounded_String;
- New_Item : in Bounded_String;
- Drop : in Truncation := Error)
- is
- Llen : constant Length_Range := Source.Length;
- Rlen : constant Length_Range := New_Item.Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen <= Max_Length then
- Source.Length := Nlen;
- Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen);
-
- else
- Source.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Llen < Max_Length then
- Source.Data (Llen + 1 .. Max_Length) :=
- New_Item.Data (1 .. Max_Length - Llen);
- end if;
-
- when Strings.Left =>
- if Rlen >= Max_Length then -- only case is Rlen = Max_Length
- Source.Data := New_Item.Data;
-
- else
- Source.Data (1 .. Max_Length - Rlen) :=
- Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
- Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
- New_Item.Data (1 .. Rlen);
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- end Append;
-
- -- Case of Bounded_String and String
-
- function Append
- (Left : in Bounded_String;
- Right : in String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_String
- is
- Result : Bounded_String;
- Llen : constant Length_Range := Left.Length;
- Rlen : constant Length_Range := Right'Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen <= Max_Length then
- Result.Length := Nlen;
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1 .. Nlen) := Right;
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Llen >= Max_Length then -- only case is Llen = Max_Length
- Result.Data := Left.Data;
-
- else
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1 .. Max_Length) :=
- Right (Right'First .. Right'First - 1 +
- Max_Length - Llen);
-
- end if;
-
- when Strings.Left =>
- if Rlen >= Max_Length then
- Result.Data (1 .. Max_Length) :=
- Right (Right'Last - (Max_Length - 1) .. Right'Last);
-
- else
- Result.Data (1 .. Max_Length - Rlen) :=
- Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
- Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
- Right;
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Append;
-
- procedure Append
- (Source : in out Bounded_String;
- New_Item : in String;
- Drop : in Truncation := Error)
- is
- Llen : constant Length_Range := Source.Length;
- Rlen : constant Length_Range := New_Item'Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen <= Max_Length then
- Source.Length := Nlen;
- Source.Data (Llen + 1 .. Nlen) := New_Item;
-
- else
- Source.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Llen < Max_Length then
- Source.Data (Llen + 1 .. Max_Length) :=
- New_Item (New_Item'First ..
- New_Item'First - 1 + Max_Length - Llen);
- end if;
-
- when Strings.Left =>
- if Rlen >= Max_Length then
- Source.Data (1 .. Max_Length) :=
- New_Item (New_Item'Last - (Max_Length - 1) ..
- New_Item'Last);
-
- else
- Source.Data (1 .. Max_Length - Rlen) :=
- Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
- Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
- New_Item;
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- end Append;
-
- -- Case of String and Bounded_String
-
- function Append
- (Left : in String;
- Right : in Bounded_String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_String
- is
- Result : Bounded_String;
- Llen : constant Length_Range := Left'Length;
- Rlen : constant Length_Range := Right.Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen <= Max_Length then
- Result.Length := Nlen;
- Result.Data (1 .. Llen) := Left;
- Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen);
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Llen >= Max_Length then
- Result.Data (1 .. Max_Length) :=
- Left (Left'First .. Left'First + (Max_Length - 1));
-
- else
- Result.Data (1 .. Llen) := Left;
- Result.Data (Llen + 1 .. Max_Length) :=
- Right.Data (1 .. Max_Length - Llen);
- end if;
-
- when Strings.Left =>
- if Rlen >= Max_Length then
- Result.Data (1 .. Max_Length) :=
- Right.Data (Rlen - (Max_Length - 1) .. Rlen);
-
- else
- Result.Data (1 .. Max_Length - Rlen) :=
- Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last);
- Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
- Right.Data (1 .. Rlen);
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Append;
-
- -- Case of Bounded_String and Character
-
- function Append
- (Left : in Bounded_String;
- Right : in Character;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_String
- is
- Result : Bounded_String;
- Llen : constant Length_Range := Left.Length;
-
- begin
- if Llen < Max_Length then
- Result.Length := Llen + 1;
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1) := Right;
- return Result;
-
- else
- case Drop is
- when Strings.Right =>
- return Left;
-
- when Strings.Left =>
- Result.Length := Max_Length;
- Result.Data (1 .. Max_Length - 1) :=
- Left.Data (2 .. Max_Length);
- Result.Data (Max_Length) := Right;
- return Result;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
- end Append;
-
- procedure Append
- (Source : in out Bounded_String;
- New_Item : in Character;
- Drop : in Truncation := Error)
- is
- Llen : constant Length_Range := Source.Length;
-
- begin
- if Llen < Max_Length then
- Source.Length := Llen + 1;
- Source.Data (Llen + 1) := New_Item;
-
- else
- Source.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- null;
-
- when Strings.Left =>
- Source.Data (1 .. Max_Length - 1) :=
- Source.Data (2 .. Max_Length);
- Source.Data (Max_Length) := New_Item;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- end Append;
-
- -- Case of Character and Bounded_String
-
- function Append
- (Left : in Character;
- Right : in Bounded_String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_String
- is
- Result : Bounded_String;
- Rlen : constant Length_Range := Right.Length;
-
- begin
- if Rlen < Max_Length then
- Result.Length := Rlen + 1;
- Result.Data (1) := Left;
- Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen);
- return Result;
-
- else
- case Drop is
- when Strings.Right =>
- Result.Length := Max_Length;
- Result.Data (1) := Left;
- Result.Data (2 .. Max_Length) :=
- Right.Data (1 .. Max_Length - 1);
- return Result;
-
- when Strings.Left =>
- return Right;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
- end Append;
-
- -----------
- -- Count --
- -----------
-
- function Count
- (Source : in Bounded_String;
- Pattern : in String;
- Mapping : in Maps.Character_Mapping := Maps.Identity)
- return Natural
- is
- begin
- return
- Search.Count (Source.Data (1 .. Source.Length), Pattern, Mapping);
- end Count;
-
- function Count
- (Source : in Bounded_String;
- Pattern : in String;
- Mapping : in Maps.Character_Mapping_Function)
- return Natural
- is
- begin
- return
- Search.Count (Source.Data (1 .. Source.Length), Pattern, Mapping);
- end Count;
-
- function Count
- (Source : in Bounded_String;
- Set : in Maps.Character_Set)
- return Natural
- is
- begin
- return Search.Count (Source.Data (1 .. Source.Length), Set);
- end Count;
-
- ------------
- -- Delete --
- ------------
-
- function Delete
- (Source : in Bounded_String;
- From : in Positive;
- Through : in Natural)
- return Bounded_String
- is
- Slen : constant Natural := Source.Length;
- Num_Delete : constant Integer := Through - From + 1;
- Result : Bounded_String;
-
- begin
- if Num_Delete <= 0 then
- return Source;
-
- elsif From > Slen + 1 then
- raise Ada.Strings.Index_Error;
-
- elsif Through >= Slen then
- Result.Length := From - 1;
- Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
- return Result;
-
- else
- Result.Length := Slen - Num_Delete;
- Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
- Result.Data (From .. Result.Length) :=
- Source.Data (Through + 1 .. Slen);
- return Result;
- end if;
- end Delete;
-
- procedure Delete
- (Source : in out Bounded_String;
- From : in Positive;
- Through : in Natural)
- is
- Slen : constant Natural := Source.Length;
- Num_Delete : constant Integer := Through - From + 1;
-
- begin
- if Num_Delete <= 0 then
- return;
-
- elsif From > Slen + 1 then
- raise Ada.Strings.Index_Error;
-
- elsif Through >= Slen then
- Source.Length := From - 1;
-
- else
- Source.Length := Slen - Num_Delete;
- Source.Data (From .. Source.Length) :=
- Source.Data (Through + 1 .. Slen);
- end if;
- end Delete;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Source : in Bounded_String;
- Index : in Positive)
- return Character
- is
- begin
- if Index in 1 .. Source.Length then
- return Source.Data (Index);
- else
- raise Strings.Index_Error;
- end if;
- end Element;
-
- ----------------
- -- Find_Token --
- ----------------
-
- procedure Find_Token
- (Source : in Bounded_String;
- Set : in Maps.Character_Set;
- Test : in Strings.Membership;
- First : out Positive;
- Last : out Natural)
- is
- begin
- Search.Find_Token
- (Source.Data (1 .. Source.Length), Set, Test, First, Last);
- end Find_Token;
-
-
- ----------
- -- Head --
- ----------
-
- function Head
- (Source : in Bounded_String;
- Count : in Natural;
- Pad : in Character := Space;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_String
- is
- Result : Bounded_String;
- Slen : constant Natural := Source.Length;
- Npad : constant Integer := Count - Slen;
-
- begin
- if Npad <= 0 then
- Result.Length := Count;
- Result.Data (1 .. Count) := Source.Data (1 .. Count);
-
- elsif Count <= Max_Length then
- Result.Length := Count;
- Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
- Result.Data (Slen + 1 .. Count) := (others => Pad);
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
- Result.Data (Slen + 1 .. Max_Length) := (others => Pad);
-
- when Strings.Left =>
- if Npad >= Max_Length then
- Result.Data := (others => Pad);
-
- else
- Result.Data (1 .. Max_Length - Npad) :=
- Source.Data (Count - Max_Length + 1 .. Slen);
- Result.Data (Max_Length - Npad + 1 .. Max_Length) :=
- (others => Pad);
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Head;
-
- procedure Head
- (Source : in out Bounded_String;
- Count : in Natural;
- Pad : in Character := Space;
- Drop : in Truncation := Error)
- is
- Slen : constant Natural := Source.Length;
- Npad : constant Integer := Count - Slen;
- Temp : String (1 .. Max_Length);
-
- begin
- if Npad <= 0 then
- Source.Length := Count;
-
- elsif Count <= Max_Length then
- Source.Length := Count;
- Source.Data (Slen + 1 .. Count) := (others => Pad);
-
- else
- Source.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- Source.Data (Slen + 1 .. Max_Length) := (others => Pad);
-
- when Strings.Left =>
- if Npad > Max_Length then
- Source.Data := (others => Pad);
-
- else
- Temp := Source.Data;
- Source.Data (1 .. Max_Length - Npad) :=
- Temp (Count - Max_Length + 1 .. Slen);
-
- for J in Max_Length - Npad + 1 .. Max_Length loop
- Source.Data (J) := Pad;
- end loop;
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- end Head;
-
- -----------
- -- Index --
- -----------
-
- function Index
- (Source : in Bounded_String;
- Pattern : in String;
- Going : in Strings.Direction := Strings.Forward;
- Mapping : in Maps.Character_Mapping := Maps.Identity)
- return Natural
- is
- begin
- return Search.Index
- (Source.Data (1 .. Source.Length), Pattern, Going, Mapping);
- end Index;
-
- function Index
- (Source : in Bounded_String;
- Pattern : in String;
- Going : in Direction := Forward;
- Mapping : in Maps.Character_Mapping_Function)
- return Natural
- is
- begin
- return Search.Index
- (Source.Data (1 .. Source.Length), Pattern, Going, Mapping);
- end Index;
-
- function Index
- (Source : in Bounded_String;
- Set : in Maps.Character_Set;
- Test : in Strings.Membership := Strings.Inside;
- Going : in Strings.Direction := Strings.Forward)
- return Natural
- is
- begin
- return Search.Index
- (Source.Data (1 .. Source.Length), Set, Test, Going);
- end Index;
-
- ---------------------
- -- Index_Non_Blank --
- ---------------------
-
- function Index_Non_Blank
- (Source : in Bounded_String;
- Going : in Strings.Direction := Strings.Forward)
- return Natural
- is
- begin
- return
- Search.Index_Non_Blank (Source.Data (1 .. Source.Length), Going);
- end Index_Non_Blank;
-
- ------------
- -- Insert --
- ------------
-
- function Insert
- (Source : in Bounded_String;
- Before : in Positive;
- New_Item : in String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_String
- is
- Slen : constant Natural := Source.Length;
- Nlen : constant Natural := New_Item'Length;
- Tlen : constant Natural := Slen + Nlen;
- Blen : constant Natural := Before - 1;
- Alen : constant Integer := Slen - Blen;
- Droplen : constant Integer := Tlen - Max_Length;
- Result : Bounded_String;
-
- -- Tlen is the length of the total string before possible truncation.
- -- Blen, Alen are the lengths of the before and after pieces of the
- -- source string.
-
- begin
- if Alen < 0 then
- raise Ada.Strings.Index_Error;
-
- elsif Droplen <= 0 then
- Result.Length := Tlen;
- Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
- Result.Data (Before .. Before + Nlen - 1) := New_Item;
- Result.Data (Before + Nlen .. Tlen) :=
- Source.Data (Before .. Slen);
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
-
- if Droplen > Alen then
- Result.Data (Before .. Max_Length) :=
- New_Item (New_Item'First
- .. New_Item'First + Max_Length - Before);
- else
- Result.Data (Before .. Before + Nlen - 1) := New_Item;
- Result.Data (Before + Nlen .. Max_Length) :=
- Source.Data (Before .. Slen - Droplen);
- end if;
-
- when Strings.Left =>
- Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
- Source.Data (Before .. Slen);
-
- if Droplen >= Blen then
- Result.Data (1 .. Max_Length - Alen) :=
- New_Item (New_Item'Last - (Max_Length - Alen) + 1
- .. New_Item'Last);
- else
- Result.Data
- (Blen - Droplen + 1 .. Max_Length - Alen) :=
- New_Item;
- Result.Data (1 .. Blen - Droplen) :=
- Source.Data (Droplen + 1 .. Blen);
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Insert;
-
- procedure Insert
- (Source : in out Bounded_String;
- Before : in Positive;
- New_Item : in String;
- Drop : in Strings.Truncation := Strings.Error)
- is
- begin
- -- We do a double copy here because this is one of the situations
- -- in which we move data to the right, and at least at the moment,
- -- GNAT is not handling such cases correctly ???
-
- Source := Insert (Source, Before, New_Item, Drop);
- end Insert;
-
- ------------
- -- Length --
- ------------
-
- function Length (Source : in Bounded_String) return Length_Range is
- begin
- return Source.Length;
- end Length;
-
- ---------------
- -- Overwrite --
- ---------------
-
- function Overwrite
- (Source : in Bounded_String;
- Position : in Positive;
- New_Item : in String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_String
- is
- Result : Bounded_String;
- Endpos : constant Natural := Position + New_Item'Length - 1;
- Slen : constant Natural := Source.Length;
- Droplen : Natural;
-
- begin
- if Position > Slen + 1 then
- raise Ada.Strings.Index_Error;
-
- elsif New_Item'Length = 0 then
- return Source;
-
- elsif Endpos <= Slen then
- Result.Length := Source.Length;
- Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
- Result.Data (Position .. Endpos) := New_Item;
- return Result;
-
- elsif Endpos <= Max_Length then
- Result.Length := Endpos;
- Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1);
- Result.Data (Position .. Endpos) := New_Item;
- return Result;
-
- else
- Result.Length := Max_Length;
- Droplen := Endpos - Max_Length;
-
- case Drop is
- when Strings.Right =>
- Result.Data (1 .. Position - 1) :=
- Source.Data (1 .. Position - 1);
-
- Result.Data (Position .. Max_Length) :=
- New_Item (New_Item'First .. New_Item'Last - Droplen);
- return Result;
-
- when Strings.Left =>
- if New_Item'Length >= Max_Length then
- Result.Data (1 .. Max_Length) :=
- New_Item (New_Item'Last - Max_Length + 1 ..
- New_Item'Last);
- return Result;
-
- else
- Result.Data (1 .. Max_Length - New_Item'Length) :=
- Source.Data (Droplen + 1 .. Position - 1);
- Result.Data
- (Max_Length - New_Item'Length + 1 .. Max_Length) :=
- New_Item;
- return Result;
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
- end Overwrite;
-
- procedure Overwrite
- (Source : in out Bounded_String;
- Position : in Positive;
- New_Item : in String;
- Drop : in Strings.Truncation := Strings.Error)
- is
- Endpos : constant Positive := Position + New_Item'Length - 1;
- Slen : constant Natural := Source.Length;
- Droplen : Natural;
-
- begin
- if Position > Slen + 1 then
- raise Ada.Strings.Index_Error;
-
- elsif Endpos <= Slen then
- Source.Data (Position .. Endpos) := New_Item;
-
- elsif Endpos <= Max_Length then
- Source.Data (Position .. Endpos) := New_Item;
- Source.Length := Endpos;
-
- else
- Source.Length := Max_Length;
- Droplen := Endpos - Max_Length;
-
- case Drop is
- when Strings.Right =>
- Source.Data (Position .. Max_Length) :=
- New_Item (New_Item'First .. New_Item'Last - Droplen);
-
- when Strings.Left =>
- if New_Item'Length > Max_Length then
- Source.Data (1 .. Max_Length) :=
- New_Item (New_Item'Last - Max_Length + 1 ..
- New_Item'Last);
-
- else
- Source.Data (1 .. Max_Length - New_Item'Length) :=
- Source.Data (Droplen + 1 .. Position - 1);
-
- Source.Data
- (Max_Length - New_Item'Length + 1 .. Max_Length) :=
- New_Item;
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
- end Overwrite;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Source : in out Bounded_String;
- Index : in Positive;
- By : in Character)
- is
- begin
- if Index <= Source.Length then
- Source.Data (Index) := By;
- else
- raise Ada.Strings.Index_Error;
- end if;
- end Replace_Element;
-
- -------------------
- -- Replace_Slice --
- -------------------
-
- function Replace_Slice
- (Source : in Bounded_String;
- Low : in Positive;
- High : in Natural;
- By : in String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_String
- is
- Slen : constant Natural := Source.Length;
-
- begin
- if Low > Slen + 1 then
- raise Strings.Index_Error;
-
- elsif High < Low then
- return Insert (Source, Low, By, Drop);
-
- else
- declare
- Blen : constant Natural := Natural'Max (0, Low - 1);
- Alen : constant Natural := Natural'Max (0, Slen - High);
- Tlen : constant Natural := Blen + By'Length + Alen;
- Droplen : constant Integer := Tlen - Max_Length;
- Result : Bounded_String;
-
- -- Tlen is the total length of the result string before any
- -- truncation. Blen and Alen are the lengths of the pieces
- -- of the original string that end up in the result string
- -- before and after the replaced slice.
-
- begin
- if Droplen <= 0 then
- Result.Length := Tlen;
- Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
- Result.Data (Low .. Low + By'Length - 1) := By;
- Result.Data (Low + By'Length .. Tlen) :=
- Source.Data (High + 1 .. Slen);
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
-
- if Droplen > Alen then
- Result.Data (Low .. Max_Length) :=
- By (By'First .. By'First + Max_Length - Low);
- else
- Result.Data (Low .. Low + By'Length - 1) := By;
- Result.Data (Low + By'Length .. Max_Length) :=
- Source.Data (High + 1 .. Slen - Droplen);
- end if;
-
- when Strings.Left =>
- Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
- Source.Data (High + 1 .. Slen);
-
- if Droplen >= Blen then
- Result.Data (1 .. Max_Length - Alen) :=
- By (By'Last - (Max_Length - Alen) + 1 .. By'Last);
- else
- Result.Data
- (Blen - Droplen + 1 .. Max_Length - Alen) := By;
- Result.Data (1 .. Blen - Droplen) :=
- Source.Data (Droplen + 1 .. Blen);
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end;
- end if;
- end Replace_Slice;
-
- procedure Replace_Slice
- (Source : in out Bounded_String;
- Low : in Positive;
- High : in Natural;
- By : in String;
- Drop : in Strings.Truncation := Strings.Error)
- is
- begin
- -- We do a double copy here because this is one of the situations
- -- in which we move data to the right, and at least at the moment,
- -- GNAT is not handling such cases correctly ???
-
- Source := Replace_Slice (Source, Low, High, By, Drop);
- end Replace_Slice;
-
---------------
-- Replicate --
---------------
@@ -1339,21 +67,8 @@ package body Ada.Strings.Bounded is
Drop : in Strings.Truncation := Strings.Error)
return Bounded_String
is
- Result : Bounded_String;
-
begin
- if Count <= Max_Length then
- Result.Length := Count;
-
- elsif Drop = Strings.Error then
- raise Ada.Strings.Length_Error;
-
- else
- Result.Length := Max_Length;
- end if;
-
- Result.Data (1 .. Result.Length) := (others => Item);
- return Result;
+ return Super_Replicate (Count, Item, Drop, Max_Length);
end Replicate;
function Replicate
@@ -1362,189 +77,10 @@ package body Ada.Strings.Bounded is
Drop : in Strings.Truncation := Strings.Error)
return Bounded_String
is
- Length : constant Integer := Count * Item'Length;
- Result : Bounded_String;
- Indx : Positive;
-
begin
- if Length <= Max_Length then
- Result.Length := Length;
-
- if Length > 0 then
- Indx := 1;
-
- for J in 1 .. Count loop
- Result.Data (Indx .. Indx + Item'Length - 1) := Item;
- Indx := Indx + Item'Length;
- end loop;
- end if;
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- Indx := 1;
-
- while Indx + Item'Length <= Max_Length + 1 loop
- Result.Data (Indx .. Indx + Item'Length - 1) := Item;
- Indx := Indx + Item'Length;
- end loop;
-
- Result.Data (Indx .. Max_Length) :=
- Item (Item'First .. Item'First + Max_Length - Indx);
-
- when Strings.Left =>
- Indx := Max_Length;
-
- while Indx - Item'Length >= 1 loop
- Result.Data (Indx - (Item'Length - 1) .. Indx) := Item;
- Indx := Indx - Item'Length;
- end loop;
-
- Result.Data (1 .. Indx) :=
- Item (Item'Last - Indx + 1 .. Item'Last);
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Replicate;
-
- function Replicate
- (Count : in Natural;
- Item : in Bounded_String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_String
- is
- begin
- return Replicate (Count, Item.Data (1 .. Item.Length), Drop);
+ return Super_Replicate (Count, Item, Drop, Max_Length);
end Replicate;
- -----------
- -- Slice --
- -----------
-
- function Slice
- (Source : Bounded_String;
- Low : Positive;
- High : Natural)
- return String
- is
- begin
- -- Note: test of High > Length is in accordance with AI95-00128
-
- if Low > Source.Length + 1 or else High > Source.Length then
- raise Index_Error;
- else
- return Source.Data (Low .. High);
- end if;
- end Slice;
-
- ----------
- -- Tail --
- ----------
-
- function Tail
- (Source : in Bounded_String;
- Count : in Natural;
- Pad : in Character := Space;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_String
- is
- Result : Bounded_String;
- Slen : constant Natural := Source.Length;
- Npad : constant Integer := Count - Slen;
-
- begin
- if Npad <= 0 then
- Result.Length := Count;
- Result.Data (1 .. Count) :=
- Source.Data (Slen - (Count - 1) .. Slen);
-
- elsif Count <= Max_Length then
- Result.Length := Count;
- Result.Data (1 .. Npad) := (others => Pad);
- Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen);
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Npad >= Max_Length then
- Result.Data := (others => Pad);
-
- else
- Result.Data (1 .. Npad) := (others => Pad);
- Result.Data (Npad + 1 .. Max_Length) :=
- Source.Data (1 .. Max_Length - Npad);
- end if;
-
- when Strings.Left =>
- Result.Data (1 .. Max_Length - Slen) := (others => Pad);
- Result.Data (Max_Length - Slen + 1 .. Max_Length) :=
- Source.Data (1 .. Slen);
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Tail;
-
- procedure Tail
- (Source : in out Bounded_String;
- Count : in Natural;
- Pad : in Character := Space;
- Drop : in Truncation := Error)
- is
- Slen : constant Natural := Source.Length;
- Npad : constant Integer := Count - Slen;
- Temp : String (1 .. Max_Length) := Source.Data;
-
- begin
- if Npad <= 0 then
- Source.Length := Count;
- Source.Data (1 .. Count) :=
- Temp (Slen - (Count - 1) .. Slen);
-
- elsif Count <= Max_Length then
- Source.Length := Count;
- Source.Data (1 .. Npad) := (others => Pad);
- Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen);
-
- else
- Source.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Npad >= Max_Length then
- Source.Data := (others => Pad);
-
- else
- Source.Data (1 .. Npad) := (others => Pad);
- Source.Data (Npad + 1 .. Max_Length) :=
- Temp (1 .. Max_Length - Npad);
- end if;
-
- when Strings.Left =>
- for J in 1 .. Max_Length - Slen loop
- Source.Data (J) := Pad;
- end loop;
-
- Source.Data (Max_Length - Slen + 1 .. Max_Length) :=
- Temp (1 .. Slen);
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- end Tail;
-----------------------
-- To_Bounded_String --
@@ -1555,221 +91,10 @@ package body Ada.Strings.Bounded is
Drop : in Strings.Truncation := Strings.Error)
return Bounded_String
is
- Slen : constant Natural := Source'Length;
- Result : Bounded_String;
-
begin
- if Slen <= Max_Length then
- Result.Length := Slen;
- Result.Data (1 .. Slen) := Source;
-
- else
- case Drop is
- when Strings.Right =>
- Result.Length := Max_Length;
- Result.Data (1 .. Max_Length) :=
- Source (Source'First .. Source'First - 1 + Max_Length);
-
- when Strings.Left =>
- Result.Length := Max_Length;
- Result.Data (1 .. Max_Length) :=
- Source (Source'Last - (Max_Length - 1) .. Source'Last);
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
+ return To_Super_String (Source, Max_Length, Drop);
end To_Bounded_String;
- ---------------
- -- To_String --
- ---------------
-
- function To_String (Source : in Bounded_String) return String is
- begin
- return Source.Data (1 .. Source.Length);
- end To_String;
-
- ---------------
- -- Translate --
- ---------------
-
- function Translate
- (Source : in Bounded_String;
- Mapping : in Maps.Character_Mapping)
- return Bounded_String
- is
- Result : Bounded_String;
-
- begin
- Result.Length := Source.Length;
-
- for J in 1 .. Source.Length loop
- Result.Data (J) := Value (Mapping, Source.Data (J));
- end loop;
-
- return Result;
- end Translate;
-
- procedure Translate
- (Source : in out Bounded_String;
- Mapping : in Maps.Character_Mapping)
- is
- begin
- for J in 1 .. Source.Length loop
- Source.Data (J) := Value (Mapping, Source.Data (J));
- end loop;
- end Translate;
-
- function Translate
- (Source : in Bounded_String;
- Mapping : in Maps.Character_Mapping_Function)
- return Bounded_String
- is
- Result : Bounded_String;
-
- begin
- Result.Length := Source.Length;
-
- for J in 1 .. Source.Length loop
- Result.Data (J) := Mapping.all (Source.Data (J));
- end loop;
-
- return Result;
- end Translate;
-
- procedure Translate
- (Source : in out Bounded_String;
- Mapping : in Maps.Character_Mapping_Function)
- is
- begin
- for J in 1 .. Source.Length loop
- Source.Data (J) := Mapping.all (Source.Data (J));
- end loop;
- end Translate;
-
- ----------
- -- Trim --
- ----------
-
- function Trim (Source : in Bounded_String; Side : in Trim_End)
- return Bounded_String
- is
- Result : Bounded_String;
- Last : Natural := Source.Length;
- First : Positive := 1;
-
- begin
- if Side = Left or else Side = Both then
- while First <= Last and then Source.Data (First) = ' ' loop
- First := First + 1;
- end loop;
- end if;
-
- if Side = Right or else Side = Both then
- while Last >= First and then Source.Data (Last) = ' ' loop
- Last := Last - 1;
- end loop;
- end if;
-
- Result.Length := Last - First + 1;
- Result.Data (1 .. Result.Length) := Source.Data (First .. Last);
- return Result;
-
- end Trim;
-
- procedure Trim
- (Source : in out Bounded_String;
- Side : in Trim_End)
- is
- Last : Length_Range := Source.Length;
- First : Positive := 1;
- Temp : String (1 .. Max_Length);
-
- begin
- Temp (1 .. Last) := Source.Data (1 .. Last);
-
- if Side = Left or else Side = Both then
- while First <= Last and then Temp (First) = ' ' loop
- First := First + 1;
- end loop;
- end if;
-
- if Side = Right or else Side = Both then
- while Last >= First and then Temp (Last) = ' ' loop
- Last := Last - 1;
- end loop;
- end if;
-
- Source := Null_Bounded_String;
- Source.Length := Last - First + 1;
- Source.Data (1 .. Source.Length) := Temp (First .. Last);
-
- end Trim;
-
- function Trim
- (Source : in Bounded_String;
- Left : in Maps.Character_Set;
- Right : in Maps.Character_Set)
- return Bounded_String
- is
- Result : Bounded_String;
-
- begin
- for First in 1 .. Source.Length loop
- if not Is_In (Source.Data (First), Left) then
- for Last in reverse First .. Source.Length loop
- if not Is_In (Source.Data (Last), Right) then
- Result.Length := Last - First + 1;
- Result.Data (1 .. Result.Length) :=
- Source.Data (First .. Last);
- return Result;
- end if;
- end loop;
- end if;
- end loop;
-
- Result.Length := 0;
- return Result;
- end Trim;
-
- procedure Trim
- (Source : in out Bounded_String;
- Left : in Maps.Character_Set;
- Right : in Maps.Character_Set)
- is
- begin
- for First in 1 .. Source.Length loop
- if not Is_In (Source.Data (First), Left) then
- for Last in reverse First .. Source.Length loop
- if not Is_In (Source.Data (Last), Right) then
- if First = 1 then
- Source.Length := Last;
- return;
- else
- Source.Length := Last - First + 1;
- Source.Data (1 .. Source.Length) :=
- Source.Data (First .. Last);
-
- for J in Source.Length + 1 .. Max_Length loop
- Source.Data (J) := ASCII.NUL;
- end loop;
-
- return;
- end if;
- end if;
- end loop;
-
- Source.Length := 0;
- return;
- end if;
- end loop;
-
- Source.Length := 0;
- end Trim;
-
end Generic_Bounded_Length;
end Ada.Strings.Bounded;
diff --git a/gcc/ada/a-strbou.ads b/gcc/ada/a-strbou.ads
index 2f414f6e0eb..7e9f54f1b0a 100644
--- a/gcc/ada/a-strbou.ads
+++ b/gcc/ada/a-strbou.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -36,6 +36,7 @@
------------------------------------------------------------------------------
with Ada.Strings.Maps;
+with Ada.Strings.Superbounded;
package Ada.Strings.Bounded is
pragma Preelaborate (Bounded);
@@ -432,33 +433,408 @@ pragma Preelaborate (Bounded);
private
- type Bounded_String is record
- Length : Length_Range := 0;
- Data : String (1 .. Max_Length) := (1 .. Max_Length => ASCII.NUL);
- end record;
+ -- Most of the implementation is in the non generic package
+ -- Ada.Strings.Superbounded. Type Bounded_String is derived from type
+ -- Superbounded.Super_String with the maximum length constraint.
+ -- Except for five, all subprograms are renames of subprograms that
+ -- are inherited from Superbounded.Super_String.
+
+ type Bounded_String is new Superbounded.Super_String (Max_Length);
Null_Bounded_String : constant Bounded_String :=
- (Length => 0, Data => (1 .. Max_Length => ASCII.NUL));
-
-
- -- Pragma Inline declarations (GNAT specific additions)
-
- pragma Inline ("=");
- pragma Inline ("<");
- pragma Inline ("<=");
- pragma Inline (">");
- pragma Inline (">=");
- pragma Inline ("&");
- pragma Inline (Count);
- pragma Inline (Element);
- pragma Inline (Find_Token);
- pragma Inline (Index);
- pragma Inline (Index_Non_Blank);
- pragma Inline (Length);
- pragma Inline (Replace_Element);
- pragma Inline (Slice);
+ (Max_Length => Max_Length,
+ Current_Length => 0,
+ Data => (1 .. Max_Length => ASCII.NUL));
+
pragma Inline (To_Bounded_String);
- pragma Inline (To_String);
+
+ function Length (Source : in Bounded_String) return Length_Range
+ renames Super_Length;
+
+ function To_String (Source : in Bounded_String) return String
+ renames Super_To_String;
+
+ function Append
+ (Left, Right : in Bounded_String;
+ Drop : in Truncation := Error)
+ return Bounded_String
+ renames Super_Append;
+
+ function Append
+ (Left : in Bounded_String;
+ Right : in String;
+ Drop : in Truncation := Error)
+ return Bounded_String
+ renames Super_Append;
+
+ function Append
+ (Left : in String;
+ Right : in Bounded_String;
+ Drop : in Truncation := Error)
+ return Bounded_String
+ renames Super_Append;
+
+ function Append
+ (Left : in Bounded_String;
+ Right : in Character;
+ Drop : in Truncation := Error)
+ return Bounded_String
+ renames Super_Append;
+
+ function Append
+ (Left : in Character;
+ Right : in Bounded_String;
+ Drop : in Truncation := Error)
+ return Bounded_String
+ renames Super_Append;
+
+ procedure Append
+ (Source : in out Bounded_String;
+ New_Item : in Bounded_String;
+ Drop : in Truncation := Error)
+ renames Super_Append;
+
+ procedure Append
+ (Source : in out Bounded_String;
+ New_Item : in String;
+ Drop : in Truncation := Error)
+ renames Super_Append;
+
+ procedure Append
+ (Source : in out Bounded_String;
+ New_Item : in Character;
+ Drop : in Truncation := Error)
+ renames Super_Append;
+
+ function "&"
+ (Left, Right : in Bounded_String)
+ return Bounded_String
+ renames Concat;
+
+ function "&"
+ (Left : in Bounded_String;
+ Right : in String)
+ return Bounded_String
+ renames Concat;
+
+ function "&"
+ (Left : in String;
+ Right : in Bounded_String)
+ return Bounded_String
+ renames Concat;
+
+ function "&"
+ (Left : in Bounded_String;
+ Right : in Character)
+ return Bounded_String
+ renames Concat;
+
+ function "&"
+ (Left : in Character;
+ Right : in Bounded_String)
+ return Bounded_String
+ renames Concat;
+
+ function Element
+ (Source : in Bounded_String;
+ Index : in Positive)
+ return Character
+ renames Super_Element;
+
+ procedure Replace_Element
+ (Source : in out Bounded_String;
+ Index : in Positive;
+ By : in Character)
+ renames Super_Replace_Element;
+
+ function Slice
+ (Source : in Bounded_String;
+ Low : in Positive;
+ High : in Natural)
+ return String
+ renames Super_Slice;
+
+ function "=" (Left, Right : in Bounded_String) return Boolean
+ renames Equal;
+
+ function "="
+ (Left : in Bounded_String;
+ Right : in String)
+ return Boolean
+ renames Equal;
+
+ function "="
+ (Left : in String;
+ Right : in Bounded_String)
+ return Boolean
+ renames Equal;
+
+ function "<" (Left, Right : in Bounded_String) return Boolean
+ renames Less;
+
+ function "<"
+ (Left : in Bounded_String;
+ Right : in String)
+ return Boolean
+ renames Less;
+
+ function "<"
+ (Left : in String;
+ Right : in Bounded_String)
+ return Boolean
+ renames Less;
+
+ function "<=" (Left, Right : in Bounded_String) return Boolean
+ renames Less_Or_Equal;
+
+ function "<="
+ (Left : in Bounded_String;
+ Right : in String)
+ return Boolean
+ renames Less_Or_Equal;
+
+ function "<="
+ (Left : in String;
+ Right : in Bounded_String)
+ return Boolean
+ renames Less_Or_Equal;
+
+ function ">" (Left, Right : in Bounded_String) return Boolean
+ renames Greater;
+
+ function ">"
+ (Left : in Bounded_String;
+ Right : in String)
+ return Boolean
+ renames Greater;
+
+ function ">"
+ (Left : in String;
+ Right : in Bounded_String)
+ return Boolean
+ renames Greater;
+
+ function ">=" (Left, Right : in Bounded_String) return Boolean
+ renames Greater_Or_Equal;
+
+ function ">="
+ (Left : in Bounded_String;
+ Right : in String)
+ return Boolean
+ renames Greater_Or_Equal;
+
+ function ">="
+ (Left : in String;
+ Right : in Bounded_String)
+ return Boolean
+ renames Greater_Or_Equal;
+
+ function Index
+ (Source : in Bounded_String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural
+ renames Super_Index;
+
+ function Index
+ (Source : in Bounded_String;
+ Pattern : in String;
+ Going : in Direction := Forward;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural
+ renames Super_Index;
+
+ function Index
+ (Source : in Bounded_String;
+ Set : in Maps.Character_Set;
+ Test : in Membership := Inside;
+ Going : in Direction := Forward)
+ return Natural
+ renames Super_Index;
+
+ function Index_Non_Blank
+ (Source : in Bounded_String;
+ Going : in Direction := Forward)
+ return Natural
+ renames Super_Index_Non_Blank;
+
+ function Count
+ (Source : in Bounded_String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping := Maps.Identity)
+ return Natural
+ renames Super_Count;
+
+ function Count
+ (Source : in Bounded_String;
+ Pattern : in String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Natural
+ renames Super_Count;
+
+ function Count
+ (Source : in Bounded_String;
+ Set : in Maps.Character_Set)
+ return Natural
+ renames Super_Count;
+
+ procedure Find_Token
+ (Source : in Bounded_String;
+ Set : in Maps.Character_Set;
+ Test : in Membership;
+ First : out Positive;
+ Last : out Natural)
+ renames Super_Find_Token;
+
+ function Translate
+ (Source : in Bounded_String;
+ Mapping : in Maps.Character_Mapping)
+ return Bounded_String
+ renames Super_Translate;
+
+ procedure Translate
+ (Source : in out Bounded_String;
+ Mapping : in Maps.Character_Mapping)
+ renames Super_Translate;
+
+ function Translate
+ (Source : in Bounded_String;
+ Mapping : in Maps.Character_Mapping_Function)
+ return Bounded_String
+ renames Super_Translate;
+
+ procedure Translate
+ (Source : in out Bounded_String;
+ Mapping : in Maps.Character_Mapping_Function)
+ renames Super_Translate;
+
+ function Replace_Slice
+ (Source : in Bounded_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in String;
+ Drop : in Truncation := Error)
+ return Bounded_String
+ renames Super_Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out Bounded_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in String;
+ Drop : in Truncation := Error)
+ renames Super_Replace_Slice;
+
+ function Insert
+ (Source : in Bounded_String;
+ Before : in Positive;
+ New_Item : in String;
+ Drop : in Truncation := Error)
+ return Bounded_String
+ renames Super_Insert;
+
+ procedure Insert
+ (Source : in out Bounded_String;
+ Before : in Positive;
+ New_Item : in String;
+ Drop : in Truncation := Error)
+ renames Super_Insert;
+
+ function Overwrite
+ (Source : in Bounded_String;
+ Position : in Positive;
+ New_Item : in String;
+ Drop : in Truncation := Error)
+ return Bounded_String
+ renames Super_Overwrite;
+
+ procedure Overwrite
+ (Source : in out Bounded_String;
+ Position : in Positive;
+ New_Item : in String;
+ Drop : in Truncation := Error)
+ renames Super_Overwrite;
+
+ function Delete
+ (Source : in Bounded_String;
+ From : in Positive;
+ Through : in Natural)
+ return Bounded_String
+ renames Super_Delete;
+
+ procedure Delete
+ (Source : in out Bounded_String;
+ From : in Positive;
+ Through : in Natural)
+ renames Super_Delete;
+
+ function Trim
+ (Source : in Bounded_String;
+ Side : in Trim_End)
+ return Bounded_String
+ renames Super_Trim;
+
+ procedure Trim
+ (Source : in out Bounded_String;
+ Side : in Trim_End)
+ renames Super_Trim;
+
+ function Trim
+ (Source : in Bounded_String;
+ Left : in Maps.Character_Set;
+ Right : in Maps.Character_Set)
+ return Bounded_String
+ renames Super_Trim;
+
+ procedure Trim
+ (Source : in out Bounded_String;
+ Left : in Maps.Character_Set;
+ Right : in Maps.Character_Set)
+ renames Super_Trim;
+
+ function Head
+ (Source : in Bounded_String;
+ Count : in Natural;
+ Pad : in Character := Space;
+ Drop : in Truncation := Error)
+ return Bounded_String
+ renames Super_Head;
+
+ procedure Head
+ (Source : in out Bounded_String;
+ Count : in Natural;
+ Pad : in Character := Space;
+ Drop : in Truncation := Error)
+ renames Super_Head;
+
+ function Tail
+ (Source : in Bounded_String;
+ Count : in Natural;
+ Pad : in Character := Space;
+ Drop : in Truncation := Error)
+ return Bounded_String
+ renames Super_Tail;
+
+ procedure Tail
+ (Source : in out Bounded_String;
+ Count : in Natural;
+ Pad : in Character := Space;
+ Drop : in Truncation := Error)
+ renames Super_Tail;
+
+ function "*"
+ (Left : in Natural;
+ Right : in Bounded_String)
+ return Bounded_String
+ renames Times;
+
+ function Replicate
+ (Count : in Natural;
+ Item : in Bounded_String;
+ Drop : in Truncation := Error)
+ return Bounded_String
+ renames Super_Replicate;
end Generic_Bounded_Length;
diff --git a/gcc/ada/a-strfix.adb b/gcc/ada/a-strfix.adb
index 1513a21c350..03a5061c49b 100644
--- a/gcc/ada/a-strfix.adb
+++ b/gcc/ada/a-strfix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -409,9 +409,10 @@ package body Ada.Strings.Fixed is
end if;
declare
- Result_Length : Natural :=
- Integer'Max
- (Source'Length, Position - Source'First + New_Item'Length);
+ Result_Length : constant Natural :=
+ Integer'Max
+ (Source'Length,
+ Position - Source'First + New_Item'Length);
Result : String (1 .. Result_Length);
Front : constant Integer := Position - Source'First;
diff --git a/gcc/ada/a-strmap.adb b/gcc/ada/a-strmap.adb
index 7ffe6eee76c..ba02086a316 100644
--- a/gcc/ada/a-strmap.adb
+++ b/gcc/ada/a-strmap.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -230,7 +230,7 @@ package body Ada.Strings.Maps is
loop
exit when not Set (C) or else C = Character'Last;
- C := Character' Succ (C);
+ C := Character'Succ (C);
end loop;
if Set (C) then
diff --git a/gcc/ada/a-strsea.ads b/gcc/ada/a-strsea.ads
index 8dba572f6e0..7096ccffc94 100644
--- a/gcc/ada/a-strsea.ads
+++ b/gcc/ada/a-strsea.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1997 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- --
diff --git a/gcc/ada/a-strsup.adb b/gcc/ada/a-strsup.adb
new file mode 100644
index 00000000000..8ae039336d9
--- /dev/null
+++ b/gcc/ada/a-strsup.adb
@@ -0,0 +1,1807 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . S U P E R B O U N D E D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Maps; use Ada.Strings.Maps;
+with Ada.Strings.Search;
+
+package body Ada.Strings.Superbounded is
+
+ ------------
+ -- Concat --
+ ------------
+
+ function Concat
+ (Left : Super_String;
+ Right : Super_String)
+ return Super_String
+ is
+ Result : Super_String (Left.Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen > Left.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end Concat;
+
+ function Concat
+ (Left : Super_String;
+ Right : String)
+ return Super_String
+ is
+ Result : Super_String (Left.Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+
+ Nlen : constant Natural := Llen + Right'Length;
+
+ begin
+ if Nlen > Left.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right;
+ end if;
+ return Result;
+ end Concat;
+
+ function Concat
+ (Left : String;
+ Right : Super_String)
+ return Super_String
+ is
+ Result : Super_String (Right.Max_Length);
+ Llen : constant Natural := Left'Length;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen > Right.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end Concat;
+
+ function Concat
+ (Left : Super_String;
+ Right : Character)
+ return Super_String
+ is
+ Result : Super_String (Left.Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+
+ begin
+ if Llen = Left.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Llen + 1;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Result.Current_Length) := Right;
+ end if;
+
+ return Result;
+ end Concat;
+
+ function Concat
+ (Left : Character;
+ Right : Super_String)
+ return Super_String
+ is
+ Result : Super_String (Right.Max_Length);
+ Rlen : constant Natural := Right.Current_Length;
+
+ begin
+ if Rlen = Right.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Rlen + 1;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end Concat;
+
+ -----------
+ -- Equal --
+ -----------
+
+ function "=" (Left, Right : Super_String) return Boolean is
+ begin
+ return Left.Current_Length = Right.Current_Length
+ and then Left.Data (1 .. Left.Current_Length) =
+ Right.Data (1 .. Right.Current_Length);
+ end "=";
+
+ function Equal (Left : Super_String; Right : String)
+ return Boolean is
+ begin
+ return Left.Current_Length = Right'Length
+ and then Left.Data (1 .. Left.Current_Length) = Right;
+ end Equal;
+
+ function Equal (Left : String; Right : Super_String)
+ return Boolean is
+ begin
+ return Left'Length = Right.Current_Length
+ and then Left = Right.Data (1 .. Right.Current_Length);
+ end Equal;
+
+ -------------
+ -- Greater --
+ -------------
+
+ function Greater (Left, Right : Super_String) return Boolean is
+ begin
+ return Left.Data (1 .. Left.Current_Length) >
+ Right.Data (1 .. Right.Current_Length);
+ end Greater;
+
+ function Greater
+ (Left : Super_String;
+ Right : String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) > Right;
+ end Greater;
+
+ function Greater
+ (Left : String;
+ Right : Super_String)
+ return Boolean
+ is
+ begin
+ return Left > Right.Data (1 .. Right.Current_Length);
+ end Greater;
+
+ ----------------------
+ -- Greater_Or_Equal --
+ ----------------------
+
+ function Greater_Or_Equal (Left, Right : Super_String) return Boolean is
+ begin
+ return Left.Data (1 .. Left.Current_Length) >=
+ Right.Data (1 .. Right.Current_Length);
+ end Greater_Or_Equal;
+
+ function Greater_Or_Equal
+ (Left : Super_String;
+ Right : String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) >= Right;
+ end Greater_Or_Equal;
+
+ function Greater_Or_Equal
+ (Left : String;
+ Right : Super_String)
+ return Boolean
+ is
+ begin
+ return Left >= Right.Data (1 .. Right.Current_Length);
+ end Greater_Or_Equal;
+
+ ----------
+ -- Less --
+ ----------
+
+ function Less (Left, Right : Super_String) return Boolean is
+ begin
+ return Left.Data (1 .. Left.Current_Length) <
+ Right.Data (1 .. Right.Current_Length);
+ end Less;
+
+ function Less
+ (Left : Super_String;
+ Right : String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) < Right;
+ end Less;
+
+ function Less
+ (Left : String;
+ Right : Super_String)
+ return Boolean
+ is
+ begin
+ return Left < Right.Data (1 .. Right.Current_Length);
+ end Less;
+
+ -------------------
+ -- Less_Or_Equal --
+ -------------------
+
+ function Less_Or_Equal (Left, Right : Super_String) return Boolean is
+ begin
+ return Left.Data (1 .. Left.Current_Length) <=
+ Right.Data (1 .. Right.Current_Length);
+ end Less_Or_Equal;
+
+ function Less_Or_Equal
+ (Left : Super_String;
+ Right : String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) <= Right;
+ end Less_Or_Equal;
+
+ function Less_Or_Equal
+ (Left : String;
+ Right : Super_String)
+ return Boolean
+ is
+ begin
+ return Left <= Right.Data (1 .. Right.Current_Length);
+ end Less_Or_Equal;
+
+ ------------------
+ -- Super_Append --
+ ------------------
+
+ -- Case of Super_String and Super_String
+
+ function Super_Append
+ (Left, Right : Super_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Left.Max_Length;
+ Result : Super_String (Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then -- only case is Llen = Max_Length
+ Result.Data := Left.Data;
+
+ else
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then -- only case is Rlen = Max_Length
+ Result.Data := Right.Data;
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Append;
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Super_String;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Llen : constant Natural := Source.Current_Length;
+ Rlen : constant Natural := New_Item.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Source.Current_Length := Nlen;
+ Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen);
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen < Max_Length then
+ Source.Data (Llen + 1 .. Max_Length) :=
+ New_Item.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then -- only case is Rlen = Max_Length
+ Source.Data := New_Item.Data;
+
+ else
+ Source.Data (1 .. Max_Length - Rlen) :=
+ Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ New_Item.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Super_Append;
+
+ -- Case of Super_String and String
+
+ function Super_Append
+ (Left : Super_String;
+ Right : String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Left.Max_Length;
+ Result : Super_String (Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+ Rlen : constant Natural := Right'Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right;
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then -- only case is Llen = Max_Length
+ Result.Data := Left.Data;
+
+ else
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right (Right'First .. Right'First - 1 +
+ Max_Length - Llen);
+
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Right (Right'Last - (Max_Length - 1) .. Right'Last);
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Append;
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : String;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Llen : constant Natural := Source.Current_Length;
+ Rlen : constant Natural := New_Item'Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Source.Current_Length := Nlen;
+ Source.Data (Llen + 1 .. Nlen) := New_Item;
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen < Max_Length then
+ Source.Data (Llen + 1 .. Max_Length) :=
+ New_Item (New_Item'First ..
+ New_Item'First - 1 + Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Source.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - (Max_Length - 1) ..
+ New_Item'Last);
+
+ else
+ Source.Data (1 .. Max_Length - Rlen) :=
+ Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ New_Item;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Super_Append;
+
+ -- Case of String and Super_String
+
+ function Super_Append
+ (Left : String;
+ Right : Super_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Right.Max_Length;
+ Result : Super_String (Max_Length);
+ Llen : constant Natural := Left'Length;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Left (Left'First .. Left'First + (Max_Length - 1));
+
+ else
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Right.Data (Rlen - (Max_Length - 1) .. Rlen);
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Append;
+
+ -- Case of Super_String and Character
+
+ function Super_Append
+ (Left : Super_String;
+ Right : Character;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Left.Max_Length;
+ Result : Super_String (Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+
+ begin
+ if Llen < Max_Length then
+ Result.Current_Length := Llen + 1;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1) := Right;
+ return Result;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ return Left;
+
+ when Strings.Left =>
+ Result.Current_Length := Max_Length;
+ Result.Data (1 .. Max_Length - 1) :=
+ Left.Data (2 .. Max_Length);
+ Result.Data (Max_Length) := Right;
+ return Result;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Append;
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Character;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Llen : constant Natural := Source.Current_Length;
+
+ begin
+ if Llen < Max_Length then
+ Source.Current_Length := Llen + 1;
+ Source.Data (Llen + 1) := New_Item;
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ null;
+
+ when Strings.Left =>
+ Source.Data (1 .. Max_Length - 1) :=
+ Source.Data (2 .. Max_Length);
+ Source.Data (Max_Length) := New_Item;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Super_Append;
+
+ -- Case of Character and Super_String
+
+ function Super_Append
+ (Left : Character;
+ Right : Super_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Right.Max_Length;
+ Result : Super_String (Max_Length);
+ Rlen : constant Natural := Right.Current_Length;
+
+ begin
+ if Rlen < Max_Length then
+ Result.Current_Length := Rlen + 1;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen);
+ return Result;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ Result.Current_Length := Max_Length;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - 1);
+ return Result;
+
+ when Strings.Left =>
+ return Right;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Append;
+
+ -----------------
+ -- Super_Count --
+ -----------------
+
+ function Super_Count
+ (Source : Super_String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping := Maps.Identity)
+ return Natural
+ is
+ begin
+ return
+ Search.Count
+ (Source.Data (1 .. Source.Current_Length), Pattern, Mapping);
+ end Super_Count;
+
+ function Super_Count
+ (Source : Super_String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return
+ Search.Count
+ (Source.Data (1 .. Source.Current_Length), Pattern, Mapping);
+ end Super_Count;
+
+ function Super_Count
+ (Source : Super_String;
+ Set : Maps.Character_Set)
+ return Natural
+ is
+ begin
+ return Search.Count (Source.Data (1 .. Source.Current_Length), Set);
+ end Super_Count;
+
+ ------------------
+ -- Super_Delete --
+ ------------------
+
+ function Super_Delete
+ (Source : Super_String;
+ From : Positive;
+ Through : Natural)
+ return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+ Slen : constant Natural := Source.Current_Length;
+ Num_Delete : constant Integer := Through - From + 1;
+
+ begin
+ if Num_Delete <= 0 then
+ return Source;
+
+ elsif From > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Through >= Slen then
+ Result.Current_Length := From - 1;
+ Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
+ return Result;
+
+ else
+ Result.Current_Length := Slen - Num_Delete;
+ Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
+ Result.Data (From .. Result.Current_Length) :=
+ Source.Data (Through + 1 .. Slen);
+ return Result;
+ end if;
+ end Super_Delete;
+
+ procedure Super_Delete
+ (Source : in out Super_String;
+ From : Positive;
+ Through : Natural)
+ is
+ Slen : constant Natural := Source.Current_Length;
+ Num_Delete : constant Integer := Through - From + 1;
+
+ begin
+ if Num_Delete <= 0 then
+ return;
+
+ elsif From > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Through >= Slen then
+ Source.Current_Length := From - 1;
+
+ else
+ Source.Current_Length := Slen - Num_Delete;
+ Source.Data (From .. Source.Current_Length) :=
+ Source.Data (Through + 1 .. Slen);
+ end if;
+ end Super_Delete;
+
+ -------------------
+ -- Super_Element --
+ -------------------
+
+ function Super_Element
+ (Source : Super_String;
+ Index : Positive)
+ return Character
+ is
+ begin
+ if Index in 1 .. Source.Current_Length then
+ return Source.Data (Index);
+ else
+ raise Strings.Index_Error;
+ end if;
+ end Super_Element;
+
+ ----------------------
+ -- Super_Find_Token --
+ ----------------------
+
+ procedure Super_Find_Token
+ (Source : Super_String;
+ Set : Maps.Character_Set;
+ Test : Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ begin
+ Search.Find_Token
+ (Source.Data (1 .. Source.Current_Length), Set, Test, First, Last);
+ end Super_Find_Token;
+
+ ----------------
+ -- Super_Head --
+ ----------------
+
+ function Super_Head
+ (Source : Super_String;
+ Count : Natural;
+ Pad : Character := Space;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Result : Super_String (Max_Length);
+ Slen : constant Natural := Source.Current_Length;
+ Npad : constant Integer := Count - Slen;
+
+ begin
+ if Npad <= 0 then
+ Result.Current_Length := Count;
+ Result.Data (1 .. Count) := Source.Data (1 .. Count);
+
+ elsif Count <= Max_Length then
+ Result.Current_Length := Count;
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Slen + 1 .. Count) := (others => Pad);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Slen + 1 .. Max_Length) := (others => Pad);
+
+ when Strings.Left =>
+ if Npad >= Max_Length then
+ Result.Data := (others => Pad);
+
+ else
+ Result.Data (1 .. Max_Length - Npad) :=
+ Source.Data (Count - Max_Length + 1 .. Slen);
+ Result.Data (Max_Length - Npad + 1 .. Max_Length) :=
+ (others => Pad);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Head;
+
+ procedure Super_Head
+ (Source : in out Super_String;
+ Count : Natural;
+ Pad : Character := Space;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Slen : constant Natural := Source.Current_Length;
+ Npad : constant Integer := Count - Slen;
+ Temp : String (1 .. Max_Length);
+
+ begin
+ if Npad <= 0 then
+ Source.Current_Length := Count;
+
+ elsif Count <= Max_Length then
+ Source.Current_Length := Count;
+ Source.Data (Slen + 1 .. Count) := (others => Pad);
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Source.Data (Slen + 1 .. Max_Length) := (others => Pad);
+
+ when Strings.Left =>
+ if Npad > Max_Length then
+ Source.Data := (others => Pad);
+
+ else
+ Temp := Source.Data;
+ Source.Data (1 .. Max_Length - Npad) :=
+ Temp (Count - Max_Length + 1 .. Slen);
+
+ for J in Max_Length - Npad + 1 .. Max_Length loop
+ Source.Data (J) := Pad;
+ end loop;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Head;
+
+ -----------------
+ -- Super_Index --
+ -----------------
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : String;
+ Going : Strings.Direction := Strings.Forward;
+ Mapping : Maps.Character_Mapping := Maps.Identity)
+ return Natural
+ is
+ begin
+ return Search.Index
+ (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping);
+ end Super_Index;
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : String;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return Search.Index
+ (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping);
+ end Super_Index;
+
+ function Super_Index
+ (Source : Super_String;
+ Set : Maps.Character_Set;
+ Test : Strings.Membership := Strings.Inside;
+ Going : Strings.Direction := Strings.Forward)
+ return Natural
+ is
+ begin
+ return Search.Index
+ (Source.Data (1 .. Source.Current_Length), Set, Test, Going);
+ end Super_Index;
+
+ ---------------------------
+ -- Super_Index_Non_Blank --
+ ---------------------------
+
+ function Super_Index_Non_Blank
+ (Source : Super_String;
+ Going : Strings.Direction := Strings.Forward)
+ return Natural
+ is
+ begin
+ return
+ Search.Index_Non_Blank
+ (Source.Data (1 .. Source.Current_Length), Going);
+ end Super_Index_Non_Blank;
+
+ ------------------
+ -- Super_Insert --
+ ------------------
+
+ function Super_Insert
+ (Source : Super_String;
+ Before : Positive;
+ New_Item : String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Result : Super_String (Max_Length);
+ Slen : constant Natural := Source.Current_Length;
+ Nlen : constant Natural := New_Item'Length;
+ Tlen : constant Natural := Slen + Nlen;
+ Blen : constant Natural := Before - 1;
+ Alen : constant Integer := Slen - Blen;
+ Droplen : constant Integer := Tlen - Max_Length;
+
+ -- Tlen is the length of the total string before possible truncation.
+ -- Blen, Alen are the lengths of the before and after pieces of the
+ -- source string.
+
+ begin
+ if Alen < 0 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Droplen <= 0 then
+ Result.Current_Length := Tlen;
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+ Result.Data (Before .. Before + Nlen - 1) := New_Item;
+ Result.Data (Before + Nlen .. Tlen) :=
+ Source.Data (Before .. Slen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+
+ if Droplen > Alen then
+ Result.Data (Before .. Max_Length) :=
+ New_Item (New_Item'First
+ .. New_Item'First + Max_Length - Before);
+ else
+ Result.Data (Before .. Before + Nlen - 1) := New_Item;
+ Result.Data (Before + Nlen .. Max_Length) :=
+ Source.Data (Before .. Slen - Droplen);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
+ Source.Data (Before .. Slen);
+
+ if Droplen >= Blen then
+ Result.Data (1 .. Max_Length - Alen) :=
+ New_Item (New_Item'Last - (Max_Length - Alen) + 1
+ .. New_Item'Last);
+ else
+ Result.Data
+ (Blen - Droplen + 1 .. Max_Length - Alen) :=
+ New_Item;
+ Result.Data (1 .. Blen - Droplen) :=
+ Source.Data (Droplen + 1 .. Blen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Insert;
+
+ procedure Super_Insert
+ (Source : in out Super_String;
+ Before : Positive;
+ New_Item : String;
+ Drop : Strings.Truncation := Strings.Error)
+ is
+ begin
+ -- We do a double copy here because this is one of the situations
+ -- in which we move data to the right, and at least at the moment,
+ -- GNAT is not handling such cases correctly ???
+
+ Source := Super_Insert (Source, Before, New_Item, Drop);
+ end Super_Insert;
+
+ ------------------
+ -- Super_Length --
+ ------------------
+
+ function Super_Length (Source : Super_String) return Natural is
+ begin
+ return Source.Current_Length;
+ end Super_Length;
+
+ ---------------------
+ -- Super_Overwrite --
+ ---------------------
+
+ function Super_Overwrite
+ (Source : Super_String;
+ Position : Positive;
+ New_Item : String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Result : Super_String (Max_Length);
+ Endpos : constant Natural := Position + New_Item'Length - 1;
+ Slen : constant Natural := Source.Current_Length;
+ Droplen : Natural;
+
+ begin
+ if Position > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif New_Item'Length = 0 then
+ return Source;
+
+ elsif Endpos <= Slen then
+ Result.Current_Length := Source.Current_Length;
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Position .. Endpos) := New_Item;
+ return Result;
+
+ elsif Endpos <= Max_Length then
+ Result.Current_Length := Endpos;
+ Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1);
+ Result.Data (Position .. Endpos) := New_Item;
+ return Result;
+
+ else
+ Result.Current_Length := Max_Length;
+ Droplen := Endpos - Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Position - 1) :=
+ Source.Data (1 .. Position - 1);
+
+ Result.Data (Position .. Max_Length) :=
+ New_Item (New_Item'First .. New_Item'Last - Droplen);
+ return Result;
+
+ when Strings.Left =>
+ if New_Item'Length >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - Max_Length + 1 ..
+ New_Item'Last);
+ return Result;
+
+ else
+ Result.Data (1 .. Max_Length - New_Item'Length) :=
+ Source.Data (Droplen + 1 .. Position - 1);
+ Result.Data
+ (Max_Length - New_Item'Length + 1 .. Max_Length) :=
+ New_Item;
+ return Result;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Overwrite;
+
+ procedure Super_Overwrite
+ (Source : in out Super_String;
+ Position : Positive;
+ New_Item : String;
+ Drop : Strings.Truncation := Strings.Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Endpos : constant Positive := Position + New_Item'Length - 1;
+ Slen : constant Natural := Source.Current_Length;
+ Droplen : Natural;
+
+ begin
+ if Position > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Endpos <= Slen then
+ Source.Data (Position .. Endpos) := New_Item;
+
+ elsif Endpos <= Max_Length then
+ Source.Data (Position .. Endpos) := New_Item;
+ Source.Current_Length := Endpos;
+
+ else
+ Source.Current_Length := Max_Length;
+ Droplen := Endpos - Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Source.Data (Position .. Max_Length) :=
+ New_Item (New_Item'First .. New_Item'Last - Droplen);
+
+ when Strings.Left =>
+ if New_Item'Length > Max_Length then
+ Source.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - Max_Length + 1 ..
+ New_Item'Last);
+
+ else
+ Source.Data (1 .. Max_Length - New_Item'Length) :=
+ Source.Data (Droplen + 1 .. Position - 1);
+
+ Source.Data
+ (Max_Length - New_Item'Length + 1 .. Max_Length) :=
+ New_Item;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Overwrite;
+
+ ---------------------------
+ -- Super_Replace_Element --
+ ---------------------------
+
+ procedure Super_Replace_Element
+ (Source : in out Super_String;
+ Index : Positive;
+ By : Character)
+ is
+ begin
+ if Index <= Source.Current_Length then
+ Source.Data (Index) := By;
+ else
+ raise Ada.Strings.Index_Error;
+ end if;
+ end Super_Replace_Element;
+
+ -------------------------
+ -- Super_Replace_Slice --
+ -------------------------
+
+ function Super_Replace_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural;
+ By : String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Slen : constant Natural := Source.Current_Length;
+
+ begin
+ if Low > Slen + 1 then
+ raise Strings.Index_Error;
+
+ elsif High < Low then
+ return Super_Insert (Source, Low, By, Drop);
+
+ else
+ declare
+ Blen : constant Natural := Natural'Max (0, Low - 1);
+ Alen : constant Natural := Natural'Max (0, Slen - High);
+ Tlen : constant Natural := Blen + By'Length + Alen;
+ Droplen : constant Integer := Tlen - Max_Length;
+ Result : Super_String (Max_Length);
+
+ -- Tlen is the total length of the result string before any
+ -- truncation. Blen and Alen are the lengths of the pieces
+ -- of the original string that end up in the result string
+ -- before and after the replaced slice.
+
+ begin
+ if Droplen <= 0 then
+ Result.Current_Length := Tlen;
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+ Result.Data (Low .. Low + By'Length - 1) := By;
+ Result.Data (Low + By'Length .. Tlen) :=
+ Source.Data (High + 1 .. Slen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+
+ if Droplen > Alen then
+ Result.Data (Low .. Max_Length) :=
+ By (By'First .. By'First + Max_Length - Low);
+ else
+ Result.Data (Low .. Low + By'Length - 1) := By;
+ Result.Data (Low + By'Length .. Max_Length) :=
+ Source.Data (High + 1 .. Slen - Droplen);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
+ Source.Data (High + 1 .. Slen);
+
+ if Droplen >= Blen then
+ Result.Data (1 .. Max_Length - Alen) :=
+ By (By'Last - (Max_Length - Alen) + 1 .. By'Last);
+ else
+ Result.Data
+ (Blen - Droplen + 1 .. Max_Length - Alen) := By;
+ Result.Data (1 .. Blen - Droplen) :=
+ Source.Data (Droplen + 1 .. Blen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end;
+ end if;
+ end Super_Replace_Slice;
+
+ procedure Super_Replace_Slice
+ (Source : in out Super_String;
+ Low : Positive;
+ High : Natural;
+ By : String;
+ Drop : Strings.Truncation := Strings.Error)
+ is
+ begin
+ -- We do a double copy here because this is one of the situations
+ -- in which we move data to the right, and at least at the moment,
+ -- GNAT is not handling such cases correctly ???
+
+ Source := Super_Replace_Slice (Source, Low, High, By, Drop);
+ end Super_Replace_Slice;
+
+ ---------------------
+ -- Super_Replicate --
+ ---------------------
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Character;
+ Drop : Truncation := Error;
+ Max_Length : Positive)
+ return Super_String
+ is
+ Result : Super_String (Max_Length);
+
+ begin
+ if Count <= Max_Length then
+ Result.Current_Length := Count;
+
+ elsif Drop = Strings.Error then
+ raise Ada.Strings.Length_Error;
+
+ else
+ Result.Current_Length := Max_Length;
+ end if;
+
+ Result.Data (1 .. Result.Current_Length) := (others => Item);
+ return Result;
+ end Super_Replicate;
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : String;
+ Drop : Truncation := Error;
+ Max_Length : Positive)
+ return Super_String
+ is
+ Length : constant Integer := Count * Item'Length;
+ Result : Super_String (Max_Length);
+ Indx : Positive;
+
+ begin
+ if Length <= Max_Length then
+ Result.Current_Length := Length;
+
+ if Length > 0 then
+ Indx := 1;
+
+ for J in 1 .. Count loop
+ Result.Data (Indx .. Indx + Item'Length - 1) := Item;
+ Indx := Indx + Item'Length;
+ end loop;
+ end if;
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Indx := 1;
+
+ while Indx + Item'Length <= Max_Length + 1 loop
+ Result.Data (Indx .. Indx + Item'Length - 1) := Item;
+ Indx := Indx + Item'Length;
+ end loop;
+
+ Result.Data (Indx .. Max_Length) :=
+ Item (Item'First .. Item'First + Max_Length - Indx);
+
+ when Strings.Left =>
+ Indx := Max_Length;
+
+ while Indx - Item'Length >= 1 loop
+ Result.Data (Indx - (Item'Length - 1) .. Indx) := Item;
+ Indx := Indx - Item'Length;
+ end loop;
+
+ Result.Data (1 .. Indx) :=
+ Item (Item'Last - Indx + 1 .. Item'Last);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Replicate;
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Super_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ begin
+ return
+ Super_Replicate
+ (Count,
+ Item.Data (1 .. Item.Current_Length),
+ Drop,
+ Item.Max_Length);
+ end Super_Replicate;
+
+ -----------------
+ -- Super_Slice --
+ -----------------
+
+ function Super_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural)
+ return String
+ is
+ begin
+ -- Note: test of High > Length is in accordance with AI95-00128
+
+ if Low > Source.Current_Length + 1
+ or else High > Source.Current_Length
+ then
+ raise Index_Error;
+ else
+ return Source.Data (Low .. High);
+ end if;
+ end Super_Slice;
+
+ ----------------
+ -- Super_Tail --
+ ----------------
+
+ function Super_Tail
+ (Source : Super_String;
+ Count : Natural;
+ Pad : Character := Space;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Result : Super_String (Max_Length);
+ Slen : constant Natural := Source.Current_Length;
+ Npad : constant Integer := Count - Slen;
+
+ begin
+ if Npad <= 0 then
+ Result.Current_Length := Count;
+ Result.Data (1 .. Count) :=
+ Source.Data (Slen - (Count - 1) .. Slen);
+
+ elsif Count <= Max_Length then
+ Result.Current_Length := Count;
+ Result.Data (1 .. Npad) := (others => Pad);
+ Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Npad >= Max_Length then
+ Result.Data := (others => Pad);
+
+ else
+ Result.Data (1 .. Npad) := (others => Pad);
+ Result.Data (Npad + 1 .. Max_Length) :=
+ Source.Data (1 .. Max_Length - Npad);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (1 .. Max_Length - Slen) := (others => Pad);
+ Result.Data (Max_Length - Slen + 1 .. Max_Length) :=
+ Source.Data (1 .. Slen);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Tail;
+
+ procedure Super_Tail
+ (Source : in out Super_String;
+ Count : Natural;
+ Pad : Character := Space;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Slen : constant Natural := Source.Current_Length;
+ Npad : constant Integer := Count - Slen;
+
+ Temp : constant String (1 .. Max_Length) := Source.Data;
+
+ begin
+ if Npad <= 0 then
+ Source.Current_Length := Count;
+ Source.Data (1 .. Count) :=
+ Temp (Slen - (Count - 1) .. Slen);
+
+ elsif Count <= Max_Length then
+ Source.Current_Length := Count;
+ Source.Data (1 .. Npad) := (others => Pad);
+ Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen);
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Npad >= Max_Length then
+ Source.Data := (others => Pad);
+
+ else
+ Source.Data (1 .. Npad) := (others => Pad);
+ Source.Data (Npad + 1 .. Max_Length) :=
+ Temp (1 .. Max_Length - Npad);
+ end if;
+
+ when Strings.Left =>
+ for J in 1 .. Max_Length - Slen loop
+ Source.Data (J) := Pad;
+ end loop;
+
+ Source.Data (Max_Length - Slen + 1 .. Max_Length) :=
+ Temp (1 .. Slen);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Tail;
+
+ ---------------------
+ -- Super_To_String --
+ ---------------------
+
+ function Super_To_String (Source : in Super_String) return String is
+ begin
+ return Source.Data (1 .. Source.Current_Length);
+ end Super_To_String;
+
+ ---------------------
+ -- Super_Translate --
+ ---------------------
+
+ function Super_Translate
+ (Source : Super_String;
+ Mapping : Maps.Character_Mapping)
+ return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+
+ begin
+ Result.Current_Length := Source.Current_Length;
+
+ for J in 1 .. Source.Current_Length loop
+ Result.Data (J) := Value (Mapping, Source.Data (J));
+ end loop;
+
+ return Result;
+ end Super_Translate;
+
+ procedure Super_Translate
+ (Source : in out Super_String;
+ Mapping : Maps.Character_Mapping)
+ is
+ begin
+ for J in 1 .. Source.Current_Length loop
+ Source.Data (J) := Value (Mapping, Source.Data (J));
+ end loop;
+ end Super_Translate;
+
+ function Super_Translate
+ (Source : Super_String;
+ Mapping : Maps.Character_Mapping_Function)
+ return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+
+ begin
+ Result.Current_Length := Source.Current_Length;
+
+ for J in 1 .. Source.Current_Length loop
+ Result.Data (J) := Mapping.all (Source.Data (J));
+ end loop;
+
+ return Result;
+ end Super_Translate;
+
+ procedure Super_Translate
+ (Source : in out Super_String;
+ Mapping : Maps.Character_Mapping_Function)
+ is
+ begin
+ for J in 1 .. Source.Current_Length loop
+ Source.Data (J) := Mapping.all (Source.Data (J));
+ end loop;
+ end Super_Translate;
+
+ ----------------
+ -- Super_Trim --
+ ----------------
+
+ function Super_Trim (Source : Super_String; Side : Trim_End)
+ return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+ Last : Natural := Source.Current_Length;
+ First : Positive := 1;
+
+ begin
+ if Side = Left or else Side = Both then
+ while First <= Last and then Source.Data (First) = ' ' loop
+ First := First + 1;
+ end loop;
+ end if;
+
+ if Side = Right or else Side = Both then
+ while Last >= First and then Source.Data (Last) = ' ' loop
+ Last := Last - 1;
+ end loop;
+ end if;
+
+ Result.Current_Length := Last - First + 1;
+ Result.Data (1 .. Result.Current_Length) := Source.Data (First .. Last);
+ return Result;
+ end Super_Trim;
+
+ procedure Super_Trim
+ (Source : in out Super_String;
+ Side : Trim_End)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Last : Natural := Source.Current_Length;
+ First : Positive := 1;
+ Temp : String (1 .. Max_Length);
+
+ begin
+ Temp (1 .. Last) := Source.Data (1 .. Last);
+
+ if Side = Left or else Side = Both then
+ while First <= Last and then Temp (First) = ' ' loop
+ First := First + 1;
+ end loop;
+ end if;
+
+ if Side = Right or else Side = Both then
+ while Last >= First and then Temp (Last) = ' ' loop
+ Last := Last - 1;
+ end loop;
+ end if;
+
+ Source.Data := (others => ASCII.NUL);
+ Source.Current_Length := Last - First + 1;
+ Source.Data (1 .. Source.Current_Length) := Temp (First .. Last);
+ end Super_Trim;
+
+ function Super_Trim
+ (Source : Super_String;
+ Left : Maps.Character_Set;
+ Right : Maps.Character_Set)
+ return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+
+ begin
+ for First in 1 .. Source.Current_Length loop
+ if not Is_In (Source.Data (First), Left) then
+ for Last in reverse First .. Source.Current_Length loop
+ if not Is_In (Source.Data (Last), Right) then
+ Result.Current_Length := Last - First + 1;
+ Result.Data (1 .. Result.Current_Length) :=
+ Source.Data (First .. Last);
+ return Result;
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ Result.Current_Length := 0;
+ return Result;
+ end Super_Trim;
+
+ procedure Super_Trim
+ (Source : in out Super_String;
+ Left : Maps.Character_Set;
+ Right : Maps.Character_Set)
+ is
+ begin
+ for First in 1 .. Source.Current_Length loop
+ if not Is_In (Source.Data (First), Left) then
+ for Last in reverse First .. Source.Current_Length loop
+ if not Is_In (Source.Data (Last), Right) then
+ if First = 1 then
+ Source.Current_Length := Last;
+ return;
+ else
+ Source.Current_Length := Last - First + 1;
+ Source.Data (1 .. Source.Current_Length) :=
+ Source.Data (First .. Last);
+
+ for J in Source.Current_Length + 1 ..
+ Source.Max_Length
+ loop
+ Source.Data (J) := ASCII.NUL;
+ end loop;
+
+ return;
+ end if;
+ end if;
+ end loop;
+
+ Source.Current_Length := 0;
+ return;
+ end if;
+ end loop;
+
+ Source.Current_Length := 0;
+ end Super_Trim;
+
+ -----------
+ -- Times --
+ -----------
+
+ function Times
+ (Left : Natural;
+ Right : Character;
+ Max_Length : Positive)
+ return Super_String
+ is
+ Result : Super_String (Max_Length);
+
+ begin
+ if Left > Max_Length then
+ raise Ada.Strings.Length_Error;
+
+ else
+ Result.Current_Length := Left;
+
+ for J in 1 .. Left loop
+ Result.Data (J) := Right;
+ end loop;
+ end if;
+
+ return Result;
+ end Times;
+
+ function Times
+ (Left : Natural;
+ Right : String;
+ Max_Length : Positive)
+ return Super_String
+ is
+ Result : Super_String (Max_Length);
+ Pos : Positive := 1;
+ Rlen : constant Natural := Right'Length;
+ Nlen : constant Natural := Left * Rlen;
+
+ begin
+ if Nlen > Max_Length then
+ raise Ada.Strings.Index_Error;
+
+ else
+ Result.Current_Length := Nlen;
+
+ if Nlen > 0 then
+ for J in 1 .. Left loop
+ Result.Data (Pos .. Pos + Rlen - 1) := Right;
+ Pos := Pos + Rlen;
+ end loop;
+ end if;
+ end if;
+
+ return Result;
+ end Times;
+
+ function Times
+ (Left : Natural;
+ Right : Super_String)
+ return Super_String
+ is
+ Result : Super_String (Right.Max_Length);
+ Pos : Positive := 1;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Left * Rlen;
+
+ begin
+ if Nlen > Right.Max_Length then
+ raise Ada.Strings.Length_Error;
+
+ else
+ Result.Current_Length := Nlen;
+
+ if Nlen > 0 then
+ for J in 1 .. Left loop
+ Result.Data (Pos .. Pos + Rlen - 1) :=
+ Right.Data (1 .. Rlen);
+ Pos := Pos + Rlen;
+ end loop;
+ end if;
+ end if;
+
+ return Result;
+ end Times;
+
+ ---------------------
+ -- To_Super_String --
+ ---------------------
+
+ function To_Super_String
+ (Source : String;
+ Max_Length : Natural;
+ Drop : Truncation := Error)
+ return Super_String
+ is
+ Result : Super_String (Max_Length);
+ Slen : constant Natural := Source'Length;
+
+ begin
+ if Slen <= Max_Length then
+ Result.Current_Length := Slen;
+ Result.Data (1 .. Slen) := Source;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ Result.Current_Length := Max_Length;
+ Result.Data (1 .. Max_Length) :=
+ Source (Source'First .. Source'First - 1 + Max_Length);
+
+ when Strings.Left =>
+ Result.Current_Length := Max_Length;
+ Result.Data (1 .. Max_Length) :=
+ Source (Source'Last - (Max_Length - 1) .. Source'Last);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end To_Super_String;
+
+end Ada.Strings.Superbounded;
diff --git a/gcc/ada/a-strsup.ads b/gcc/ada/a-strsup.ads
new file mode 100644
index 00000000000..7716ca79e25
--- /dev/null
+++ b/gcc/ada/a-strsup.ads
@@ -0,0 +1,473 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . S U P E R B O U N D E D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This non generic package contains most of the implementation of the
+-- generic package Ada.Strings.Bounded.Generic_Bounded_Length.
+
+-- It defines type Super_String as a discriminated record with the maximum
+-- length as the discriminant. Individual instantiations of Strings.Bounded
+-- use this type with an appropriate discriminant value set.
+
+with Ada.Strings.Maps;
+
+package Ada.Strings.Superbounded is
+pragma Preelaborate (Superbounded);
+
+ type Super_String (Max_Length : Positive) is record
+ Current_Length : Natural := 0;
+ Data : String (1 .. Max_Length) := (others => ASCII.NUL);
+ end record;
+ -- Type Bounded_String in Ada.Strings.Bounded.Generic_Bounded_Length is
+ -- derived from this type, with the constraint of the maximum length.
+
+ -- The subprograms defined for Super_String are similar to those
+ -- defined for Bounded_String, except that they have different names, so
+ -- that they can be renamed in Ada.Strings.Bounded.Generic_Bounded_Length.
+
+ function Super_Length (Source : Super_String) return Natural;
+
+ --------------------------------------------------------
+ -- Conversion, Concatenation, and Selection Functions --
+ --------------------------------------------------------
+
+ function To_Super_String
+ (Source : String;
+ Max_Length : Natural;
+ Drop : Truncation := Error)
+ return Super_String;
+ -- Note the additional parameter Max_Length, which specifies the maximum
+ -- length setting of the resulting Super_String value.
+
+ -- The following procedures have declarations (and semantics) that are
+ -- exactly analogous to those declared in Ada.Strings.Bounded.
+
+ function Super_To_String (Source : Super_String) return String;
+
+ function Super_Append
+ (Left, Right : Super_String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ function Super_Append
+ (Left : Super_String;
+ Right : String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ function Super_Append
+ (Left : String;
+ Right : Super_String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ function Super_Append
+ (Left : Super_String;
+ Right : Character;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ function Super_Append
+ (Left : Character;
+ Right : Super_String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Super_String;
+ Drop : Truncation := Error);
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : String;
+ Drop : Truncation := Error);
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Character;
+ Drop : Truncation := Error);
+
+ function Concat
+ (Left, Right : Super_String)
+ return Super_String;
+
+ function Concat
+ (Left : Super_String;
+ Right : String)
+ return Super_String;
+
+ function Concat
+ (Left : String;
+ Right : Super_String)
+ return Super_String;
+
+ function Concat
+ (Left : Super_String;
+ Right : Character)
+ return Super_String;
+
+ function Concat
+ (Left : Character;
+ Right : Super_String)
+ return Super_String;
+
+ function Super_Element
+ (Source : Super_String;
+ Index : Positive)
+ return Character;
+
+ procedure Super_Replace_Element
+ (Source : in out Super_String;
+ Index : Positive;
+ By : Character);
+
+ function Super_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural)
+ return String;
+
+ function "=" (Left, Right : Super_String) return Boolean;
+
+ function Equal (Left, Right : Super_String) return Boolean renames "=";
+
+ function Equal
+ (Left : Super_String;
+ Right : String)
+ return Boolean;
+
+ function Equal
+ (Left : String;
+ Right : Super_String)
+ return Boolean;
+
+ function Less (Left, Right : Super_String) return Boolean;
+
+ function Less
+ (Left : Super_String;
+ Right : String)
+ return Boolean;
+
+ function Less
+ (Left : String;
+ Right : Super_String)
+ return Boolean;
+
+ function Less_Or_Equal (Left, Right : Super_String) return Boolean;
+
+ function Less_Or_Equal
+ (Left : Super_String;
+ Right : String)
+ return Boolean;
+
+ function Less_Or_Equal
+ (Left : String;
+ Right : Super_String)
+ return Boolean;
+
+ function Greater (Left, Right : Super_String) return Boolean;
+
+ function Greater
+ (Left : Super_String;
+ Right : String)
+ return Boolean;
+
+ function Greater
+ (Left : String;
+ Right : Super_String)
+ return Boolean;
+
+ function Greater_Or_Equal (Left, Right : Super_String) return Boolean;
+
+ function Greater_Or_Equal
+ (Left : Super_String;
+ Right : String)
+ return Boolean;
+
+ function Greater_Or_Equal
+ (Left : String;
+ Right : Super_String)
+ return Boolean;
+
+ ----------------------
+ -- Search Functions --
+ ----------------------
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : String;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping := Maps.Identity)
+ return Natural;
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : String;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping_Function)
+ return Natural;
+
+ function Super_Index
+ (Source : Super_String;
+ Set : Maps.Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward)
+ return Natural;
+
+ function Super_Index_Non_Blank
+ (Source : Super_String;
+ Going : Direction := Forward)
+ return Natural;
+
+ function Super_Count
+ (Source : Super_String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping := Maps.Identity)
+ return Natural;
+
+ function Super_Count
+ (Source : Super_String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping_Function)
+ return Natural;
+
+ function Super_Count
+ (Source : Super_String;
+ Set : Maps.Character_Set)
+ return Natural;
+
+ procedure Super_Find_Token
+ (Source : Super_String;
+ Set : Maps.Character_Set;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ ------------------------------------
+ -- String Translation Subprograms --
+ ------------------------------------
+
+ function Super_Translate
+ (Source : Super_String;
+ Mapping : Maps.Character_Mapping)
+ return Super_String;
+
+ procedure Super_Translate
+ (Source : in out Super_String;
+ Mapping : Maps.Character_Mapping);
+
+ function Super_Translate
+ (Source : Super_String;
+ Mapping : Maps.Character_Mapping_Function)
+ return Super_String;
+
+ procedure Super_Translate
+ (Source : in out Super_String;
+ Mapping : Maps.Character_Mapping_Function);
+
+ ---------------------------------------
+ -- String Transformation Subprograms --
+ ---------------------------------------
+
+ function Super_Replace_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural;
+ By : String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ procedure Super_Replace_Slice
+ (Source : in out Super_String;
+ Low : Positive;
+ High : Natural;
+ By : String;
+ Drop : Truncation := Error);
+
+ function Super_Insert
+ (Source : Super_String;
+ Before : Positive;
+ New_Item : String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ procedure Super_Insert
+ (Source : in out Super_String;
+ Before : Positive;
+ New_Item : String;
+ Drop : Truncation := Error);
+
+ function Super_Overwrite
+ (Source : Super_String;
+ Position : Positive;
+ New_Item : String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ procedure Super_Overwrite
+ (Source : in out Super_String;
+ Position : Positive;
+ New_Item : String;
+ Drop : Truncation := Error);
+
+ function Super_Delete
+ (Source : Super_String;
+ From : Positive;
+ Through : Natural)
+ return Super_String;
+
+ procedure Super_Delete
+ (Source : in out Super_String;
+ From : Positive;
+ Through : Natural);
+
+ ---------------------------------
+ -- String Selector Subprograms --
+ ---------------------------------
+
+ function Super_Trim
+ (Source : Super_String;
+ Side : Trim_End)
+ return Super_String;
+
+ procedure Super_Trim
+ (Source : in out Super_String;
+ Side : Trim_End);
+
+ function Super_Trim
+ (Source : Super_String;
+ Left : Maps.Character_Set;
+ Right : Maps.Character_Set)
+ return Super_String;
+
+ procedure Super_Trim
+ (Source : in out Super_String;
+ Left : Maps.Character_Set;
+ Right : Maps.Character_Set);
+
+ function Super_Head
+ (Source : Super_String;
+ Count : Natural;
+ Pad : Character := Space;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ procedure Super_Head
+ (Source : in out Super_String;
+ Count : Natural;
+ Pad : Character := Space;
+ Drop : Truncation := Error);
+
+ function Super_Tail
+ (Source : Super_String;
+ Count : Natural;
+ Pad : Character := Space;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ procedure Super_Tail
+ (Source : in out Super_String;
+ Count : Natural;
+ Pad : Character := Space;
+ Drop : Truncation := Error);
+
+ ------------------------------------
+ -- String Constructor Subprograms --
+ ------------------------------------
+
+ -- Note: in some of the following routines, there is an extra parameter
+ -- Max_Length which specifies the value of the maximum length for the
+ -- resulting Super_String value.
+
+ function Times
+ (Left : Natural;
+ Right : Character;
+ Max_Length : Positive)
+ return Super_String;
+ -- Note the additional parameter Max_Length
+
+ function Times
+ (Left : Natural;
+ Right : String;
+ Max_Length : Positive)
+ return Super_String;
+ -- Note the additional parameter Max_Length
+
+ function Times
+ (Left : Natural;
+ Right : Super_String)
+ return Super_String;
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Character;
+ Drop : Truncation := Error;
+ Max_Length : Positive)
+ return Super_String;
+ -- Note the additional parameter Max_Length
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : String;
+ Drop : Truncation := Error;
+ Max_Length : Positive)
+ return Super_String;
+ -- Note the additional parameter Max_Length
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Super_String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+private
+
+ -- Pragma Inline declarations
+
+ pragma Inline ("=");
+ pragma Inline (Less);
+ pragma Inline (Less_Or_Equal);
+ pragma Inline (Greater);
+ pragma Inline (Greater_Or_Equal);
+ pragma Inline (Concat);
+ pragma Inline (Super_Count);
+ pragma Inline (Super_Element);
+ pragma Inline (Super_Find_Token);
+ pragma Inline (Super_Index);
+ pragma Inline (Super_Index_Non_Blank);
+ pragma Inline (Super_Length);
+ pragma Inline (Super_Replace_Element);
+ pragma Inline (Super_Slice);
+ pragma Inline (Super_To_String);
+
+end Ada.Strings.Superbounded;
diff --git a/gcc/ada/a-strunb.adb b/gcc/ada/a-strunb.adb
index 13422c97384..d9c411f5601 100644
--- a/gcc/ada/a-strunb.adb
+++ b/gcc/ada/a-strunb.adb
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S T R I N G S . U N B O U N D E D --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,20 +39,35 @@ package body Ada.Strings.Unbounded is
use Ada.Finalization;
+ procedure Realloc_For_Chunk
+ (Source : in out Unbounded_String;
+ Chunk_Size : Natural);
+ pragma Inline (Realloc_For_Chunk);
+ -- Adjust the size allocated for the string. Add at least Chunk_Size so it
+ -- is safe to add a string of this size at the end of the current
+ -- content. The real size allocated for the string is Chunk_Size + x %
+ -- of the current string size. This buffered handling makes the Append
+ -- unbounded string routines very fast.
+
---------
-- "&" --
---------
function "&" (Left, Right : Unbounded_String) return Unbounded_String is
- L_Length : constant Integer := Left.Reference.all'Length;
- R_Length : constant Integer := Right.Reference.all'Length;
- Length : constant Integer := L_Length + R_Length;
+ L_Length : constant Natural := Left.Last;
+ R_Length : constant Natural := Right.Last;
Result : Unbounded_String;
begin
- Result.Reference := new String (1 .. Length);
- Result.Reference.all (1 .. L_Length) := Left.Reference.all;
- Result.Reference.all (L_Length + 1 .. Length) := Right.Reference.all;
+ Result.Last := L_Length + R_Length;
+
+ Result.Reference := new String (1 .. Result.Last);
+
+ Result.Reference (1 .. L_Length) :=
+ Left.Reference (1 .. Left.Last);
+ Result.Reference (L_Length + 1 .. Result.Last) :=
+ Right.Reference (1 .. Right.Last);
+
return Result;
end "&";
@@ -61,14 +76,17 @@ package body Ada.Strings.Unbounded is
Right : String)
return Unbounded_String
is
- L_Length : constant Integer := Left.Reference.all'Length;
- Length : constant Integer := L_Length + Right'Length;
+ L_Length : constant Natural := Left.Last;
Result : Unbounded_String;
begin
- Result.Reference := new String (1 .. Length);
- Result.Reference.all (1 .. L_Length) := Left.Reference.all;
- Result.Reference.all (L_Length + 1 .. Length) := Right;
+ Result.Last := L_Length + Right'Length;
+
+ Result.Reference := new String (1 .. Result.Last);
+
+ Result.Reference (1 .. L_Length) := Left.Reference (1 .. Left.Last);
+ Result.Reference (L_Length + 1 .. Result.Last) := Right;
+
return Result;
end "&";
@@ -77,14 +95,18 @@ package body Ada.Strings.Unbounded is
Right : Unbounded_String)
return Unbounded_String
is
- R_Length : constant Integer := Right.Reference.all'Length;
- Length : constant Integer := Left'Length + R_Length;
+ R_Length : constant Natural := Right.Last;
Result : Unbounded_String;
begin
- Result.Reference := new String (1 .. Length);
- Result.Reference.all (1 .. Left'Length) := Left;
- Result.Reference.all (Left'Length + 1 .. Length) := Right.Reference.all;
+ Result.Last := Left'Length + R_Length;
+
+ Result.Reference := new String (1 .. Result.Last);
+
+ Result.Reference (1 .. Left'Length) := Left;
+ Result.Reference (Left'Length + 1 .. Result.Last) :=
+ Right.Reference (1 .. Right.Last);
+
return Result;
end "&";
@@ -93,13 +115,17 @@ package body Ada.Strings.Unbounded is
Right : Character)
return Unbounded_String
is
- Length : constant Integer := Left.Reference.all'Length + 1;
Result : Unbounded_String;
begin
- Result.Reference := new String (1 .. Length);
- Result.Reference.all (1 .. Length - 1) := Left.Reference.all;
- Result.Reference.all (Length) := Right;
+ Result.Last := Left.Last + 1;
+
+ Result.Reference := new String (1 .. Result.Last);
+
+ Result.Reference (1 .. Result.Last - 1) :=
+ Left.Reference (1 .. Left.Last);
+ Result.Reference (Result.Last) := Right;
+
return Result;
end "&";
@@ -108,13 +134,15 @@ package body Ada.Strings.Unbounded is
Right : Unbounded_String)
return Unbounded_String
is
- Length : constant Integer := Right.Reference.all'Length + 1;
Result : Unbounded_String;
begin
- Result.Reference := new String (1 .. Length);
- Result.Reference.all (1) := Left;
- Result.Reference.all (2 .. Length) := Right.Reference.all;
+ Result.Last := Right.Last + 1;
+
+ Result.Reference := new String (1 .. Result.Last);
+ Result.Reference (1) := Left;
+ Result.Reference (2 .. Result.Last) :=
+ Right.Reference (1 .. Right.Last);
return Result;
end "&";
@@ -130,6 +158,8 @@ package body Ada.Strings.Unbounded is
Result : Unbounded_String;
begin
+ Result.Last := Left;
+
Result.Reference := new String (1 .. Left);
for J in Result.Reference'Range loop
Result.Reference (J) := Right;
@@ -143,13 +173,19 @@ package body Ada.Strings.Unbounded is
Right : String)
return Unbounded_String
is
- Len : constant Integer := Right'Length;
+ Len : constant Natural := Right'Length;
+ K : Positive;
Result : Unbounded_String;
begin
- Result.Reference := new String (1 .. Left * Len);
+ Result.Last := Left * Len;
+
+ Result.Reference := new String (1 .. Result.Last);
+
+ K := 1;
for J in 1 .. Left loop
- Result.Reference.all (Len * J - Len + 1 .. Len * J) := Right;
+ Result.Reference (K .. K + Len - 1) := Right;
+ K := K + Len;
end loop;
return Result;
@@ -160,14 +196,20 @@ package body Ada.Strings.Unbounded is
Right : Unbounded_String)
return Unbounded_String
is
- Len : constant Integer := Right.Reference.all'Length;
+ Len : constant Natural := Right.Last;
+ K : Positive;
Result : Unbounded_String;
begin
- Result.Reference := new String (1 .. Left * Len);
+ Result.Last := Left * Len;
+
+ Result.Reference := new String (1 .. Result.Last);
+
+ K := 1;
for I in 1 .. Left loop
- Result.Reference.all (Len * I - Len + 1 .. Len * I) :=
- Right.Reference.all;
+ Result.Reference (K .. K + Len - 1) :=
+ Right.Reference (1 .. Right.Last);
+ K := K + Len;
end loop;
return Result;
@@ -177,135 +219,140 @@ package body Ada.Strings.Unbounded is
-- "<" --
---------
- function "<" (Left, Right : in Unbounded_String) return Boolean is
+ function "<" (Left, Right : Unbounded_String) return Boolean is
begin
- return Left.Reference.all < Right.Reference.all;
+ return
+ Left.Reference (1 .. Left.Last) < Right.Reference (1 .. Right.Last);
end "<";
function "<"
- (Left : in Unbounded_String;
- Right : in String)
+ (Left : Unbounded_String;
+ Right : String)
return Boolean
is
begin
- return Left.Reference.all < Right;
+ return Left.Reference (1 .. Left.Last) < Right;
end "<";
function "<"
- (Left : in String;
- Right : in Unbounded_String)
+ (Left : String;
+ Right : Unbounded_String)
return Boolean
is
begin
- return Left < Right.Reference.all;
+ return Left < Right.Reference (1 .. Right.Last);
end "<";
----------
-- "<=" --
----------
- function "<=" (Left, Right : in Unbounded_String) return Boolean is
+ function "<=" (Left, Right : Unbounded_String) return Boolean is
begin
- return Left.Reference.all <= Right.Reference.all;
+ return
+ Left.Reference (1 .. Left.Last) <= Right.Reference (1 .. Right.Last);
end "<=";
function "<="
- (Left : in Unbounded_String;
- Right : in String)
+ (Left : Unbounded_String;
+ Right : String)
return Boolean
is
begin
- return Left.Reference.all <= Right;
+ return Left.Reference (1 .. Left.Last) <= Right;
end "<=";
function "<="
- (Left : in String;
- Right : in Unbounded_String)
+ (Left : String;
+ Right : Unbounded_String)
return Boolean
is
begin
- return Left <= Right.Reference.all;
+ return Left <= Right.Reference (1 .. Right.Last);
end "<=";
---------
-- "=" --
---------
- function "=" (Left, Right : in Unbounded_String) return Boolean is
+ function "=" (Left, Right : Unbounded_String) return Boolean is
begin
- return Left.Reference.all = Right.Reference.all;
+ return
+ Left.Reference (1 .. Left.Last) = Right.Reference (1 .. Right.Last);
end "=";
function "="
- (Left : in Unbounded_String;
- Right : in String)
+ (Left : Unbounded_String;
+ Right : String)
return Boolean
is
begin
- return Left.Reference.all = Right;
+ return Left.Reference (1 .. Left.Last) = Right;
end "=";
function "="
- (Left : in String;
- Right : in Unbounded_String)
+ (Left : String;
+ Right : Unbounded_String)
return Boolean
is
begin
- return Left = Right.Reference.all;
+ return Left = Right.Reference (1 .. Right.Last);
end "=";
---------
-- ">" --
---------
- function ">" (Left, Right : in Unbounded_String) return Boolean is
+ function ">" (Left, Right : Unbounded_String) return Boolean is
begin
- return Left.Reference.all > Right.Reference.all;
+ return
+ Left.Reference (1 .. Left.Last) > Right.Reference (1 .. Right.Last);
end ">";
function ">"
- (Left : in Unbounded_String;
- Right : in String)
+ (Left : Unbounded_String;
+ Right : String)
return Boolean
is
begin
- return Left.Reference.all > Right;
+ return Left.Reference (1 .. Left.Last) > Right;
end ">";
function ">"
- (Left : in String;
- Right : in Unbounded_String)
+ (Left : String;
+ Right : Unbounded_String)
return Boolean
is
begin
- return Left > Right.Reference.all;
+ return Left > Right.Reference (1 .. Right.Last);
end ">";
----------
-- ">=" --
----------
- function ">=" (Left, Right : in Unbounded_String) return Boolean is
+ function ">=" (Left, Right : Unbounded_String) return Boolean is
begin
- return Left.Reference.all >= Right.Reference.all;
+ return
+ Left.Reference (1 .. Left.Last) >= Right.Reference (1 .. Right.Last);
end ">=";
function ">="
- (Left : in Unbounded_String;
- Right : in String)
+ (Left : Unbounded_String;
+ Right : String)
return Boolean
is
begin
- return Left.Reference.all >= Right;
+ return Left.Reference (1 .. Left.Last) >= Right;
end ">=";
function ">="
- (Left : in String;
- Right : in Unbounded_String)
+ (Left : String;
+ Right : Unbounded_String)
return Boolean
is
begin
- return Left >= Right.Reference.all;
+ return Left >= Right.Reference (1 .. Right.Last);
end ">=";
------------
@@ -316,9 +363,11 @@ package body Ada.Strings.Unbounded is
begin
-- Copy string, except we do not copy the statically allocated null
-- string, since it can never be deallocated.
+ -- Note that we do not copy extra string room here to avoid dragging
+ -- unused allocated memory.
if Object.Reference /= Null_String'Access then
- Object.Reference := new String'(Object.Reference.all);
+ Object.Reference := new String'(Object.Reference (1 .. Object.Last));
end if;
end Adjust;
@@ -328,50 +377,34 @@ package body Ada.Strings.Unbounded is
procedure Append
(Source : in out Unbounded_String;
- New_Item : in Unbounded_String)
+ New_Item : Unbounded_String)
is
- S_Length : constant Integer := Source.Reference.all'Length;
- Length : constant Integer := S_Length + New_Item.Reference.all'Length;
- Tmp : String_Access;
-
begin
- Tmp := new String (1 .. Length);
- Tmp (1 .. S_Length) := Source.Reference.all;
- Tmp (S_Length + 1 .. Length) := New_Item.Reference.all;
- Free (Source.Reference);
- Source.Reference := Tmp;
+ Realloc_For_Chunk (Source, New_Item.Last);
+ Source.Reference (Source.Last + 1 .. Source.Last + New_Item.Last) :=
+ New_Item.Reference (1 .. New_Item.Last);
+ Source.Last := Source.Last + New_Item.Last;
end Append;
procedure Append
(Source : in out Unbounded_String;
- New_Item : in String)
+ New_Item : String)
is
- S_Length : constant Integer := Source.Reference.all'Length;
- Length : constant Integer := S_Length + New_Item'Length;
- Tmp : String_Access;
-
begin
- Tmp := new String (1 .. Length);
- Tmp (1 .. S_Length) := Source.Reference.all;
- Tmp (S_Length + 1 .. Length) := New_Item;
- Free (Source.Reference);
- Source.Reference := Tmp;
+ Realloc_For_Chunk (Source, New_Item'Length);
+ Source.Reference (Source.Last + 1 .. Source.Last + New_Item'Length) :=
+ New_Item;
+ Source.Last := Source.Last + New_Item'Length;
end Append;
procedure Append
(Source : in out Unbounded_String;
- New_Item : in Character)
+ New_Item : Character)
is
- S_Length : constant Integer := Source.Reference.all'Length;
- Length : constant Integer := S_Length + 1;
- Tmp : String_Access;
-
begin
- Tmp := new String (1 .. Length);
- Tmp (1 .. S_Length) := Source.Reference.all;
- Tmp (S_Length + 1) := New_Item;
- Free (Source.Reference);
- Source.Reference := Tmp;
+ Realloc_For_Chunk (Source, 1);
+ Source.Reference (Source.Last + 1) := New_Item;
+ Source.Last := Source.Last + 1;
end Append;
-----------
@@ -385,17 +418,19 @@ package body Ada.Strings.Unbounded is
return Natural
is
begin
- return Search.Count (Source.Reference.all, Pattern, Mapping);
+ return
+ Search.Count (Source.Reference (1 .. Source.Last), Pattern, Mapping);
end Count;
function Count
- (Source : in Unbounded_String;
- Pattern : in String;
- Mapping : in Maps.Character_Mapping_Function)
+ (Source : Unbounded_String;
+ Pattern : String;
+ Mapping : Maps.Character_Mapping_Function)
return Natural
is
begin
- return Search.Count (Source.Reference.all, Pattern, Mapping);
+ return
+ Search.Count (Source.Reference (1 .. Source.Last), Pattern, Mapping);
end Count;
function Count
@@ -404,7 +439,7 @@ package body Ada.Strings.Unbounded is
return Natural
is
begin
- return Search.Count (Source.Reference.all, Set);
+ return Search.Count (Source.Reference (1 .. Source.Last), Set);
end Count;
------------
@@ -420,20 +455,31 @@ package body Ada.Strings.Unbounded is
begin
return
To_Unbounded_String
- (Fixed.Delete (Source.Reference.all, From, Through));
+ (Fixed.Delete (Source.Reference (1 .. Source.Last), From, Through));
end Delete;
procedure Delete
(Source : in out Unbounded_String;
- From : in Positive;
- Through : in Natural)
+ From : Positive;
+ Through : Natural)
is
- Old : String_Access := Source.Reference;
-
begin
- Source.Reference :=
- new String' (Fixed.Delete (Old.all, From, Through));
- Free (Old);
+ if From > Through then
+ null;
+
+ elsif From < Source.Reference'First or else Through > Source.Last then
+ raise Index_Error;
+
+ else
+ declare
+ Len : constant Natural := Through - From + 1;
+
+ begin
+ Source.Reference (From .. Source.Last - Len) :=
+ Source.Reference (Through + 1 .. Source.Last);
+ Source.Last := Source.Last - Len;
+ end;
+ end if;
end Delete;
-------------
@@ -446,8 +492,8 @@ package body Ada.Strings.Unbounded is
return Character
is
begin
- if Index <= Source.Reference.all'Last then
- return Source.Reference.all (Index);
+ if Index <= Source.Last then
+ return Source.Reference (Index);
else
raise Strings.Index_Error;
end if;
@@ -467,6 +513,7 @@ package body Ada.Strings.Unbounded is
if Object.Reference /= Null_String'Access then
Deallocate (Object.Reference);
Object.Reference := Null_Unbounded_String.Reference;
+ Object.Last := 0;
end if;
end Finalize;
@@ -482,7 +529,8 @@ package body Ada.Strings.Unbounded is
Last : out Natural)
is
begin
- Search.Find_Token (Source.Reference.all, Set, Test, First, Last);
+ Search.Find_Token
+ (Source.Reference (1 .. Source.Last), Set, Test, First, Last);
end Find_Token;
----------
@@ -494,7 +542,7 @@ package body Ada.Strings.Unbounded is
new Ada.Unchecked_Deallocation (String, String_Access);
begin
- -- Note: Don't try to free statically allocated null string
+ -- Note: Do not try to free statically allocated null string
if X /= Null_Unbounded_String.Reference then
Deallocate (X);
@@ -512,19 +560,22 @@ package body Ada.Strings.Unbounded is
return Unbounded_String
is
begin
- return
- To_Unbounded_String (Fixed.Head (Source.Reference.all, Count, Pad));
+ return To_Unbounded_String
+ (Fixed.Head (Source.Reference (1 .. Source.Last), Count, Pad));
end Head;
procedure Head
(Source : in out Unbounded_String;
- Count : in Natural;
- Pad : in Character := Space)
+ Count : Natural;
+ Pad : Character := Space)
is
Old : String_Access := Source.Reference;
begin
- Source.Reference := new String'(Fixed.Head (Old.all, Count, Pad));
+ Source.Reference :=
+ new String'(Fixed.Head (Source.Reference (1 .. Source.Last),
+ Count, Pad));
+ Source.Last := Source.Reference'Length;
Free (Old);
end Head;
@@ -540,18 +591,20 @@ package body Ada.Strings.Unbounded is
return Natural
is
begin
- return Search.Index (Source.Reference.all, Pattern, Going, Mapping);
+ return Search.Index
+ (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping);
end Index;
function Index
- (Source : in Unbounded_String;
- Pattern : in String;
- Going : in Direction := Forward;
- Mapping : in Maps.Character_Mapping_Function)
- return Natural
+ (Source : Unbounded_String;
+ Pattern : String;
+ Going : Direction := Forward;
+ Mapping : Maps.Character_Mapping_Function)
+ return Natural
is
begin
- return Search.Index (Source.Reference.all, Pattern, Going, Mapping);
+ return Search.Index
+ (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping);
end Index;
function Index
@@ -562,7 +615,8 @@ package body Ada.Strings.Unbounded is
return Natural
is
begin
- return Search.Index (Source.Reference.all, Set, Test, Going);
+ return Search.Index
+ (Source.Reference (1 .. Source.Last), Set, Test, Going);
end Index;
function Index_Non_Blank
@@ -571,7 +625,8 @@ package body Ada.Strings.Unbounded is
return Natural
is
begin
- return Search.Index_Non_Blank (Source.Reference.all, Going);
+ return
+ Search.Index_Non_Blank (Source.Reference (1 .. Source.Last), Going);
end Index_Non_Blank;
----------------
@@ -581,6 +636,7 @@ package body Ada.Strings.Unbounded is
procedure Initialize (Object : in out Unbounded_String) is
begin
Object.Reference := Null_Unbounded_String.Reference;
+ Object.Last := 0;
end Initialize;
------------
@@ -594,22 +650,28 @@ package body Ada.Strings.Unbounded is
return Unbounded_String
is
begin
- return
- To_Unbounded_String
- (Fixed.Insert (Source.Reference.all, Before, New_Item));
+ return To_Unbounded_String
+ (Fixed.Insert (Source.Reference (1 .. Source.Last), Before, New_Item));
end Insert;
procedure Insert
(Source : in out Unbounded_String;
- Before : in Positive;
- New_Item : in String)
+ Before : Positive;
+ New_Item : String)
is
- Old : String_Access := Source.Reference;
-
begin
- Source.Reference :=
- new String' (Fixed.Insert (Source.Reference.all, Before, New_Item));
- Free (Old);
+ if Before not in Source.Reference'First .. Source.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ Realloc_For_Chunk (Source, New_Item'Size);
+
+ Source.Reference
+ (Before + New_Item'Length .. Source.Last + New_Item'Length) :=
+ Source.Reference (Before .. Source.Last);
+
+ Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item;
+ Source.Last := Source.Last + New_Item'Length;
end Insert;
------------
@@ -618,7 +680,7 @@ package body Ada.Strings.Unbounded is
function Length (Source : Unbounded_String) return Natural is
begin
- return Source.Reference.all'Length;
+ return Source.Last;
end Length;
---------------
@@ -633,18 +695,19 @@ package body Ada.Strings.Unbounded is
begin
return To_Unbounded_String
- (Fixed.Overwrite (Source.Reference.all, Position, New_Item));
+ (Fixed.Overwrite
+ (Source.Reference (1 .. Source.Last), Position, New_Item));
end Overwrite;
procedure Overwrite
(Source : in out Unbounded_String;
- Position : in Positive;
- New_Item : in String)
+ Position : Positive;
+ New_Item : String)
is
- NL : constant Integer := New_Item'Length;
+ NL : constant Natural := New_Item'Length;
begin
- if Position <= Source.Reference'Length - NL + 1 then
+ if Position <= Source.Last - NL + 1 then
Source.Reference (Position .. Position + NL - 1) := New_Item;
else
@@ -652,13 +715,42 @@ package body Ada.Strings.Unbounded is
Old : String_Access := Source.Reference;
begin
- Source.Reference := new
- String'(Fixed.Overwrite (Old.all, Position, New_Item));
+ Source.Reference := new String'
+ (Fixed.Overwrite
+ (Source.Reference (1 .. Source.Last), Position, New_Item));
+ Source.Last := Source.Reference'Length;
Free (Old);
end;
end if;
end Overwrite;
+ -----------------------
+ -- Realloc_For_Chunk --
+ -----------------------
+
+ procedure Realloc_For_Chunk
+ (Source : in out Unbounded_String;
+ Chunk_Size : Natural)
+ is
+ Growth_Factor : constant := 50;
+ S_Length : constant Natural := Source.Reference'Length;
+
+ begin
+ if Chunk_Size > S_Length - Source.Last then
+ declare
+ Alloc_Chunk_Size : constant Positive :=
+ Chunk_Size + (S_Length / Growth_Factor);
+ Tmp : String_Access;
+
+ begin
+ Tmp := new String (1 .. S_Length + Alloc_Chunk_Size);
+ Tmp (1 .. Source.Last) := Source.Reference (1 .. Source.Last);
+ Free (Source.Reference);
+ Source.Reference := Tmp;
+ end;
+ end if;
+ end Realloc_For_Chunk;
+
---------------------
-- Replace_Element --
---------------------
@@ -669,8 +761,8 @@ package body Ada.Strings.Unbounded is
By : Character)
is
begin
- if Index <= Source.Reference.all'Last then
- Source.Reference.all (Index) := By;
+ if Index <= Source.Last then
+ Source.Reference (Index) := By;
else
raise Strings.Index_Error;
end if;
@@ -688,22 +780,24 @@ package body Ada.Strings.Unbounded is
return Unbounded_String
is
begin
- return
- To_Unbounded_String
- (Fixed.Replace_Slice (Source.Reference.all, Low, High, By));
+ return To_Unbounded_String
+ (Fixed.Replace_Slice
+ (Source.Reference (1 .. Source.Last), Low, High, By));
end Replace_Slice;
procedure Replace_Slice
(Source : in out Unbounded_String;
- Low : in Positive;
- High : in Natural;
- By : in String)
+ Low : Positive;
+ High : Natural;
+ By : String)
is
Old : String_Access := Source.Reference;
begin
- Source.Reference :=
- new String'(Fixed.Replace_Slice (Old.all, Low, High, By));
+ Source.Reference := new String'
+ (Fixed.Replace_Slice
+ (Source.Reference (1 .. Source.Last), Low, High, By));
+ Source.Last := Source.Reference'Length;
Free (Old);
end Replace_Slice;
@@ -717,15 +811,13 @@ package body Ada.Strings.Unbounded is
High : Natural)
return String
is
- Length : constant Natural := Source.Reference'Length;
-
begin
-- Note: test of High > Length is in accordance with AI95-00128
- if Low > Length + 1 or else High > Length then
+ if Low > Source.Last + 1 or else High > Source.Last then
raise Index_Error;
else
- return Source.Reference.all (Low .. High);
+ return Source.Reference (Low .. High);
end if;
end Slice;
@@ -740,19 +832,21 @@ package body Ada.Strings.Unbounded is
return Unbounded_String is
begin
- return
- To_Unbounded_String (Fixed.Tail (Source.Reference.all, Count, Pad));
+ return To_Unbounded_String
+ (Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad));
end Tail;
procedure Tail
(Source : in out Unbounded_String;
- Count : in Natural;
- Pad : in Character := Space)
+ Count : Natural;
+ Pad : Character := Space)
is
Old : String_Access := Source.Reference;
begin
- Source.Reference := new String'(Fixed.Tail (Old.all, Count, Pad));
+ Source.Reference := new String'
+ (Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad));
+ Source.Last := Source.Reference'Length;
Free (Old);
end Tail;
@@ -762,7 +856,7 @@ package body Ada.Strings.Unbounded is
function To_String (Source : Unbounded_String) return String is
begin
- return Source.Reference.all;
+ return Source.Reference (1 .. Source.Last);
end To_String;
-------------------------
@@ -773,18 +867,20 @@ package body Ada.Strings.Unbounded is
Result : Unbounded_String;
begin
- Result.Reference := new String (1 .. Source'Length);
+ Result.Last := Source'Length;
+ Result.Reference := new String (1 .. Source'Length);
Result.Reference.all := Source;
return Result;
end To_Unbounded_String;
function To_Unbounded_String
- (Length : in Natural)
+ (Length : Natural)
return Unbounded_String
is
Result : Unbounded_String;
begin
+ Result.Last := Length;
Result.Reference := new String (1 .. Length);
return Result;
end To_Unbounded_String;
@@ -799,8 +895,8 @@ package body Ada.Strings.Unbounded is
return Unbounded_String
is
begin
- return
- To_Unbounded_String (Fixed.Translate (Source.Reference.all, Mapping));
+ return To_Unbounded_String
+ (Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping));
end Translate;
procedure Translate
@@ -808,25 +904,25 @@ package body Ada.Strings.Unbounded is
Mapping : Maps.Character_Mapping)
is
begin
- Fixed.Translate (Source.Reference.all, Mapping);
+ Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping);
end Translate;
function Translate
- (Source : in Unbounded_String;
- Mapping : in Maps.Character_Mapping_Function)
+ (Source : Unbounded_String;
+ Mapping : Maps.Character_Mapping_Function)
return Unbounded_String
is
begin
- return
- To_Unbounded_String (Fixed.Translate (Source.Reference.all, Mapping));
+ return To_Unbounded_String
+ (Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping));
end Translate;
procedure Translate
(Source : in out Unbounded_String;
- Mapping : in Maps.Character_Mapping_Function)
+ Mapping : Maps.Character_Mapping_Function)
is
begin
- Fixed.Translate (Source.Reference.all, Mapping);
+ Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping);
end Translate;
----------
@@ -834,45 +930,50 @@ package body Ada.Strings.Unbounded is
----------
function Trim
- (Source : in Unbounded_String;
- Side : in Trim_End)
+ (Source : Unbounded_String;
+ Side : Trim_End)
return Unbounded_String
is
begin
- return To_Unbounded_String (Fixed.Trim (Source.Reference.all, Side));
+ return To_Unbounded_String
+ (Fixed.Trim (Source.Reference (1 .. Source.Last), Side));
end Trim;
procedure Trim
(Source : in out Unbounded_String;
- Side : in Trim_End)
+ Side : Trim_End)
is
Old : String_Access := Source.Reference;
begin
- Source.Reference := new String'(Fixed.Trim (Old.all, Side));
+ Source.Reference := new String'
+ (Fixed.Trim (Source.Reference (1 .. Source.Last), Side));
+ Source.Last := Source.Reference'Length;
Free (Old);
end Trim;
function Trim
- (Source : in Unbounded_String;
- Left : in Maps.Character_Set;
- Right : in Maps.Character_Set)
+ (Source : Unbounded_String;
+ Left : Maps.Character_Set;
+ Right : Maps.Character_Set)
return Unbounded_String
is
begin
- return
- To_Unbounded_String (Fixed.Trim (Source.Reference.all, Left, Right));
+ return To_Unbounded_String
+ (Fixed.Trim (Source.Reference (1 .. Source.Last), Left, Right));
end Trim;
procedure Trim
(Source : in out Unbounded_String;
- Left : in Maps.Character_Set;
- Right : in Maps.Character_Set)
+ Left : Maps.Character_Set;
+ Right : Maps.Character_Set)
is
Old : String_Access := Source.Reference;
begin
- Source.Reference := new String'(Fixed.Trim (Old.all, Left, Right));
+ Source.Reference := new String'
+ (Fixed.Trim (Source.Reference (1 .. Source.Last), Left, Right));
+ Source.Last := Source.Reference'Length;
Free (Old);
end Trim;
diff --git a/gcc/ada/a-strunb.ads b/gcc/ada/a-strunb.ads
index fe909009e12..996eb0e10cf 100644
--- a/gcc/ada/a-strunb.ads
+++ b/gcc/ada/a-strunb.ads
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNAT RUN-TIME COMPONENTS --
+-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S T R I N G S . U N B O U N D E D --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -365,8 +365,16 @@ private
type Unbounded_String is new AF.Controlled with record
Reference : String_Access := Null_String'Access;
+ Last : Natural := 0;
end record;
+ -- The Unbounded_String is using a buffered implementation to increase
+ -- speed of the Append/Delete/Insert procedures. The Reference string
+ -- pointer above contains the current string value and extra room at the
+ -- end to be used by the next Append routine. Last is the index of the
+ -- string ending character. So the current string value is really
+ -- Reference (1 .. Last).
+
pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String);
pragma Finalize_Storage_Only (Unbounded_String);
@@ -375,7 +383,13 @@ private
procedure Adjust (Object : in out Unbounded_String);
procedure Finalize (Object : in out Unbounded_String);
+ -- Note: the following declaration is illegal since library level
+ -- controlled objects are not allowed in preelaborated units. See
+ -- AI-161 for a discussion of this issue and an attempt to address it.
+ -- Meanwhile, what happens in GNAT is that this check is omitted for
+ -- internal implementation units (see check in sem_cat.adb).
+
Null_Unbounded_String : constant Unbounded_String :=
- (AF.Controlled with Reference => Null_String'Access);
+ (AF.Controlled with Reference => Null_String'Access, Last => 0);
end Ada.Strings.Unbounded;
diff --git a/gcc/ada/a-ststio.adb b/gcc/ada/a-ststio.adb
index 74c9be2da3c..8df6a379ba9 100644
--- a/gcc/ada/a-ststio.adb
+++ b/gcc/ada/a-ststio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -114,11 +114,14 @@ package body Ada.Streams.Stream_IO is
Name : in String := "";
Form : in String := "")
is
- File_Control_Block : Stream_AFCB;
+ Dummy_File_Control_Block : Stream_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => To_FCB (Mode),
Name => Name,
Form => Form,
@@ -212,11 +215,14 @@ package body Ada.Streams.Stream_IO is
Name : in String;
Form : in String := "")
is
- File_Control_Block : Stream_AFCB;
+ Dummy_File_Control_Block : Stream_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => To_FCB (Mode),
Name => Name,
Form => Form,
@@ -228,7 +234,19 @@ package body Ada.Streams.Stream_IO is
Reset (File, Mode);
- File.Last_Op := Op_Read;
+ -- Set last operation. The purpose here is to ensure proper handling
+ -- of the initial operation. In general, a write after a read requires
+ -- resetting and doing a seek, so we set the last operation as Read
+ -- for an In_Out file, but for an Out file we set the last operation
+ -- to Op_Write, since in this case it is not necessary to do a seek
+ -- (and furthermore there are situations (such as the case of writing
+ -- a sequential Posix FIFO file) where the lseek would cause problems.
+
+ if Mode = Out_File then
+ File.Last_Op := Op_Write;
+ else
+ File.Last_Op := Op_Read;
+ end if;
end Open;
----------
diff --git a/gcc/ada/a-stunau.adb b/gcc/ada/a-stunau.adb
index 148bd3f74b1..2fe26cc8e72 100644
--- a/gcc/ada/a-stunau.adb
+++ b/gcc/ada/a-stunau.adb
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S T R I N G S . U N B O U N D E D . A U X --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -37,9 +37,29 @@ package body Ada.Strings.Unbounded.Aux is
-- Get_String --
----------------
- function Get_String (U : Unbounded_String) return String_Access is
+ function Get_String (U : Unbounded_String) return String_Access is
begin
- return U.Reference;
+ if U.Last = U.Reference'Length then
+ return U.Reference;
+
+ else
+ declare
+ type Unbounded_String_Access is access all Unbounded_String;
+
+ U_Ptr : constant Unbounded_String_Access := U'Unrestricted_Access;
+ -- Unbounded_String is a controlled type which is always passed
+ -- by copy it is always safe to take the pointer to such object
+ -- here. This pointer is used to set the U.Reference value which
+ -- would not be possible otherwise as U is read-only.
+
+ Old : String_Access := U.Reference;
+
+ begin
+ U_Ptr.Reference := new String'(U.Reference (1 .. U.Last));
+ Free (Old);
+ return U.Reference;
+ end;
+ end if;
end Get_String;
----------------
@@ -48,7 +68,7 @@ package body Ada.Strings.Unbounded.Aux is
procedure Set_String (UP : in out Unbounded_String; S : String) is
begin
- if UP.Reference'Length = S'Length then
+ if UP.Last = S'Length then
UP.Reference.all := S;
else
@@ -60,6 +80,7 @@ package body Ada.Strings.Unbounded.Aux is
Tmp := new String'(String_1 (S));
Finalize (UP);
UP.Reference := Tmp;
+ UP.Last := UP.Reference'Length;
end;
end if;
end Set_String;
@@ -68,6 +89,7 @@ package body Ada.Strings.Unbounded.Aux is
begin
Finalize (UP);
UP.Reference := S;
+ UP.Last := UP.Reference'Length;
end Set_String;
end Ada.Strings.Unbounded.Aux;
diff --git a/gcc/ada/a-stunau.ads b/gcc/ada/a-stunau.ads
index c5b1eeafdbe..2da87482fa0 100644
--- a/gcc/ada/a-stunau.ads
+++ b/gcc/ada/a-stunau.ads
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . S T R I N G S . U N B O U N D E D . A U X --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,7 +39,7 @@
package Ada.Strings.Unbounded.Aux is
pragma Preelaborate (Aux);
- function Get_String (U : Unbounded_String) return String_Access;
+ function Get_String (U : Unbounded_String) return String_Access;
pragma Inline (Get_String);
-- This function returns the internal string pointer used in the
-- representation of an unbounded string. There is no copy involved,
diff --git a/gcc/ada/a-stwibo.adb b/gcc/ada/a-stwibo.adb
index 982ca638c71..9d0661a6c96 100644
--- a/gcc/ada/a-stwibo.adb
+++ b/gcc/ada/a-stwibo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -31,123 +31,11 @@
-- --
------------------------------------------------------------------------------
-with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps;
-with Ada.Strings.Wide_Search;
-
package body Ada.Strings.Wide_Bounded is
package body Generic_Bounded_Length is
---------
- -- "&" --
- ---------
-
- function "&"
- (Left : in Bounded_Wide_String;
- Right : in Bounded_Wide_String)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Llen : constant Length_Range := Left.Length;
- Rlen : constant Length_Range := Right.Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen > Max_Length then
- raise Ada.Strings.Length_Error;
- else
- Result.Length := Nlen;
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
- end if;
-
- return Result;
- end "&";
-
- function "&"
- (Left : in Bounded_Wide_String;
- Right : in Wide_String)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Llen : constant Length_Range := Left.Length;
-
- Nlen : constant Natural := Llen + Right'Length;
-
- begin
- if Nlen > Max_Length then
- raise Ada.Strings.Length_Error;
- else
- Result.Length := Nlen;
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1 .. Nlen) := Right;
- end if;
- return Result;
- end "&";
-
- function "&"
- (Left : in Wide_String;
- Right : in Bounded_Wide_String)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Llen : constant Length_Range := Left'Length;
- Rlen : constant Length_Range := Right.Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen > Max_Length then
- raise Ada.Strings.Length_Error;
- else
- Result.Length := Nlen;
- Result.Data (1 .. Llen) := Left;
- Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
- end if;
-
- return Result;
- end "&";
-
- function "&"
- (Left : in Bounded_Wide_String;
- Right : in Wide_Character)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Llen : constant Length_Range := Left.Length;
-
- begin
- if Llen = Max_Length then
- raise Ada.Strings.Length_Error;
- else
- Result.Length := Llen + 1;
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Result.Length) := Right;
- end if;
-
- return Result;
- end "&";
-
- function "&"
- (Left : in Wide_Character;
- Right : in Bounded_Wide_String)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Rlen : Length_Range := Right.Length;
-
- begin
- if Rlen = Max_Length then
- raise Ada.Strings.Length_Error;
- else
- Result.Length := Rlen + 1;
- Result.Data (1) := Left;
- Result.Data (2 .. Result.Length) := Right.Data (1 .. Rlen);
- end if;
-
- return Result;
- end "&";
-
- ---------
-- "*" --
---------
@@ -156,20 +44,8 @@ package body Ada.Strings.Wide_Bounded is
Right : in Wide_Character)
return Bounded_Wide_String
is
- Result : Bounded_Wide_String;
-
begin
- if Left > Max_Length then
- raise Ada.Strings.Length_Error;
- else
- Result.Length := Left;
-
- for J in 1 .. Left loop
- Result.Data (J) := Right;
- end loop;
- end if;
-
- return Result;
+ return Times (Left, Right, Max_Length);
end "*";
function "*"
@@ -177,1187 +53,10 @@ package body Ada.Strings.Wide_Bounded is
Right : in Wide_String)
return Bounded_Wide_String
is
- Result : Bounded_Wide_String;
- Pos : Positive := 1;
- Rlen : constant Natural := Right'Length;
- Nlen : constant Natural := Left * Rlen;
-
begin
- if Nlen > Max_Length then
- raise Ada.Strings.Index_Error;
- else
- Result.Length := Nlen;
-
- if Nlen > 0 then
- for J in 1 .. Left loop
- Result.Data (Pos .. Pos + Rlen - 1) := Right;
- Pos := Pos + Rlen;
- end loop;
- end if;
- end if;
-
- return Result;
+ return Times (Left, Right, Max_Length);
end "*";
- function "*"
- (Left : in Natural;
- Right : in Bounded_Wide_String)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Pos : Positive := 1;
- Rlen : constant Length_Range := Right.Length;
- Nlen : constant Natural := Left * Rlen;
-
- begin
- if Nlen > Max_Length then
- raise Ada.Strings.Length_Error;
-
- else
- Result.Length := Nlen;
-
- if Nlen > 0 then
- for J in 1 .. Left loop
- Result.Data (Pos .. Pos + Rlen - 1) :=
- Right.Data (1 .. Rlen);
- Pos := Pos + Rlen;
- end loop;
- end if;
- end if;
-
- return Result;
- end "*";
-
- ---------
- -- "<" --
- ---------
-
- function "<"
- (Left : in Bounded_Wide_String;
- Right : in Bounded_Wide_String)
- return Boolean
- is
- begin
- return Left.Data (1 .. Left.Length) < Right.Data (1 .. Right.Length);
- end "<";
-
- function "<"
- (Left : in Bounded_Wide_String;
- Right : in Wide_String)
- return Boolean
- is
- begin
- return Left.Data (1 .. Left.Length) < Right;
- end "<";
-
- function "<"
- (Left : in Wide_String;
- Right : in Bounded_Wide_String)
- return Boolean
- is
- begin
- return Left < Right.Data (1 .. Right.Length);
- end "<";
-
- ----------
- -- "<=" --
- ----------
-
- function "<="
- (Left : in Bounded_Wide_String;
- Right : in Bounded_Wide_String)
- return Boolean
- is
- begin
- return Left.Data (1 .. Left.Length) <= Right.Data (1 .. Right.Length);
- end "<=";
-
- function "<="
- (Left : in Bounded_Wide_String;
- Right : in Wide_String)
- return Boolean
- is
- begin
- return Left.Data (1 .. Left.Length) <= Right;
- end "<=";
-
- function "<="
- (Left : in Wide_String;
- Right : in Bounded_Wide_String)
- return Boolean
- is
- begin
- return Left <= Right.Data (1 .. Right.Length);
- end "<=";
-
- ---------
- -- "=" --
- ---------
-
- function "="
- (Left : in Bounded_Wide_String;
- Right : in Bounded_Wide_String)
- return Boolean
- is
- begin
- return Left.Length = Right.Length
- and then Left.Data (1 .. Left.Length) =
- Right.Data (1 .. Right.Length);
- end "=";
-
- function "="
- (Left : in Bounded_Wide_String;
- Right : in Wide_String)
- return Boolean
- is
- begin
- return Left.Length = Right'Length
- and then Left.Data (1 .. Left.Length) = Right;
- end "=";
-
- function "="
- (Left : in Wide_String;
- Right : in Bounded_Wide_String)
- return Boolean
- is
- begin
- return Left'Length = Right.Length
- and then Left = Right.Data (1 .. Right.Length);
- end "=";
-
- ---------
- -- ">" --
- ---------
-
- function ">"
- (Left : in Bounded_Wide_String;
- Right : in Bounded_Wide_String)
- return Boolean
- is
- begin
- return Left.Data (1 .. Left.Length) > Right.Data (1 .. Right.Length);
- end ">";
-
- function ">"
- (Left : in Bounded_Wide_String;
- Right : in Wide_String)
- return Boolean
- is
- begin
- return Left.Data (1 .. Left.Length) > Right;
- end ">";
-
- function ">"
- (Left : in Wide_String;
- Right : in Bounded_Wide_String)
- return Boolean
- is
- begin
- return Left > Right.Data (1 .. Right.Length);
- end ">";
-
- ----------
- -- ">=" --
- ----------
-
- function ">="
- (Left : in Bounded_Wide_String;
- Right : in Bounded_Wide_String)
- return Boolean
- is
- begin
- return Left.Data (1 .. Left.Length) >= Right.Data (1 .. Right.Length);
- end ">=";
-
- function ">="
- (Left : in Bounded_Wide_String;
- Right : in Wide_String)
- return Boolean
- is
- begin
- return Left.Data (1 .. Left.Length) >= Right;
- end ">=";
-
- function ">="
- (Left : in Wide_String;
- Right : in Bounded_Wide_String)
- return Boolean
- is
- begin
- return Left >= Right.Data (1 .. Right.Length);
- end ">=";
-
- ------------
- -- Append --
- ------------
-
- -- Case of Bounded_Wide_String and Bounded_Wide_String
-
- function Append
- (Left, Right : in Bounded_Wide_String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Llen : constant Length_Range := Left.Length;
- Rlen : constant Length_Range := Right.Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen <= Max_Length then
- Result.Length := Nlen;
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Llen >= Max_Length then -- only case is Llen = Max_Length
- Result.Data := Right.Data;
-
- else
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1 .. Max_Length) :=
- Right.Data (1 .. Max_Length - Llen);
- end if;
-
- when Strings.Left =>
- if Rlen >= Max_Length then -- only case is Rlen = Max_Length
- Result.Data := Right.Data;
-
- else
- Result.Data (1 .. Max_Length - Rlen) :=
- Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
- Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
- Right.Data (1 .. Rlen);
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Append;
-
- procedure Append
- (Source : in out Bounded_Wide_String;
- New_Item : in Bounded_Wide_String;
- Drop : in Truncation := Error)
- is
- Llen : constant Length_Range := Source.Length;
- Rlen : constant Length_Range := New_Item.Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen <= Max_Length then
- Source.Length := Nlen;
- Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen);
-
- else
- Source.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Llen < Max_Length then
- Source.Data (Llen + 1 .. Max_Length) :=
- New_Item.Data (1 .. Max_Length - Llen);
- end if;
-
- when Strings.Left =>
- if Rlen >= Max_Length then -- only case is Rlen = Max_Length
- Source.Data := New_Item.Data;
-
- else
- Source.Data (1 .. Max_Length - Rlen) :=
- Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
- Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
- New_Item.Data (1 .. Rlen);
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- end Append;
-
- -- Case of Bounded_Wide_String and Wide_String
-
- function Append
- (Left : in Bounded_Wide_String;
- Right : in Wide_String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Llen : constant Length_Range := Left.Length;
- Rlen : constant Length_Range := Right'Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen <= Max_Length then
- Result.Length := Nlen;
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1 .. Nlen) := Right;
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Llen >= Max_Length then -- only case is Llen = Max_Length
- Result.Data := Left.Data;
-
- else
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1 .. Max_Length) :=
- Right (Right'First .. Right'First - 1 +
- Max_Length - Llen);
-
- end if;
-
- when Strings.Left =>
- if Rlen >= Max_Length then
- Result.Data (1 .. Max_Length) :=
- Right (Right'Last - (Max_Length - 1) .. Right'Last);
-
- else
- Result.Data (1 .. Max_Length - Rlen) :=
- Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
- Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
- Right;
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Append;
-
- procedure Append
- (Source : in out Bounded_Wide_String;
- New_Item : in Wide_String;
- Drop : in Truncation := Error)
- is
- Llen : constant Length_Range := Source.Length;
- Rlen : constant Length_Range := New_Item'Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen <= Max_Length then
- Source.Length := Nlen;
- Source.Data (Llen + 1 .. Nlen) := New_Item;
-
- else
- Source.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Llen < Max_Length then
- Source.Data (Llen + 1 .. Max_Length) :=
- New_Item (New_Item'First ..
- New_Item'First - 1 + Max_Length - Llen);
- end if;
-
- when Strings.Left =>
- if Rlen >= Max_Length then
- Source.Data (1 .. Max_Length) :=
- New_Item (New_Item'Last - (Max_Length - 1) ..
- New_Item'Last);
-
- else
- Source.Data (1 .. Max_Length - Rlen) :=
- Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
- Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
- New_Item;
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- end Append;
-
- -- Case of Wide_String and Bounded_Wide_String
-
- function Append
- (Left : in Wide_String;
- Right : in Bounded_Wide_String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Llen : constant Length_Range := Left'Length;
- Rlen : constant Length_Range := Right.Length;
- Nlen : constant Natural := Llen + Rlen;
-
- begin
- if Nlen <= Max_Length then
- Result.Length := Nlen;
- Result.Data (1 .. Llen) := Left;
- Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen);
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Llen >= Max_Length then
- Result.Data (1 .. Max_Length) :=
- Left (Left'First .. Left'First + (Max_Length - 1));
-
- else
- Result.Data (1 .. Llen) := Left;
- Result.Data (Llen + 1 .. Max_Length) :=
- Right.Data (1 .. Max_Length - Llen);
- end if;
-
- when Strings.Left =>
- if Rlen >= Max_Length then
- Result.Data (1 .. Max_Length) :=
- Right.Data (Rlen - (Max_Length - 1) .. Rlen);
-
- else
- Result.Data (1 .. Max_Length - Rlen) :=
- Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last);
- Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
- Right.Data (1 .. Rlen);
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Append;
-
- -- Case of Bounded_Wide_String and Wide_Character
-
- function Append
- (Left : in Bounded_Wide_String;
- Right : in Wide_Character;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Llen : constant Length_Range := Left.Length;
-
- begin
- if Llen < Max_Length then
- Result.Length := Llen + 1;
- Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
- Result.Data (Llen + 1) := Right;
- return Result;
-
- else
- case Drop is
- when Strings.Right =>
- return Left;
-
- when Strings.Left =>
- Result.Length := Max_Length;
- Result.Data (1 .. Max_Length - 1) :=
- Left.Data (2 .. Max_Length);
- Result.Data (Max_Length) := Right;
- return Result;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
- end Append;
-
- procedure Append
- (Source : in out Bounded_Wide_String;
- New_Item : in Wide_Character;
- Drop : in Truncation := Error)
- is
- Llen : constant Length_Range := Source.Length;
-
- begin
- if Llen < Max_Length then
- Source.Length := Llen + 1;
- Source.Data (Llen + 1) := New_Item;
-
- else
- Source.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- null;
-
- when Strings.Left =>
- Source.Data (1 .. Max_Length - 1) :=
- Source.Data (2 .. Max_Length);
- Source.Data (Max_Length) := New_Item;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- end Append;
-
- -- Case of Wide_Character and Bounded_Wide_String
-
- function Append
- (Left : in Wide_Character;
- Right : in Bounded_Wide_String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Rlen : constant Length_Range := Right.Length;
-
- begin
- if Rlen < Max_Length then
- Result.Length := Rlen + 1;
- Result.Data (1) := Left;
- Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen);
- return Result;
-
- else
- case Drop is
- when Strings.Right =>
- Result.Length := Max_Length;
- Result.Data (1) := Left;
- Result.Data (2 .. Max_Length) :=
- Right.Data (1 .. Max_Length - 1);
- return Result;
-
- when Strings.Left =>
- return Right;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
- end Append;
-
- -----------
- -- Count --
- -----------
-
- function Count
- (Source : in Bounded_Wide_String;
- Pattern : in Wide_String;
- Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
- return Natural
- is
- begin
- return
- Wide_Search.Count
- (Source.Data (1 .. Source.Length), Pattern, Mapping);
- end Count;
-
- function Count
- (Source : in Bounded_Wide_String;
- Pattern : in Wide_String;
- Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
- return Natural
- is
- begin
- return
- Wide_Search.Count
- (Source.Data (1 .. Source.Length), Pattern, Mapping);
- end Count;
-
- function Count
- (Source : in Bounded_Wide_String;
- Set : in Wide_Maps.Wide_Character_Set)
- return Natural
- is
- begin
- return Wide_Search.Count (Source.Data (1 .. Source.Length), Set);
- end Count;
-
- ------------
- -- Delete --
- ------------
-
- function Delete
- (Source : in Bounded_Wide_String;
- From : in Positive;
- Through : in Natural)
- return Bounded_Wide_String
- is
- Slen : constant Natural := Source.Length;
- Num_Delete : constant Integer := Through - From + 1;
- Result : Bounded_Wide_String;
-
- begin
- if Num_Delete <= 0 then
- return Source;
-
- elsif From > Slen + 1 then
- raise Ada.Strings.Index_Error;
-
- elsif Through >= Slen then
- Result.Length := From - 1;
- Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
- return Result;
-
- else
- Result.Length := Slen - Num_Delete;
- Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
- Result.Data (From .. Result.Length) :=
- Source.Data (Through + 1 .. Slen);
- return Result;
- end if;
- end Delete;
-
- procedure Delete
- (Source : in out Bounded_Wide_String;
- From : in Positive;
- Through : in Natural)
- is
- Slen : constant Natural := Source.Length;
- Num_Delete : constant Integer := Through - From + 1;
-
- begin
- if Num_Delete <= 0 then
- return;
-
- elsif From > Slen + 1 then
- raise Ada.Strings.Index_Error;
-
- elsif Through >= Slen then
- Source.Length := From - 1;
-
- else
- Source.Length := Slen - Num_Delete;
- Source.Data (From .. Source.Length) :=
- Source.Data (Through + 1 .. Slen);
- end if;
- end Delete;
-
- -------------
- -- Element --
- -------------
-
- function Element
- (Source : in Bounded_Wide_String;
- Index : in Positive)
- return Wide_Character
- is
- begin
- if Index in 1 .. Source.Length then
- return Source.Data (Index);
- else
- raise Strings.Index_Error;
- end if;
- end Element;
-
- ----------------
- -- Find_Token --
- ----------------
-
- procedure Find_Token
- (Source : in Bounded_Wide_String;
- Set : in Wide_Maps.Wide_Character_Set;
- Test : in Strings.Membership;
- First : out Positive;
- Last : out Natural)
- is
- begin
- Wide_Search.Find_Token
- (Source.Data (1 .. Source.Length), Set, Test, First, Last);
- end Find_Token;
-
-
- ----------
- -- Head --
- ----------
-
- function Head
- (Source : in Bounded_Wide_String;
- Count : in Natural;
- Pad : in Wide_Character := Wide_Space;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Slen : constant Natural := Source.Length;
- Npad : constant Integer := Count - Slen;
-
- begin
- if Npad <= 0 then
- Result.Length := Count;
- Result.Data (1 .. Count) := Source.Data (1 .. Count);
-
- elsif Count <= Max_Length then
- Result.Length := Count;
- Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
- Result.Data (Slen + 1 .. Count) := (others => Pad);
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
- Result.Data (Slen + 1 .. Max_Length) := (others => Pad);
-
- when Strings.Left =>
- if Npad >= Max_Length then
- Result.Data := (others => Pad);
-
- else
- Result.Data (1 .. Max_Length - Npad) :=
- Source.Data (Count - Max_Length + 1 .. Slen);
- Result.Data (Max_Length - Npad + 1 .. Max_Length) :=
- (others => Pad);
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Head;
-
- procedure Head
- (Source : in out Bounded_Wide_String;
- Count : in Natural;
- Pad : in Wide_Character := Wide_Space;
- Drop : in Truncation := Error)
- is
- Slen : constant Natural := Source.Length;
- Npad : constant Integer := Count - Slen;
- Temp : Wide_String (1 .. Max_Length);
-
- begin
- if Npad <= 0 then
- Source.Length := Count;
-
- elsif Count <= Max_Length then
- Source.Length := Count;
- Source.Data (Slen + 1 .. Count) := (others => Pad);
-
- else
- Source.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- Source.Data (Slen + 1 .. Max_Length) := (others => Pad);
-
- when Strings.Left =>
- if Npad > Max_Length then
- Source.Data := (others => Pad);
-
- else
- Temp := Source.Data;
- Source.Data (1 .. Max_Length - Npad) :=
- Temp (Count - Max_Length + 1 .. Slen);
-
- for J in Max_Length - Npad + 1 .. Max_Length loop
- Source.Data (J) := Pad;
- end loop;
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- end Head;
-
- -----------
- -- Index --
- -----------
-
- function Index
- (Source : in Bounded_Wide_String;
- Pattern : in Wide_String;
- Going : in Strings.Direction := Strings.Forward;
- Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
- return Natural
- is
- begin
- return Wide_Search.Index
- (Source.Data (1 .. Source.Length), Pattern, Going, Mapping);
- end Index;
-
- function Index
- (Source : in Bounded_Wide_String;
- Pattern : in Wide_String;
- Going : in Direction := Forward;
- Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
- return Natural
- is
- begin
- return Wide_Search.Index
- (Source.Data (1 .. Source.Length), Pattern, Going, Mapping);
- end Index;
-
- function Index
- (Source : in Bounded_Wide_String;
- Set : in Wide_Maps.Wide_Character_Set;
- Test : in Strings.Membership := Strings.Inside;
- Going : in Strings.Direction := Strings.Forward)
- return Natural
- is
- begin
- return Wide_Search.Index
- (Source.Data (1 .. Source.Length), Set, Test, Going);
- end Index;
-
- ---------------------
- -- Index_Non_Blank --
- ---------------------
-
- function Index_Non_Blank
- (Source : in Bounded_Wide_String;
- Going : in Strings.Direction := Strings.Forward)
- return Natural
- is
- begin
- return
- Wide_Search.Index_Non_Blank
- (Source.Data (1 .. Source.Length), Going);
- end Index_Non_Blank;
-
- ------------
- -- Insert --
- ------------
-
- function Insert
- (Source : in Bounded_Wide_String;
- Before : in Positive;
- New_Item : in Wide_String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_Wide_String
- is
- Slen : constant Natural := Source.Length;
- Nlen : constant Natural := New_Item'Length;
- Tlen : constant Natural := Slen + Nlen;
- Blen : constant Natural := Before - 1;
- Alen : constant Integer := Slen - Blen;
- Droplen : constant Integer := Tlen - Max_Length;
- Result : Bounded_Wide_String;
-
- -- Tlen is the length of the total string before possible truncation.
- -- Blen, Alen are the lengths of the before and after pieces of the
- -- source string.
-
- begin
- if Alen < 0 then
- raise Ada.Strings.Index_Error;
-
- elsif Droplen <= 0 then
- Result.Length := Tlen;
- Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
- Result.Data (Before .. Before + Nlen - 1) := New_Item;
- Result.Data (Before + Nlen .. Tlen) :=
- Source.Data (Before .. Slen);
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
-
- if Droplen > Alen then
- Result.Data (Before .. Max_Length) :=
- New_Item (New_Item'First
- .. New_Item'First + Max_Length - Before);
- else
- Result.Data (Before .. Before + Nlen - 1) := New_Item;
- Result.Data (Before + Nlen .. Max_Length) :=
- Source.Data (Before .. Slen - Droplen);
- end if;
-
- when Strings.Left =>
- Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
- Source.Data (Before .. Slen);
-
- if Droplen >= Blen then
- Result.Data (1 .. Max_Length - Alen) :=
- New_Item (New_Item'Last - (Max_Length - Alen) + 1
- .. New_Item'Last);
- else
- Result.Data
- (Blen - Droplen + 1 .. Max_Length - Alen) :=
- New_Item;
- Result.Data (1 .. Blen - Droplen) :=
- Source.Data (Droplen + 1 .. Blen);
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Insert;
-
- procedure Insert
- (Source : in out Bounded_Wide_String;
- Before : in Positive;
- New_Item : in Wide_String;
- Drop : in Strings.Truncation := Strings.Error)
- is
- begin
- -- We do a double copy here because this is one of the situations
- -- in which we move data to the right, and at least at the moment,
- -- GNAT is not handling such cases correctly ???
-
- Source := Insert (Source, Before, New_Item, Drop);
- end Insert;
-
- ------------
- -- Length --
- ------------
-
- function Length (Source : in Bounded_Wide_String) return Length_Range is
- begin
- return Source.Length;
- end Length;
-
- ---------------
- -- Overwrite --
- ---------------
-
- function Overwrite
- (Source : in Bounded_Wide_String;
- Position : in Positive;
- New_Item : in Wide_String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Endpos : constant Natural := Position + New_Item'Length - 1;
- Slen : constant Natural := Source.Length;
- Droplen : Natural;
-
- begin
- if Position > Slen + 1 then
- raise Ada.Strings.Index_Error;
-
- elsif New_Item'Length = 0 then
- return Source;
-
- elsif Endpos <= Slen then
- Result.Length := Source.Length;
- Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
- Result.Data (Position .. Endpos) := New_Item;
- return Result;
-
- elsif Endpos <= Max_Length then
- Result.Length := Endpos;
- Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1);
- Result.Data (Position .. Endpos) := New_Item;
- return Result;
-
- else
- Result.Length := Max_Length;
- Droplen := Endpos - Max_Length;
-
- case Drop is
- when Strings.Right =>
- Result.Data (1 .. Position - 1) :=
- Source.Data (1 .. Position - 1);
-
- Result.Data (Position .. Max_Length) :=
- New_Item (New_Item'First .. New_Item'Last - Droplen);
- return Result;
-
- when Strings.Left =>
- if New_Item'Length >= Max_Length then
- Result.Data (1 .. Max_Length) :=
- New_Item (New_Item'Last - Max_Length + 1 ..
- New_Item'Last);
- return Result;
-
- else
- Result.Data (1 .. Max_Length - New_Item'Length) :=
- Source.Data (Droplen + 1 .. Position - 1);
- Result.Data
- (Max_Length - New_Item'Length + 1 .. Max_Length) :=
- New_Item;
- return Result;
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
- end Overwrite;
-
- procedure Overwrite
- (Source : in out Bounded_Wide_String;
- Position : in Positive;
- New_Item : in Wide_String;
- Drop : in Strings.Truncation := Strings.Error)
- is
- Endpos : constant Positive := Position + New_Item'Length - 1;
- Slen : constant Natural := Source.Length;
- Droplen : Natural;
-
- begin
- if Position > Slen + 1 then
- raise Ada.Strings.Index_Error;
-
- elsif Endpos <= Slen then
- Source.Data (Position .. Endpos) := New_Item;
-
- elsif Endpos <= Max_Length then
- Source.Data (Position .. Endpos) := New_Item;
- Source.Length := Endpos;
-
- else
- Source.Length := Max_Length;
- Droplen := Endpos - Max_Length;
-
- case Drop is
- when Strings.Right =>
- Source.Data (Position .. Max_Length) :=
- New_Item (New_Item'First .. New_Item'Last - Droplen);
-
- when Strings.Left =>
- if New_Item'Length > Max_Length then
- Source.Data (1 .. Max_Length) :=
- New_Item (New_Item'Last - Max_Length + 1 ..
- New_Item'Last);
-
- else
- Source.Data (1 .. Max_Length - New_Item'Length) :=
- Source.Data (Droplen + 1 .. Position - 1);
-
- Source.Data
- (Max_Length - New_Item'Length + 1 .. Max_Length) :=
- New_Item;
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
- end Overwrite;
-
- ---------------------
- -- Replace_Element --
- ---------------------
-
- procedure Replace_Element
- (Source : in out Bounded_Wide_String;
- Index : in Positive;
- By : in Wide_Character)
- is
- begin
- if Index <= Source.Length then
- Source.Data (Index) := By;
- else
- raise Ada.Strings.Index_Error;
- end if;
- end Replace_Element;
-
- -------------------
- -- Replace_Slice --
- -------------------
-
- function Replace_Slice
- (Source : in Bounded_Wide_String;
- Low : in Positive;
- High : in Natural;
- By : in Wide_String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_Wide_String
- is
- Slen : constant Natural := Source.Length;
-
- begin
- if Low > Slen + 1 then
- raise Strings.Index_Error;
-
- elsif High < Low then
- return Insert (Source, Low, By, Drop);
-
- else
- declare
- Blen : constant Natural := Natural'Max (0, Low - 1);
- Alen : constant Natural := Natural'Max (0, Slen - High);
- Tlen : constant Natural := Blen + By'Length + Alen;
- Droplen : constant Integer := Tlen - Max_Length;
- Result : Bounded_Wide_String;
-
- -- Tlen is the total length of the result string before any
- -- truncation. Blen and Alen are the lengths of the pieces
- -- of the original string that end up in the result string
- -- before and after the replaced slice.
-
- begin
- if Droplen <= 0 then
- Result.Length := Tlen;
- Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
- Result.Data (Low .. Low + By'Length - 1) := By;
- Result.Data (Low + By'Length .. Tlen) :=
- Source.Data (High + 1 .. Slen);
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
-
- if Droplen > Alen then
- Result.Data (Low .. Max_Length) :=
- By (By'First .. By'First + Max_Length - Low);
- else
- Result.Data (Low .. Low + By'Length - 1) := By;
- Result.Data (Low + By'Length .. Max_Length) :=
- Source.Data (High + 1 .. Slen - Droplen);
- end if;
-
- when Strings.Left =>
- Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
- Source.Data (High + 1 .. Slen);
-
- if Droplen >= Blen then
- Result.Data (1 .. Max_Length - Alen) :=
- By (By'Last - (Max_Length - Alen) + 1 .. By'Last);
- else
- Result.Data
- (Blen - Droplen + 1 .. Max_Length - Alen) := By;
- Result.Data (1 .. Blen - Droplen) :=
- Source.Data (Droplen + 1 .. Blen);
- end if;
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end;
- end if;
- end Replace_Slice;
-
- procedure Replace_Slice
- (Source : in out Bounded_Wide_String;
- Low : in Positive;
- High : in Natural;
- By : in Wide_String;
- Drop : in Strings.Truncation := Strings.Error)
- is
- begin
- -- We do a double copy here because this is one of the situations
- -- in which we move data to the right, and at least at the moment,
- -- GNAT is not handling such cases correctly ???
-
- Source := Replace_Slice (Source, Low, High, By, Drop);
- end Replace_Slice;
-
---------------
-- Replicate --
---------------
@@ -1368,21 +67,8 @@ package body Ada.Strings.Wide_Bounded is
Drop : in Strings.Truncation := Strings.Error)
return Bounded_Wide_String
is
- Result : Bounded_Wide_String;
-
begin
- if Count <= Max_Length then
- Result.Length := Count;
-
- elsif Drop = Strings.Error then
- raise Ada.Strings.Length_Error;
-
- else
- Result.Length := Max_Length;
- end if;
-
- Result.Data (1 .. Result.Length) := (others => Item);
- return Result;
+ return Super_Replicate (Count, Item, Drop, Max_Length);
end Replicate;
function Replicate
@@ -1391,420 +77,24 @@ package body Ada.Strings.Wide_Bounded is
Drop : in Strings.Truncation := Strings.Error)
return Bounded_Wide_String
is
- Length : constant Integer := Count * Item'Length;
- Result : Bounded_Wide_String;
- Indx : Positive;
-
begin
- if Length <= Max_Length then
- Result.Length := Length;
-
- if Length > 0 then
- Indx := 1;
-
- for J in 1 .. Count loop
- Result.Data (Indx .. Indx + Item'Length - 1) := Item;
- Indx := Indx + Item'Length;
- end loop;
- end if;
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- Indx := 1;
-
- while Indx + Item'Length <= Max_Length + 1 loop
- Result.Data (Indx .. Indx + Item'Length - 1) := Item;
- Indx := Indx + Item'Length;
- end loop;
-
- Result.Data (Indx .. Max_Length) :=
- Item (Item'First .. Item'First + Max_Length - Indx);
-
- when Strings.Left =>
- Indx := Max_Length;
-
- while Indx - Item'Length >= 1 loop
- Result.Data (Indx - (Item'Length - 1) .. Indx) := Item;
- Indx := Indx - Item'Length;
- end loop;
-
- Result.Data (1 .. Indx) :=
- Item (Item'Last - Indx + 1 .. Item'Last);
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Replicate;
-
- function Replicate
- (Count : in Natural;
- Item : in Bounded_Wide_String;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_Wide_String
- is
- begin
- return Replicate (Count, Item.Data (1 .. Item.Length), Drop);
+ return Super_Replicate (Count, Item, Drop, Max_Length);
end Replicate;
- -----------
- -- Slice --
- -----------
-
- function Slice
- (Source : Bounded_Wide_String;
- Low : Positive;
- High : Natural)
- return Wide_String
- is
- begin
- -- Note: test of High > Length is in accordance with AI95-00128
-
- if Low > Source.Length + 1 or else High > Source.Length then
- raise Index_Error;
-
- else
- declare
- Result : Wide_String (1 .. High - Low + 1);
-
- begin
- Result := Source.Data (Low .. High);
- return Result;
- end;
- end if;
- end Slice;
-
- ----------
- -- Tail --
- ----------
-
- function Tail
- (Source : in Bounded_Wide_String;
- Count : in Natural;
- Pad : in Wide_Character := Wide_Space;
- Drop : in Strings.Truncation := Strings.Error)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Slen : constant Natural := Source.Length;
- Npad : constant Integer := Count - Slen;
-
- begin
- if Npad <= 0 then
- Result.Length := Count;
- Result.Data (1 .. Count) :=
- Source.Data (Slen - (Count - 1) .. Slen);
-
- elsif Count <= Max_Length then
- Result.Length := Count;
- Result.Data (1 .. Npad) := (others => Pad);
- Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen);
-
- else
- Result.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Npad >= Max_Length then
- Result.Data := (others => Pad);
-
- else
- Result.Data (1 .. Npad) := (others => Pad);
- Result.Data (Npad + 1 .. Max_Length) :=
- Source.Data (1 .. Max_Length - Npad);
- end if;
-
- when Strings.Left =>
- Result.Data (1 .. Max_Length - Slen) := (others => Pad);
- Result.Data (Max_Length - Slen + 1 .. Max_Length) :=
- Source.Data (1 .. Slen);
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
- end Tail;
-
- procedure Tail
- (Source : in out Bounded_Wide_String;
- Count : in Natural;
- Pad : in Wide_Character := Wide_Space;
- Drop : in Truncation := Error)
- is
- Slen : constant Natural := Source.Length;
- Npad : constant Integer := Count - Slen;
- Temp : Wide_String (1 .. Max_Length) := Source.Data;
-
- begin
- if Npad <= 0 then
- Source.Length := Count;
- Source.Data (1 .. Count) :=
- Temp (Slen - (Count - 1) .. Slen);
-
- elsif Count <= Max_Length then
- Source.Length := Count;
- Source.Data (1 .. Npad) := (others => Pad);
- Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen);
-
- else
- Source.Length := Max_Length;
-
- case Drop is
- when Strings.Right =>
- if Npad >= Max_Length then
- Source.Data := (others => Pad);
-
- else
- Source.Data (1 .. Npad) := (others => Pad);
- Source.Data (Npad + 1 .. Max_Length) :=
- Temp (1 .. Max_Length - Npad);
- end if;
-
- when Strings.Left =>
- for J in 1 .. Max_Length - Slen loop
- Source.Data (J) := Pad;
- end loop;
-
- Source.Data (Max_Length - Slen + 1 .. Max_Length) :=
- Temp (1 .. Slen);
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- end Tail;
- ----------------------------
- -- To_Bounded_Wide_String --
- ----------------------------
+ -----------------------
+ -- To_Bounded_String --
+ -----------------------
function To_Bounded_Wide_String
(Source : in Wide_String;
Drop : in Strings.Truncation := Strings.Error)
return Bounded_Wide_String
is
- Slen : constant Natural := Source'Length;
- Result : Bounded_Wide_String;
-
begin
- if Slen <= Max_Length then
- Result.Length := Slen;
- Result.Data (1 .. Slen) := Source;
-
- else
- case Drop is
- when Strings.Right =>
- Result.Length := Max_Length;
- Result.Data (1 .. Max_Length) :=
- Source (Source'First .. Source'First - 1 + Max_Length);
-
- when Strings.Left =>
- Result.Length := Max_Length;
- Result.Data (1 .. Max_Length) :=
- Source (Source'Last - (Max_Length - 1) .. Source'Last);
-
- when Strings.Error =>
- raise Ada.Strings.Length_Error;
- end case;
- end if;
-
- return Result;
+ return To_Super_String (Source, Max_Length, Drop);
end To_Bounded_Wide_String;
- --------------------
- -- To_Wide_String --
- --------------------
-
- function To_Wide_String
- (Source : in Bounded_Wide_String)
- return Wide_String
- is
- begin
- return Source.Data (1 .. Source.Length);
- end To_Wide_String;
-
- ---------------
- -- Translate --
- ---------------
-
- function Translate
- (Source : in Bounded_Wide_String;
- Mapping : in Wide_Maps.Wide_Character_Mapping)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
-
- begin
- Result.Length := Source.Length;
-
- for J in 1 .. Source.Length loop
- Result.Data (J) := Value (Mapping, Source.Data (J));
- end loop;
-
- return Result;
- end Translate;
-
- procedure Translate
- (Source : in out Bounded_Wide_String;
- Mapping : in Wide_Maps.Wide_Character_Mapping)
- is
- begin
- for J in 1 .. Source.Length loop
- Source.Data (J) := Value (Mapping, Source.Data (J));
- end loop;
- end Translate;
-
- function Translate
- (Source : in Bounded_Wide_String;
- Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
-
- begin
- Result.Length := Source.Length;
-
- for J in 1 .. Source.Length loop
- Result.Data (J) := Mapping.all (Source.Data (J));
- end loop;
-
- return Result;
- end Translate;
-
- procedure Translate
- (Source : in out Bounded_Wide_String;
- Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
- is
- begin
- for J in 1 .. Source.Length loop
- Source.Data (J) := Mapping.all (Source.Data (J));
- end loop;
- end Translate;
-
- ----------
- -- Trim --
- ----------
-
- function Trim
- (Source : in Bounded_Wide_String;
- Side : in Trim_End)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
- Last : Natural := Source.Length;
- First : Positive := 1;
-
- begin
- if Side = Left or else Side = Both then
- while First <= Last and then Source.Data (First) = ' ' loop
- First := First + 1;
- end loop;
- end if;
-
- if Side = Right or else Side = Both then
- while Last >= First and then Source.Data (Last) = ' ' loop
- Last := Last - 1;
- end loop;
- end if;
-
- Result.Length := Last - First + 1;
- Result.Data (1 .. Result.Length) := Source.Data (First .. Last);
- return Result;
-
- end Trim;
-
- procedure Trim
- (Source : in out Bounded_Wide_String;
- Side : in Trim_End)
- is
- Last : Length_Range := Source.Length;
- First : Positive := 1;
- Temp : Wide_String (1 .. Max_Length);
-
- begin
- Temp (1 .. Last) := Source.Data (1 .. Last);
-
- if Side = Left or else Side = Both then
- while First <= Last and then Temp (First) = ' ' loop
- First := First + 1;
- end loop;
- end if;
-
- if Side = Right or else Side = Both then
- while Last >= First and then Temp (Last) = ' ' loop
- Last := Last - 1;
- end loop;
- end if;
-
- Source.Length := Last - First + 1;
- Source.Data (1 .. Source.Length) := Temp (First .. Last);
-
- end Trim;
-
- function Trim
- (Source : in Bounded_Wide_String;
- Left : in Wide_Maps.Wide_Character_Set;
- Right : in Wide_Maps.Wide_Character_Set)
- return Bounded_Wide_String
- is
- Result : Bounded_Wide_String;
-
- begin
- for First in 1 .. Source.Length loop
- if not Is_In (Source.Data (First), Left) then
- for Last in reverse First .. Source.Length loop
- if not Is_In (Source.Data (Last), Right) then
- Result.Length := Last - First + 1;
- Result.Data (1 .. Result.Length) :=
- Source.Data (First .. Last);
- return Result;
- end if;
- end loop;
- end if;
- end loop;
-
- Result.Length := 0;
- return Result;
- end Trim;
-
- procedure Trim
- (Source : in out Bounded_Wide_String;
- Left : in Wide_Maps.Wide_Character_Set;
- Right : in Wide_Maps.Wide_Character_Set)
- is
- begin
- for First in 1 .. Source.Length loop
- if not Is_In (Source.Data (First), Left) then
- for Last in reverse First .. Source.Length loop
- if not Is_In (Source.Data (Last), Right) then
- if First = 1 then
- Source.Length := Last;
- return;
- else
- Source.Length := Last - First + 1;
- Source.Data (1 .. Source.Length) :=
- Source.Data (First .. Last);
- return;
- end if;
- end if;
- end loop;
-
- Source.Length := 0;
- return;
- end if;
- end loop;
-
- Source.Length := 0;
- end Trim;
-
end Generic_Bounded_Length;
end Ada.Strings.Wide_Bounded;
diff --git a/gcc/ada/a-stwibo.ads b/gcc/ada/a-stwibo.ads
index 3da44797543..9cebf6f484b 100644
--- a/gcc/ada/a-stwibo.ads
+++ b/gcc/ada/a-stwibo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1997 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -36,6 +36,7 @@
------------------------------------------------------------------------------
with Ada.Strings.Wide_Maps;
+with Ada.Strings.Wide_Superbounded;
package Ada.Strings.Wide_Bounded is
pragma Preelaborate (Wide_Bounded);
@@ -448,34 +449,412 @@ pragma Preelaborate (Wide_Bounded);
return Bounded_Wide_String;
private
- Wide_NUL : constant Wide_Character := Wide_Character'Val (0);
- type Bounded_Wide_String is record
- Length : Length_Range := 0;
- Data : Wide_String (1 .. Max_Length);
- end record;
+ -- Most of the implementation is in the non generic package
+ -- Ada.Strings.Superbounded. Type Bounded_Wide_String is derived from
+ -- type Wide_Superbounded.Super_String with the maximum length
+ -- constraint. Except for five, all subprograms are renames of
+ -- subprograms that are inherited from Wide_Superbounded.Super_String.
+
+ type Bounded_Wide_String is
+ new Wide_Superbounded.Super_String (Max_Length);
Null_Bounded_Wide_String : constant Bounded_Wide_String :=
- (Length => 0, Data => (1 .. Max_Length => Wide_NUL));
-
- -- Pragma Inline declarations (GNAT specific additions)
-
- pragma Inline ("=");
- pragma Inline ("<");
- pragma Inline ("<=");
- pragma Inline (">");
- pragma Inline (">=");
- pragma Inline ("&");
- pragma Inline (Count);
- pragma Inline (Element);
- pragma Inline (Find_Token);
- pragma Inline (Index);
- pragma Inline (Index_Non_Blank);
- pragma Inline (Length);
- pragma Inline (Replace_Element);
- pragma Inline (Slice);
+ (Max_Length => Max_Length,
+ Current_Length => 0,
+ Data => (1 .. Max_Length => Wide_Superbounded.Wide_NUL));
+
pragma Inline (To_Bounded_Wide_String);
- pragma Inline (To_Wide_String);
+
+ function Length (Source : in Bounded_Wide_String) return Length_Range
+ renames Super_Length;
+
+ function To_Wide_String
+ (Source : in Bounded_Wide_String)
+ return Wide_String
+ renames Super_To_String;
+
+ function Append
+ (Left, Right : in Bounded_Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String
+ renames Super_Append;
+
+ function Append
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String
+ renames Super_Append;
+
+ function Append
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String
+ renames Super_Append;
+
+ function Append
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_Character;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String
+ renames Super_Append;
+
+ function Append
+ (Left : in Wide_Character;
+ Right : in Bounded_Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String
+ renames Super_Append;
+
+ procedure Append
+ (Source : in out Bounded_Wide_String;
+ New_Item : in Bounded_Wide_String;
+ Drop : in Truncation := Error)
+ renames Super_Append;
+
+ procedure Append
+ (Source : in out Bounded_Wide_String;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Error)
+ renames Super_Append;
+
+ procedure Append
+ (Source : in out Bounded_Wide_String;
+ New_Item : in Wide_Character;
+ Drop : in Truncation := Error)
+ renames Super_Append;
+
+ function "&"
+ (Left, Right : in Bounded_Wide_String)
+ return Bounded_Wide_String
+ renames Concat;
+
+ function "&"
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Bounded_Wide_String
+ renames Concat;
+
+ function "&"
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Bounded_Wide_String
+ renames Concat;
+
+ function "&"
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_Character)
+ return Bounded_Wide_String
+ renames Concat;
+
+ function "&"
+ (Left : in Wide_Character;
+ Right : in Bounded_Wide_String)
+ return Bounded_Wide_String
+ renames Concat;
+
+ function Element
+ (Source : in Bounded_Wide_String;
+ Index : in Positive)
+ return Wide_Character
+ renames Super_Element;
+
+ procedure Replace_Element
+ (Source : in out Bounded_Wide_String;
+ Index : in Positive;
+ By : in Wide_Character)
+ renames Super_Replace_Element;
+
+ function Slice
+ (Source : in Bounded_Wide_String;
+ Low : in Positive;
+ High : in Natural)
+ return Wide_String
+ renames Super_Slice;
+
+ function "=" (Left, Right : in Bounded_Wide_String) return Boolean
+ renames Equal;
+
+ function "="
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ renames Equal;
+
+ function "="
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ renames Equal;
+
+ function "<" (Left, Right : in Bounded_Wide_String) return Boolean
+ renames Less;
+
+ function "<"
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ renames Less;
+
+ function "<"
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ renames Less;
+
+ function "<=" (Left, Right : in Bounded_Wide_String) return Boolean
+ renames Less_Or_Equal;
+
+ function "<="
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ renames Less_Or_Equal;
+
+ function "<="
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ renames Less_Or_Equal;
+
+ function ">" (Left, Right : in Bounded_Wide_String) return Boolean
+ renames Greater;
+
+ function ">"
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ renames Greater;
+
+ function ">"
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ renames Greater;
+
+ function ">=" (Left, Right : in Bounded_Wide_String) return Boolean
+ renames Greater_Or_Equal;
+
+ function ">="
+ (Left : in Bounded_Wide_String;
+ Right : in Wide_String)
+ return Boolean
+ renames Greater_Or_Equal;
+
+ function ">="
+ (Left : in Wide_String;
+ Right : in Bounded_Wide_String)
+ return Boolean
+ renames Greater_Or_Equal;
+
+ function Index
+ (Source : in Bounded_Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural
+ renames Super_Index;
+
+ function Index
+ (Source : in Bounded_Wide_String;
+ Pattern : in Wide_String;
+ Going : in Direction := Forward;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural
+ renames Super_Index;
+
+ function Index
+ (Source : in Bounded_Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership := Inside;
+ Going : in Direction := Forward)
+ return Natural
+ renames Super_Index;
+
+ function Index_Non_Blank
+ (Source : in Bounded_Wide_String;
+ Going : in Direction := Forward)
+ return Natural
+ renames Super_Index_Non_Blank;
+
+ function Count
+ (Source : in Bounded_Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural
+ renames Super_Count;
+
+ function Count
+ (Source : in Bounded_Wide_String;
+ Pattern : in Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural
+ renames Super_Count;
+
+ function Count
+ (Source : in Bounded_Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set)
+ return Natural
+ renames Super_Count;
+
+ procedure Find_Token
+ (Source : in Bounded_Wide_String;
+ Set : in Wide_Maps.Wide_Character_Set;
+ Test : in Membership;
+ First : out Positive;
+ Last : out Natural)
+ renames Super_Find_Token;
+
+ function Translate
+ (Source : in Bounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping)
+ return Bounded_Wide_String
+ renames Super_Translate;
+
+ procedure Translate
+ (Source : in out Bounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping)
+ renames Super_Translate;
+
+ function Translate
+ (Source : in Bounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ return Bounded_Wide_String
+ renames Super_Translate;
+
+ procedure Translate
+ (Source : in out Bounded_Wide_String;
+ Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ renames Super_Translate;
+
+ function Replace_Slice
+ (Source : in Bounded_Wide_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String
+ renames Super_Replace_Slice;
+
+ procedure Replace_Slice
+ (Source : in out Bounded_Wide_String;
+ Low : in Positive;
+ High : in Natural;
+ By : in Wide_String;
+ Drop : in Truncation := Error)
+ renames Super_Replace_Slice;
+
+ function Insert
+ (Source : in Bounded_Wide_String;
+ Before : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String
+ renames Super_Insert;
+
+ procedure Insert
+ (Source : in out Bounded_Wide_String;
+ Before : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Error)
+ renames Super_Insert;
+
+ function Overwrite
+ (Source : in Bounded_Wide_String;
+ Position : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String
+ renames Super_Overwrite;
+
+ procedure Overwrite
+ (Source : in out Bounded_Wide_String;
+ Position : in Positive;
+ New_Item : in Wide_String;
+ Drop : in Truncation := Error)
+ renames Super_Overwrite;
+
+ function Delete
+ (Source : in Bounded_Wide_String;
+ From : in Positive;
+ Through : in Natural)
+ return Bounded_Wide_String
+ renames Super_Delete;
+
+ procedure Delete
+ (Source : in out Bounded_Wide_String;
+ From : in Positive;
+ Through : in Natural)
+ renames Super_Delete;
+
+ function Trim
+ (Source : in Bounded_Wide_String;
+ Side : in Trim_End)
+ return Bounded_Wide_String
+ renames Super_Trim;
+
+ procedure Trim
+ (Source : in out Bounded_Wide_String;
+ Side : in Trim_End)
+ renames Super_Trim;
+
+ function Trim
+ (Source : in Bounded_Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set)
+ return Bounded_Wide_String
+ renames Super_Trim;
+
+ procedure Trim
+ (Source : in out Bounded_Wide_String;
+ Left : in Wide_Maps.Wide_Character_Set;
+ Right : in Wide_Maps.Wide_Character_Set)
+ renames Super_Trim;
+
+ function Head
+ (Source : in Bounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String
+ renames Super_Head;
+
+ procedure Head
+ (Source : in out Bounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space;
+ Drop : in Truncation := Error)
+ renames Super_Head;
+
+ function Tail
+ (Source : in Bounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String
+ renames Super_Tail;
+
+ procedure Tail
+ (Source : in out Bounded_Wide_String;
+ Count : in Natural;
+ Pad : in Wide_Character := Wide_Space;
+ Drop : in Truncation := Error)
+ renames Super_Tail;
+
+ function "*"
+ (Left : in Natural;
+ Right : in Bounded_Wide_String)
+ return Bounded_Wide_String
+ renames Times;
+
+ function Replicate
+ (Count : in Natural;
+ Item : in Bounded_Wide_String;
+ Drop : in Truncation := Error)
+ return Bounded_Wide_String
+ renames Super_Replicate;
end Generic_Bounded_Length;
diff --git a/gcc/ada/a-stwifi.adb b/gcc/ada/a-stwifi.adb
index dc71f1b878a..100fb8019e6 100644
--- a/gcc/ada/a-stwifi.adb
+++ b/gcc/ada/a-stwifi.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -379,7 +379,7 @@ package body Ada.Strings.Wide_Fixed is
raise Index_Error;
else
declare
- Result_Length : Natural :=
+ Result_Length : constant Natural :=
Natural'Max
(Source'Length,
Position - Source'First + New_Item'Length);
@@ -588,7 +588,8 @@ package body Ada.Strings.Wide_Fixed is
else
declare
- Result : Wide_String (1 .. High - Low + 1) := Source (Low .. High);
+ Result : constant Wide_String (1 .. High - Low + 1) :=
+ Source (Low .. High);
begin
return Result;
diff --git a/gcc/ada/a-stwima.adb b/gcc/ada/a-stwima.adb
index 23bfc0b3ee2..e3bacd4498a 100644
--- a/gcc/ada/a-stwima.adb
+++ b/gcc/ada/a-stwima.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -707,7 +707,7 @@ package body Ada.Strings.Wide_Maps is
begin
return
(AF.Controlled with
- Set => new Wide_Character_Ranges' (1 => (Singleton, Singleton)));
+ Set => new Wide_Character_Ranges'(1 => (Singleton, Singleton)));
end To_Set;
-----------
diff --git a/gcc/ada/a-stwisu.adb b/gcc/ada/a-stwisu.adb
new file mode 100644
index 00000000000..ebf15f71264
--- /dev/null
+++ b/gcc/ada/a-stwisu.adb
@@ -0,0 +1,1809 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ S U P E R B O U N D E D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps;
+with Ada.Strings.Wide_Search;
+
+package body Ada.Strings.Wide_Superbounded is
+
+ ------------
+ -- Concat --
+ ------------
+
+ function Concat
+ (Left : Super_String;
+ Right : Super_String)
+ return Super_String
+ is
+ Result : Super_String (Left.Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen > Left.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end Concat;
+
+ function Concat
+ (Left : Super_String;
+ Right : Wide_String)
+ return Super_String
+ is
+ Result : Super_String (Left.Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+
+ Nlen : constant Natural := Llen + Right'Length;
+
+ begin
+ if Nlen > Left.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right;
+ end if;
+ return Result;
+ end Concat;
+
+ function Concat
+ (Left : Wide_String;
+ Right : Super_String)
+ return Super_String
+ is
+ Result : Super_String (Right.Max_Length);
+ Llen : constant Natural := Left'Length;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen > Right.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end Concat;
+
+ function Concat
+ (Left : Super_String;
+ Right : Wide_Character)
+ return Super_String
+ is
+ Result : Super_String (Left.Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+
+ begin
+ if Llen = Left.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Llen + 1;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Result.Current_Length) := Right;
+ end if;
+
+ return Result;
+ end Concat;
+
+ function Concat
+ (Left : Wide_Character;
+ Right : Super_String)
+ return Super_String
+ is
+ Result : Super_String (Right.Max_Length);
+ Rlen : constant Natural := Right.Current_Length;
+
+ begin
+ if Rlen = Right.Max_Length then
+ raise Ada.Strings.Length_Error;
+ else
+ Result.Current_Length := Rlen + 1;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen);
+ end if;
+
+ return Result;
+ end Concat;
+
+ -----------
+ -- Equal --
+ -----------
+
+ function "=" (Left, Right : Super_String) return Boolean is
+ begin
+ return Left.Current_Length = Right.Current_Length
+ and then Left.Data (1 .. Left.Current_Length) =
+ Right.Data (1 .. Right.Current_Length);
+ end "=";
+
+ function Equal (Left : Super_String; Right : Wide_String)
+ return Boolean is
+ begin
+ return Left.Current_Length = Right'Length
+ and then Left.Data (1 .. Left.Current_Length) = Right;
+ end Equal;
+
+ function Equal (Left : Wide_String; Right : Super_String)
+ return Boolean is
+ begin
+ return Left'Length = Right.Current_Length
+ and then Left = Right.Data (1 .. Right.Current_Length);
+ end Equal;
+
+ -------------
+ -- Greater --
+ -------------
+
+ function Greater (Left, Right : Super_String) return Boolean is
+ begin
+ return Left.Data (1 .. Left.Current_Length) >
+ Right.Data (1 .. Right.Current_Length);
+ end Greater;
+
+ function Greater
+ (Left : Super_String;
+ Right : Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) > Right;
+ end Greater;
+
+ function Greater
+ (Left : Wide_String;
+ Right : Super_String)
+ return Boolean
+ is
+ begin
+ return Left > Right.Data (1 .. Right.Current_Length);
+ end Greater;
+
+ ----------------------
+ -- Greater_Or_Equal --
+ ----------------------
+
+ function Greater_Or_Equal (Left, Right : Super_String) return Boolean is
+ begin
+ return Left.Data (1 .. Left.Current_Length) >=
+ Right.Data (1 .. Right.Current_Length);
+ end Greater_Or_Equal;
+
+ function Greater_Or_Equal
+ (Left : Super_String;
+ Right : Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) >= Right;
+ end Greater_Or_Equal;
+
+ function Greater_Or_Equal
+ (Left : Wide_String;
+ Right : Super_String)
+ return Boolean
+ is
+ begin
+ return Left >= Right.Data (1 .. Right.Current_Length);
+ end Greater_Or_Equal;
+
+ ----------
+ -- Less --
+ ----------
+
+ function Less (Left, Right : Super_String) return Boolean is
+ begin
+ return Left.Data (1 .. Left.Current_Length) <
+ Right.Data (1 .. Right.Current_Length);
+ end Less;
+
+ function Less
+ (Left : Super_String;
+ Right : Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) < Right;
+ end Less;
+
+ function Less
+ (Left : Wide_String;
+ Right : Super_String)
+ return Boolean
+ is
+ begin
+ return Left < Right.Data (1 .. Right.Current_Length);
+ end Less;
+
+ -------------------
+ -- Less_Or_Equal --
+ -------------------
+
+ function Less_Or_Equal (Left, Right : Super_String) return Boolean is
+ begin
+ return Left.Data (1 .. Left.Current_Length) <=
+ Right.Data (1 .. Right.Current_Length);
+ end Less_Or_Equal;
+
+ function Less_Or_Equal
+ (Left : Super_String;
+ Right : Wide_String)
+ return Boolean
+ is
+ begin
+ return Left.Data (1 .. Left.Current_Length) <= Right;
+ end Less_Or_Equal;
+
+ function Less_Or_Equal
+ (Left : Wide_String;
+ Right : Super_String)
+ return Boolean
+ is
+ begin
+ return Left <= Right.Data (1 .. Right.Current_Length);
+ end Less_Or_Equal;
+
+ ------------------
+ -- Super_Append --
+ ------------------
+
+ -- Case of Super_String and Super_String
+
+ function Super_Append
+ (Left, Right : Super_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Left.Max_Length;
+ Result : Super_String (Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then -- only case is Llen = Max_Length
+ Result.Data := Left.Data;
+
+ else
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then -- only case is Rlen = Max_Length
+ Result.Data := Right.Data;
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Append;
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Super_String;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Llen : constant Natural := Source.Current_Length;
+ Rlen : constant Natural := New_Item.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Source.Current_Length := Nlen;
+ Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen);
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen < Max_Length then
+ Source.Data (Llen + 1 .. Max_Length) :=
+ New_Item.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then -- only case is Rlen = Max_Length
+ Source.Data := New_Item.Data;
+
+ else
+ Source.Data (1 .. Max_Length - Rlen) :=
+ Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ New_Item.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Super_Append;
+
+ -- Case of Super_String and Wide_String
+
+ function Super_Append
+ (Left : Super_String;
+ Right : Wide_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Left.Max_Length;
+ Result : Super_String (Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+ Rlen : constant Natural := Right'Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Nlen) := Right;
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then -- only case is Llen = Max_Length
+ Result.Data := Left.Data;
+
+ else
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right (Right'First .. Right'First - 1 +
+ Max_Length - Llen);
+
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Right (Right'Last - (Max_Length - 1) .. Right'Last);
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Append;
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Wide_String;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Llen : constant Natural := Source.Current_Length;
+ Rlen : constant Natural := New_Item'Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Source.Current_Length := Nlen;
+ Source.Data (Llen + 1 .. Nlen) := New_Item;
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen < Max_Length then
+ Source.Data (Llen + 1 .. Max_Length) :=
+ New_Item (New_Item'First ..
+ New_Item'First - 1 + Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Source.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - (Max_Length - 1) ..
+ New_Item'Last);
+
+ else
+ Source.Data (1 .. Max_Length - Rlen) :=
+ Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen);
+ Source.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ New_Item;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Super_Append;
+
+ -- Case of Wide_String and Super_String
+
+ function Super_Append
+ (Left : Wide_String;
+ Right : Super_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Right.Max_Length;
+ Result : Super_String (Max_Length);
+ Llen : constant Natural := Left'Length;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Llen + Rlen;
+
+ begin
+ if Nlen <= Max_Length then
+ Result.Current_Length := Nlen;
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Llen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Left (Left'First .. Left'First + (Max_Length - 1));
+
+ else
+ Result.Data (1 .. Llen) := Left;
+ Result.Data (Llen + 1 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - Llen);
+ end if;
+
+ when Strings.Left =>
+ if Rlen >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ Right.Data (Rlen - (Max_Length - 1) .. Rlen);
+
+ else
+ Result.Data (1 .. Max_Length - Rlen) :=
+ Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last);
+ Result.Data (Max_Length - Rlen + 1 .. Max_Length) :=
+ Right.Data (1 .. Rlen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Append;
+
+ -- Case of Super_String and Wide_Character
+
+ function Super_Append
+ (Left : Super_String;
+ Right : Wide_Character;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Left.Max_Length;
+ Result : Super_String (Max_Length);
+ Llen : constant Natural := Left.Current_Length;
+
+ begin
+ if Llen < Max_Length then
+ Result.Current_Length := Llen + 1;
+ Result.Data (1 .. Llen) := Left.Data (1 .. Llen);
+ Result.Data (Llen + 1) := Right;
+ return Result;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ return Left;
+
+ when Strings.Left =>
+ Result.Current_Length := Max_Length;
+ Result.Data (1 .. Max_Length - 1) :=
+ Left.Data (2 .. Max_Length);
+ Result.Data (Max_Length) := Right;
+ return Result;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Append;
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Wide_Character;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Llen : constant Natural := Source.Current_Length;
+
+ begin
+ if Llen < Max_Length then
+ Source.Current_Length := Llen + 1;
+ Source.Data (Llen + 1) := New_Item;
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ null;
+
+ when Strings.Left =>
+ Source.Data (1 .. Max_Length - 1) :=
+ Source.Data (2 .. Max_Length);
+ Source.Data (Max_Length) := New_Item;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ end Super_Append;
+
+ -- Case of Wide_Character and Super_String
+
+ function Super_Append
+ (Left : Wide_Character;
+ Right : Super_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Right.Max_Length;
+ Result : Super_String (Max_Length);
+ Rlen : constant Natural := Right.Current_Length;
+
+ begin
+ if Rlen < Max_Length then
+ Result.Current_Length := Rlen + 1;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen);
+ return Result;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ Result.Current_Length := Max_Length;
+ Result.Data (1) := Left;
+ Result.Data (2 .. Max_Length) :=
+ Right.Data (1 .. Max_Length - 1);
+ return Result;
+
+ when Strings.Left =>
+ return Right;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Append;
+
+ -----------------
+ -- Super_Count --
+ -----------------
+
+ function Super_Count
+ (Source : Super_String;
+ Pattern : Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural
+ is
+ begin
+ return
+ Wide_Search.Count
+ (Source.Data (1 .. Source.Current_Length), Pattern, Mapping);
+ end Super_Count;
+
+ function Super_Count
+ (Source : Super_String;
+ Pattern : Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return
+ Wide_Search.Count
+ (Source.Data (1 .. Source.Current_Length), Pattern, Mapping);
+ end Super_Count;
+
+ function Super_Count
+ (Source : Super_String;
+ Set : Wide_Maps.Wide_Character_Set)
+ return Natural
+ is
+ begin
+ return Wide_Search.Count (Source.Data (1 .. Source.Current_Length), Set);
+ end Super_Count;
+
+ ------------------
+ -- Super_Delete --
+ ------------------
+
+ function Super_Delete
+ (Source : Super_String;
+ From : Positive;
+ Through : Natural)
+ return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+ Slen : constant Natural := Source.Current_Length;
+ Num_Delete : constant Integer := Through - From + 1;
+
+ begin
+ if Num_Delete <= 0 then
+ return Source;
+
+ elsif From > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Through >= Slen then
+ Result.Current_Length := From - 1;
+ Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
+ return Result;
+
+ else
+ Result.Current_Length := Slen - Num_Delete;
+ Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1);
+ Result.Data (From .. Result.Current_Length) :=
+ Source.Data (Through + 1 .. Slen);
+ return Result;
+ end if;
+ end Super_Delete;
+
+ procedure Super_Delete
+ (Source : in out Super_String;
+ From : Positive;
+ Through : Natural)
+ is
+ Slen : constant Natural := Source.Current_Length;
+ Num_Delete : constant Integer := Through - From + 1;
+
+ begin
+ if Num_Delete <= 0 then
+ return;
+
+ elsif From > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Through >= Slen then
+ Source.Current_Length := From - 1;
+
+ else
+ Source.Current_Length := Slen - Num_Delete;
+ Source.Data (From .. Source.Current_Length) :=
+ Source.Data (Through + 1 .. Slen);
+ end if;
+ end Super_Delete;
+
+ -------------------
+ -- Super_Element --
+ -------------------
+
+ function Super_Element
+ (Source : Super_String;
+ Index : Positive)
+ return Wide_Character
+ is
+ begin
+ if Index in 1 .. Source.Current_Length then
+ return Source.Data (Index);
+ else
+ raise Strings.Index_Error;
+ end if;
+ end Super_Element;
+
+ ----------------------
+ -- Super_Find_Token --
+ ----------------------
+
+ procedure Super_Find_Token
+ (Source : Super_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ Test : Strings.Membership;
+ First : out Positive;
+ Last : out Natural)
+ is
+ begin
+ Wide_Search.Find_Token
+ (Source.Data (1 .. Source.Current_Length), Set, Test, First, Last);
+ end Super_Find_Token;
+
+ ----------------
+ -- Super_Head --
+ ----------------
+
+ function Super_Head
+ (Source : Super_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Result : Super_String (Max_Length);
+ Slen : constant Natural := Source.Current_Length;
+ Npad : constant Integer := Count - Slen;
+
+ begin
+ if Npad <= 0 then
+ Result.Current_Length := Count;
+ Result.Data (1 .. Count) := Source.Data (1 .. Count);
+
+ elsif Count <= Max_Length then
+ Result.Current_Length := Count;
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Slen + 1 .. Count) := (others => Pad);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Slen + 1 .. Max_Length) := (others => Pad);
+
+ when Strings.Left =>
+ if Npad >= Max_Length then
+ Result.Data := (others => Pad);
+
+ else
+ Result.Data (1 .. Max_Length - Npad) :=
+ Source.Data (Count - Max_Length + 1 .. Slen);
+ Result.Data (Max_Length - Npad + 1 .. Max_Length) :=
+ (others => Pad);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Head;
+
+ procedure Super_Head
+ (Source : in out Super_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Slen : constant Natural := Source.Current_Length;
+ Npad : constant Integer := Count - Slen;
+ Temp : Wide_String (1 .. Max_Length);
+
+ begin
+ if Npad <= 0 then
+ Source.Current_Length := Count;
+
+ elsif Count <= Max_Length then
+ Source.Current_Length := Count;
+ Source.Data (Slen + 1 .. Count) := (others => Pad);
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Source.Data (Slen + 1 .. Max_Length) := (others => Pad);
+
+ when Strings.Left =>
+ if Npad > Max_Length then
+ Source.Data := (others => Pad);
+
+ else
+ Temp := Source.Data;
+ Source.Data (1 .. Max_Length - Npad) :=
+ Temp (Count - Max_Length + 1 .. Slen);
+
+ for J in Max_Length - Npad + 1 .. Max_Length loop
+ Source.Data (J) := Pad;
+ end loop;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Head;
+
+ -----------------
+ -- Super_Index --
+ -----------------
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : Wide_String;
+ Going : Strings.Direction := Strings.Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural
+ is
+ begin
+ return Wide_Search.Index
+ (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping);
+ end Super_Index;
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural
+ is
+ begin
+ return Wide_Search.Index
+ (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping);
+ end Super_Index;
+
+ function Super_Index
+ (Source : Super_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ Test : Strings.Membership := Strings.Inside;
+ Going : Strings.Direction := Strings.Forward)
+ return Natural
+ is
+ begin
+ return Wide_Search.Index
+ (Source.Data (1 .. Source.Current_Length), Set, Test, Going);
+ end Super_Index;
+
+ ---------------------------
+ -- Super_Index_Non_Blank --
+ ---------------------------
+
+ function Super_Index_Non_Blank
+ (Source : Super_String;
+ Going : Strings.Direction := Strings.Forward)
+ return Natural
+ is
+ begin
+ return
+ Wide_Search.Index_Non_Blank
+ (Source.Data (1 .. Source.Current_Length), Going);
+ end Super_Index_Non_Blank;
+
+ ------------------
+ -- Super_Insert --
+ ------------------
+
+ function Super_Insert
+ (Source : Super_String;
+ Before : Positive;
+ New_Item : Wide_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Result : Super_String (Max_Length);
+ Slen : constant Natural := Source.Current_Length;
+ Nlen : constant Natural := New_Item'Length;
+ Tlen : constant Natural := Slen + Nlen;
+ Blen : constant Natural := Before - 1;
+ Alen : constant Integer := Slen - Blen;
+ Droplen : constant Integer := Tlen - Max_Length;
+
+ -- Tlen is the length of the total Wide_String before possible
+ -- truncation. Blen, Alen are the lengths of the before and after
+ -- pieces of the source Wide_String.
+
+ begin
+ if Alen < 0 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Droplen <= 0 then
+ Result.Current_Length := Tlen;
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+ Result.Data (Before .. Before + Nlen - 1) := New_Item;
+ Result.Data (Before + Nlen .. Tlen) :=
+ Source.Data (Before .. Slen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+
+ if Droplen > Alen then
+ Result.Data (Before .. Max_Length) :=
+ New_Item (New_Item'First
+ .. New_Item'First + Max_Length - Before);
+ else
+ Result.Data (Before .. Before + Nlen - 1) := New_Item;
+ Result.Data (Before + Nlen .. Max_Length) :=
+ Source.Data (Before .. Slen - Droplen);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
+ Source.Data (Before .. Slen);
+
+ if Droplen >= Blen then
+ Result.Data (1 .. Max_Length - Alen) :=
+ New_Item (New_Item'Last - (Max_Length - Alen) + 1
+ .. New_Item'Last);
+ else
+ Result.Data
+ (Blen - Droplen + 1 .. Max_Length - Alen) :=
+ New_Item;
+ Result.Data (1 .. Blen - Droplen) :=
+ Source.Data (Droplen + 1 .. Blen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Insert;
+
+ procedure Super_Insert
+ (Source : in out Super_String;
+ Before : Positive;
+ New_Item : Wide_String;
+ Drop : Strings.Truncation := Strings.Error)
+ is
+ begin
+ -- We do a double copy here because this is one of the situations
+ -- in which we move data to the right, and at least at the moment,
+ -- GNAT is not handling such cases correctly ???
+
+ Source := Super_Insert (Source, Before, New_Item, Drop);
+ end Super_Insert;
+
+ ------------------
+ -- Super_Length --
+ ------------------
+
+ function Super_Length (Source : Super_String) return Natural is
+ begin
+ return Source.Current_Length;
+ end Super_Length;
+
+ ---------------------
+ -- Super_Overwrite --
+ ---------------------
+
+ function Super_Overwrite
+ (Source : Super_String;
+ Position : Positive;
+ New_Item : Wide_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Result : Super_String (Max_Length);
+ Endpos : constant Natural := Position + New_Item'Length - 1;
+ Slen : constant Natural := Source.Current_Length;
+ Droplen : Natural;
+
+ begin
+ if Position > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif New_Item'Length = 0 then
+ return Source;
+
+ elsif Endpos <= Slen then
+ Result.Current_Length := Source.Current_Length;
+ Result.Data (1 .. Slen) := Source.Data (1 .. Slen);
+ Result.Data (Position .. Endpos) := New_Item;
+ return Result;
+
+ elsif Endpos <= Max_Length then
+ Result.Current_Length := Endpos;
+ Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1);
+ Result.Data (Position .. Endpos) := New_Item;
+ return Result;
+
+ else
+ Result.Current_Length := Max_Length;
+ Droplen := Endpos - Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Position - 1) :=
+ Source.Data (1 .. Position - 1);
+
+ Result.Data (Position .. Max_Length) :=
+ New_Item (New_Item'First .. New_Item'Last - Droplen);
+ return Result;
+
+ when Strings.Left =>
+ if New_Item'Length >= Max_Length then
+ Result.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - Max_Length + 1 ..
+ New_Item'Last);
+ return Result;
+
+ else
+ Result.Data (1 .. Max_Length - New_Item'Length) :=
+ Source.Data (Droplen + 1 .. Position - 1);
+ Result.Data
+ (Max_Length - New_Item'Length + 1 .. Max_Length) :=
+ New_Item;
+ return Result;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Overwrite;
+
+ procedure Super_Overwrite
+ (Source : in out Super_String;
+ Position : Positive;
+ New_Item : Wide_String;
+ Drop : Strings.Truncation := Strings.Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Endpos : constant Positive := Position + New_Item'Length - 1;
+ Slen : constant Natural := Source.Current_Length;
+ Droplen : Natural;
+
+ begin
+ if Position > Slen + 1 then
+ raise Ada.Strings.Index_Error;
+
+ elsif Endpos <= Slen then
+ Source.Data (Position .. Endpos) := New_Item;
+
+ elsif Endpos <= Max_Length then
+ Source.Data (Position .. Endpos) := New_Item;
+ Source.Current_Length := Endpos;
+
+ else
+ Source.Current_Length := Max_Length;
+ Droplen := Endpos - Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Source.Data (Position .. Max_Length) :=
+ New_Item (New_Item'First .. New_Item'Last - Droplen);
+
+ when Strings.Left =>
+ if New_Item'Length > Max_Length then
+ Source.Data (1 .. Max_Length) :=
+ New_Item (New_Item'Last - Max_Length + 1 ..
+ New_Item'Last);
+
+ else
+ Source.Data (1 .. Max_Length - New_Item'Length) :=
+ Source.Data (Droplen + 1 .. Position - 1);
+
+ Source.Data
+ (Max_Length - New_Item'Length + 1 .. Max_Length) :=
+ New_Item;
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Overwrite;
+
+ ---------------------------
+ -- Super_Replace_Element --
+ ---------------------------
+
+ procedure Super_Replace_Element
+ (Source : in out Super_String;
+ Index : Positive;
+ By : Wide_Character)
+ is
+ begin
+ if Index <= Source.Current_Length then
+ Source.Data (Index) := By;
+ else
+ raise Ada.Strings.Index_Error;
+ end if;
+ end Super_Replace_Element;
+
+ -------------------------
+ -- Super_Replace_Slice --
+ -------------------------
+
+ function Super_Replace_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Slen : constant Natural := Source.Current_Length;
+
+ begin
+ if Low > Slen + 1 then
+ raise Strings.Index_Error;
+
+ elsif High < Low then
+ return Super_Insert (Source, Low, By, Drop);
+
+ else
+ declare
+ Blen : constant Natural := Natural'Max (0, Low - 1);
+ Alen : constant Natural := Natural'Max (0, Slen - High);
+ Tlen : constant Natural := Blen + By'Length + Alen;
+ Droplen : constant Integer := Tlen - Max_Length;
+ Result : Super_String (Max_Length);
+
+ -- Tlen is the total length of the result Wide_String before any
+ -- truncation. Blen and Alen are the lengths of the pieces
+ -- of the original Wide_String that end up in the result
+ -- Wide_String before and after the replaced slice.
+
+ begin
+ if Droplen <= 0 then
+ Result.Current_Length := Tlen;
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+ Result.Data (Low .. Low + By'Length - 1) := By;
+ Result.Data (Low + By'Length .. Tlen) :=
+ Source.Data (High + 1 .. Slen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Result.Data (1 .. Blen) := Source.Data (1 .. Blen);
+
+ if Droplen > Alen then
+ Result.Data (Low .. Max_Length) :=
+ By (By'First .. By'First + Max_Length - Low);
+ else
+ Result.Data (Low .. Low + By'Length - 1) := By;
+ Result.Data (Low + By'Length .. Max_Length) :=
+ Source.Data (High + 1 .. Slen - Droplen);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (Max_Length - (Alen - 1) .. Max_Length) :=
+ Source.Data (High + 1 .. Slen);
+
+ if Droplen >= Blen then
+ Result.Data (1 .. Max_Length - Alen) :=
+ By (By'Last - (Max_Length - Alen) + 1 .. By'Last);
+ else
+ Result.Data
+ (Blen - Droplen + 1 .. Max_Length - Alen) := By;
+ Result.Data (1 .. Blen - Droplen) :=
+ Source.Data (Droplen + 1 .. Blen);
+ end if;
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end;
+ end if;
+ end Super_Replace_Slice;
+
+ procedure Super_Replace_Slice
+ (Source : in out Super_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_String;
+ Drop : Strings.Truncation := Strings.Error)
+ is
+ begin
+ -- We do a double copy here because this is one of the situations
+ -- in which we move data to the right, and at least at the moment,
+ -- GNAT is not handling such cases correctly ???
+
+ Source := Super_Replace_Slice (Source, Low, High, By, Drop);
+ end Super_Replace_Slice;
+
+ ---------------------
+ -- Super_Replicate --
+ ---------------------
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Wide_Character;
+ Drop : Truncation := Error;
+ Max_Length : Positive)
+ return Super_String
+ is
+ Result : Super_String (Max_Length);
+
+ begin
+ if Count <= Max_Length then
+ Result.Current_Length := Count;
+
+ elsif Drop = Strings.Error then
+ raise Ada.Strings.Length_Error;
+
+ else
+ Result.Current_Length := Max_Length;
+ end if;
+
+ Result.Data (1 .. Result.Current_Length) := (others => Item);
+ return Result;
+ end Super_Replicate;
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Wide_String;
+ Drop : Truncation := Error;
+ Max_Length : Positive)
+ return Super_String
+ is
+ Length : constant Integer := Count * Item'Length;
+ Result : Super_String (Max_Length);
+ Indx : Positive;
+
+ begin
+ if Length <= Max_Length then
+ Result.Current_Length := Length;
+
+ if Length > 0 then
+ Indx := 1;
+
+ for J in 1 .. Count loop
+ Result.Data (Indx .. Indx + Item'Length - 1) := Item;
+ Indx := Indx + Item'Length;
+ end loop;
+ end if;
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ Indx := 1;
+
+ while Indx + Item'Length <= Max_Length + 1 loop
+ Result.Data (Indx .. Indx + Item'Length - 1) := Item;
+ Indx := Indx + Item'Length;
+ end loop;
+
+ Result.Data (Indx .. Max_Length) :=
+ Item (Item'First .. Item'First + Max_Length - Indx);
+
+ when Strings.Left =>
+ Indx := Max_Length;
+
+ while Indx - Item'Length >= 1 loop
+ Result.Data (Indx - (Item'Length - 1) .. Indx) := Item;
+ Indx := Indx - Item'Length;
+ end loop;
+
+ Result.Data (1 .. Indx) :=
+ Item (Item'Last - Indx + 1 .. Item'Last);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Replicate;
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Super_String;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ begin
+ return
+ Super_Replicate
+ (Count,
+ Item.Data (1 .. Item.Current_Length),
+ Drop,
+ Item.Max_Length);
+ end Super_Replicate;
+
+ -----------------
+ -- Super_Slice --
+ -----------------
+
+ function Super_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural)
+ return Wide_String
+ is
+ begin
+ -- Note: test of High > Length is in accordance with AI95-00128
+
+ if Low > Source.Current_Length + 1
+ or else High > Source.Current_Length
+ then
+ raise Index_Error;
+ else
+ return Source.Data (Low .. High);
+ end if;
+ end Super_Slice;
+
+ ----------------
+ -- Super_Tail --
+ ----------------
+
+ function Super_Tail
+ (Source : Super_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space;
+ Drop : Strings.Truncation := Strings.Error)
+ return Super_String
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Result : Super_String (Max_Length);
+ Slen : constant Natural := Source.Current_Length;
+ Npad : constant Integer := Count - Slen;
+
+ begin
+ if Npad <= 0 then
+ Result.Current_Length := Count;
+ Result.Data (1 .. Count) :=
+ Source.Data (Slen - (Count - 1) .. Slen);
+
+ elsif Count <= Max_Length then
+ Result.Current_Length := Count;
+ Result.Data (1 .. Npad) := (others => Pad);
+ Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen);
+
+ else
+ Result.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Npad >= Max_Length then
+ Result.Data := (others => Pad);
+
+ else
+ Result.Data (1 .. Npad) := (others => Pad);
+ Result.Data (Npad + 1 .. Max_Length) :=
+ Source.Data (1 .. Max_Length - Npad);
+ end if;
+
+ when Strings.Left =>
+ Result.Data (1 .. Max_Length - Slen) := (others => Pad);
+ Result.Data (Max_Length - Slen + 1 .. Max_Length) :=
+ Source.Data (1 .. Slen);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end Super_Tail;
+
+ procedure Super_Tail
+ (Source : in out Super_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space;
+ Drop : Truncation := Error)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Slen : constant Natural := Source.Current_Length;
+ Npad : constant Integer := Count - Slen;
+
+ Temp : constant Wide_String (1 .. Max_Length) := Source.Data;
+
+ begin
+ if Npad <= 0 then
+ Source.Current_Length := Count;
+ Source.Data (1 .. Count) :=
+ Temp (Slen - (Count - 1) .. Slen);
+
+ elsif Count <= Max_Length then
+ Source.Current_Length := Count;
+ Source.Data (1 .. Npad) := (others => Pad);
+ Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen);
+
+ else
+ Source.Current_Length := Max_Length;
+
+ case Drop is
+ when Strings.Right =>
+ if Npad >= Max_Length then
+ Source.Data := (others => Pad);
+
+ else
+ Source.Data (1 .. Npad) := (others => Pad);
+ Source.Data (Npad + 1 .. Max_Length) :=
+ Temp (1 .. Max_Length - Npad);
+ end if;
+
+ when Strings.Left =>
+ for J in 1 .. Max_Length - Slen loop
+ Source.Data (J) := Pad;
+ end loop;
+
+ Source.Data (Max_Length - Slen + 1 .. Max_Length) :=
+ Temp (1 .. Slen);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+ end Super_Tail;
+
+ ---------------------
+ -- Super_To_String --
+ ---------------------
+
+ function Super_To_String (Source : in Super_String) return Wide_String is
+ begin
+ return Source.Data (1 .. Source.Current_Length);
+ end Super_To_String;
+
+ ---------------------
+ -- Super_Translate --
+ ---------------------
+
+ function Super_Translate
+ (Source : Super_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping)
+ return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+
+ begin
+ Result.Current_Length := Source.Current_Length;
+
+ for J in 1 .. Source.Current_Length loop
+ Result.Data (J) := Value (Mapping, Source.Data (J));
+ end loop;
+
+ return Result;
+ end Super_Translate;
+
+ procedure Super_Translate
+ (Source : in out Super_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping)
+ is
+ begin
+ for J in 1 .. Source.Current_Length loop
+ Source.Data (J) := Value (Mapping, Source.Data (J));
+ end loop;
+ end Super_Translate;
+
+ function Super_Translate
+ (Source : Super_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
+ return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+
+ begin
+ Result.Current_Length := Source.Current_Length;
+
+ for J in 1 .. Source.Current_Length loop
+ Result.Data (J) := Mapping.all (Source.Data (J));
+ end loop;
+
+ return Result;
+ end Super_Translate;
+
+ procedure Super_Translate
+ (Source : in out Super_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
+ is
+ begin
+ for J in 1 .. Source.Current_Length loop
+ Source.Data (J) := Mapping.all (Source.Data (J));
+ end loop;
+ end Super_Translate;
+
+ ----------------
+ -- Super_Trim --
+ ----------------
+
+ function Super_Trim
+ (Source : Super_String;
+ Side : Trim_End)
+ return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+ Last : Natural := Source.Current_Length;
+ First : Positive := 1;
+
+ begin
+ if Side = Left or else Side = Both then
+ while First <= Last and then Source.Data (First) = ' ' loop
+ First := First + 1;
+ end loop;
+ end if;
+
+ if Side = Right or else Side = Both then
+ while Last >= First and then Source.Data (Last) = ' ' loop
+ Last := Last - 1;
+ end loop;
+ end if;
+
+ Result.Current_Length := Last - First + 1;
+ Result.Data (1 .. Result.Current_Length) := Source.Data (First .. Last);
+ return Result;
+ end Super_Trim;
+
+ procedure Super_Trim
+ (Source : in out Super_String;
+ Side : Trim_End)
+ is
+ Max_Length : constant Positive := Source.Max_Length;
+ Last : Natural := Source.Current_Length;
+ First : Positive := 1;
+ Temp : Wide_String (1 .. Max_Length);
+
+ begin
+ Temp (1 .. Last) := Source.Data (1 .. Last);
+
+ if Side = Left or else Side = Both then
+ while First <= Last and then Temp (First) = ' ' loop
+ First := First + 1;
+ end loop;
+ end if;
+
+ if Side = Right or else Side = Both then
+ while Last >= First and then Temp (Last) = ' ' loop
+ Last := Last - 1;
+ end loop;
+ end if;
+
+ Source.Data := (others => Wide_NUL);
+ Source.Current_Length := Last - First + 1;
+ Source.Data (1 .. Source.Current_Length) := Temp (First .. Last);
+ end Super_Trim;
+
+ function Super_Trim
+ (Source : Super_String;
+ Left : Wide_Maps.Wide_Character_Set;
+ Right : Wide_Maps.Wide_Character_Set)
+ return Super_String
+ is
+ Result : Super_String (Source.Max_Length);
+
+ begin
+ for First in 1 .. Source.Current_Length loop
+ if not Is_In (Source.Data (First), Left) then
+ for Last in reverse First .. Source.Current_Length loop
+ if not Is_In (Source.Data (Last), Right) then
+ Result.Current_Length := Last - First + 1;
+ Result.Data (1 .. Result.Current_Length) :=
+ Source.Data (First .. Last);
+ return Result;
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ Result.Current_Length := 0;
+ return Result;
+ end Super_Trim;
+
+ procedure Super_Trim
+ (Source : in out Super_String;
+ Left : Wide_Maps.Wide_Character_Set;
+ Right : Wide_Maps.Wide_Character_Set)
+ is
+ begin
+ for First in 1 .. Source.Current_Length loop
+ if not Is_In (Source.Data (First), Left) then
+ for Last in reverse First .. Source.Current_Length loop
+ if not Is_In (Source.Data (Last), Right) then
+ if First = 1 then
+ Source.Current_Length := Last;
+ return;
+ else
+ Source.Current_Length := Last - First + 1;
+ Source.Data (1 .. Source.Current_Length) :=
+ Source.Data (First .. Last);
+
+ for J in Source.Current_Length + 1 ..
+ Source.Max_Length
+ loop
+ Source.Data (J) := Wide_NUL;
+ end loop;
+
+ return;
+ end if;
+ end if;
+ end loop;
+
+ Source.Current_Length := 0;
+ return;
+ end if;
+ end loop;
+
+ Source.Current_Length := 0;
+ end Super_Trim;
+
+ -----------
+ -- Times --
+ -----------
+
+ function Times
+ (Left : Natural;
+ Right : Wide_Character;
+ Max_Length : Positive)
+ return Super_String
+ is
+ Result : Super_String (Max_Length);
+
+ begin
+ if Left > Max_Length then
+ raise Ada.Strings.Length_Error;
+
+ else
+ Result.Current_Length := Left;
+
+ for J in 1 .. Left loop
+ Result.Data (J) := Right;
+ end loop;
+ end if;
+
+ return Result;
+ end Times;
+
+ function Times
+ (Left : Natural;
+ Right : Wide_String;
+ Max_Length : Positive)
+ return Super_String
+ is
+ Result : Super_String (Max_Length);
+ Pos : Positive := 1;
+ Rlen : constant Natural := Right'Length;
+ Nlen : constant Natural := Left * Rlen;
+
+ begin
+ if Nlen > Max_Length then
+ raise Ada.Strings.Index_Error;
+
+ else
+ Result.Current_Length := Nlen;
+
+ if Nlen > 0 then
+ for J in 1 .. Left loop
+ Result.Data (Pos .. Pos + Rlen - 1) := Right;
+ Pos := Pos + Rlen;
+ end loop;
+ end if;
+ end if;
+
+ return Result;
+ end Times;
+
+ function Times
+ (Left : Natural;
+ Right : Super_String)
+ return Super_String
+ is
+ Result : Super_String (Right.Max_Length);
+ Pos : Positive := 1;
+ Rlen : constant Natural := Right.Current_Length;
+ Nlen : constant Natural := Left * Rlen;
+
+ begin
+ if Nlen > Right.Max_Length then
+ raise Ada.Strings.Length_Error;
+
+ else
+ Result.Current_Length := Nlen;
+
+ if Nlen > 0 then
+ for J in 1 .. Left loop
+ Result.Data (Pos .. Pos + Rlen - 1) :=
+ Right.Data (1 .. Rlen);
+ Pos := Pos + Rlen;
+ end loop;
+ end if;
+ end if;
+
+ return Result;
+ end Times;
+
+ ---------------------
+ -- To_Super_String --
+ ---------------------
+
+ function To_Super_String
+ (Source : Wide_String;
+ Max_Length : Natural;
+ Drop : Truncation := Error)
+ return Super_String
+ is
+ Result : Super_String (Max_Length);
+ Slen : constant Natural := Source'Length;
+
+ begin
+ if Slen <= Max_Length then
+ Result.Current_Length := Slen;
+ Result.Data (1 .. Slen) := Source;
+
+ else
+ case Drop is
+ when Strings.Right =>
+ Result.Current_Length := Max_Length;
+ Result.Data (1 .. Max_Length) :=
+ Source (Source'First .. Source'First - 1 + Max_Length);
+
+ when Strings.Left =>
+ Result.Current_Length := Max_Length;
+ Result.Data (1 .. Max_Length) :=
+ Source (Source'Last - (Max_Length - 1) .. Source'Last);
+
+ when Strings.Error =>
+ raise Ada.Strings.Length_Error;
+ end case;
+ end if;
+
+ return Result;
+ end To_Super_String;
+
+end Ada.Strings.Wide_Superbounded;
diff --git a/gcc/ada/a-stwisu.ads b/gcc/ada/a-stwisu.ads
new file mode 100644
index 00000000000..8ea068642f8
--- /dev/null
+++ b/gcc/ada/a-stwisu.ads
@@ -0,0 +1,478 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . S T R I N G S . W I D E _ S U P E R B O U N D E D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This non generic package contains most of the implementation of the
+-- generic package Ada.Strings.Wide_Bounded.Generic_Bounded_Length.
+
+-- It defines type Super_String as a discriminated record with the maximum
+-- length as the discriminant. Individual instantiations of
+-- Strings.Wide_Bounded.Generic_Bounded_Length use this type with
+-- an appropriate discriminant value set.
+
+with Ada.Strings.Wide_Maps;
+
+package Ada.Strings.Wide_Superbounded is
+pragma Preelaborate (Wide_Superbounded);
+
+ Wide_NUL : constant Wide_Character := Wide_Character'Val (0);
+
+ type Super_String (Max_Length : Positive) is record
+ Current_Length : Natural := 0;
+ Data : Wide_String (1 .. Max_Length) := (others => Wide_NUL);
+ end record;
+ -- Type Wide_Bounded_String in
+ -- Ada.Strings.Wide_Bounded.Generic_Bounded_Length is derived from this
+ -- type, with the constraint of the maximum length.
+
+ -- The subprograms defined for Super_String are similar to those
+ -- defined for Wide_Bounded_String, except that they have different names,
+ -- so that they can be renamed in
+ -- Ada.Strings.Wide_Bounded.Generic_Bounded_Length.
+
+ function Super_Length (Source : Super_String) return Natural;
+
+ --------------------------------------------------------
+ -- Conversion, Concatenation, and Selection Functions --
+ --------------------------------------------------------
+
+ function To_Super_String
+ (Source : Wide_String;
+ Max_Length : Natural;
+ Drop : Truncation := Error)
+ return Super_String;
+ -- Note the additional parameter Max_Length, which specifies the maximum
+ -- length setting of the resulting Super_String value.
+
+ -- The following procedures have declarations (and semantics) that are
+ -- exactly analogous to those declared in Ada.Strings.Bounded.
+
+ function Super_To_String (Source : Super_String) return Wide_String;
+
+ function Super_Append
+ (Left, Right : Super_String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ function Super_Append
+ (Left : Super_String;
+ Right : Wide_String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ function Super_Append
+ (Left : Wide_String;
+ Right : Super_String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ function Super_Append
+ (Left : Super_String;
+ Right : Wide_Character;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ function Super_Append
+ (Left : Wide_Character;
+ Right : Super_String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Super_String;
+ Drop : Truncation := Error);
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Wide_String;
+ Drop : Truncation := Error);
+
+ procedure Super_Append
+ (Source : in out Super_String;
+ New_Item : Wide_Character;
+ Drop : Truncation := Error);
+
+ function Concat
+ (Left, Right : Super_String)
+ return Super_String;
+
+ function Concat
+ (Left : Super_String;
+ Right : Wide_String)
+ return Super_String;
+
+ function Concat
+ (Left : Wide_String;
+ Right : Super_String)
+ return Super_String;
+
+ function Concat
+ (Left : Super_String;
+ Right : Wide_Character)
+ return Super_String;
+
+ function Concat
+ (Left : Wide_Character;
+ Right : Super_String)
+ return Super_String;
+
+ function Super_Element
+ (Source : Super_String;
+ Index : Positive)
+ return Wide_Character;
+
+ procedure Super_Replace_Element
+ (Source : in out Super_String;
+ Index : Positive;
+ By : Wide_Character);
+
+ function Super_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural)
+ return Wide_String;
+
+ function "=" (Left, Right : Super_String) return Boolean;
+
+ function Equal (Left, Right : Super_String) return Boolean renames "=";
+
+ function Equal
+ (Left : Super_String;
+ Right : Wide_String)
+ return Boolean;
+
+ function Equal
+ (Left : Wide_String;
+ Right : Super_String)
+ return Boolean;
+
+ function Less (Left, Right : Super_String) return Boolean;
+
+ function Less
+ (Left : Super_String;
+ Right : Wide_String)
+ return Boolean;
+
+ function Less
+ (Left : Wide_String;
+ Right : Super_String)
+ return Boolean;
+
+ function Less_Or_Equal (Left, Right : Super_String) return Boolean;
+
+ function Less_Or_Equal
+ (Left : Super_String;
+ Right : Wide_String)
+ return Boolean;
+
+ function Less_Or_Equal
+ (Left : Wide_String;
+ Right : Super_String)
+ return Boolean;
+
+ function Greater (Left, Right : Super_String) return Boolean;
+
+ function Greater
+ (Left : Super_String;
+ Right : Wide_String)
+ return Boolean;
+
+ function Greater
+ (Left : Wide_String;
+ Right : Super_String)
+ return Boolean;
+
+ function Greater_Or_Equal (Left, Right : Super_String) return Boolean;
+
+ function Greater_Or_Equal
+ (Left : Super_String;
+ Right : Wide_String)
+ return Boolean;
+
+ function Greater_Or_Equal
+ (Left : Wide_String;
+ Right : Super_String)
+ return Boolean;
+
+ ----------------------
+ -- Search Functions --
+ ----------------------
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural;
+
+ function Super_Index
+ (Source : Super_String;
+ Pattern : Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Super_Index
+ (Source : Super_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ Test : Membership := Inside;
+ Going : Direction := Forward)
+ return Natural;
+
+ function Super_Index_Non_Blank
+ (Source : Super_String;
+ Going : Direction := Forward)
+ return Natural;
+
+ function Super_Count
+ (Source : Super_String;
+ Pattern : Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
+ return Natural;
+
+ function Super_Count
+ (Source : Super_String;
+ Pattern : Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
+ return Natural;
+
+ function Super_Count
+ (Source : Super_String;
+ Set : Wide_Maps.Wide_Character_Set)
+ return Natural;
+
+ procedure Super_Find_Token
+ (Source : Super_String;
+ Set : Wide_Maps.Wide_Character_Set;
+ Test : Membership;
+ First : out Positive;
+ Last : out Natural);
+
+ -----------------------------------------
+ -- Wide_String Translation Subprograms --
+ -----------------------------------------
+
+ function Super_Translate
+ (Source : Super_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping)
+ return Super_String;
+
+ procedure Super_Translate
+ (Source : in out Super_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping);
+
+ function Super_Translate
+ (Source : Super_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
+ return Super_String;
+
+ procedure Super_Translate
+ (Source : in out Super_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function);
+
+ --------------------------------------------
+ -- Wide_String Transformation Subprograms --
+ --------------------------------------------
+
+ function Super_Replace_Slice
+ (Source : Super_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ procedure Super_Replace_Slice
+ (Source : in out Super_String;
+ Low : Positive;
+ High : Natural;
+ By : Wide_String;
+ Drop : Truncation := Error);
+
+ function Super_Insert
+ (Source : Super_String;
+ Before : Positive;
+ New_Item : Wide_String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ procedure Super_Insert
+ (Source : in out Super_String;
+ Before : Positive;
+ New_Item : Wide_String;
+ Drop : Truncation := Error);
+
+ function Super_Overwrite
+ (Source : Super_String;
+ Position : Positive;
+ New_Item : Wide_String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ procedure Super_Overwrite
+ (Source : in out Super_String;
+ Position : Positive;
+ New_Item : Wide_String;
+ Drop : Truncation := Error);
+
+ function Super_Delete
+ (Source : Super_String;
+ From : Positive;
+ Through : Natural)
+ return Super_String;
+
+ procedure Super_Delete
+ (Source : in out Super_String;
+ From : Positive;
+ Through : Natural);
+
+ --------------------------------------
+ -- Wide_String Selector Subprograms --
+ --------------------------------------
+
+ function Super_Trim
+ (Source : Super_String;
+ Side : Trim_End)
+ return Super_String;
+
+ procedure Super_Trim
+ (Source : in out Super_String;
+ Side : Trim_End);
+
+ function Super_Trim
+ (Source : Super_String;
+ Left : Wide_Maps.Wide_Character_Set;
+ Right : Wide_Maps.Wide_Character_Set)
+ return Super_String;
+
+ procedure Super_Trim
+ (Source : in out Super_String;
+ Left : Wide_Maps.Wide_Character_Set;
+ Right : Wide_Maps.Wide_Character_Set);
+
+ function Super_Head
+ (Source : Super_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ procedure Super_Head
+ (Source : in out Super_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space;
+ Drop : Truncation := Error);
+
+ function Super_Tail
+ (Source : Super_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space;
+ Drop : Truncation := Error)
+ return Super_String;
+
+ procedure Super_Tail
+ (Source : in out Super_String;
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space;
+ Drop : Truncation := Error);
+
+ ------------------------------------
+ -- Wide_String Constructor Subprograms --
+ ------------------------------------
+
+ -- Note: in some of the following routines, there is an extra parameter
+ -- Max_Length which specifies the value of the maximum length for the
+ -- resulting Super_String value.
+
+ function Times
+ (Left : Natural;
+ Right : Wide_Character;
+ Max_Length : Positive)
+ return Super_String;
+ -- Note the additional parameter Max_Length
+
+ function Times
+ (Left : Natural;
+ Right : Wide_String;
+ Max_Length : Positive)
+ return Super_String;
+ -- Note the additional parameter Max_Length
+
+ function Times
+ (Left : Natural;
+ Right : Super_String)
+ return Super_String;
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Wide_Character;
+ Drop : Truncation := Error;
+ Max_Length : Positive)
+ return Super_String;
+ -- Note the additional parameter Max_Length
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Wide_String;
+ Drop : Truncation := Error;
+ Max_Length : Positive)
+ return Super_String;
+ -- Note the additional parameter Max_Length
+
+ function Super_Replicate
+ (Count : Natural;
+ Item : Super_String;
+ Drop : Truncation := Error)
+ return Super_String;
+
+private
+
+ -- Pragma Inline declarations
+
+ pragma Inline ("=");
+ pragma Inline (Less);
+ pragma Inline (Less_Or_Equal);
+ pragma Inline (Greater);
+ pragma Inline (Greater_Or_Equal);
+ pragma Inline (Concat);
+ pragma Inline (Super_Count);
+ pragma Inline (Super_Element);
+ pragma Inline (Super_Find_Token);
+ pragma Inline (Super_Index);
+ pragma Inline (Super_Index_Non_Blank);
+ pragma Inline (Super_Length);
+ pragma Inline (Super_Replace_Element);
+ pragma Inline (Super_Slice);
+ pragma Inline (Super_To_String);
+
+end Ada.Strings.Wide_Superbounded;
diff --git a/gcc/ada/a-stwiun.adb b/gcc/ada/a-stwiun.adb
index 113957e918b..5e88d3e9997 100644
--- a/gcc/ada/a-stwiun.adb
+++ b/gcc/ada/a-stwiun.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,6 +39,16 @@ package body Ada.Strings.Wide_Unbounded is
use Ada.Finalization;
+ procedure Realloc_For_Chunk
+ (Source : in out Unbounded_Wide_String;
+ Chunk_Size : Natural);
+ pragma Inline (Realloc_For_Chunk);
+ -- Adjust the size allocated for the string. Add at least Chunk_Size so it
+ -- is safe to add a string of this size at the end of the current
+ -- content. The real size allocated for the string is Chunk_Size + x %
+ -- of the current string size. This buffered handling makes the Append
+ -- unbounded wide string routines very fast.
+
---------
-- "&" --
---------
@@ -48,15 +58,20 @@ package body Ada.Strings.Wide_Unbounded is
Right : Unbounded_Wide_String)
return Unbounded_Wide_String
is
- L_Length : constant Integer := Left.Reference.all'Length;
- R_Length : constant Integer := Right.Reference.all'Length;
- Length : constant Integer := L_Length + R_Length;
+ L_Length : constant Natural := Left.Last;
+ R_Length : constant Natural := Right.Last;
Result : Unbounded_Wide_String;
begin
- Result.Reference := new Wide_String (1 .. Length);
- Result.Reference.all (1 .. L_Length) := Left.Reference.all;
- Result.Reference.all (L_Length + 1 .. Length) := Right.Reference.all;
+ Result.Last := L_Length + R_Length;
+
+ Result.Reference := new Wide_String (1 .. Result.Last);
+
+ Result.Reference (1 .. L_Length) :=
+ Left.Reference (1 .. Left.Last);
+ Result.Reference (L_Length + 1 .. Result.Last) :=
+ Right.Reference (1 .. Right.Last);
+
return Result;
end "&";
@@ -65,14 +80,17 @@ package body Ada.Strings.Wide_Unbounded is
Right : Wide_String)
return Unbounded_Wide_String
is
- L_Length : constant Integer := Left.Reference.all'Length;
- Length : constant Integer := L_Length + Right'Length;
+ L_Length : constant Natural := Left.Last;
Result : Unbounded_Wide_String;
begin
- Result.Reference := new Wide_String (1 .. Length);
- Result.Reference.all (1 .. L_Length) := Left.Reference.all;
- Result.Reference.all (L_Length + 1 .. Length) := Right;
+ Result.Last := L_Length + Right'Length;
+
+ Result.Reference := new Wide_String (1 .. Result.Last);
+
+ Result.Reference (1 .. L_Length) := Left.Reference (1 .. Left.Last);
+ Result.Reference (L_Length + 1 .. Result.Last) := Right;
+
return Result;
end "&";
@@ -81,14 +99,18 @@ package body Ada.Strings.Wide_Unbounded is
Right : Unbounded_Wide_String)
return Unbounded_Wide_String
is
- R_Length : constant Integer := Right.Reference.all'Length;
- Length : constant Integer := Left'Length + R_Length;
+ R_Length : constant Natural := Right.Last;
Result : Unbounded_Wide_String;
begin
- Result.Reference := new Wide_String (1 .. Length);
- Result.Reference.all (1 .. Left'Length) := Left;
- Result.Reference.all (Left'Length + 1 .. Length) := Right.Reference.all;
+ Result.Last := Left'Length + R_Length;
+
+ Result.Reference := new Wide_String (1 .. Result.Last);
+
+ Result.Reference (1 .. Left'Length) := Left;
+ Result.Reference (Left'Length + 1 .. Result.Last) :=
+ Right.Reference (1 .. Right.Last);
+
return Result;
end "&";
@@ -97,13 +119,17 @@ package body Ada.Strings.Wide_Unbounded is
Right : Wide_Character)
return Unbounded_Wide_String
is
- Length : constant Integer := Left.Reference.all'Length + 1;
Result : Unbounded_Wide_String;
begin
- Result.Reference := new Wide_String (1 .. Length);
- Result.Reference.all (1 .. Length - 1) := Left.Reference.all;
- Result.Reference.all (Length) := Right;
+ Result.Last := Left.Last + 1;
+
+ Result.Reference := new Wide_String (1 .. Result.Last);
+
+ Result.Reference (1 .. Result.Last - 1) :=
+ Left.Reference (1 .. Left.Last);
+ Result.Reference (Result.Last) := Right;
+
return Result;
end "&";
@@ -112,13 +138,16 @@ package body Ada.Strings.Wide_Unbounded is
Right : Unbounded_Wide_String)
return Unbounded_Wide_String
is
- Length : constant Integer := Right.Reference.all'Length + 1;
Result : Unbounded_Wide_String;
begin
- Result.Reference := new Wide_String (1 .. Length);
- Result.Reference.all (1) := Left;
- Result.Reference.all (2 .. Length) := Right.Reference.all;
+ Result.Last := Right.Last + 1;
+
+ Result.Reference := new Wide_String (1 .. Result.Last);
+ Result.Reference (1) := Left;
+ Result.Reference (2 .. Result.Last) :=
+ Right.Reference (1 .. Right.Last);
+
return Result;
end "&";
@@ -134,6 +163,8 @@ package body Ada.Strings.Wide_Unbounded is
Result : Unbounded_Wide_String;
begin
+ Result.Last := Left;
+
Result.Reference := new Wide_String (1 .. Left);
for J in Result.Reference'Range loop
Result.Reference (J) := Right;
@@ -147,14 +178,19 @@ package body Ada.Strings.Wide_Unbounded is
Right : Wide_String)
return Unbounded_Wide_String
is
+ Len : constant Natural := Right'Length;
+ K : Positive;
Result : Unbounded_Wide_String;
begin
- Result.Reference := new Wide_String (1 .. Left * Right'Length);
+ Result.Last := Left * Len;
+
+ Result.Reference := new Wide_String (1 .. Result.Last);
+ K := 1;
for J in 1 .. Left loop
- Result.Reference.all
- (Right'Length * J - Right'Length + 1 .. Right'Length * J) := Right;
+ Result.Reference (K .. K + Len - 1) := Right;
+ K := K + Len;
end loop;
return Result;
@@ -165,15 +201,20 @@ package body Ada.Strings.Wide_Unbounded is
Right : Unbounded_Wide_String)
return Unbounded_Wide_String
is
- R_Length : constant Integer := Right.Reference.all'Length;
+ Len : constant Natural := Right.Last;
+ K : Positive;
Result : Unbounded_Wide_String;
begin
- Result.Reference := new Wide_String (1 .. Left * R_Length);
+ Result.Last := Left * Len;
+
+ Result.Reference := new Wide_String (1 .. Result.Last);
+ K := 1;
for I in 1 .. Left loop
- Result.Reference.all (R_Length * I - R_Length + 1 .. R_Length * I) :=
- Right.Reference.all;
+ Result.Reference (K .. K + Len - 1) :=
+ Right.Reference (1 .. Right.Last);
+ K := K + Len;
end loop;
return Result;
@@ -184,30 +225,31 @@ package body Ada.Strings.Wide_Unbounded is
---------
function "<"
- (Left : in Unbounded_Wide_String;
- Right : in Unbounded_Wide_String)
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String)
return Boolean
is
begin
- return Left.Reference.all < Right.Reference.all;
+ return
+ Left.Reference (1 .. Left.Last) < Right.Reference (1 .. Right.Last);
end "<";
function "<"
- (Left : in Unbounded_Wide_String;
- Right : in Wide_String)
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String)
return Boolean
is
begin
- return Left.Reference.all < Right;
+ return Left.Reference (1 .. Left.Last) < Right;
end "<";
function "<"
- (Left : in Wide_String;
- Right : in Unbounded_Wide_String)
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String)
return Boolean
is
begin
- return Left < Right.Reference.all;
+ return Left < Right.Reference (1 .. Right.Last);
end "<";
----------
@@ -215,30 +257,31 @@ package body Ada.Strings.Wide_Unbounded is
----------
function "<="
- (Left : in Unbounded_Wide_String;
- Right : in Unbounded_Wide_String)
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String)
return Boolean
is
begin
- return Left.Reference.all <= Right.Reference.all;
+ return
+ Left.Reference (1 .. Left.Last) <= Right.Reference (1 .. Right.Last);
end "<=";
function "<="
- (Left : in Unbounded_Wide_String;
- Right : in Wide_String)
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String)
return Boolean
is
begin
- return Left.Reference.all <= Right;
+ return Left.Reference (1 .. Left.Last) <= Right;
end "<=";
function "<="
- (Left : in Wide_String;
- Right : in Unbounded_Wide_String)
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String)
return Boolean
is
begin
- return Left <= Right.Reference.all;
+ return Left <= Right.Reference (1 .. Right.Last);
end "<=";
---------
@@ -246,30 +289,31 @@ package body Ada.Strings.Wide_Unbounded is
---------
function "="
- (Left : in Unbounded_Wide_String;
- Right : in Unbounded_Wide_String)
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String)
return Boolean
is
begin
- return Left.Reference.all = Right.Reference.all;
+ return
+ Left.Reference (1 .. Left.Last) = Right.Reference (1 .. Right.Last);
end "=";
function "="
- (Left : in Unbounded_Wide_String;
- Right : in Wide_String)
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String)
return Boolean
is
begin
- return Left.Reference.all = Right;
+ return Left.Reference (1 .. Left.Last) = Right;
end "=";
function "="
- (Left : in Wide_String;
- Right : in Unbounded_Wide_String)
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String)
return Boolean
is
begin
- return Left = Right.Reference.all;
+ return Left = Right.Reference (1 .. Right.Last);
end "=";
---------
@@ -277,30 +321,31 @@ package body Ada.Strings.Wide_Unbounded is
---------
function ">"
- (Left : in Unbounded_Wide_String;
- Right : in Unbounded_Wide_String)
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String)
return Boolean
is
begin
- return Left.Reference.all > Right.Reference.all;
+ return
+ Left.Reference (1 .. Left.Last) > Right.Reference (1 .. Right.Last);
end ">";
function ">"
- (Left : in Unbounded_Wide_String;
- Right : in Wide_String)
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String)
return Boolean
is
begin
- return Left.Reference.all > Right;
+ return Left.Reference (1 .. Left.Last) > Right;
end ">";
function ">"
- (Left : in Wide_String;
- Right : in Unbounded_Wide_String)
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String)
return Boolean
is
begin
- return Left > Right.Reference.all;
+ return Left > Right.Reference (1 .. Right.Last);
end ">";
----------
@@ -308,30 +353,31 @@ package body Ada.Strings.Wide_Unbounded is
----------
function ">="
- (Left : in Unbounded_Wide_String;
- Right : in Unbounded_Wide_String)
+ (Left : Unbounded_Wide_String;
+ Right : Unbounded_Wide_String)
return Boolean
is
begin
- return Left.Reference.all >= Right.Reference.all;
+ return
+ Left.Reference (1 .. Left.Last) >= Right.Reference (1 .. Right.Last);
end ">=";
function ">="
- (Left : in Unbounded_Wide_String;
- Right : in Wide_String)
+ (Left : Unbounded_Wide_String;
+ Right : Wide_String)
return Boolean
is
begin
- return Left.Reference.all >= Right;
+ return Left.Reference (1 .. Left.Last) >= Right;
end ">=";
function ">="
- (Left : in Wide_String;
- Right : in Unbounded_Wide_String)
+ (Left : Wide_String;
+ Right : Unbounded_Wide_String)
return Boolean
is
begin
- return Left >= Right.Reference.all;
+ return Left >= Right.Reference (1 .. Right.Last);
end ">=";
------------
@@ -342,9 +388,12 @@ package body Ada.Strings.Wide_Unbounded is
begin
-- Copy string, except we do not copy the statically allocated
-- null string, since it can never be deallocated.
+ -- Note that we do not copy extra string room here to avoid dragging
+ -- unused allocated memory.
if Object.Reference /= Null_Wide_String'Access then
- Object.Reference := new Wide_String'(Object.Reference.all);
+ Object.Reference :=
+ new Wide_String'(Object.Reference (1 .. Object.Last));
end if;
end Adjust;
@@ -354,63 +403,34 @@ package body Ada.Strings.Wide_Unbounded is
procedure Append
(Source : in out Unbounded_Wide_String;
- New_Item : in Unbounded_Wide_String)
+ New_Item : Unbounded_Wide_String)
is
- S_Length : constant Integer := Source.Reference.all'Length;
- Length : constant Integer := S_Length + New_Item.Reference.all'Length;
- Temp : Wide_String_Access := Source.Reference;
-
begin
- if Source.Reference = Null_Wide_String'Access then
- Source := To_Unbounded_Wide_String (New_Item.Reference.all);
- return;
- end if;
-
- Source.Reference := new Wide_String (1 .. Length);
-
- Source.Reference.all (1 .. S_Length) := Temp.all;
- Source.Reference.all (S_Length + 1 .. Length) := New_Item.Reference.all;
- Free (Temp);
+ Realloc_For_Chunk (Source, New_Item.Last);
+ Source.Reference (Source.Last + 1 .. Source.Last + New_Item.Last) :=
+ New_Item.Reference (1 .. New_Item.Last);
+ Source.Last := Source.Last + New_Item.Last;
end Append;
procedure Append
(Source : in out Unbounded_Wide_String;
- New_Item : in Wide_String)
+ New_Item : Wide_String)
is
- S_Length : constant Integer := Source.Reference.all'Length;
- Length : constant Integer := S_Length + New_Item'Length;
- Temp : Wide_String_Access := Source.Reference;
-
begin
- if Source.Reference = Null_Wide_String'Access then
- Source := To_Unbounded_Wide_String (New_Item);
- return;
- end if;
-
- Source.Reference := new Wide_String (1 .. Length);
- Source.Reference.all (1 .. S_Length) := Temp.all;
- Source.Reference.all (S_Length + 1 .. Length) := New_Item;
- Free (Temp);
+ Realloc_For_Chunk (Source, New_Item'Length);
+ Source.Reference (Source.Last + 1 .. Source.Last + New_Item'Length) :=
+ New_Item;
+ Source.Last := Source.Last + New_Item'Length;
end Append;
procedure Append
(Source : in out Unbounded_Wide_String;
- New_Item : in Wide_Character)
+ New_Item : Wide_Character)
is
- S_Length : constant Integer := Source.Reference.all'Length;
- Length : constant Integer := S_Length + 1;
- Temp : Wide_String_Access := Source.Reference;
-
begin
- if Source.Reference = Null_Wide_String'Access then
- Source := To_Unbounded_Wide_String ("" & New_Item);
- return;
- end if;
-
- Source.Reference := new Wide_String (1 .. Length);
- Source.Reference.all (1 .. S_Length) := Temp.all;
- Source.Reference.all (S_Length + 1) := New_Item;
- Free (Temp);
+ Realloc_For_Chunk (Source, 1);
+ Source.Reference (Source.Last + 1) := New_Item;
+ Source.Last := Source.Last + 1;
end Append;
-----------
@@ -425,17 +445,19 @@ package body Ada.Strings.Wide_Unbounded is
return Natural
is
begin
- return Wide_Search.Count (Source.Reference.all, Pattern, Mapping);
+ return Wide_Search.Count
+ (Source.Reference (1 .. Source.Last), Pattern, Mapping);
end Count;
function Count
- (Source : in Unbounded_Wide_String;
- Pattern : in Wide_String;
- Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
return Natural
is
begin
- return Wide_Search.Count (Source.Reference.all, Pattern, Mapping);
+ return Wide_Search.Count
+ (Source.Reference (1 .. Source.Last), Pattern, Mapping);
end Count;
function Count
@@ -444,7 +466,7 @@ package body Ada.Strings.Wide_Unbounded is
return Natural
is
begin
- return Wide_Search.Count (Source.Reference.all, Set);
+ return Wide_Search.Count (Source.Reference (1 .. Source.Last), Set);
end Count;
------------
@@ -458,20 +480,33 @@ package body Ada.Strings.Wide_Unbounded is
return Unbounded_Wide_String
is
begin
- return
- To_Unbounded_Wide_String
- (Wide_Fixed.Delete (Source.Reference.all, From, Through));
+ return To_Unbounded_Wide_String
+ (Wide_Fixed.Delete
+ (Source.Reference (1 .. Source.Last), From, Through));
end Delete;
procedure Delete
(Source : in out Unbounded_Wide_String;
- From : in Positive;
- Through : in Natural)
+ From : Positive;
+ Through : Natural)
is
- Temp : Wide_String_Access := Source.Reference;
begin
- Source := To_Unbounded_Wide_String
- (Wide_Fixed.Delete (Temp.all, From, Through));
+ if From > Through then
+ null;
+
+ elsif From < Source.Reference'First or else Through > Source.Last then
+ raise Index_Error;
+
+ else
+ declare
+ Len : constant Natural := Through - From + 1;
+
+ begin
+ Source.Reference (From .. Source.Last - Len) :=
+ Source.Reference (Through + 1 .. Source.Last);
+ Source.Last := Source.Last - Len;
+ end;
+ end if;
end Delete;
-------------
@@ -484,8 +519,8 @@ package body Ada.Strings.Wide_Unbounded is
return Wide_Character
is
begin
- if Index <= Source.Reference.all'Last then
- return Source.Reference.all (Index);
+ if Index <= Source.Last then
+ return Source.Reference (Index);
else
raise Strings.Index_Error;
end if;
@@ -520,7 +555,8 @@ package body Ada.Strings.Wide_Unbounded is
Last : out Natural)
is
begin
- Wide_Search.Find_Token (Source.Reference.all, Set, Test, First, Last);
+ Wide_Search.Find_Token
+ (Source.Reference (1 .. Source.Last), Set, Test, First, Last);
end Find_Token;
----------
@@ -531,7 +567,11 @@ package body Ada.Strings.Wide_Unbounded is
procedure Deallocate is
new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access);
begin
- Deallocate (X);
+ -- Note: Do not try to free statically allocated null string
+
+ if X /= Null_Unbounded_Wide_String.Reference then
+ Deallocate (X);
+ end if;
end Free;
----------
@@ -547,17 +587,21 @@ package body Ada.Strings.Wide_Unbounded is
begin
return
To_Unbounded_Wide_String
- (Wide_Fixed.Head (Source.Reference.all, Count, Pad));
+ (Wide_Fixed.Head (Source.Reference (1 .. Source.Last), Count, Pad));
end Head;
procedure Head
(Source : in out Unbounded_Wide_String;
- Count : in Natural;
- Pad : in Wide_Character := Wide_Space)
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space)
is
+ Old : Wide_String_Access := Source.Reference;
+
begin
- Source := To_Unbounded_Wide_String
- (Wide_Fixed.Head (Source.Reference.all, Count, Pad));
+ Source.Reference := new Wide_String'
+ (Wide_Fixed.Head (Source.Reference (1 .. Source.Last), Count, Pad));
+ Source.Last := Source.Reference'Length;
+ Free (Old);
end Head;
-----------
@@ -573,20 +617,20 @@ package body Ada.Strings.Wide_Unbounded is
return Natural
is
begin
- return
- Wide_Search.Index (Source.Reference.all, Pattern, Going, Mapping);
+ return Wide_Search.Index
+ (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping);
end Index;
function Index
- (Source : in Unbounded_Wide_String;
- Pattern : in Wide_String;
- Going : in Direction := Forward;
- Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ (Source : Unbounded_Wide_String;
+ Pattern : Wide_String;
+ Going : Direction := Forward;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
return Natural
is
begin
- return
- Wide_Search.Index (Source.Reference.all, Pattern, Going, Mapping);
+ return Wide_Search.Index
+ (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping);
end Index;
function Index
@@ -597,7 +641,8 @@ package body Ada.Strings.Wide_Unbounded is
return Natural
is
begin
- return Wide_Search.Index (Source.Reference.all, Set, Test, Going);
+ return Wide_Search.Index
+ (Source.Reference (1 .. Source.Last), Set, Test, Going);
end Index;
function Index_Non_Blank
@@ -606,7 +651,8 @@ package body Ada.Strings.Wide_Unbounded is
return Natural
is
begin
- return Wide_Search.Index_Non_Blank (Source.Reference.all, Going);
+ return Wide_Search.Index_Non_Blank
+ (Source.Reference (1 .. Source.Last), Going);
end Index_Non_Blank;
----------------
@@ -616,6 +662,7 @@ package body Ada.Strings.Wide_Unbounded is
procedure Initialize (Object : in out Unbounded_Wide_String) is
begin
Object.Reference := Null_Unbounded_Wide_String.Reference;
+ Object.Last := 0;
end Initialize;
------------
@@ -629,19 +676,29 @@ package body Ada.Strings.Wide_Unbounded is
return Unbounded_Wide_String
is
begin
- return
- To_Unbounded_Wide_String
- (Wide_Fixed.Insert (Source.Reference.all, Before, New_Item));
+ return To_Unbounded_Wide_String
+ (Wide_Fixed.Insert
+ (Source.Reference (1 .. Source.Last), Before, New_Item));
end Insert;
procedure Insert
(Source : in out Unbounded_Wide_String;
- Before : in Positive;
- New_Item : in Wide_String)
+ Before : Positive;
+ New_Item : Wide_String)
is
begin
- Source := To_Unbounded_Wide_String
- (Wide_Fixed.Insert (Source.Reference.all, Before, New_Item));
+ if Before not in Source.Reference'First .. Source.Last + 1 then
+ raise Index_Error;
+ end if;
+
+ Realloc_For_Chunk (Source, New_Item'Size);
+
+ Source.Reference
+ (Before + New_Item'Length .. Source.Last + New_Item'Length) :=
+ Source.Reference (Before .. Source.Last);
+
+ Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item;
+ Source.Last := Source.Last + New_Item'Length;
end Insert;
------------
@@ -650,7 +707,7 @@ package body Ada.Strings.Wide_Unbounded is
function Length (Source : Unbounded_Wide_String) return Natural is
begin
- return Source.Reference.all'Length;
+ return Source.Last;
end Length;
---------------
@@ -665,20 +722,62 @@ package body Ada.Strings.Wide_Unbounded is
begin
return To_Unbounded_Wide_String
- (Wide_Fixed.Overwrite (Source.Reference.all, Position, New_Item));
+ (Wide_Fixed.Overwrite
+ (Source.Reference (1 .. Source.Last), Position, New_Item));
end Overwrite;
procedure Overwrite
(Source : in out Unbounded_Wide_String;
- Position : in Positive;
- New_Item : in Wide_String)
+ Position : Positive;
+ New_Item : Wide_String)
is
- Temp : Wide_String_Access := Source.Reference;
+ NL : constant Natural := New_Item'Length;
+
begin
- Source := To_Unbounded_Wide_String
- (Wide_Fixed.Overwrite (Temp.all, Position, New_Item));
+ if Position <= Source.Last - NL + 1 then
+ Source.Reference (Position .. Position + NL - 1) := New_Item;
+
+ else
+ declare
+ Old : Wide_String_Access := Source.Reference;
+
+ begin
+ Source.Reference := new Wide_String'
+ (Wide_Fixed.Overwrite
+ (Source.Reference (1 .. Source.Last), Position, New_Item));
+ Source.Last := Source.Reference'Length;
+ Free (Old);
+ end;
+ end if;
end Overwrite;
+ -----------------------
+ -- Realloc_For_Chunk --
+ -----------------------
+
+ procedure Realloc_For_Chunk
+ (Source : in out Unbounded_Wide_String;
+ Chunk_Size : Natural)
+ is
+ Growth_Factor : constant := 50;
+ S_Length : constant Natural := Source.Reference'Length;
+
+ begin
+ if Chunk_Size > S_Length - Source.Last then
+ declare
+ Alloc_Chunk_Size : constant Positive :=
+ Chunk_Size + (S_Length / Growth_Factor);
+ Tmp : Wide_String_Access;
+
+ begin
+ Tmp := new Wide_String (1 .. S_Length + Alloc_Chunk_Size);
+ Tmp (1 .. Source.Last) := Source.Reference (1 .. Source.Last);
+ Free (Source.Reference);
+ Source.Reference := Tmp;
+ end;
+ end if;
+ end Realloc_For_Chunk;
+
---------------------
-- Replace_Element --
---------------------
@@ -689,8 +788,8 @@ package body Ada.Strings.Wide_Unbounded is
By : Wide_Character)
is
begin
- if Index <= Source.Reference.all'Last then
- Source.Reference.all (Index) := By;
+ if Index <= Source.Last then
+ Source.Reference (Index) := By;
else
raise Strings.Index_Error;
end if;
@@ -710,19 +809,24 @@ package body Ada.Strings.Wide_Unbounded is
begin
return
To_Unbounded_Wide_String
- (Wide_Fixed.Replace_Slice (Source.Reference.all, Low, High, By));
+ (Wide_Fixed.Replace_Slice
+ (Source.Reference (1 .. Source.Last), Low, High, By));
end Replace_Slice;
procedure Replace_Slice
(Source : in out Unbounded_Wide_String;
- Low : in Positive;
- High : in Natural;
- By : in Wide_String)
+ Low : Positive;
+ High : Natural;
+ By : Wide_String)
is
- Temp : Wide_String_Access := Source.Reference;
+ Old : Wide_String_Access := Source.Reference;
+
begin
- Source := To_Unbounded_Wide_String
- (Wide_Fixed.Replace_Slice (Temp.all, Low, High, By));
+ Source.Reference := new Wide_String'
+ (Wide_Fixed.Replace_Slice
+ (Source.Reference (1 .. Source.Last), Low, High, By));
+ Source.Last := Source.Reference'Length;
+ Free (Old);
end Replace_Slice;
-----------
@@ -735,22 +839,14 @@ package body Ada.Strings.Wide_Unbounded is
High : Natural)
return Wide_String
is
- Length : constant Natural := Source.Reference'Length;
-
begin
-- Note: test of High > Length is in accordance with AI95-00128
- if Low > Length + 1 or else High > Length then
+ if Low > Source.Last + 1 or else High > Source.Last then
raise Index_Error;
else
- declare
- Result : Wide_String (1 .. High - Low + 1);
-
- begin
- Result := Source.Reference.all (Low .. High);
- return Result;
- end;
+ return Source.Reference (Low .. High);
end if;
end Slice;
@@ -765,21 +861,22 @@ package body Ada.Strings.Wide_Unbounded is
return Unbounded_Wide_String is
begin
- return
- To_Unbounded_Wide_String
- (Wide_Fixed.Tail (Source.Reference.all, Count, Pad));
+ return To_Unbounded_Wide_String
+ (Wide_Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad));
end Tail;
procedure Tail
(Source : in out Unbounded_Wide_String;
- Count : in Natural;
- Pad : in Wide_Character := Wide_Space)
+ Count : Natural;
+ Pad : Wide_Character := Wide_Space)
is
- Temp : Wide_String_Access := Source.Reference;
+ Old : Wide_String_Access := Source.Reference;
begin
- Source := To_Unbounded_Wide_String
- (Wide_Fixed.Tail (Temp.all, Count, Pad));
+ Source.Reference := new Wide_String'
+ (Wide_Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad));
+ Source.Last := Source.Reference'Length;
+ Free (Old);
end Tail;
------------------------------
@@ -793,17 +890,19 @@ package body Ada.Strings.Wide_Unbounded is
Result : Unbounded_Wide_String;
begin
- Result.Reference := new Wide_String (1 .. Source'Length);
+ Result.Last := Source'Length;
+ Result.Reference := new Wide_String (1 .. Source'Length);
Result.Reference.all := Source;
return Result;
end To_Unbounded_Wide_String;
- function To_Unbounded_Wide_String (Length : in Natural)
+ function To_Unbounded_Wide_String (Length : Natural)
return Unbounded_Wide_String
is
Result : Unbounded_Wide_String;
begin
+ Result.Last := Length;
Result.Reference := new Wide_String (1 .. Length);
return Result;
end To_Unbounded_Wide_String;
@@ -817,7 +916,7 @@ package body Ada.Strings.Wide_Unbounded is
return Wide_String
is
begin
- return Source.Reference.all;
+ return Source.Reference (1 .. Source.Last);
end To_Wide_String;
---------------
@@ -830,9 +929,8 @@ package body Ada.Strings.Wide_Unbounded is
return Unbounded_Wide_String
is
begin
- return
- To_Unbounded_Wide_String
- (Wide_Fixed.Translate (Source.Reference.all, Mapping));
+ return To_Unbounded_Wide_String
+ (Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping));
end Translate;
procedure Translate
@@ -840,26 +938,25 @@ package body Ada.Strings.Wide_Unbounded is
Mapping : Wide_Maps.Wide_Character_Mapping)
is
begin
- Wide_Fixed.Translate (Source.Reference.all, Mapping);
+ Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping);
end Translate;
function Translate
- (Source : in Unbounded_Wide_String;
- Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ (Source : Unbounded_Wide_String;
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
return Unbounded_Wide_String
is
begin
- return
- To_Unbounded_Wide_String
- (Wide_Fixed.Translate (Source.Reference.all, Mapping));
+ return To_Unbounded_Wide_String
+ (Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping));
end Translate;
procedure Translate
(Source : in out Unbounded_Wide_String;
- Mapping : in Wide_Maps.Wide_Character_Mapping_Function)
+ Mapping : Wide_Maps.Wide_Character_Mapping_Function)
is
begin
- Wide_Fixed.Translate (Source.Reference.all, Mapping);
+ Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping);
end Translate;
----------
@@ -867,48 +964,49 @@ package body Ada.Strings.Wide_Unbounded is
----------
function Trim
- (Source : in Unbounded_Wide_String;
- Side : in Trim_End)
+ (Source : Unbounded_Wide_String;
+ Side : Trim_End)
return Unbounded_Wide_String
is
begin
- return
- To_Unbounded_Wide_String
- (Wide_Fixed.Trim (Source.Reference.all, Side));
+ return To_Unbounded_Wide_String
+ (Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side));
end Trim;
procedure Trim
(Source : in out Unbounded_Wide_String;
- Side : in Trim_End)
+ Side : Trim_End)
is
Old : Wide_String_Access := Source.Reference;
begin
- Source.Reference := new Wide_String'(Wide_Fixed.Trim (Old.all, Side));
+ Source.Reference := new Wide_String'
+ (Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side));
+ Source.Last := Source.Reference'Length;
Free (Old);
end Trim;
function Trim
- (Source : in Unbounded_Wide_String;
- Left : in Wide_Maps.Wide_Character_Set;
- Right : in Wide_Maps.Wide_Character_Set)
+ (Source : Unbounded_Wide_String;
+ Left : Wide_Maps.Wide_Character_Set;
+ Right : Wide_Maps.Wide_Character_Set)
return Unbounded_Wide_String
is
begin
- return
- To_Unbounded_Wide_String
- (Wide_Fixed.Trim (Source.Reference.all, Left, Right));
+ return To_Unbounded_Wide_String
+ (Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Left, Right));
end Trim;
procedure Trim
(Source : in out Unbounded_Wide_String;
- Left : in Wide_Maps.Wide_Character_Set;
- Right : in Wide_Maps.Wide_Character_Set)
+ Left : Wide_Maps.Wide_Character_Set;
+ Right : Wide_Maps.Wide_Character_Set)
is
Old : Wide_String_Access := Source.Reference;
begin
- Source.Reference :=
- new Wide_String'(Wide_Fixed.Trim (Old.all, Left, Right));
+ Source.Reference := new Wide_String'
+ (Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Left, Right));
+ Source.Last := Source.Reference'Length;
Free (Old);
end Trim;
diff --git a/gcc/ada/a-stwiun.ads b/gcc/ada/a-stwiun.ads
index d2cf86ef6a1..6b348d456fd 100644
--- a/gcc/ada/a-stwiun.ads
+++ b/gcc/ada/a-stwiun.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -389,8 +389,16 @@ private
type Unbounded_Wide_String is new AF.Controlled with record
Reference : Wide_String_Access := Null_Wide_String'Access;
+ Last : Natural := 0;
end record;
+ -- The Unbounded_Wide_String is using a buffered implementation to increase
+ -- speed of the Append/Delete/Insert procedures. The Reference string
+ -- pointer above contains the current string value and extra room at the
+ -- end to be used by the next Append routine. Last is the index of the
+ -- string ending character. So the current string value is really
+ -- Reference (1 .. Last).
+
pragma Stream_Convert
(Unbounded_Wide_String, To_Unbounded_Wide, To_Wide_String);
@@ -401,6 +409,6 @@ private
procedure Finalize (Object : in out Unbounded_Wide_String);
Null_Unbounded_Wide_String : constant Unbounded_Wide_String :=
- (AF.Controlled with Reference => Null_Wide_String'Access);
+ (AF.Controlled with Reference => Null_Wide_String'Access, Last => 0);
end Ada.Strings.Wide_Unbounded;
diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb
index 9da303d73d8..f88874d79fa 100644
--- a/gcc/ada/a-tags.adb
+++ b/gcc/ada/a-tags.adb
@@ -32,10 +32,12 @@
------------------------------------------------------------------------------
with Ada.Exceptions;
+
+with System.HTable;
+
with Unchecked_Conversion;
-with GNAT.HTable;
-pragma Elaborate_All (GNAT.HTable);
+pragma Elaborate_All (System.HTable);
package body Ada.Tags is
@@ -66,8 +68,9 @@ package body Ada.Tags is
type Tag_Table is array (Natural range <>) of Tag;
pragma Suppress_Initialization (Tag_Table);
- type Wide_Boolean is (False, True);
- for Wide_Boolean'Size use Standard'Address_Size;
+ type Wide_Boolean is new Boolean;
+ -- This name should probably be changed sometime ??? and indeed
+ -- probably this field could simply be of type Standard.Boolean.
type Type_Specific_Data is record
Idepth : Natural;
@@ -119,7 +122,7 @@ package body Ada.Tags is
type HTable_Headers is range 1 .. 64;
-- The following internal package defines the routines used for
- -- the instantiation of a new GNAT.HTable.Static_HTable (see
+ -- the instantiation of a new System.HTable.Static_HTable (see
-- below). See spec in g-htable.ads for details of usage.
package HTable_Subprograms is
@@ -129,7 +132,7 @@ package body Ada.Tags is
function Equal (A, B : S.Address) return Boolean;
end HTable_Subprograms;
- package External_Tag_HTable is new GNAT.HTable.Static_HTable (
+ package External_Tag_HTable is new System.HTable.Static_HTable (
Header_Num => HTable_Headers,
Element => Dispatch_Table,
Elmt_Ptr => Tag,
@@ -154,8 +157,8 @@ package body Ada.Tags is
-----------
function Equal (A, B : S.Address) return Boolean is
- Str1 : Cstring_Ptr := To_Cstring_Ptr (A);
- Str2 : Cstring_Ptr := To_Cstring_Ptr (B);
+ Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A);
+ Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B);
J : Integer := 1;
begin
@@ -186,8 +189,8 @@ package body Ada.Tags is
----------
function Hash (F : S.Address) return HTable_Headers is
- function H is new GNAT.HTable.Hash (HTable_Headers);
- Str : Cstring_Ptr := To_Cstring_Ptr (F);
+ function H is new System.HTable.Hash (HTable_Headers);
+ Str : constant Cstring_Ptr := To_Cstring_Ptr (F);
Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
begin
@@ -236,7 +239,7 @@ package body Ada.Tags is
-------------------
function Expanded_Name (T : Tag) return String is
- Result : Cstring_Ptr := T.TSD.Expanded_Name;
+ Result : constant Cstring_Ptr := T.TSD.Expanded_Name;
begin
return Result (1 .. Length (Result));
@@ -247,7 +250,7 @@ package body Ada.Tags is
------------------
function External_Tag (T : Tag) return String is
- Result : Cstring_Ptr := T.TSD.External_Tag;
+ Result : constant Cstring_Ptr := T.TSD.External_Tag;
begin
return Result (1 .. Length (Result));
@@ -408,36 +411,21 @@ package body Ada.Tags is
-- Parent_Size --
-----------------
- -- Fake type with a tag as first component. Should match the
- -- layout of all tagged types.
-
- type T is record
- A : Tag;
- end record;
-
- type T_Ptr is access all T;
-
- function To_T_Ptr is new Unchecked_Conversion (S.Address, T_Ptr);
-
- -- The profile of the implicitly defined _size primitive
-
type Acc_Size is access function (A : S.Address) return Long_Long_Integer;
function To_Acc_Size is new Unchecked_Conversion (S.Address, Acc_Size);
+ -- The profile of the implicitly defined _size primitive
- function Parent_Size (Obj : S.Address) return SSE.Storage_Count is
-
- -- Get the tag of the object
-
- Obj_Tag : constant Tag := To_T_Ptr (Obj).A;
-
- -- Get the tag of the parent type through the dispatch table
+ function Parent_Size
+ (Obj : S.Address;
+ T : Tag)
+ return SSE.Storage_Count is
- Parent_Tag : constant Tag := Obj_Tag.TSD.Ancestor_Tags (1);
-
- -- Get an access to the _size primitive of the parent. We assume that
- -- it is always in the first slot of the distatch table
+ Parent_Tag : constant Tag := T.TSD.Ancestor_Tags (1);
+ -- The tag of the parent type through the dispatch table
F : constant Acc_Size := To_Acc_Size (Parent_Tag.Prims_Ptr (1));
+ -- Access to the _size primitive of the parent. We assume that
+ -- it is always in the first slot of the distatch table
begin
-- Here we compute the size of the _parent field of the object
@@ -445,6 +433,15 @@ package body Ada.Tags is
return SSE.Storage_Count (F.all (Obj));
end Parent_Size;
+ ----------------
+ -- Parent_Tag --
+ ----------------
+
+ function Parent_Tag (T : Tag) return Tag is
+ begin
+ return T.TSD.Ancestor_Tags (1);
+ end Parent_Tag;
+
------------------
-- Register_Tag --
------------------
diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads
index b4ab29a1ba1..8dc78c6797a 100644
--- a/gcc/ada/a-tags.ads
+++ b/gcc/ada/a-tags.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -59,7 +59,7 @@ private
----------------------------------------------------------------
-- GNAT's Dispatch Table format is customizable in order to match the
- -- format used in another language. GNAT supports programs that use
+ -- format used in another langauge. GNAT supports programs that use
-- two different dispatch table format at the same time: the native
-- format that supports Ada 95 tagged types and which is described in
-- Ada.Tags and a foreign format for types that are imported from some
@@ -133,15 +133,26 @@ private
-- Entry point used to initialize the TSD of a type knowing the
-- TSD of the direct ancestor.
- function Parent_Size (Obj : S.Address) return SSE.Storage_Count;
- -- Computes the size of field _Parent of a tagged extension object
+ function Parent_Size
+ (Obj : S.Address;
+ T : Tag)
+ return SSE.Storage_Count;
+ -- Computes the size the ancestor part of a tagged extension object
-- whose address is 'obj' by calling the indirectly _size function of
- -- the parent. This function assumes that _size is always in slot 1 of
+ -- the ancestor. The ancestor is the parent of the type represented by
+ -- tag T. This function assumes that _size is always in slot 1 of
-- the dispatch table.
pragma Export (Ada, Parent_Size, "ada__tags__parent_size");
-- This procedure is used in s-finimp and is thus exported manually
+ function Parent_Tag (T : Tag) return Tag;
+ -- Obj is the address of a tagged object. Parent_Tag fetch the tag of the
+ -- immediate ancestor (parent) of the type associated with Obj.
+
+ pragma Export (Ada, Parent_Tag, "ada__tags__parent_tag");
+ -- This procedure is used in s-finimp and is thus exported manually
+
procedure Register_Tag (T : Tag);
-- Insert the Tag and its associated external_tag in a table for the
-- sake of Internal_Tag
@@ -225,4 +236,5 @@ private
pragma Inline_Always (Set_RC_Offset);
pragma Inline_Always (Set_Remotely_Callable);
pragma Inline_Always (Set_TSD);
+
end Ada.Tags;
diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb
index 6d9d114d7f4..92f9f7921bd 100644
--- a/gcc/ada/a-tasatt.adb
+++ b/gcc/ada/a-tasatt.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2002 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,8 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -120,7 +121,7 @@
-- finalization for that type of attribute. On task termination, the
-- runtime system uses the pointer to call the appropriate deallocator.
--- While this gets around the limitation that instantiations be at
+-- While this gets around the limitation that instantations be at
-- the library level, it relies on an implementation feature that
-- may not always be safe, i.e. that it is safe to call the
-- Deallocate procedure for an instantiation of Ada.Task_Attributes
@@ -286,11 +287,6 @@ package body Ada.Task_Attributes is
-- Unchecked Conversions --
---------------------------
- pragma Warnings (Off);
- -- These unchecked conversions can give warnings when alignments
- -- are incorrect, but they will not be used in such cases anyway,
- -- so the warnings can be safely ignored.
-
-- The following type corresponds to Dummy_Wrapper,
-- declared in System.Tasking.Task_Attributes.
@@ -306,7 +302,9 @@ package body Ada.Task_Attributes is
-- they will not actually be used.
function To_Attribute_Handle is new Unchecked_Conversion
- (Access_Address, Attribute_Handle);
+ (System.Address, Attribute_Handle);
+ function To_Direct_Attribute_Element is new Unchecked_Conversion
+ (System.Address, Direct_Attribute_Element);
-- For reference to directly addressed task attributes
type Access_Integer_Address is access all
@@ -346,11 +344,7 @@ package body Ada.Task_Attributes is
(Task_Identification.Task_Id, Task_ID);
-- To access TCB of identified task
- Null_ID : constant Task_ID := To_Task_ID (Task_Identification.Null_Task_Id);
- -- ??? need comments on use and purpose
-
- type Local_Deallocator is
- access procedure (P : in out Access_Node);
+ type Local_Deallocator is access procedure (P : in out Access_Node);
function To_Lib_Level_Deallocator is new Unchecked_Conversion
(Local_Deallocator, Deallocator);
@@ -380,6 +374,12 @@ package body Ada.Task_Attributes is
-- The generic formal type, may be controlled
end record;
+ -- A number of unchecked conversions involving Wrapper_Access sources
+ -- are performed in this unit. We have to ensure that the designated
+ -- object is always strictly enough aligned.
+
+ for Wrapper'Alignment use Standard'Maximum_Alignment;
+
procedure Free is
new Unchecked_Deallocation (Wrapper, Access_Wrapper);
@@ -388,10 +388,6 @@ package body Ada.Task_Attributes is
begin
Free (T);
-
- exception
- when others =>
- pragma Assert (Shutdown ("Exception in Deallocate")); null;
end Deallocate;
---------------
@@ -403,12 +399,11 @@ package body Ada.Task_Attributes is
return Attribute_Handle
is
TT : Task_ID := To_Task_ID (T);
- Error_Message : constant String := "Trying to get the reference of a";
+ Error_Message : constant String := "Trying to get the reference of a ";
begin
- if TT = Null_ID then
- Raise_Exception (Program_Error'Identity,
- Error_Message & "null task");
+ if TT = null then
+ Raise_Exception (Program_Error'Identity, Error_Message & "null task");
end if;
if TT.Common.State = Terminated then
@@ -416,71 +411,67 @@ package body Ada.Task_Attributes is
Error_Message & "terminated task");
end if;
- begin
- Defer_Abortion;
- POP.Lock_RTS;
+ -- Directly addressed case
- -- Directly addressed case
-
- if Local.Index /= 0 then
- POP.Unlock_RTS;
- Undefer_Abortion;
+ if Local.Index /= 0 then
- -- Return the attribute handle. Warnings off because this return
- -- statement generates alignment warnings for large attributes
- -- (but will never be executed in this case anyway).
+ -- Return the attribute handle. Warnings off because this return
+ -- statement generates alignment warnings for large attributes
+ -- (but will never be executed in this case anyway).
- pragma Warnings (Off);
- return
- To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Access);
- pragma Warnings (On);
+ pragma Warnings (Off);
+ return
+ To_Attribute_Handle (TT.Direct_Attributes (Local.Index)'Address);
+ pragma Warnings (On);
- -- Not directly addressed
+ -- Not directly addressed
- else
- declare
- P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
- W : Access_Wrapper;
+ else
+ declare
+ P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
+ W : Access_Wrapper;
- begin
- while P /= null loop
- if P.Instance = Access_Instance'(Local'Unchecked_Access) then
- POP.Unlock_RTS;
- Undefer_Abortion;
- return To_Access_Wrapper (P.Wrapper).Value'Access;
- end if;
+ begin
+ Defer_Abortion;
+ POP.Lock_RTS;
- P := P.Next;
- end loop;
+ while P /= null loop
+ if P.Instance = Access_Instance'(Local'Unchecked_Access) then
+ POP.Unlock_RTS;
+ Undefer_Abortion;
+ return To_Access_Wrapper (P.Wrapper).Value'Access;
+ end if;
- -- Unlock the RTS here to follow the lock ordering rule
- -- that prevent us from using new (i.e the Global_Lock) while
- -- holding any other lock.
+ P := P.Next;
+ end loop;
- POP.Unlock_RTS;
- W := new Wrapper'
- ((null, Local'Unchecked_Access, null), Initial_Value);
- POP.Lock_RTS;
-
- P := W.Noed'Unchecked_Access;
- P.Wrapper := To_Access_Dummy_Wrapper (W);
- P.Next := To_Access_Node (TT.Indirect_Attributes);
- TT.Indirect_Attributes := To_Access_Address (P);
- POP.Unlock_RTS;
- Undefer_Abortion;
- return W.Value'Access;
- end;
- end if;
+ -- Unlock the RTS here to follow the lock ordering rule
+ -- that prevent us from using new (i.e the Global_Lock) while
+ -- holding any other lock.
- pragma Assert (Shutdown ("Should never get here in Reference"));
- return null;
+ POP.Unlock_RTS;
+ W := new Wrapper'
+ ((null, Local'Unchecked_Access, null), Initial_Value);
+ POP.Lock_RTS;
- exception
- when others =>
+ P := W.Noed'Unchecked_Access;
+ P.Wrapper := To_Access_Dummy_Wrapper (W);
+ P.Next := To_Access_Node (TT.Indirect_Attributes);
+ TT.Indirect_Attributes := To_Access_Address (P);
POP.Unlock_RTS;
Undefer_Abortion;
- raise;
- end;
+ return W.Value'Access;
+
+ exception
+ when others =>
+ POP.Unlock_RTS;
+ Undefer_Abortion;
+ raise;
+ end;
+ end if;
+
+ pragma Assert (Shutdown ("Should never get here in Reference"));
+ return null;
exception
when Tasking_Error | Program_Error =>
@@ -498,12 +489,11 @@ package body Ada.Task_Attributes is
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
is
TT : Task_ID := To_Task_ID (T);
- Error_Message : constant String := "Trying to Reinitialize a";
+ Error_Message : constant String := "Trying to Reinitialize a ";
begin
- if TT = Null_ID then
- Raise_Exception (Program_Error'Identity,
- Error_Message & "null task");
+ if TT = null then
+ Raise_Exception (Program_Error'Identity, Error_Message & "null task");
end if;
if TT.Common.State = Terminated then
@@ -511,11 +501,12 @@ package body Ada.Task_Attributes is
Error_Message & "terminated task");
end if;
- if Local.Index = 0 then
+ if Local.Index /= 0 then
+ Set_Value (Initial_Value, T);
+ else
declare
P, Q : Access_Node;
W : Access_Wrapper;
-
begin
Defer_Abortion;
POP.Lock_RTS;
@@ -547,10 +538,8 @@ package body Ada.Task_Attributes is
when others =>
POP.Unlock_RTS;
Undefer_Abortion;
+ raise;
end;
-
- else
- Set_Value (Initial_Value, T);
end if;
exception
@@ -569,13 +558,12 @@ package body Ada.Task_Attributes is
(Val : Attribute;
T : Task_Identification.Task_Id := Task_Identification.Current_Task)
is
- TT : Task_ID := To_Task_ID (T);
- Error_Message : constant String := "Trying to Set the Value of a";
+ TT : Task_ID := To_Task_ID (T);
+ Error_Message : constant String := "Trying to Set the Value of a ";
begin
- if TT = Null_ID then
- Raise_Exception (Program_Error'Identity,
- Error_Message & "null task");
+ if TT = null then
+ Raise_Exception (Program_Error'Identity, Error_Message & "null task");
end if;
if TT.Common.State = Terminated then
@@ -583,61 +571,55 @@ package body Ada.Task_Attributes is
Error_Message & "terminated task");
end if;
- begin
- Defer_Abortion;
- POP.Lock_RTS;
+ -- Directly addressed case
- -- Directly addressed case
+ if Local.Index /= 0 then
- if Local.Index /= 0 then
+ -- Set attribute handle, warnings off, because this code can generate
+ -- alignment warnings with large attributes (but of course will not
+ -- be executed in this case, since we never have direct addressing in
+ -- such cases).
- -- Set attribute handle, warnings off, because this code can
- -- generate alignment warnings with large attributes (but of
- -- course wil not be executed in this case, since we never
- -- have direct addressing in such cases).
+ pragma Warnings (Off);
+ To_Attribute_Handle
+ (TT.Direct_Attributes (Local.Index)'Address).all := Val;
+ pragma Warnings (On);
+ return;
+ end if;
- pragma Warnings (Off);
- To_Attribute_Handle
- (TT.Direct_Attributes (Local.Index)'Access).all := Val;
- pragma Warnings (On);
- POP.Unlock_RTS;
- Undefer_Abortion;
- return;
+ -- Not directly addressed
- -- Not directly addressed
+ declare
+ P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
+ W : Access_Wrapper;
- else
- declare
- P : Access_Node := To_Access_Node (TT.Indirect_Attributes);
- W : Access_Wrapper;
+ begin
+ Defer_Abortion;
+ POP.Lock_RTS;
- begin
- while P /= null loop
+ while P /= null loop
- if P.Instance = Access_Instance'(Local'Unchecked_Access) then
- To_Access_Wrapper (P.Wrapper).Value := Val;
- POP.Unlock_RTS;
- Undefer_Abortion;
- return;
- end if;
+ if P.Instance = Access_Instance'(Local'Unchecked_Access) then
+ To_Access_Wrapper (P.Wrapper).Value := Val;
+ POP.Unlock_RTS;
+ Undefer_Abortion;
+ return;
+ end if;
- P := P.Next;
- end loop;
+ P := P.Next;
+ end loop;
- -- Unlock RTS here to follow the lock ordering rule that
- -- prevent us from using new (i.e the Global_Lock) while
- -- holding any other lock.
+ -- Unlock RTS here to follow the lock ordering rule that
+ -- prevent us from using new (i.e the Global_Lock) while
+ -- holding any other lock.
- POP.Unlock_RTS;
- W := new Wrapper'
- ((null, Local'Unchecked_Access, null), Val);
- POP.Lock_RTS;
- P := W.Noed'Unchecked_Access;
- P.Wrapper := To_Access_Dummy_Wrapper (W);
- P.Next := To_Access_Node (TT.Indirect_Attributes);
- TT.Indirect_Attributes := To_Access_Address (P);
- end;
- end if;
+ POP.Unlock_RTS;
+ W := new Wrapper'((null, Local'Unchecked_Access, null), Val);
+ POP.Lock_RTS;
+ P := W.Noed'Unchecked_Access;
+ P.Wrapper := To_Access_Dummy_Wrapper (W);
+ P.Next := To_Access_Node (TT.Indirect_Attributes);
+ TT.Indirect_Attributes := To_Access_Address (P);
POP.Unlock_RTS;
Undefer_Abortion;
@@ -649,15 +631,12 @@ package body Ada.Task_Attributes is
raise;
end;
- return;
-
exception
when Tasking_Error | Program_Error =>
raise;
when others =>
raise Program_Error;
-
end Set_Value;
-----------
@@ -668,14 +647,12 @@ package body Ada.Task_Attributes is
(T : Task_Identification.Task_Id := Task_Identification.Current_Task)
return Attribute
is
- Result : Attribute;
TT : Task_ID := To_Task_ID (T);
- Error_Message : constant String := "Trying to get the Value of a";
+ Error_Message : constant String := "Trying to get the Value of a ";
begin
- if TT = Null_ID then
- Raise_Exception
- (Program_Error'Identity, Error_Message & "null task");
+ if TT = null then
+ Raise_Exception (Program_Error'Identity, Error_Message & "null task");
end if;
if TT.Common.State = Terminated then
@@ -683,56 +660,52 @@ package body Ada.Task_Attributes is
(Program_Error'Identity, Error_Message & "terminated task");
end if;
- begin
- -- Directly addressed case
-
- if Local.Index /= 0 then
+ -- Directly addressed case
- -- Get value of attribute. Warnings off, because for large
- -- attributes, this code can generate alignment warnings.
- -- But of course large attributes are never directly addressed
- -- so in fact we will never execute the code in this case.
-
- pragma Warnings (Off);
- Result :=
- To_Attribute_Handle
- (TT.Direct_Attributes (Local.Index)'Access).all;
- pragma Warnings (On);
+ if Local.Index /= 0 then
- -- Not directly addressed
+ -- Get value of attribute. Warnings off, because for large
+ -- attributes, this code can generate alignment warnings.
+ -- But of course large attributes are never directly addressed
+ -- so in fact we will never execute the code in this case.
- else
- declare
- P : Access_Node;
+ pragma Warnings (Off);
+ return To_Attribute_Handle
+ (TT.Direct_Attributes (Local.Index)'Address).all;
+ pragma Warnings (On);
+ end if;
- begin
- Defer_Abortion;
- POP.Lock_RTS;
- P := To_Access_Node (TT.Indirect_Attributes);
+ -- Not directly addressed
- while P /= null loop
- if P.Instance = Access_Instance'(Local'Unchecked_Access) then
- POP.Unlock_RTS;
- Undefer_Abortion;
- return To_Access_Wrapper (P.Wrapper).Value;
- end if;
+ declare
+ P : Access_Node;
+ Result : Attribute;
- P := P.Next;
- end loop;
+ begin
+ Defer_Abortion;
+ POP.Lock_RTS;
+ P := To_Access_Node (TT.Indirect_Attributes);
- Result := Initial_Value;
+ while P /= null loop
+ if P.Instance = Access_Instance'(Local'Unchecked_Access) then
+ Result := To_Access_Wrapper (P.Wrapper).Value;
POP.Unlock_RTS;
Undefer_Abortion;
+ return Result;
+ end if;
- exception
- when others =>
- POP.Unlock_RTS;
- Undefer_Abortion;
- raise;
- end;
- end if;
+ P := P.Next;
+ end loop;
- return Result;
+ POP.Unlock_RTS;
+ Undefer_Abortion;
+ return Initial_Value;
+
+ exception
+ when others =>
+ POP.Unlock_RTS;
+ Undefer_Abortion;
+ raise;
end;
exception
@@ -774,11 +747,11 @@ begin
-- Try to find space for the attribute in the TCB.
Local.Index := 0;
- Two_To_J := 2 ** Direct_Index'First;
+ Two_To_J := 1;
if Attribute'Size <= System.Address'Size then
- for J in Direct_Index loop
- if (Two_To_J and In_Use) /= 0 then
+ for J in Direct_Index_Range loop
+ if (Two_To_J and In_Use) = 0 then
-- Reserve location J for this attribute
@@ -804,7 +777,6 @@ begin
-- Attribute goes directly in the TCB
if Local.Index /= 0 then
-
-- Replace stub for initialization routine
-- that is called at task creation.
@@ -815,13 +787,11 @@ begin
declare
C : System.Tasking.Task_ID := System.Tasking.All_Tasks_List;
-
begin
while C /= null loop
- POP.Write_Lock (C);
C.Direct_Attributes (Local.Index) :=
- System.Storage_Elements.To_Address (Local.Initial_Value);
- POP.Unlock (C);
+ To_Direct_Attribute_Element
+ (System.Storage_Elements.To_Address (Local.Initial_Value));
C := C.Common.All_Tasks_Link;
end loop;
end;
@@ -834,19 +804,9 @@ begin
Initialization.Finalize_Attributes_Link :=
System.Tasking.Task_Attributes.Finalize_Attributes'Access;
-
end if;
POP.Unlock_RTS;
Undefer_Abortion;
-
- exception
- when others => null;
- pragma Assert (Shutdown ("Exception in task attribute initializer"));
-
- -- If we later decide to allow exceptions to propagate, we need to
- -- not only release locks and undefer abortion, we also need to undo
- -- any initializations that succeeded up to this point, or we will
- -- risk a dangling reference when the task terminates.
end;
end Ada.Task_Attributes;
diff --git a/gcc/ada/a-taside.adb b/gcc/ada/a-taside.adb
index 6bc3b018a12..c15ce991e0b 100644
--- a/gcc/ada/a-taside.adb
+++ b/gcc/ada/a-taside.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -47,9 +47,6 @@ with System.Tasking.Rendezvous;
with System.Task_Primitives.Operations;
-- used for Self
-with System.Task_Info;
-use type System.Task_Info.Task_Image_Type;
-
with Unchecked_Conversion;
package body Ada.Task_Identification is
@@ -114,7 +111,6 @@ package body Ada.Task_Identification is
-----------
function Image (T : Task_Id) return String is
- use System.Task_Info;
function To_Address is new
Unchecked_Conversion (Task_Id, System.Address);
@@ -122,11 +118,11 @@ package body Ada.Task_Identification is
if T = Null_Task_Id then
return "";
- elsif T.Common.Task_Image = null then
+ elsif T.Common.Task_Image_Len = 0 then
return System.Address_Image (To_Address (T));
else
- return T.Common.Task_Image.all
+ return T.Common.Task_Image (1 .. T.Common.Task_Image_Len)
& "_" & System.Address_Image (To_Address (T));
end if;
end Image;
diff --git a/gcc/ada/a-teioed.adb b/gcc/ada/a-teioed.adb
index f273a246b67..e4ad7156e8f 100644
--- a/gcc/ada/a-teioed.adb
+++ b/gcc/ada/a-teioed.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -112,7 +112,6 @@ package body Ada.Text_IO.Editing is
exception
when others =>
raise Picture_Error;
-
end Expand;
-------------------
@@ -137,6 +136,7 @@ package body Ada.Text_IO.Editing is
Answer : String (1 .. Pic.Picture.Length) := Pic.Picture.Expanded;
Last : Integer;
Currency_Pos : Integer := Pic.Start_Currency;
+ In_Currency : Boolean := False;
Dollar : Boolean := False;
-- Overridden immediately if necessary.
@@ -298,7 +298,7 @@ package body Ada.Text_IO.Editing is
if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 >
Pic.Max_Leading_Digits
then
- raise Layout_Error;
+ raise Ada.Text_IO.Layout_Error;
end if;
if Pic.Radix_Position = Invalid_Position then
@@ -433,6 +433,7 @@ package body Ada.Text_IO.Editing is
else
if Pic.Floater = '#' then
Currency_Pos := Currency_Symbol'Length;
+ In_Currency := True;
end if;
for J in reverse Pic.Start_Float .. Position loop
@@ -441,7 +442,15 @@ package body Ada.Text_IO.Editing is
when '*' =>
Answer (J) := Fill_Character;
- when 'Z' | 'b' | '/' | '0' =>
+ when 'b' | '/' =>
+ if In_Currency and then Currency_Pos > 0 then
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos - 1;
+ else
+ Answer (J) := ' ';
+ end if;
+
+ when 'Z' | '0' =>
Answer (J) := ' ';
when '9' =>
@@ -489,7 +498,7 @@ package body Ada.Text_IO.Editing is
end loop;
if Pic.Floater = '#' and then Currency_Pos /= 0 then
- raise Layout_Error;
+ raise Ada.Text_IO.Layout_Error;
end if;
end if;
@@ -497,7 +506,7 @@ package body Ada.Text_IO.Editing is
if Sign_Position = Invalid_Position then
if Attrs.Negative then
- raise Layout_Error;
+ raise Ada.Text_IO.Layout_Error;
end if;
else
@@ -604,7 +613,7 @@ package body Ada.Text_IO.Editing is
else
if Pic.Floater = '#' and then Currency_Pos /= 0 then
- raise Layout_Error;
+ raise Ada.Text_IO.Layout_Error;
end if;
-- No trailing digits, but now J may need to stick in a currency
@@ -624,29 +633,37 @@ package body Ada.Text_IO.Editing is
Currency_Pos := 1;
end if;
- -- Note: There are some weird cases J can imagine with 'b' or '#'
- -- in currency strings where the following code will cause
- -- glitches. The trick is to tell when the character in the
- -- answer should be checked, and when to look at the original
- -- string. Some other time. RIE 11/26/96 ???
-
case Answer (J) is
when '*' =>
Answer (J) := Fill_Character;
when 'b' =>
- Answer (J) := ' ';
+ if In_Currency then
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos + 1;
+
+ if Currency_Pos > Currency_Symbol'Length then
+ In_Currency := False;
+ end if;
+ end if;
when '#' =>
if Currency_Pos > Currency_Symbol'Length then
Answer (J) := ' ';
else
+ In_Currency := True;
Answer (J) := Currency_Symbol (Currency_Pos);
Currency_Pos := Currency_Pos + 1;
+
+ if Currency_Pos > Currency_Symbol'Length then
+ In_Currency := False;
+ end if;
end if;
when '_' =>
+ Answer (J) := Currency_Symbol (Currency_Pos);
+ Currency_Pos := Currency_Pos + 1;
case Pic.Floater is
@@ -692,7 +709,7 @@ package body Ada.Text_IO.Editing is
Last := Last - 1;
end if;
- return String' (1 .. Last => ' ');
+ return String'(1 .. Last => ' ');
elsif Zero and Pic.Star_Fill then
Last := Answer'Last;
@@ -708,9 +725,9 @@ package body Ada.Text_IO.Editing is
elsif Dollar then
if Pic.Radix_Position > Pic.Start_Currency then
- return String' (1 .. Pic.Radix_Position - 1 => '*') &
+ return String'(1 .. Pic.Radix_Position - 1 => '*') &
Radix_Point &
- String' (Pic.Radix_Position + 1 .. Last => '*');
+ String'(Pic.Radix_Position + 1 .. Last => '*');
else
return
@@ -724,13 +741,13 @@ package body Ada.Text_IO.Editing is
end if;
else
- return String' (1 .. Pic.Radix_Position - 1 => '*') &
+ return String'(1 .. Pic.Radix_Position - 1 => '*') &
Radix_Point &
- String' (Pic.Radix_Position + 1 .. Last => '*');
+ String'(Pic.Radix_Position + 1 .. Last => '*');
end if;
end if;
- return String' (1 .. Last => '*');
+ return String'(1 .. Last => '*');
end if;
-- This was once a simple return statement, now there are nine
@@ -739,7 +756,7 @@ package body Ada.Text_IO.Editing is
-- Processing the radix and sign expansion separately
-- would require lots of copying--the string and some of its
- -- indices--without really simplifying the logic. The cases are:
+ -- indicies--without really simplifying the logic. The cases are:
-- 1) Expand $, replace '.' with Radix_Point
-- 2) No currency expansion, replace '.' with Radix_Point
@@ -823,7 +840,6 @@ package body Ada.Text_IO.Editing is
return Answer;
end if;
-
end Format_Number;
-------------------------
@@ -904,7 +920,6 @@ package body Ada.Text_IO.Editing is
-- No significant (intger) digits needs a null range.
return Answer;
-
end Parse_Number_String;
----------------
@@ -930,11 +945,13 @@ package body Ada.Text_IO.Editing is
------------------
procedure Precalculate (Pic : in out Format_Record) is
+ Debug : constant Boolean := False;
+ -- Set True to generate debug output
Computed_BWZ : Boolean := True;
- Debug : Boolean := False;
type Legality is (Okay, Reject);
+
State : Legality := Reject;
-- Start in reject, which will reject null strings.
@@ -984,6 +1001,7 @@ package body Ada.Text_IO.Editing is
procedure Number;
procedure Optional_RHS_Sign;
procedure Picture_String;
+ procedure Set_Debug;
------------
-- At_End --
@@ -991,9 +1009,25 @@ package body Ada.Text_IO.Editing is
function At_End return Boolean is
begin
+ Debug_Start ("At_End");
return Index > Pic.Picture.Length;
end At_End;
+ --------------
+ -- Set_Debug--
+ --------------
+
+ -- Needed to have a procedure to pass to pragma Debug
+
+ procedure Set_Debug is
+ begin
+ -- Uncomment this line and make Debug a variable to enable debug
+
+ -- Debug := True;
+
+ null;
+ end Set_Debug;
+
-------------------
-- Debug_Integer --
-------------------
@@ -1032,7 +1066,16 @@ package body Ada.Text_IO.Editing is
procedure Floating_Bracket is
begin
Debug_Start ("Floating_Bracket");
- Pic.Floater := '<';
+
+ -- Two different floats not allowed.
+
+ if Pic.Floater /= '!' and then Pic.Floater /= '<' then
+ raise Picture_Error;
+
+ else
+ Pic.Floater := '<';
+ end if;
+
Pic.End_Float := Index;
Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
@@ -1082,7 +1125,6 @@ package body Ada.Text_IO.Editing is
end loop;
end Floating_Bracket;
-
--------------------
-- Floating_Minus --
--------------------
@@ -1288,9 +1330,18 @@ package body Ada.Text_IO.Editing is
begin
Debug_Start ("Leading_Dollar");
- -- Treat as a floating dollar, and unwind otherwise.
+ -- Treat as a floating dollar, and unwind otherwise
+
+ if Pic.Floater /= '!' and then Pic.Floater /= '$' then
+
+ -- Two floats not allowed
+
+ raise Picture_Error;
+
+ else
+ Pic.Floater := '$';
+ end if;
- Pic.Floater := '$';
Pic.Start_Currency := Index;
Pic.End_Currency := Index;
Pic.Start_Float := Index;
@@ -1330,8 +1381,10 @@ package body Ada.Text_IO.Editing is
if State = Okay then
raise Picture_Error;
else
- -- Will overwrite Floater and Start_Float
+ -- Overwrite Floater and Start_Float
+ Pic.Floater := 'Z';
+ Pic.Start_Float := Index;
Zero_Suppression;
end if;
@@ -1339,8 +1392,9 @@ package body Ada.Text_IO.Editing is
if State = Okay then
raise Picture_Error;
else
- -- Will overwrite Floater and Start_Float
-
+ -- Overwrite Floater and Start_Float
+ Pic.Floater := '*';
+ Pic.Start_Float := Index;
Star_Suppression;
end if;
@@ -1413,7 +1467,15 @@ package body Ada.Text_IO.Editing is
-- Treat as a floating currency. If it isn't, this will be
-- overwritten later.
- Pic.Floater := '#';
+ if Pic.Floater /= '!' and then Pic.Floater /= '#' then
+
+ -- Two floats not allowed
+
+ raise Picture_Error;
+
+ else
+ Pic.Floater := '#';
+ end if;
Pic.Start_Currency := Index;
Pic.End_Currency := Index;
@@ -1453,8 +1515,10 @@ package body Ada.Text_IO.Editing is
else
Pic.Max_Leading_Digits := 0;
- -- Will overwrite Floater and Start_Float
+ -- Overwrite Floater and Start_Float
+ Pic.Floater := 'Z';
+ Pic.Start_Float := Index;
Zero_Suppression;
end if;
@@ -1464,8 +1528,9 @@ package body Ada.Text_IO.Editing is
else
Pic.Max_Leading_Digits := 0;
- -- Will overwrite Floater and Start_Float
-
+ -- Overwrite Floater and Start_Float
+ Pic.Floater := '*';
+ Pic.Start_Float := Index;
Star_Suppression;
end if;
@@ -2284,6 +2349,11 @@ package body Ada.Text_IO.Editing is
Set_State (Okay);
+ -- Overwrite Floater and Start_Float
+
+ Pic.Floater := 'Z';
+ Pic.Start_Float := Index;
+
Zero_Suppression;
Trailing_Currency;
Optional_RHS_Sign;
@@ -2406,7 +2476,17 @@ package body Ada.Text_IO.Editing is
procedure Star_Suppression is
begin
Debug_Start ("Star_Suppression");
- Pic.Floater := '*';
+
+ if Pic.Floater /= '!' and then Pic.Floater /= '*' then
+
+ -- Two floats not allowed
+
+ raise Picture_Error;
+
+ else
+ Pic.Floater := '*';
+ end if;
+
Pic.Start_Float := Index;
Pic.End_Float := Index;
Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
@@ -2450,6 +2530,12 @@ package body Ada.Text_IO.Editing is
return;
when '#' | '$' =>
+ if Pic.Max_Currency_Digits > 0 then
+ raise Picture_Error;
+ end if;
+
+ -- Cannot have leading and trailing currency
+
Trailing_Currency;
Set_State (Okay);
return;
@@ -2587,6 +2673,8 @@ package body Ada.Text_IO.Editing is
-- Start of processing for Precalculate
begin
+ pragma Debug (Set_Debug);
+
Picture_String;
if Debug then
@@ -2621,7 +2709,6 @@ package body Ada.Text_IO.Editing is
-- To deal with special cases like null strings.
raise Picture_Error;
-
end Precalculate;
----------------
@@ -2650,7 +2737,6 @@ package body Ada.Text_IO.Editing is
exception
when others =>
raise Picture_Error;
-
end To_Picture;
-----------
@@ -2675,7 +2761,7 @@ package body Ada.Text_IO.Editing is
Format_Rec.Original_BWZ := Blank_When_Zero;
Precalculate (Format_Rec);
- -- False only if Blank_When_0 is True but the pic string has a '*'
+ -- False only if Blank_When_Zero is True but the pic string has a '*'
return not Blank_When_Zero or
Strings_Fixed.Index (Expanded_Pic, "*") = 0;
@@ -2683,7 +2769,6 @@ package body Ada.Text_IO.Editing is
exception
when others => return False;
-
end Valid;
--------------------
@@ -2790,7 +2875,7 @@ package body Ada.Text_IO.Editing is
begin
if Result'Length > To'Length then
- raise Text_IO.Layout_Error;
+ raise Ada.Text_IO.Layout_Error;
else
Strings_Fixed.Move (Source => Result, Target => To,
Justify => Strings.Right);
@@ -2816,10 +2901,9 @@ package body Ada.Text_IO.Editing is
end;
exception
- when Layout_Error => return False;
+ when Ada.Text_IO.Layout_Error => return False;
end Valid;
-
end Decimal_Output;
end Ada.Text_IO.Editing;
diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb
index c133865c339..b61ebd3c80a 100644
--- a/gcc/ada/a-textio.adb
+++ b/gcc/ada/a-textio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -56,7 +56,7 @@ package body Ada.Text_IO is
-------------------
function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr is
- pragma Warnings (Off, Control_Block);
+ pragma Unreferenced (Control_Block);
begin
return new Text_AFCB;
@@ -136,11 +136,14 @@ package body Ada.Text_IO is
Name : in String := "";
Form : in String := "")
is
- File_Control_Block : Text_AFCB;
+ Dummy_File_Control_Block : Text_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => To_FCB (Mode),
Name => Name,
Form => Form,
@@ -338,6 +341,15 @@ package body Ada.Text_IO is
return End_Of_Page (Current_In);
end End_Of_Page;
+ --------------
+ -- EOF_Char --
+ --------------
+
+ function EOF_Char return Integer is
+ begin
+ return EOF;
+ end EOF_Char;
+
-----------
-- Flush --
-----------
@@ -481,7 +493,9 @@ package body Ada.Text_IO is
end_of_file : int;
procedure getc_immediate
- (stream : FILEs; ch : out int; end_of_file : out int);
+ (stream : FILEs;
+ ch : out int;
+ end_of_file : out int);
pragma Import (C, getc_immediate, "getc_immediate");
begin
@@ -503,7 +517,6 @@ package body Ada.Text_IO is
end if;
Item := Character'Val (ch);
-
end Get_Immediate;
procedure Get_Immediate
@@ -913,11 +926,14 @@ package body Ada.Text_IO is
Name : in String;
Form : in String := "")
is
- File_Control_Block : Text_AFCB;
+ Dummy_File_Control_Block : Text_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => To_FCB (Mode),
Name => Name,
Form => Form,
@@ -1046,6 +1062,9 @@ package body Ada.Text_IO is
(File : in File_Type;
Item : in String)
is
+ Ilen : Natural := Item'Length;
+ Istart : Natural := Item'First;
+
begin
FIO.Check_Write_Status (AP (File));
@@ -1065,13 +1084,25 @@ package body Ada.Text_IO is
-- tasking programs, since often the OS will treat the entire put
-- operation as an atomic operation.
+ -- We only do this if the message is 512 characters or less in length,
+ -- since otherwise Put_Line would use an unbounded amount of stack
+ -- space and could cause undetected stack overflow. If we have a
+ -- longer string, then output the first part separately to avoid this.
+
+ if Ilen > 512 then
+ FIO.Write_Buf (AP (File), Item'Address, size_t (Ilen - 512));
+ Istart := Istart + Ilen - 512;
+ Ilen := 512;
+ end if;
+
+ -- Now prepare the string with its terminator
+
declare
- Ilen : constant Natural := Item'Length;
Buffer : String (1 .. Ilen + 2);
Plen : size_t;
begin
- Buffer (1 .. Ilen) := Item;
+ Buffer (1 .. Ilen) := Item (Istart .. Item'Last);
Buffer (Ilen + 1) := Character'Val (LM);
if File.Page_Length /= 0
@@ -1121,7 +1152,8 @@ package body Ada.Text_IO is
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset)
is
- ch : int;
+ Discard_ch : int;
+ pragma Warnings (Off, Discard_ch);
begin
if File.Mode /= FCB.In_File then
@@ -1143,7 +1175,7 @@ package body Ada.Text_IO is
-- be expected if stream and text input are mixed this way?
if File.Before_LM_PM then
- ch := ungetc (PM, File.Stream);
+ Discard_ch := ungetc (PM, File.Stream);
File.Before_LM_PM := False;
end if;
diff --git a/gcc/ada/a-textio.ads b/gcc/ada/a-textio.ads
index 42c74ee065a..4f38370c77a 100644
--- a/gcc/ada/a-textio.ads
+++ b/gcc/ada/a-textio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -342,7 +342,7 @@ private
Self : aliased File_Type;
-- Set to point to the containing Text_AFCB block. This is used to
- -- implement the Current_{Error,Input,Output} functions which return
+ -- implement the Current_{Error,Input,Ouput} functions which return
-- a File_Access, the file access value returned is a pointer to
-- the Self field of the corresponding file.
@@ -411,6 +411,11 @@ private
-- this interfaces package with the spec of Ada.Text_IO, and we know that
-- in fact these types are identical
+ function EOF_Char return Integer;
+ -- Returns the system-specific character indicating the end of a text file.
+ -- This is exported for use by child packages such as Enumeration_Aux to
+ -- eliminate their needing to depend directly on Interfaces.C_Streams.
+
function Getc (File : File_Type) return Integer;
-- Gets next character from file, which has already been checked for
-- being in read status, and returns the character read if no error
diff --git a/gcc/ada/a-tienau.adb b/gcc/ada/a-tienau.adb
index f420f76b21c..3b529321438 100644
--- a/gcc/ada/a-tienau.adb
+++ b/gcc/ada/a-tienau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -33,23 +33,11 @@
with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Interfaces.C_Streams; use Interfaces.C_Streams;
-- Note: this package does not yet deal properly with wide characters ???
package body Ada.Text_IO.Enumeration_Aux is
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- -- These definitions replace the ones in Ada.Characters.Handling, which
- -- do not seem to work for some strange not understood reason ??? at
- -- least in the OS/2 version.
-
- function To_Lower (C : Character) return Character;
- function To_Upper (C : Character) return Character;
-
------------------
-- Get_Enum_Lit --
------------------
@@ -59,7 +47,7 @@ package body Ada.Text_IO.Enumeration_Aux is
Buf : out String;
Buflen : out Natural)
is
- ch : int;
+ ch : Integer;
C : Character;
begin
@@ -112,7 +100,7 @@ package body Ada.Text_IO.Enumeration_Aux is
Store_Char (File, Character'Pos (To_Upper (C)), Buf, Buflen);
ch := Getc (File);
- exit when ch = EOF;
+ exit when ch = EOF_Char;
C := Character'Val (ch);
exit when not Is_Letter (C)
@@ -238,7 +226,6 @@ package body Ada.Text_IO.Enumeration_Aux is
end if;
end if;
- Stop := Stop - 1;
raise Data_Error;
-- Similarly for identifiers, read as far as we can, in particular,
@@ -270,29 +257,6 @@ package body Ada.Text_IO.Enumeration_Aux is
Stop := Stop + 1;
end loop;
end if;
-
end Scan_Enum_Lit;
- --------------
- -- To_Lower --
- --------------
-
- function To_Lower (C : Character) return Character is
- begin
- if C in 'A' .. 'Z' then
- return Character'Val (Character'Pos (C) + 32);
- else
- return C;
- end if;
- end To_Lower;
-
- function To_Upper (C : Character) return Character is
- begin
- if C in 'a' .. 'z' then
- return Character'Val (Character'Pos (C) - 32);
- else
- return C;
- end if;
- end To_Upper;
-
end Ada.Text_IO.Enumeration_Aux;
diff --git a/gcc/ada/a-tifiio.adb b/gcc/ada/a-tifiio.adb
index a1b3badd96b..52f8e706458 100644
--- a/gcc/ada/a-tifiio.adb
+++ b/gcc/ada/a-tifiio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1999 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- --
@@ -31,19 +31,284 @@
-- --
------------------------------------------------------------------------------
+-- Fixed point I/O
+-- ---------------
+
+-- The following documents implementation details of the fixed point
+-- input/output routines in the GNAT run time. The first part describes
+-- general properties of fixed point types as defined by the Ada 95 standard,
+-- including the Information Systems Annex.
+
+-- Subsequently these are reduced to implementation constraints and the impact
+-- of these constraints on a few possible approaches to I/O are given.
+-- Based on this analysis, a specific implementation is selected for use in
+-- the GNAT run time. Finally, the chosen algorithm is analyzed numerically in
+-- order to provide user-level documentation on limits for range and precision
+-- of fixed point types as well as accuracy of input/output conversions.
+
+-- -------------------------------------------
+-- - General Properties of Fixed Point Types -
+-- -------------------------------------------
+
+-- Operations on fixed point values, other than input and output, are not
+-- important for the purposes of this document. Only the set of values that a
+-- fixed point type can represent and the input and output operations are
+-- significant.
+
+-- Values
+-- ------
+
+-- Set set of values of a fixed point type comprise the integral
+-- multiples of a number called the small of the type. The small can
+-- either be a power of ten, a power of two or (if the implementation
+-- allows) an arbitrary strictly positive real value.
+
+-- Implementations need to support fixed-point types with a precision
+-- of at least 24 bits, and (in order to comply with the Information
+-- Systems Annex) decimal types need to support at least digits 18.
+-- For the rest, however, no requirements exist for the minimal small
+-- and range that need to be supported.
+
+-- Operations
+-- ----------
+
+-- 'Image and 'Wide_Image (see RM 3.5(34))
+
+-- These attributes return a decimal real literal best approximating
+-- the value (rounded away from zero if halfway between) with a
+-- single leading character that is either a minus sign or a space,
+-- one or more digits before the decimal point (with no redundant
+-- leading zeros), a decimal point, and N digits after the decimal
+-- point. For a subtype S, the value of N is S'Aft, the smallest
+-- positive integer such that (10**N)*S'Delta is greater or equal to
+-- one, see RM 3.5.10(5).
+
+-- For an arbitrary small, this means large number arithmetic needs
+-- to be performed.
+
+-- Put (see RM A.10.9(22-26))
+
+-- The requirements for Put add no extra constraints over the image
+-- attributes, although it would be nice to be able to output more
+-- than S'Aft digits after the decimal point for values of subtype S.
+
+-- 'Value and 'Wide_Value attribute (RM 3.5(40-55))
+
+-- Since the input can be given in any base in the range 2..16,
+-- accurate conversion to a fixed point number may require
+-- arbitrary precision arithmetic if there is no limit on the
+-- magnitude of the small of the fixed point type.
+
+-- Get (see RM A.10.9(12-21))
+
+-- The requirements for Get are identical to those of the Value
+-- attribute.
+
+-- ------------------------------
+-- - Implementation Constraints -
+-- ------------------------------
+
+-- The requirements listed above for the input/output operations lead to
+-- significant complexity, if no constraints are put on supported smalls.
+
+-- Implementation Strategies
+-- -------------------------
+
+-- * Float arithmetic
+-- * Arbitrary-precision integer arithmetic
+-- * Fixed-precision integer arithmetic
+
+-- Although it seems convenient to convert fixed point numbers to floating-
+-- point and then print them, this leads to a number of restrictions.
+-- The first one is precision. The widest floating-point type generally
+-- available has 53 bits of mantissa. This means that Fine_Delta cannot
+-- be less than 2.0**(-53).
+
+-- In GNAT, Fine_Delta is 2.0**(-63), and Duration for example is a
+-- 64-bit type. It would still be possible to use multi-precision
+-- floating-point to perform calculations using longer mantissas,
+-- but this is a much harder approach.
+
+-- The base conversions needed for input and output of (non-decimal)
+-- fixed point types can be seen as pairs of integer multiplications
+-- and divisions.
+
+-- Arbitrary-precision integer arithmetic would be suitable for the job
+-- at hand, but has the draw-back that it is very heavy implementation-wise.
+-- Especially in embedded systems, where fixed point types are often used,
+-- it may not be desirable to require large amounts of storage and time
+-- for fixed I/O operations.
+
+-- Fixed-precision integer arithmetic has the advantage of simplicity and
+-- speed. For the most common fixed point types this would be a perfect
+-- solution. The downside however may be a too limited set of acceptable
+-- fixed point types.
+
+-- Extra Precision
+-- ---------------
+
+-- Using a scaled divide which truncates and returns a remainder R,
+-- another E trailing digits can be calculated by computing the value
+-- (R * (10.0**E)) / Z using another scaled divide. This procedure
+-- can be repeated to compute an arbitrary number of digits in linear
+-- time and storage. The last scaled divide should be rounded, with
+-- a possible carry propagating to the more significant digits, to
+-- ensure correct rounding of the unit in the last place.
+
+-- An extension of this technique is to limit the value of Q to 9 decimal
+-- digits, since 32-bit integers can be much more efficient than 64-bit
+-- integers to output.
+
+with Interfaces; use Interfaces;
+with System.Arith_64; use System.Arith_64;
+with System.Img_Real; use System.Img_Real;
+with Ada.Text_IO; use Ada.Text_IO;
with Ada.Text_IO.Float_Aux;
+with Ada.Text_IO.Generic_Aux;
package body Ada.Text_IO.Fixed_IO is
- -- Note: we use the floating-point I/O routines for input/output of
- -- ordinary fixed-point. This works fine for fixed-point declarations
- -- whose mantissa is no longer than the mantissa of Long_Long_Float,
- -- and we simply consider that we have only partial support for fixed-
- -- point types with larger mantissas (this situation will not arise on
- -- the x86, but it will rise on machines only supporting IEEE long).
+ -- Note: we still use the floating-point I/O routines for input of
+ -- ordinary fixed-point and output using exponent format. This will
+ -- result in inaccuracies for fixed point types with a small that is
+ -- not a power of two, and for types that require more precision than
+ -- is available in Long_Long_Float.
package Aux renames Ada.Text_IO.Float_Aux;
+ Extra_Layout_Space : constant Field := 5 + Num'Fore;
+ -- Extra space that may be needed for output of sign, decimal point,
+ -- exponent indication and mandatory decimals after and before the
+ -- decimal point. A string with length
+
+ -- Fore + Aft + Exp + Extra_Layout_Space
+
+ -- is always long enough for formatting any fixed point number.
+
+ -- Implementation of Put routines
+
+ -- The following section describes a specific implementation choice for
+ -- performing base conversions needed for output of values of a fixed
+ -- point type T with small T'Small. The goal is to be able to output
+ -- all values of types with a precision of 64 bits and a delta of at
+ -- least 2.0**(-63), as these are current GNAT limitations already.
+
+ -- The chosen algorithm uses fixed precision integer arithmetic for
+ -- reasons of simplicity and efficiency. It is important to understand
+ -- in what ways the most simple and accurate approach to fixed point I/O
+ -- is limiting, before considering more complicated schemes.
+
+ -- Without loss of generality assume T has a range (-2.0**63) * T'Small
+ -- .. (2.0**63 - 1) * T'Small, and is output with Aft digits after the
+ -- decimal point and T'Fore - 1 before. If T'Small is integer, or
+ -- 1.0 / T'Small is integer, let S = T'Small and E = 0. For other T'Small,
+ -- let S and E be integers such that S / 10**E best approximates T'Small
+ -- and S is in the range 10**17 .. 10**18 - 1. The extra decimal scaling
+ -- factor 10**E can be trivially handled during final output, by adjusting
+ -- the decimal point or exponent.
+
+ -- Convert a value X * S of type T to a 64-bit integer value Q equal
+ -- to 10.0**D * (X * S) rounded to the nearest integer.
+ -- This conversion is a scaled integer divide of the form
+
+ -- Q := (X * Y) / Z,
+
+ -- where all variables are 64-bit signed integers using 2's complement,
+ -- and both the multiplication and division are done using full
+ -- intermediate precision. The final decimal value to be output is
+
+ -- Q * 10**(E-D)
+
+ -- This value can be written to the output file or to the result string
+ -- according to the format described in RM A.3.10. The details of this
+ -- operation are omitted here.
+
+ -- A 64-bit value can contain all integers with 18 decimal digits, but
+ -- not all with 19 decimal digits. If the total number of requested output
+ -- digits (Fore - 1) + Aft is greater than 18, for purposes of the
+ -- conversion Aft is adjusted to 18 - (Fore - 1). In that case, or
+ -- when Fore > 19, trailing zeros can complete the output after writing
+ -- the first 18 significant digits, or the technique described in the
+ -- next section can be used.
+
+ -- The final expression for D is
+
+ -- D := Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1)));
+
+ -- For Y and Z the following expressions can be derived:
+
+ -- Q / (10.0**D) = X * S
+
+ -- Q = X * S * (10.0**D) = (X * Y) / Z
+
+ -- S * 10.0**D = Y / Z;
+
+ -- If S is an integer greater than or equal to one, then Fore must be at
+ -- least 20 in order to print T'First, which is at most -2.0**63.
+ -- This means D < 0, so use
+
+ -- (1) Y = -S and Z = -10**(-D).
+
+ -- If 1.0 / S is an integer greater than one, use
+
+ -- (2) Y = -10**D and Z = -(1.0 / S), for D >= 0
+
+ -- or
+
+ -- (3) Y = 1 and Z = (1.0 / S) * 10**(-D), for D < 0
+
+ -- Negative values are used for nominator Y and denominator Z, so that S
+ -- can have a maximum value of 2.0**63 and a minimum of 2.0**(-63).
+ -- For Z in -1 .. -9, Fore will still be 20, and D will be negative, as
+ -- (-2.0**63) / -9 is greater than 10**18. In these cases there is room
+ -- in the denominator for the extra decimal scaling required, so case (3)
+ -- will not overflow.
+
+ pragma Assert (System.Fine_Delta >= 2.0**(-63));
+ pragma Assert (Num'Small in 2.0**(-63) .. 2.0**63);
+ pragma Assert (Num'Fore <= 37);
+ -- These assertions need to be relaxed to allow for a Small of
+ -- 2.0**(-64) at least, since there is an ACATS test for this ???
+
+ Max_Digits : constant := 18;
+ -- Maximum number of decimal digits that can be represented in a
+ -- 64-bit signed number, see above
+
+ -- The constants E0 .. E5 implement a binary search for the appropriate
+ -- power of ten to scale the small so that it has one digit before the
+ -- decimal point.
+
+ subtype Int is Integer;
+ E0 : constant Int := -20 * Boolean'Pos (Num'Small >= 1.0E1);
+ E1 : constant Int := E0 + 10 * Boolean'Pos (Num'Small * 10.0**E0 < 1.0E-10);
+ E2 : constant Int := E1 + 5 * Boolean'Pos (Num'Small * 10.0**E1 < 1.0E-5);
+ E3 : constant Int := E2 + 3 * Boolean'Pos (Num'Small * 10.0**E2 < 1.0E-3);
+ E4 : constant Int := E3 + 2 * Boolean'Pos (Num'Small * 10.0**E3 < 1.0E-1);
+ E5 : constant Int := E4 + 1 * Boolean'Pos (Num'Small * 10.0**E4 < 1.0E-0);
+
+ Scale : constant Integer := E5;
+
+ pragma Assert (Num'Small * 10.0**Scale >= 1.0
+ and then Num'Small * 10.0**Scale < 10.0);
+
+ Exact : constant Boolean :=
+ Float'Floor (Num'Small) = Float'Ceiling (Num'Small)
+ or Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small)
+ or Num'Small >= 10.0**Max_Digits;
+ -- True iff a numerator and denominator can be calculated such that
+ -- their ratio exactly represents the small of Num
+
+ -- Local Subprograms
+
+ procedure Put
+ (To : out String;
+ Last : out Natural;
+ Item : Num;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field);
+ -- Actual output function, used internally by all other Put routines
+
---------
-- Get --
---------
@@ -100,8 +365,11 @@ package body Ada.Text_IO.Fixed_IO is
Aft : in Field := Default_Aft;
Exp : in Field := Default_Exp)
is
+ S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space);
+ Last : Natural;
begin
- Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp);
+ Put (S, Last, Item, Fore, Aft, Exp);
+ Generic_Aux.Put_Item (File, S (1 .. Last));
end Put;
procedure Put
@@ -110,8 +378,11 @@ package body Ada.Text_IO.Fixed_IO is
Aft : in Field := Default_Aft;
Exp : in Field := Default_Exp)
is
+ S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space);
+ Last : Natural;
begin
- Aux.Put (Current_Out, Long_Long_Float (Item), Fore, Aft, Exp);
+ Put (S, Last, Item, Fore, Aft, Exp);
+ Generic_Aux.Put_Item (Text_IO.Current_Out, S (1 .. Last));
end Put;
procedure Put
@@ -120,8 +391,272 @@ package body Ada.Text_IO.Fixed_IO is
Aft : in Field := Default_Aft;
Exp : in Field := Default_Exp)
is
+ Fore : constant Integer := To'Length
+ - 1 -- Decimal point
+ - Field'Max (1, Aft) -- Decimal part
+ - Boolean'Pos (Exp /= 0) -- Exponent indicator
+ - Exp; -- Exponent
+ Last : Natural;
+
begin
- Aux.Puts (To, Long_Long_Float (Item), Aft, Exp);
+ if Fore not in Field'Range then
+ raise Layout_Error;
+ end if;
+
+ Put (To, Last, Item, Fore, Aft, Exp);
+
+ if Last /= To'Last then
+ raise Layout_Error;
+ end if;
+ end Put;
+
+ procedure Put
+ (To : out String;
+ Last : out Natural;
+ Item : Num;
+ Fore : Field;
+ Aft : Field;
+ Exp : Field)
+ is
+ subtype Digit is Int64 range 0 .. 9;
+ X : constant Int64 := Int64'Integer_Value (Item);
+ A : constant Field := Field'Max (Aft, 1);
+ Neg : constant Boolean := (Item < 0.0);
+ Pos : Integer; -- Next digit X has value X * 10.0**Pos;
+
+ Y, Z : Int64;
+ E : constant Integer := Boolean'Pos (not Exact)
+ * (Max_Digits - 1 + Scale);
+ D : constant Integer := Boolean'Pos (Exact)
+ * Integer'Min (A, Max_Digits - (Num'Fore - 1))
+ + Boolean'Pos (not Exact)
+ * (Scale - 1);
+
+
+ procedure Put_Character (C : Character);
+ pragma Inline (Put_Character);
+ -- Add C to the output string To, updating Last
+
+ procedure Put_Digit (X : Digit);
+ -- Add digit X to the output string (going from left to right),
+ -- updating Last and Pos, and inserting the sign, leading zeroes
+ -- or a decimal point when necessary. After outputting the first
+ -- digit, Pos must not be changed outside Put_Digit anymore
+
+ procedure Put_Int64 (X : Int64; Scale : Integer);
+ -- Output the decimal number X * 10**Scale
+
+ procedure Put_Scaled
+ (X, Y, Z : Int64;
+ A : Field;
+ E : Integer);
+ -- Output the decimal number (X * Y / Z) * 10**E, producing A digits
+ -- after the decimal point and rounding the final digit. The value
+ -- X * Y / Z is computed with full precision, but must be in the
+ -- range of Int64.
+
+ -------------------
+ -- Put_Character --
+ -------------------
+
+ procedure Put_Character (C : Character) is
+ begin
+ Last := Last + 1;
+ To (Last) := C;
+ end Put_Character;
+
+ ---------------
+ -- Put_Digit --
+ ---------------
+
+ procedure Put_Digit (X : Digit) is
+ Digs : constant array (Digit) of Character := "0123456789";
+ begin
+ if Last = 0 then
+ if X /= 0 or Pos <= 0 then
+ -- Before outputting first digit, include leading space,
+ -- posible minus sign and, if the first digit is fractional,
+ -- decimal seperator and leading zeros.
+
+ -- The Fore part has Pos + 1 + Boolean'Pos (Neg) characters,
+ -- if Pos >= 0 and otherwise has a single zero digit plus minus
+ -- sign if negative. Add leading space if necessary.
+
+ for J in Integer'Max (0, Pos) + 2 + Boolean'Pos (Neg) .. Fore
+ loop
+ Put_Character (' ');
+ end loop;
+
+ -- Output minus sign, if number is negative
+
+ if Neg then
+ Put_Character ('-');
+ end if;
+
+ -- If starting with fractional digit, output leading zeros
+
+ if Pos < 0 then
+ Put_Character ('0');
+ Put_Character ('.');
+
+ for J in Pos .. -2 loop
+ Put_Character ('0');
+ end loop;
+ end if;
+
+ Put_Character (Digs (X));
+ end if;
+
+ else
+ -- This is not the first digit to be output, so the only
+ -- special handling is that for the decimal point
+
+ if Pos = -1 then
+ Put_Character ('.');
+ end if;
+
+ Put_Character (Digs (X));
+ end if;
+
+ Pos := Pos - 1;
+ end Put_Digit;
+
+ ---------------
+ -- Put_Int64 --
+ ---------------
+
+ procedure Put_Int64 (X : Int64; Scale : Integer) is
+ begin
+ if X = 0 then
+ return;
+ end if;
+
+ Pos := Scale;
+
+ if X not in -9 .. 9 then
+ Put_Int64 (X / 10, Scale + 1);
+ end if;
+
+ Put_Digit (abs (X rem 10));
+ end Put_Int64;
+
+ ----------------
+ -- Put_Scaled --
+ ----------------
+
+ procedure Put_Scaled
+ (X, Y, Z : Int64;
+ A : Field;
+ E : Integer)
+ is
+ N : constant Natural := (A + Max_Digits - 1) / Max_Digits + 1;
+ pragma Debug (Put_Line ("N =" & N'Img));
+ Q : array (1 .. N) of Int64 := (others => 0);
+
+ XX : Int64 := X;
+ YY : Int64 := Y;
+ AA : Field := A;
+
+ begin
+ for J in Q'Range loop
+ exit when XX = 0;
+
+ Scaled_Divide (XX, YY, Z, Q (J), XX, Round => AA = 0);
+
+ -- As the last block of digits is rounded, a carry may have to
+ -- be propagated to the more significant digits. Since the last
+ -- block may have less than Max_Digits, the test for this block
+ -- is specialized.
+
+ -- The absolute value of the left-most digit block may equal
+ -- 10*Max_Digits, as no carry can be propagated from there.
+ -- The final output routines need to be prepared to handle
+ -- this specific case.
+
+ if (Q (J) = YY or -Q (J) = YY) and then J > Q'First then
+ if Q (J) < 0 then
+ Q (J - 1) := Q (J - 1) + 1;
+ else
+ Q (J - 1) := Q (J - 1) - 1;
+ end if;
+
+ Q (J) := 0;
+
+ Propagate_Carry :
+ for J in reverse Q'First + 1 .. Q'Last loop
+ if Q (J) >= 10**Max_Digits then
+ Q (J - 1) := Q (J - 1) + 1;
+ Q (J) := Q (J) - 10**Max_Digits;
+
+ elsif Q (J) <= -10**Max_Digits then
+ Q (J - 1) := Q (J - 1) - 1;
+ Q (J) := Q (J) + 10**Max_Digits;
+ end if;
+ end loop Propagate_Carry;
+ end if;
+
+ YY := -10**Integer'Min (Max_Digits, AA);
+ AA := AA - Integer'Min (Max_Digits, AA);
+ end loop;
+
+ for J in Q'First .. Q'Last - 1 loop
+ Put_Int64 (Q (J), E - (J - Q'First) * Max_Digits);
+ end loop;
+
+ Put_Int64 (Q (Q'Last), E - A);
+ end Put_Scaled;
+
+ -- Start of processing for Put
+
+ begin
+ Last := To'First - 1;
+
+ if Exp /= 0 then
+
+ -- With the Exp format, it is not known how many output digits to
+ -- generate, as leading zeros must be ignored. Computing too many
+ -- digits and then truncating the output will not give the closest
+ -- output, it is necessary to round at the correct digit.
+
+ -- The general approach is as follows: as long as no digits have
+ -- been generated, compute the Aft next digits (without rounding).
+ -- Once a non-zero digit is generated, determine the exact number
+ -- of digits remaining and compute them with rounding.
+ -- Since a large number of iterations might be necessary in case
+ -- of Aft = 1, the following optimization would be desirable.
+ -- Count the number Z of leading zero bits in the integer
+ -- representation of X, and start with producing
+ -- Aft + Z * 1000 / 3322 digits in the first scaled division.
+
+ -- However, the floating-point routines are still used now ???
+
+ System.Img_Real.Set_Image_Real (Long_Long_Float (Item), To, Last,
+ Fore, Aft, Exp);
+ return;
+ end if;
+
+ if Exact then
+ Y := Int64'Min (Int64 (-Num'Small), -1) * 10**Integer'Max (0, D);
+ Z := Int64'Min (Int64 (-1.0 / Num'Small), -1)
+ * 10**Integer'Max (0, -D);
+ else
+ Y := Int64 (-Num'Small * 10.0**E);
+ Z := -10**Max_Digits;
+ end if;
+
+ Put_Scaled (X, Y, Z, A - D, -D);
+
+ -- If only zero digits encountered, unit digit has not been output yet
+
+ if Last < To'First then
+ Pos := 0;
+ end if;
+
+ -- Always output digits up to the first one after the decimal point
+
+ while Pos >= -A loop
+ Put_Digit (0);
+ end loop;
end Put;
end Ada.Text_IO.Fixed_IO;
diff --git a/gcc/ada/a-tiflau.adb b/gcc/ada/a-tiflau.adb
index 7953fef4b27..bfe6cb28639 100644
--- a/gcc/ada/a-tiflau.adb
+++ b/gcc/ada/a-tiflau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -82,7 +82,6 @@ package body Ada.Text_IO.Float_Aux is
exception
when Constraint_Error =>
- Last := Pos - 1;
raise Data_Error;
end Gets;
diff --git a/gcc/ada/a-tiflio.adb b/gcc/ada/a-tiflio.adb
index f528c1f060d..e90478c7c19 100644
--- a/gcc/ada/a-tiflio.adb
+++ b/gcc/ada/a-tiflio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1999 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- --
@@ -51,6 +51,15 @@ package body Ada.Text_IO.Float_IO is
begin
Aux.Get (File, Long_Long_Float (Item), Width);
+ -- In the case where the type is unconstrained (e.g. Standard'Float),
+ -- the above conversion may result in an infinite value, which is
+ -- normally fine for a conversion, but in this case, we want to treat
+ -- that as a data error.
+
+ if not Item'Valid then
+ raise Data_Error;
+ end if;
+
exception
when Constraint_Error => raise Data_Error;
end Get;
@@ -64,6 +73,15 @@ package body Ada.Text_IO.Float_IO is
begin
Aux.Get (Current_In, Long_Long_Float (Item), Width);
+ -- In the case where the type is unconstrained (e.g. Standard'Float),
+ -- the above conversion may result in an infinite value, which is
+ -- normally fine for a conversion, but in this case, we want to treat
+ -- that as a data error.
+
+ if not Item'Valid then
+ raise Data_Error;
+ end if;
+
exception
when Constraint_Error => raise Data_Error;
end Get;
@@ -78,6 +96,15 @@ package body Ada.Text_IO.Float_IO is
begin
Aux.Gets (From, Long_Long_Float (Item), Last);
+ -- In the case where the type is unconstrained (e.g. Standard'Float),
+ -- the above conversion may result in an infinite value, which is
+ -- normally fine for a conversion, but in this case, we want to treat
+ -- that as a data error.
+
+ if not Item'Valid then
+ raise Data_Error;
+ end if;
+
exception
when Constraint_Error => raise Data_Error;
end Get;
diff --git a/gcc/ada/a-tigeau.adb b/gcc/ada/a-tigeau.adb
index 527f12a8a84..0e4e43035ad 100644
--- a/gcc/ada/a-tigeau.adb
+++ b/gcc/ada/a-tigeau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -432,12 +432,11 @@ package body Ada.Text_IO.Generic_Aux is
begin
File.Col := File.Col + 1;
- if Ptr = Buf'Last then
- raise Data_Error;
- else
+ if Ptr < Buf'Last then
Ptr := Ptr + 1;
- Buf (Ptr) := Character'Val (ch);
end if;
+
+ Buf (Ptr) := Character'Val (ch);
end Store_Char;
-----------------
diff --git a/gcc/ada/a-tigeau.ads b/gcc/ada/a-tigeau.ads
index 2f73ee0735b..659553c794c 100644
--- a/gcc/ada/a-tigeau.ads
+++ b/gcc/ada/a-tigeau.ads
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -168,7 +168,12 @@ private package Ada.Text_IO.Generic_Aux is
Ptr : in out Integer);
-- Store a single character in buffer, checking for overflow and
-- adjusting the column number in the file to reflect the fact
- -- that a character has been acquired from the input stream.
+ -- that a character has been acquired from the input stream. If
+ -- the character will not fit in the buffer it is stored in the
+ -- last character position of the buffer and Ptr is unchanged.
+ -- No exception is raised in this case, it is the caller's job
+ -- to raise Data_Error if the buffer fills up, so typically the
+ -- caller will make the buffer one character longer than needed.
procedure String_Skip (Str : String; Ptr : out Integer);
-- Used in the Get from string procedures to skip leading blanks in the
diff --git a/gcc/ada/a-tiinau.adb b/gcc/ada/a-tiinau.adb
index c043570f14e..f9d7ce0052a 100644
--- a/gcc/ada/a-tiinau.adb
+++ b/gcc/ada/a-tiinau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -124,7 +124,6 @@ package body Ada.Text_IO.Integer_Aux is
exception
when Constraint_Error =>
- Last := Pos - 1;
raise Data_Error;
end Gets_Int;
@@ -146,7 +145,6 @@ package body Ada.Text_IO.Integer_Aux is
exception
when Constraint_Error =>
- Last := Pos - 1;
raise Data_Error;
end Gets_LLI;
diff --git a/gcc/ada/a-timoau.adb b/gcc/ada/a-timoau.adb
index 98725fd05d3..d147748fd3f 100644
--- a/gcc/ada/a-timoau.adb
+++ b/gcc/ada/a-timoau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -126,7 +126,6 @@ package body Ada.Text_IO.Modular_Aux is
exception
when Constraint_Error =>
- Last := Pos - 1;
raise Data_Error;
end Gets_LLU;
@@ -148,7 +147,6 @@ package body Ada.Text_IO.Modular_Aux is
exception
when Constraint_Error =>
- Last := Pos - 1;
raise Data_Error;
end Gets_Uns;
diff --git a/gcc/ada/a-tiocst.adb b/gcc/ada/a-tiocst.adb
index 79bbbeaf0e8..e8dd0b0b022 100644
--- a/gcc/ada/a-tiocst.adb
+++ b/gcc/ada/a-tiocst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -61,17 +61,21 @@ package body Ada.Text_IO.C_Streams is
procedure Open
(File : in out File_Type;
- Mode : in File_Mode;
- C_Stream : in FILEs;
- Form : in String := "")
+ Mode : File_Mode;
+ C_Stream : FILEs;
+ Form : String := "";
+ Name : String := "")
is
- File_Control_Block : Text_AFCB;
+ Dummy_File_Control_Block : Text_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => To_FCB (Mode),
- Name => "",
+ Name => Name,
Form => Form,
Amethod => 'T',
Creat => False,
diff --git a/gcc/ada/a-tiocst.ads b/gcc/ada/a-tiocst.ads
index c7dafd68a9e..282a5905c58 100644
--- a/gcc/ada/a-tiocst.ads
+++ b/gcc/ada/a-tiocst.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -46,9 +46,10 @@ package Ada.Text_IO.C_Streams is
procedure Open
(File : in out File_Type;
- Mode : in File_Mode;
- C_Stream : in ICS.FILEs;
- Form : in String := "");
+ Mode : File_Mode;
+ C_Stream : ICS.FILEs;
+ Form : String := "";
+ Name : String := "");
-- Create new file from existing stream
end Ada.Text_IO.C_Streams;
diff --git a/gcc/ada/a-witeio.adb b/gcc/ada/a-witeio.adb
index 4a986301971..50b1202796d 100644
--- a/gcc/ada/a-witeio.adb
+++ b/gcc/ada/a-witeio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -86,7 +86,7 @@ package body Ada.Wide_Text_IO is
(Control_Block : Wide_Text_AFCB)
return FCB.AFCB_Ptr
is
- pragma Warnings (Off, Control_Block);
+ pragma Unreferenced (Control_Block);
begin
return new Wide_Text_AFCB;
@@ -166,11 +166,14 @@ package body Ada.Wide_Text_IO is
Name : in String := "";
Form : in String := "")
is
- File_Control_Block : Wide_Text_AFCB;
+ Dummy_File_Control_Block : Wide_Text_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => To_FCB (Mode),
Name => Name,
Form => Form,
@@ -1007,11 +1010,14 @@ package body Ada.Wide_Text_IO is
Name : in String;
Form : in String := "")
is
- File_Control_Block : Wide_Text_AFCB;
+ Dummy_File_Control_Block : Wide_Text_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => To_FCB (Mode),
Name => Name,
Form => Form,
@@ -1144,7 +1150,8 @@ package body Ada.Wide_Text_IO is
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset)
is
- ch : int;
+ Discard_ch : int;
+ pragma Unreferenced (Discard_ch);
begin
-- Need to deal with Before_Wide_Character ???
@@ -1168,7 +1175,7 @@ package body Ada.Wide_Text_IO is
-- be expected if stream and text input are mixed this way?
if File.Before_LM_PM then
- ch := ungetc (PM, File.Stream);
+ Discard_ch := ungetc (PM, File.Stream);
File.Before_LM_PM := False;
end if;
diff --git a/gcc/ada/a-witeio.ads b/gcc/ada/a-witeio.ads
index dae0cbac71f..662f5976b79 100644
--- a/gcc/ada/a-witeio.ads
+++ b/gcc/ada/a-witeio.ads
@@ -140,7 +140,7 @@ package Ada.Wide_Text_IO is
-- Buffer control --
--------------------
- -- Note: The parameter file is in out in the RM, but as pointed out
+ -- Note: The paramter file is in out in the RM, but as pointed out
-- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight.
procedure Flush (File : in File_Type);
diff --git a/gcc/ada/a-wtcstr.adb b/gcc/ada/a-wtcstr.adb
index ff463104c7d..c69b92ec896 100644
--- a/gcc/ada/a-wtcstr.adb
+++ b/gcc/ada/a-wtcstr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -61,17 +61,21 @@ package body Ada.Wide_Text_IO.C_Streams is
procedure Open
(File : in out File_Type;
- Mode : in File_Mode;
- C_Stream : in FILEs;
- Form : in String := "")
+ Mode : File_Mode;
+ C_Stream : FILEs;
+ Form : String := "";
+ Name : String := "")
is
- File_Control_Block : Wide_Text_AFCB;
+ Dummy_File_Control_Block : Wide_Text_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => To_FCB (Mode),
- Name => "",
+ Name => Name,
Form => Form,
Amethod => 'W',
Creat => False,
diff --git a/gcc/ada/a-wtcstr.ads b/gcc/ada/a-wtcstr.ads
index 0053eb5c75d..e1324bf2dc7 100644
--- a/gcc/ada/a-wtcstr.ads
+++ b/gcc/ada/a-wtcstr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -46,9 +46,10 @@ package Ada.Wide_Text_IO.C_Streams is
procedure Open
(File : in out File_Type;
- Mode : in File_Mode;
- C_Stream : in ICS.FILEs;
- Form : in String := "");
+ Mode : File_Mode;
+ C_Stream : ICS.FILEs;
+ Form : String := "";
+ Name : String := "");
-- Create new file from existing stream
end Ada.Wide_Text_IO.C_Streams;
diff --git a/gcc/ada/a-wtdeio.adb b/gcc/ada/a-wtdeio.adb
index e96791022b5..81e81524e73 100644
--- a/gcc/ada/a-wtdeio.adb
+++ b/gcc/ada/a-wtdeio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2000 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- --
@@ -138,6 +138,8 @@ package body Ada.Wide_Text_IO.Decimal_IO is
Aft : in Field := Default_Aft;
Exp : in Field := Default_Exp)
is
+ pragma Unreferenced (Fore);
+ -- ??? how come this is unreferenced, sounds wrong ???
begin
Put (Current_Output, Item, Aft, Exp);
end Put;
diff --git a/gcc/ada/a-wtedit.adb b/gcc/ada/a-wtedit.adb
index 78ce2360332..ab7e9643c1d 100644
--- a/gcc/ada/a-wtedit.adb
+++ b/gcc/ada/a-wtedit.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -896,9 +896,9 @@ package body Ada.Wide_Text_IO.Editing is
elsif Dollar then
if Pic.Radix_Position > Pic.Start_Currency then
- return Wide_String' (1 .. Pic.Radix_Position - 1 => '*') &
+ return Wide_String'(1 .. Pic.Radix_Position - 1 => '*') &
Radix_Point &
- Wide_String' (Pic.Radix_Position + 1 .. Last => '*');
+ Wide_String'(Pic.Radix_Position + 1 .. Last => '*');
else
return
@@ -920,7 +920,7 @@ package body Ada.Wide_Text_IO.Editing is
end if;
end if;
- return Wide_String' (1 .. Last => '*');
+ return Wide_String'(1 .. Last => '*');
end if;
-- This was once a simple return statement, now there are nine
@@ -929,7 +929,7 @@ package body Ada.Wide_Text_IO.Editing is
-- Processing the radix and sign expansion separately
-- would require lots of copying--the string and some of its
- -- indices--without really simplifying the logic. The cases are:
+ -- indicies--without really simplifying the logic. The cases are:
-- 1) Expand $, replace '.' with Radix_Point
-- 2) No currency expansion, replace '.' with Radix_Point
diff --git a/gcc/ada/a-wtenau.adb b/gcc/ada/a-wtenau.adb
index 4019f4c6156..b7346cc5f50 100644
--- a/gcc/ada/a-wtenau.adb
+++ b/gcc/ada/a-wtenau.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- --
@@ -135,8 +135,9 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is
null;
else
- exit when Is_Letter (Character'Val (ch))
- and then not Is_Digit (Character'Val (ch));
+ exit when not Is_Letter (Character'Val (ch))
+ and then
+ not Is_Digit (Character'Val (ch));
end if;
end loop;
end if;
@@ -279,7 +280,6 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is
end if;
end if;
- Stop := Stop - 1;
raise Data_Error;
-- Similarly for identifiers, read as far as we can, in particular,
diff --git a/gcc/ada/a-wtflau.adb b/gcc/ada/a-wtflau.adb
index c7c6741d1b9..c1da8cb4991 100644
--- a/gcc/ada/a-wtflau.adb
+++ b/gcc/ada/a-wtflau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -82,7 +82,6 @@ package body Ada.Wide_Text_IO.Float_Aux is
exception
when Constraint_Error =>
- Last := Pos - 1;
raise Data_Error;
end Gets;
diff --git a/gcc/ada/a-wtinau.adb b/gcc/ada/a-wtinau.adb
index 28618c87d65..66b5f210efc 100644
--- a/gcc/ada/a-wtinau.adb
+++ b/gcc/ada/a-wtinau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -124,9 +124,7 @@ package body Ada.Wide_Text_IO.Integer_Aux is
exception
when Constraint_Error =>
- Last := Pos - 1;
raise Data_Error;
-
end Gets_Int;
--------------
@@ -147,9 +145,7 @@ package body Ada.Wide_Text_IO.Integer_Aux is
exception
when Constraint_Error =>
- Last := Pos - 1;
raise Data_Error;
-
end Gets_LLI;
------------------
diff --git a/gcc/ada/a-wtmoau.adb b/gcc/ada/a-wtmoau.adb
index cdd48051b4e..e26d97a9604 100644
--- a/gcc/ada/a-wtmoau.adb
+++ b/gcc/ada/a-wtmoau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -126,9 +126,7 @@ package body Ada.Wide_Text_IO.Modular_Aux is
exception
when Constraint_Error =>
- Last := Pos - 1;
raise Data_Error;
-
end Gets_LLU;
--------------
@@ -149,9 +147,7 @@ package body Ada.Wide_Text_IO.Modular_Aux is
exception
when Constraint_Error =>
- Last := Pos - 1;
raise Data_Error;
-
end Gets_Uns;
------------------
diff --git a/gcc/ada/ada-tree.def b/gcc/ada/ada-tree.def
index b6172c037d7..9b3b1cdf9bd 100644
--- a/gcc/ada/ada-tree.def
+++ b/gcc/ada/ada-tree.def
@@ -6,8 +6,7 @@
* *
* Specification *
* *
- * *
- * Copyright (C) 1992-2001 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- *
diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c
index 864e9dc1141..44fd3357868 100644
--- a/gcc/ada/adaint.c
+++ b/gcc/ada/adaint.c
@@ -4,7 +4,6 @@
* *
* A D A I N T *
* *
- * *
* C Implementation File *
* *
* Copyright (C) 1992-2003, Free Software Foundation, Inc. *
@@ -54,6 +53,7 @@
#ifdef IN_RTS
#include "tconfig.h"
#include "tsystem.h"
+
#include <sys/stat.h>
#include <fcntl.h>
#include <time.h>
@@ -65,7 +65,23 @@
#include "config.h"
#include "system.h"
#endif
+
+#ifdef __MINGW32__
+#include "mingw32.h"
+#include <sys/utime.h>
+#else
+#ifndef VMS
+#include <utime.h>
+#endif
+#endif
+
+#ifdef __MINGW32__
+#if OLD_MINGW
#include <sys/wait.h>
+#endif
+#else
+#include <sys/wait.h>
+#endif
#if defined (__EMX__) || defined (MSDOS) || defined (_WIN32)
#elif defined (VMS)
@@ -98,7 +114,7 @@ struct dsc$descriptor_fib
/* I/O Status Block. */
struct IOSB
-{
+{
unsigned short status, count;
unsigned long devdep;
};
@@ -213,34 +229,56 @@ const int __gnat_vmsp = 1;
const int __gnat_vmsp = 0;
#endif
-/* This variable is used to export the maximum length of a path name to
- Ada code. */
-
#ifdef __EMX__
-int __gnat_max_path_len = _MAX_PATH;
+#define GNAT_MAX_PATH_LEN MAX_PATH
#elif defined (VMS)
-int __gnat_max_path_len = 4096; /* PATH_MAX */
+#define GNAT_MAX_PATH_LEN 256 /* PATH_MAX */
#elif defined (__vxworks) || defined (__OPENNT)
-int __gnat_max_path_len = PATH_MAX;
+#define GNAT_MAX_PATH_LEN PATH_MAX
+
+#else
+
+#if defined (__MINGW32__)
+#include "mingw32.h"
+
+#if OLD_MINGW
+#include <sys/param.h>
+#endif
#else
#include <sys/param.h>
-int __gnat_max_path_len = MAXPATHLEN;
+#endif
+
+#define GNAT_MAX_PATH_LEN MAXPATHLEN
#endif
+/* The __gnat_max_path_len variable is used to export the maximum
+ length of a path name to Ada code. max_path_len is also provided
+ for compatibility with older GNAT versions, please do not use
+ it. */
+
+int __gnat_max_path_len = GNAT_MAX_PATH_LEN;
+int max_path_len = GNAT_MAX_PATH_LEN;
+
/* The following macro HAVE_READDIR_R should be defined if the
system provides the routine readdir_r. */
#undef HAVE_READDIR_R
void
-__gnat_to_gm_time (p_time, p_year, p_month, p_day, p_hours, p_mins, p_secs)
- int *p_time, *p_year, *p_month, *p_day, *p_hours, *p_mins, *p_secs;
+__gnat_to_gm_time
+ (OS_Time *p_time,
+ int *p_year,
+ int *p_month,
+ int *p_day,
+ int *p_hours,
+ int *p_mins,
+ int *p_secs)
{
struct tm *res;
- time_t time = *p_time;
+ time_t time = (time_t) *p_time;
#ifdef _WIN32
/* On Windows systems, the time is sometimes rounded up to the nearest
@@ -249,7 +287,11 @@ __gnat_to_gm_time (p_time, p_year, p_month, p_day, p_hours, p_mins, p_secs)
time++;
#endif
+#ifdef VMS
+ res = localtime (&time);
+#else
res = gmtime (&time);
+#endif
if (res)
{
@@ -269,11 +311,8 @@ __gnat_to_gm_time (p_time, p_year, p_month, p_day, p_hours, p_mins, p_secs)
of characters of its content in BUF. Otherwise, return -1. For Windows,
OS/2 and vxworks, always return -1. */
-int
-__gnat_readlink (path, buf, bufsiz)
- char *path;
- char *buf;
- size_t bufsiz;
+int
+__gnat_readlink (char *path, char *buf, size_t bufsiz)
{
#if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
return -1;
@@ -291,9 +330,7 @@ __gnat_readlink (path, buf, bufsiz)
Interix and VMS, always return -1. */
int
-__gnat_symlink (oldpath, newpath)
- char *oldpath;
- char *newpath;
+__gnat_symlink (char *oldpath, char *newpath)
{
#if defined (MSDOS) || defined (_WIN32) || defined (__EMX__)
return -1;
@@ -313,9 +350,7 @@ __gnat_symlink (oldpath, newpath)
/* Version that does not use link. */
int
-__gnat_try_lock (dir, file)
- char *dir;
- char *file;
+__gnat_try_lock (char *dir, char *file)
{
char full_path[256];
int fd;
@@ -335,9 +370,7 @@ __gnat_try_lock (dir, file)
line problem ??? */
int
-__gnat_try_lock (dir, file)
- char *dir;
- char *file;
+__gnat_try_lock (char *dir, char *file)
{
char full_path[256];
int fd;
@@ -354,11 +387,10 @@ __gnat_try_lock (dir, file)
#else
/* Version using link(), more secure over NFS. */
+/* See TN 6913-016 for discussion ??? */
int
-__gnat_try_lock (dir, file)
- char *dir;
- char *file;
+__gnat_try_lock (char *dir, char *file)
{
char full_path[256];
char temp_file[256];
@@ -428,9 +460,7 @@ __gnat_get_default_identifier_character_set ()
/* Return the current working directory. */
void
-__gnat_get_current_dir (dir, length)
- char *dir;
- int *length;
+__gnat_get_current_dir (char *dir, int *length)
{
#ifdef VMS
/* Force Unix style, which is what GNAT uses internally. */
@@ -441,17 +471,18 @@ __gnat_get_current_dir (dir, length)
*length = strlen (dir);
- dir[*length] = DIR_SEPARATOR;
- ++*length;
+ if (dir [*length - 1] != DIR_SEPARATOR)
+ {
+ dir [*length] = DIR_SEPARATOR;
+ ++(*length);
+ }
dir[*length] = '\0';
}
/* Return the suffix for object files. */
void
-__gnat_get_object_suffix_ptr (len, value)
- int *len;
- const char **value;
+__gnat_get_object_suffix_ptr (int *len, const char **value)
{
*value = HOST_OBJECT_SUFFIX;
@@ -466,9 +497,7 @@ __gnat_get_object_suffix_ptr (len, value)
/* Return the suffix for executable files. */
void
-__gnat_get_executable_suffix_ptr (len, value)
- int *len;
- const char **value;
+__gnat_get_executable_suffix_ptr (int *len, const char **value)
{
*value = HOST_EXECUTABLE_SUFFIX;
if (!*value)
@@ -483,9 +512,7 @@ __gnat_get_executable_suffix_ptr (len, value)
executable extension. */
void
-__gnat_get_debuggable_suffix_ptr (len, value)
- int *len;
- const char **value;
+__gnat_get_debuggable_suffix_ptr (int *len, const char **value)
{
#ifndef MSDOS
*value = HOST_EXECUTABLE_SUFFIX;
@@ -503,9 +530,7 @@ __gnat_get_debuggable_suffix_ptr (len, value)
}
int
-__gnat_open_read (path, fmode)
- char *path;
- int fmode;
+__gnat_open_read (char *path, int fmode)
{
int fd;
int o_fmode = O_BINARY;
@@ -526,16 +551,23 @@ __gnat_open_read (path, fmode)
return fd < 0 ? -1 : fd;
}
-#if defined (__EMX__)
+#if defined (__EMX__) || defined (__MINGW32__)
#define PERM (S_IREAD | S_IWRITE)
+#elif defined (VMS)
+/* Excerpt from DECC C RTL Reference Manual:
+ To create files with OpenVMS RMS default protections using the UNIX
+ system-call functions umask, mkdir, creat, and open, call mkdir, creat,
+ and open with a file-protection mode argument of 0777 in a program
+ that never specifically calls umask. These default protections include
+ correctly establishing protections based on ACLs, previous versions of
+ files, and so on. */
+#define PERM 0777
#else
#define PERM (S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH)
#endif
int
-__gnat_open_rw (path, fmode)
- char *path;
- int fmode;
+__gnat_open_rw (char *path, int fmode)
{
int fd;
int o_fmode = O_BINARY;
@@ -554,9 +586,7 @@ __gnat_open_rw (path, fmode)
}
int
-__gnat_open_create (path, fmode)
- char *path;
- int fmode;
+__gnat_open_create (char *path, int fmode)
{
int fd;
int o_fmode = O_BINARY;
@@ -575,9 +605,7 @@ __gnat_open_create (path, fmode)
}
int
-__gnat_open_append (path, fmode)
- char *path;
- int fmode;
+__gnat_open_append (char *path, int fmode)
{
int fd;
int o_fmode = O_BINARY;
@@ -598,9 +626,7 @@ __gnat_open_append (path, fmode)
/* Open a new file. Return error (-1) if the file already exists. */
int
-__gnat_open_new (path, fmode)
- char *path;
- int fmode;
+__gnat_open_new (char *path, int fmode)
{
int fd;
int o_fmode = O_BINARY;
@@ -623,9 +649,7 @@ __gnat_open_new (path, fmode)
processes, however they really slow down output. Used in gnatchop. */
int
-__gnat_open_new_temp (path, fmode)
- char *path;
- int fmode;
+__gnat_open_new_temp (char *path, int fmode)
{
int fd;
int o_fmode = O_BINARY;
@@ -658,8 +682,7 @@ __gnat_open_new_temp (path, fmode)
/* Return the number of bytes in the specified file. */
long
-__gnat_file_length (fd)
- int fd;
+__gnat_file_length (int fd)
{
int ret;
struct stat statbuf;
@@ -675,8 +698,7 @@ __gnat_file_length (fd)
TMP_FILENAME. */
void
-__gnat_tmp_name (tmp_filename)
- char *tmp_filename;
+__gnat_tmp_name (char *tmp_filename)
{
#ifdef __MINGW32__
{
@@ -689,10 +711,16 @@ __gnat_tmp_name (tmp_filename)
pname = (char *) tempnam ("c:\\temp", "gnat-");
+ /* if pname is NULL, the file was not created properly, the disk is full
+ or there is no more free temporary files */
+
+ if (pname == NULL)
+ *tmp_filename = '\0';
+
/* If pname start with a back slash and not path information it means that
the filename is valid for the current working directory. */
- if (pname[0] == '\\')
+ else if (pname[0] == '\\')
{
strcpy (tmp_filename, ".\\");
strcat (tmp_filename, pname+1);
@@ -704,12 +732,15 @@ __gnat_tmp_name (tmp_filename)
}
#elif defined (linux)
+#define MAX_SAFE_PATH 1000
char *tmpdir = getenv ("TMPDIR");
- if (tmpdir == NULL)
+ /* If tmpdir is longer than MAX_SAFE_PATH, revert to default value to avoid
+ a buffer overflow. */
+ if (tmpdir == NULL || strlen (tmpdir) > MAX_SAFE_PATH)
strcpy (tmp_filename, "/tmp/gnat-XXXXXX");
else
- sprintf (tmp_filename, "%.200s/gnat-XXXXXX", tmpdir);
+ sprintf (tmp_filename, "%s/gnat-XXXXXX", tmpdir);
close (mkstemp(tmp_filename));
#else
@@ -721,9 +752,7 @@ __gnat_tmp_name (tmp_filename)
in the buffer. */
char *
-__gnat_readdir (dirp, buffer)
- DIR *dirp;
- char* buffer;
+__gnat_readdir (DIR *dirp, char *buffer)
{
/* If possible, try to use the thread-safe version. */
#ifdef HAVE_READDIR_R
@@ -766,8 +795,7 @@ __gnat_readdir_is_thread_safe ()
stat structure. */
static time_t
-win32_filetime (h)
- HANDLE h;
+win32_filetime (HANDLE h)
{
BOOL res;
FILETIME t_create;
@@ -784,7 +812,7 @@ win32_filetime (h)
res = GetFileTime (h, &t_create, &t_access, &t_write);
- timestamp = (((long long) t_write.dwHighDateTime << 32)
+ timestamp = (((long long) t_write.dwHighDateTime << 32)
+ t_write.dwLowDateTime);
timestamp = timestamp / 10000000 - offset;
@@ -796,8 +824,7 @@ win32_filetime (h)
/* Return a GNAT time stamp given a file name. */
time_t
-__gnat_file_time_name (name)
- char *name;
+__gnat_file_time_name (char *name)
{
struct stat statbuf;
@@ -828,8 +855,7 @@ __gnat_file_time_name (name)
/* Return a GNAT time stamp given a file descriptor. */
time_t
-__gnat_file_time_fd (fd)
- int fd;
+__gnat_file_time_fd (int fd)
{
/* The following workaround code is due to the fact that under EMX and
DJGPP fstat attempts to convert time values to GMT rather than keep the
@@ -920,9 +946,7 @@ __gnat_file_time_fd (fd)
/* Set the file time stamp. */
void
-__gnat_set_file_time_name (name, time_stamp)
- char *name;
- time_t time_stamp;
+__gnat_set_file_time_name (char *name, time_t time_stamp)
{
#if defined (__EMX__) || defined (MSDOS) || defined (_WIN32) \
|| defined (__vxworks)
@@ -1051,18 +1075,14 @@ __gnat_set_file_time_name (name, time_stamp)
{
time_t t;
- struct tm *ts;
-
- ts = localtime (&time_stamp);
/* Set creation time to requested time. */
- unix_time_to_vms (time_stamp + ts->tm_gmtoff, newtime);
+ unix_time_to_vms (time_stamp, newtime);
t = time ((time_t) 0);
- ts = localtime (&t);
/* Set revision time to now in local time. */
- unix_time_to_vms (t + ts->tm_gmtoff, revtime);
+ unix_time_to_vms (t, revtime);
}
/* Reopen the file, modify the times and then close. */
@@ -1105,10 +1125,7 @@ __gnat_set_file_time_name (name, time_stamp)
}
void
-__gnat_get_env_value_ptr (name, len, value)
- char *name;
- int *len;
- char **value;
+__gnat_get_env_value_ptr (char *name, int *len, char **value)
{
*value = getenv (name);
if (!*value)
@@ -1123,7 +1140,7 @@ __gnat_get_env_value_ptr (name, len, value)
#ifdef VMS
-static char *to_host_path_spec PARAMS ((char *));
+static char *to_host_path_spec (char *);
struct descriptor_s
{
@@ -1141,9 +1158,7 @@ typedef struct _ile3
#endif
void
-__gnat_set_env_value (name, value)
- char *name;
- char *value;
+__gnat_set_env_value (char *name, char *value)
{
#ifdef MSDOS
@@ -1151,18 +1166,25 @@ __gnat_set_env_value (name, value)
struct descriptor_s name_desc;
/* Put in JOB table for now, so that the project stuff at least works. */
struct descriptor_s table_desc = {7, 0, "LNM$JOB"};
- char *host_pathspec = to_host_path_spec (value);
+ char *host_pathspec = value;
char *copy_pathspec;
int num_dirs_in_pathspec = 1;
char *ptr;
-
- if (*host_pathspec == 0)
- return;
+ long status;
name_desc.len = strlen (name);
name_desc.mbz = 0;
name_desc.adr = name;
+ if (*host_pathspec == 0)
+ /* deassign */
+ {
+ status = LIB$DELETE_LOGICAL (&name_desc, &table_desc);
+ /* no need to check status; if the logical name is not
+ defined, that's fine. */
+ return;
+ }
+
ptr = host_pathspec;
while (*ptr++)
if (*ptr == ',')
@@ -1280,9 +1302,7 @@ __gnat_get_libraries_from_registry ()
}
int
-__gnat_stat (name, statbuf)
- char *name;
- struct stat *statbuf;
+__gnat_stat (char *name, struct stat *statbuf)
{
#ifdef _WIN32
/* Under Windows the directory name for the stat function must not be
@@ -1311,17 +1331,15 @@ __gnat_stat (name, statbuf)
}
int
-__gnat_file_exists (name)
- char *name;
+__gnat_file_exists (char *name)
{
struct stat statbuf;
return !__gnat_stat (name, &statbuf);
}
-int
-__gnat_is_absolute_path (name)
- char *name;
+int
+__gnat_is_absolute_path (char *name)
{
return (*name == '/' || *name == DIR_SEPARATOR
#if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
@@ -1331,8 +1349,7 @@ __gnat_is_absolute_path (name)
}
int
-__gnat_is_regular_file (name)
- char *name;
+__gnat_is_regular_file (char *name)
{
int ret;
struct stat statbuf;
@@ -1342,8 +1359,7 @@ __gnat_is_regular_file (name)
}
int
-__gnat_is_directory (name)
- char *name;
+__gnat_is_directory (char *name)
{
int ret;
struct stat statbuf;
@@ -1353,8 +1369,19 @@ __gnat_is_directory (name)
}
int
-__gnat_is_writable_file (name)
- char *name;
+__gnat_is_readable_file (char *name)
+{
+ int ret;
+ int mode;
+ struct stat statbuf;
+
+ ret = __gnat_stat (name, &statbuf);
+ mode = statbuf.st_mode & S_IRUSR;
+ return (!ret && mode);
+}
+
+int
+__gnat_is_writable_file (char *name)
{
int ret;
int mode;
@@ -1365,6 +1392,52 @@ __gnat_is_writable_file (name)
return (!ret && mode);
}
+void
+__gnat_set_writable (char *name)
+{
+#ifndef __vxworks
+ struct stat statbuf;
+
+ if (stat (name, &statbuf) == 0)
+ {
+ statbuf.st_mode = statbuf.st_mode | S_IWUSR;
+ chmod (name, statbuf.st_mode);
+ }
+#endif
+}
+
+void
+__gnat_set_readonly (char *name)
+{
+#ifndef __vxworks
+ struct stat statbuf;
+
+ if (stat (name, &statbuf) == 0)
+ {
+ statbuf.st_mode = statbuf.st_mode & 07577;
+ chmod (name, statbuf.st_mode);
+ }
+#endif
+}
+
+int
+__gnat_is_symbolic_link (char *name)
+{
+#if defined (__vxworks)
+ return 0;
+
+#elif defined (_AIX) || defined (unix)
+ int ret;
+ struct stat statbuf;
+
+ ret = lstat (name, &statbuf);
+ return (!ret && S_ISLNK (statbuf.st_mode));
+
+#else
+ return 0;
+#endif
+}
+
#ifdef VMS
/* Defined in VMS header files. */
#define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
@@ -1379,8 +1452,7 @@ __gnat_is_writable_file (name)
#endif
int
-__gnat_portable_spawn (args)
- char *args[];
+__gnat_portable_spawn (char *args[])
{
int status = 0;
int finished;
@@ -1468,8 +1540,7 @@ static Process_List *PLIST = NULL;
static int plist_length = 0;
static void
-add_handle (h)
- HANDLE h;
+add_handle (HANDLE h)
{
Process_List *pl;
@@ -1487,8 +1558,7 @@ add_handle (h)
plist_leave();
}
-void remove_handle (h)
- HANDLE h;
+void remove_handle (HANDLE h)
{
Process_List *pl, *prev;
@@ -1521,9 +1591,7 @@ void remove_handle (h)
}
static int
-win32_no_block_spawn (command, args)
- char *command;
- char *args[];
+win32_no_block_spawn (char *command, char *args[])
{
BOOL result;
STARTUPINFO SI;
@@ -1586,8 +1654,7 @@ win32_no_block_spawn (command, args)
}
static int
-win32_wait (status)
- int *status;
+win32_wait (int *status)
{
DWORD exitcode;
HANDLE *hl;
@@ -1634,8 +1701,7 @@ win32_wait (status)
#endif
int
-__gnat_portable_no_block_spawn (args)
- char *args[];
+__gnat_portable_no_block_spawn (char *args[])
{
int pid = 0;
@@ -1669,7 +1735,7 @@ __gnat_portable_no_block_spawn (args)
if (execv (args[0], args) != 0)
#if defined (VMS)
return -1; /* execv is in parent context on VMS. */
-#else
+#else
_exit (1);
#endif
}
@@ -1680,8 +1746,7 @@ __gnat_portable_no_block_spawn (args)
}
int
-__gnat_portable_wait (process_status)
- int *process_status;
+__gnat_portable_wait (int *process_status)
{
int status = 0;
int pid = 0;
@@ -1707,8 +1772,7 @@ __gnat_portable_wait (process_status)
}
int
-__gnat_waitpid (pid)
- int pid;
+__gnat_waitpid (int pid)
{
int status = 0;
@@ -1725,8 +1789,7 @@ __gnat_waitpid (pid)
}
void
-__gnat_os_exit (status)
- int status;
+__gnat_os_exit (int status)
{
#ifdef VMS
/* Exit without changing 0 to 1. */
@@ -1739,26 +1802,29 @@ __gnat_os_exit (status)
/* Locate a regular file, give a Path value. */
char *
-__gnat_locate_regular_file (file_name, path_val)
- char *file_name;
- char *path_val;
+__gnat_locate_regular_file (char *file_name, char *path_val)
{
char *ptr;
+ int absolute = __gnat_is_absolute_path (file_name);
/* Handle absolute pathnames. */
+ if (absolute)
+ {
+ if (__gnat_is_regular_file (file_name))
+ return xstrdup (file_name);
+
+ return 0;
+ }
+
+ /* If file_name include directory separator(s), try it first as
+ a path name relative to the current directory */
for (ptr = file_name; *ptr && *ptr != '/' && *ptr != DIR_SEPARATOR; ptr++)
;
- if (*ptr != 0
-#if defined (__EMX__) || defined (MSDOS) || defined (WINNT)
- || isalpha (file_name[0]) && file_name[1] == ':'
-#endif
- )
+ if (*ptr != 0)
{
if (__gnat_is_regular_file (file_name))
return xstrdup (file_name);
-
- return 0;
}
if (path_val == 0)
@@ -1798,9 +1864,7 @@ __gnat_locate_regular_file (file_name, path_val)
instead. */
char *
-__gnat_locate_exec (exec_name, path_val)
- char *exec_name;
- char *path_val;
+__gnat_locate_exec (char *exec_name, char *path_val)
{
if (!strstr (exec_name, HOST_EXECUTABLE_SUFFIX))
{
@@ -1818,17 +1882,31 @@ __gnat_locate_exec (exec_name, path_val)
/* Locate an executable using the Systems default PATH. */
char *
-__gnat_locate_exec_on_path (exec_name)
- char *exec_name;
+__gnat_locate_exec_on_path (char *exec_name)
{
+ char *apath_val;
#ifdef VMS
char *path_val = "/VAXC$PATH";
#else
char *path_val = getenv ("PATH");
#endif
- char *apath_val = alloca (strlen (path_val) + 1);
+#ifdef _WIN32
+ /* In Win32 systems we expand the PATH as for XP environment
+ variables are not automatically expanded. */
+ int len = strlen (path_val) * 3;
+ char *expanded_path_val = alloca (len + 1);
+
+ DWORD res = ExpandEnvironmentStrings (path_val, expanded_path_val, len);
+
+ if (res != 0)
+ {
+ path_val = expanded_path_val;
+ }
+#endif
+ apath_val = alloca (strlen (path_val) + 1);
strcpy (apath_val, path_val);
+
return __gnat_locate_exec (exec_name, apath_val);
}
@@ -1837,32 +1915,33 @@ __gnat_locate_exec_on_path (exec_name)
/* These functions are used to translate to and from VMS and Unix syntax
file, directory and path specifications. */
+#define MAXPATH 256
#define MAXNAMES 256
#define NEW_CANONICAL_FILELIST_INCREMENT 64
-static char new_canonical_dirspec[255];
-static char new_canonical_filespec[255];
-static char new_canonical_pathspec[MAXNAMES*255];
+static char new_canonical_dirspec [MAXPATH];
+static char new_canonical_filespec [MAXPATH];
+static char new_canonical_pathspec [MAXNAMES*MAXPATH];
static unsigned new_canonical_filelist_index;
static unsigned new_canonical_filelist_in_use;
static unsigned new_canonical_filelist_allocated;
static char **new_canonical_filelist;
-static char new_host_pathspec[MAXNAMES*255];
-static char new_host_dirspec[255];
-static char new_host_filespec[255];
+static char new_host_pathspec [MAXNAMES*MAXPATH];
+static char new_host_dirspec [MAXPATH];
+static char new_host_filespec [MAXPATH];
/* Routine is called repeatedly by decc$from_vms via
- __gnat_to_canonical_file_list_init until it returns 0 or the expansion runs
- out. */
+ __gnat_to_canonical_file_list_init until it returns 0 or the expansion
+ runs out. */
static int
-wildcard_translate_unix (name)
- char *name;
+wildcard_translate_unix (char *name)
{
char *ver;
- char buff[256];
+ char buff [MAXPATH];
- strcpy (buff, name);
+ strncpy (buff, name, MAXPATH);
+ buff [MAXPATH - 1] = (char) 0;
ver = strrchr (buff, '.');
/* Chop off the version. */
@@ -1888,19 +1967,19 @@ wildcard_translate_unix (name)
one at a time (_next). If onlydirs set, only expand directory files. */
int
-__gnat_to_canonical_file_list_init (filespec, onlydirs)
- char *filespec;
- int onlydirs;
+__gnat_to_canonical_file_list_init (char *filespec, int onlydirs)
{
int len;
- char buff[256];
+ char buff [MAXPATH];
len = strlen (filespec);
- strcpy (buff, filespec);
+ strncpy (buff, filespec, MAXPATH);
+
+ /* Only look for directories */
+ if (onlydirs && !strstr (&buff [len-5], "*.dir"))
+ strncat (buff, "*.dir", MAXPATH);
- /* Only look for directories. */
- if (onlydirs && !strstr (&buff[len - 5], "*.dir"))
- strcat (buff, "*.dir");
+ buff [MAXPATH - 1] = (char) 0;
decc$from_vms (buff, wildcard_translate_unix, 1);
@@ -1953,9 +2032,7 @@ __gnat_to_canonical_file_list_free ()
slashes, in case it's a logical name. */
char *
-__gnat_to_canonical_dir_spec (dirspec, prefixflag)
- char *dirspec;
- int prefixflag;
+__gnat_to_canonical_dir_spec (char *dirspec, int prefixflag)
{
int len;
@@ -1965,16 +2042,28 @@ __gnat_to_canonical_dir_spec (dirspec, prefixflag)
char *dirspec1;
if (strchr (dirspec, ']') || strchr (dirspec, ':'))
- strcpy (new_canonical_dirspec, (char *) decc$translate_vms (dirspec));
+ {
+ strncpy (new_canonical_dirspec,
+ (char *) decc$translate_vms (dirspec),
+ MAXPATH);
+ }
else if (!strchr (dirspec, '/') && (dirspec1 = getenv (dirspec)) != 0)
- strcpy (new_canonical_dirspec, (char *) decc$translate_vms (dirspec1));
+ {
+ strncpy (new_canonical_dirspec,
+ (char *) decc$translate_vms (dirspec1),
+ MAXPATH);
+ }
else
- strcpy (new_canonical_dirspec, dirspec);
+ {
+ strncpy (new_canonical_dirspec, dirspec, MAXPATH);
+ }
}
len = strlen (new_canonical_dirspec);
- if (prefixflag && new_canonical_dirspec[len - 1] != '/')
- strcat (new_canonical_dirspec, "/");
+ if (prefixflag && new_canonical_dirspec [len-1] != '/')
+ strncat (new_canonical_dirspec, "/", MAXPATH);
+
+ new_canonical_dirspec [MAXPATH - 1] = (char) 0;
return new_canonical_dirspec;
@@ -1984,14 +2073,22 @@ __gnat_to_canonical_dir_spec (dirspec, prefixflag)
If no indicators of VMS syntax found, return input string. */
char *
-__gnat_to_canonical_file_spec (filespec)
- char *filespec;
+__gnat_to_canonical_file_spec (char *filespec)
{
- strcpy (new_canonical_filespec, "");
+ strncpy (new_canonical_filespec, "", MAXPATH);
+
if (strchr (filespec, ']') || strchr (filespec, ':'))
- strcpy (new_canonical_filespec, (char *) decc$translate_vms (filespec));
+ {
+ strncpy (new_canonical_filespec,
+ (char *) decc$translate_vms (filespec),
+ MAXPATH);
+ }
else
- strcpy (new_canonical_filespec, filespec);
+ {
+ strncpy (new_canonical_filespec, filespec, MAXPATH);
+ }
+
+ new_canonical_filespec [MAXPATH - 1] = (char) 0;
return new_canonical_filespec;
}
@@ -2000,10 +2097,9 @@ __gnat_to_canonical_file_spec (filespec)
If no indicators of VMS syntax found, return input string. */
char *
-__gnat_to_canonical_path_spec (pathspec)
- char *pathspec;
+__gnat_to_canonical_path_spec (char *pathspec)
{
- char *curr, *next, buff[256];
+ char *curr, *next, buff [MAXPATH];
if (pathspec == 0)
return pathspec;
@@ -2035,37 +2131,38 @@ __gnat_to_canonical_path_spec (pathspec)
char *next_dir;
next_dir = __gnat_to_canonical_file_list_next ();
- strcat (new_canonical_pathspec, next_dir);
+ strncat (new_canonical_pathspec, next_dir, MAXPATH);
/* Don't append the separator after the last expansion. */
if (i+1 < dirs)
- strcat (new_canonical_pathspec, ":");
+ strncat (new_canonical_pathspec, ":", MAXPATH);
}
__gnat_to_canonical_file_list_free ();
}
else
- strcat (new_canonical_pathspec,
- __gnat_to_canonical_dir_spec (buff, 0));
+ strncat (new_canonical_pathspec,
+ __gnat_to_canonical_dir_spec (buff, 0), MAXPATH);
if (*next == 0)
break;
- strcat (new_canonical_pathspec, ":");
+ strncat (new_canonical_pathspec, ":", MAXPATH);
curr = next + 1;
}
+ new_canonical_pathspec [MAXPATH - 1] = (char) 0;
+
return new_canonical_pathspec;
}
-static char filename_buff[256];
+static char filename_buff [MAXPATH];
static int
-translate_unix (name, type)
- char *name;
- int type;
+translate_unix (char *name, int type)
{
- strcpy (filename_buff, name);
+ strncpy (filename_buff, name, MAXPATH);
+ filename_buff [MAXPATH - 1] = (char) 0;
return 0;
}
@@ -2073,10 +2170,9 @@ translate_unix (name, type)
directories. */
static char *
-to_host_path_spec (pathspec)
- char *pathspec;
+to_host_path_spec (char *pathspec)
{
- char *curr, *next, buff[256];
+ char *curr, *next, buff [MAXPATH];
if (pathspec == 0)
return pathspec;
@@ -2097,13 +2193,15 @@ to_host_path_spec (pathspec)
strncpy (buff, curr, next - curr);
buff[next - curr] = 0;
- strcat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0));
+ strncat (new_host_pathspec, __gnat_to_host_dir_spec (buff, 0), MAXPATH);
if (*next == 0)
break;
- strcat (new_host_pathspec, ",");
+ strncat (new_host_pathspec, ",", MAXPATH);
curr = next + 1;
}
+ new_host_pathspec [MAXPATH - 1] = (char) 0;
+
return new_host_pathspec;
}
@@ -2113,13 +2211,12 @@ to_host_path_spec (pathspec)
string. */
char *
-__gnat_to_host_dir_spec (dirspec, prefixflag)
- char *dirspec;
- int prefixflag ATTRIBUTE_UNUSED;
+__gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
{
int len = strlen (dirspec);
- strcpy (new_host_dirspec, dirspec);
+ strncpy (new_host_dirspec, dirspec, MAXPATH);
+ new_host_dirspec [MAXPATH - 1] = (char) 0;
if (strchr (new_host_dirspec, ']') || strchr (new_host_dirspec, ':'))
return new_host_dirspec;
@@ -2131,28 +2228,31 @@ __gnat_to_host_dir_spec (dirspec, prefixflag)
}
decc$to_vms (new_host_dirspec, translate_unix, 1, 2);
- strcpy (new_host_dirspec, filename_buff);
+ strncpy (new_host_dirspec, filename_buff, MAXPATH);
+ new_host_dirspec [MAXPATH - 1] = (char) 0;
return new_host_dirspec;
-
}
/* Translate a Unix syntax file specification into VMS syntax.
If indicators of VMS syntax found, return input string. */
char *
-__gnat_to_host_file_spec (filespec)
- char *filespec;
+__gnat_to_host_file_spec (char *filespec)
{
- strcpy (new_host_filespec, "");
+ strncpy (new_host_filespec, "", MAXPATH);
if (strchr (filespec, ']') || strchr (filespec, ':'))
- strcpy (new_host_filespec, filespec);
+ {
+ strncpy (new_host_filespec, filespec, MAXPATH);
+ }
else
{
decc$to_vms (filespec, translate_unix, 1, 1);
- strcpy (new_host_filespec, filename_buff);
+ strncpy (new_host_filespec, filename_buff, MAXPATH);
}
+ new_host_filespec [MAXPATH - 1] = (char) 0;
+
return new_host_filespec;
}
@@ -2162,14 +2262,13 @@ __gnat_adjust_os_resource_limits ()
SYS$ADJWSL (131072, 0);
}
-#else
+#else /* VMS */
/* Dummy functions for Osint import for non-VMS systems. */
int
-__gnat_to_canonical_file_list_init (dirspec, onlydirs)
- char *dirspec ATTRIBUTE_UNUSED;
- int onlydirs ATTRIBUTE_UNUSED;
+__gnat_to_canonical_file_list_init
+ (char *dirspec ATTRIBUTE_UNUSED, int onlydirs ATTRIBUTE_UNUSED)
{
return 0;
}
@@ -2186,38 +2285,31 @@ __gnat_to_canonical_file_list_free ()
}
char *
-__gnat_to_canonical_dir_spec (dirspec, prefixflag)
- char *dirspec;
- int prefixflag ATTRIBUTE_UNUSED;
+__gnat_to_canonical_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
{
return dirspec;
}
char *
-__gnat_to_canonical_file_spec (filespec)
- char *filespec;
+__gnat_to_canonical_file_spec (char *filespec)
{
return filespec;
}
char *
-__gnat_to_canonical_path_spec (pathspec)
- char *pathspec;
+__gnat_to_canonical_path_spec (char *pathspec)
{
return pathspec;
}
char *
-__gnat_to_host_dir_spec (dirspec, prefixflag)
- char *dirspec;
- int prefixflag ATTRIBUTE_UNUSED;
+__gnat_to_host_dir_spec (char *dirspec, int prefixflag ATTRIBUTE_UNUSED)
{
return dirspec;
}
char *
-__gnat_to_host_file_spec (filespec)
- char *filespec;
+__gnat_to_host_file_spec (char *filespec)
{
return filespec;
}
@@ -2238,7 +2330,8 @@ void __dummy () {}
#endif
#if defined (__mips_vxworks)
-int _flush_cache()
+int
+_flush_cache()
{
CACHE_USER_FLUSH (0, ENTIRE_CACHE);
}
@@ -2246,21 +2339,21 @@ int _flush_cache()
#if defined (CROSS_COMPILE) \
|| (! (defined (sparc) && defined (sun) && defined (__SVR4)) \
- && ! defined (linux) \
+ && ! (defined (linux) && defined (i386)) \
&& ! defined (hpux) \
+ && ! defined (_AIX) \
&& ! (defined (__alpha__) && defined (__osf__)) \
&& ! defined (__MINGW32__))
/* Dummy function to satisfy g-trasym.o. Currently Solaris sparc, HP/UX,
- GNU/Linux, Tru64 & Windows provide a non-dummy version of this procedure in
- libaddr2line.a. */
+ GNU/Linux x86, Tru64 & Windows provide a non-dummy version of this
+ procedure in libaddr2line.a. */
void
-convert_addresses (addrs, n_addr, buf, len)
- char *addrs[] ATTRIBUTE_UNUSED;
- int n_addr ATTRIBUTE_UNUSED;
- void *buf ATTRIBUTE_UNUSED;
- int *len;
+convert_addresses (void *addrs ATTRIBUTE_UNUSED,
+ int n_addr ATTRIBUTE_UNUSED,
+ void *buf ATTRIBUTE_UNUSED,
+ int *len ATTRIBUTE_UNUSED)
{
*len = 0;
}
@@ -2271,3 +2364,84 @@ int __gnat_argument_needs_quote = 1;
#else
int __gnat_argument_needs_quote = 0;
#endif
+
+/* This option is used to enable/disable object files handling from the
+ binder file by the GNAT Project module. For example, this is disabled on
+ Windows as it is already done by the mdll module. */
+#if defined (_WIN32)
+int __gnat_prj_add_obj_files = 0;
+#else
+int __gnat_prj_add_obj_files = 1;
+#endif
+
+/* char used as prefix/suffix for environment variables */
+#if defined (_WIN32)
+char __gnat_environment_char = '%';
+#else
+char __gnat_environment_char = '$';
+#endif
+
+/* This functions copy the file attributes from a source file to a
+ destination file.
+
+ mode = 0 : In this mode copy only the file time stamps (last access and
+ last modification time stamps).
+
+ mode = 1 : In this mode, time stamps and read/write/execute attributes are
+ copied.
+
+ Returns 0 if operation was successful and -1 in case of error. */
+
+int
+__gnat_copy_attribs (char *from, char *to, int mode)
+{
+#if defined (VMS) || defined (__vxworks)
+ return -1;
+#else
+ struct stat fbuf;
+ struct utimbuf tbuf;
+
+ if (stat (from, &fbuf) == -1)
+ {
+ return -1;
+ }
+
+ tbuf.actime = fbuf.st_atime;
+ tbuf.modtime = fbuf.st_mtime;
+
+ if (utime (to, &tbuf) == -1)
+ {
+ return -1;
+ }
+
+ if (mode == 1)
+ {
+ if (chmod (to, fbuf.st_mode) == -1)
+ {
+ return -1;
+ }
+ }
+
+ return 0;
+#endif
+}
+
+/* This function is installed in libgcc.a. */
+extern void __gnat_install_locks (void (*) (void), void (*) (void));
+
+/* This function offers a hook for libgnarl to set the
+ locking subprograms for libgcc_eh. */
+
+void
+__gnatlib_install_locks (lock, unlock)
+ void (*lock) (void) ATTRIBUTE_UNUSED;
+ void (*unlock) (void) ATTRIBUTE_UNUSED;
+{
+#ifdef IN_RTS
+ __gnat_install_locks (lock, unlock);
+ /* There is a bootstrap path issue if adaint is build with this
+ symbol unresolved for the stage1 compiler. Since the compiler
+ does not use tasking, we simply make __gnatlib_install_locks
+ a no-op in this case. */
+#endif
+}
diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h
index edfd25d3677..5ce5d68ba2d 100644
--- a/gcc/ada/adaint.h
+++ b/gcc/ada/adaint.h
@@ -4,7 +4,6 @@
* *
* A D A I N T *
* *
- * *
* C Header File *
* *
* Copyright (C) 1992-2003 Free Software Foundation, Inc. *
@@ -31,117 +30,130 @@
* *
****************************************************************************/
-#if defined(__rtems__)
#include <stdio.h>
-#endif
-
#include <dirent.h>
-extern int __gnat_max_path_len;
-extern void __gnat_to_gm_time PARAMS ((int *, int *,
- int *, int *,
- int *, int *,
- int *));
-extern int __gnat_get_maximum_file_name_length PARAMS ((void));
-extern int __gnat_get_switches_case_sensitive PARAMS ((void));
-extern int __gnat_get_file_names_case_sensitive PARAMS ((void));
-extern char __gnat_get_default_identifier_character_set PARAMS ((void));
-extern void __gnat_get_current_dir PARAMS ((char *, int *));
-extern void __gnat_get_object_suffix_ptr PARAMS ((int *,
- const char **));
-extern void __gnat_get_executable_suffix_ptr PARAMS ((int *,
- const char **));
-extern void __gnat_get_debuggable_suffix_ptr PARAMS ((int *,
- const char **));
-extern int __gnat_readlink PARAMS ((char *, char *,
- size_t));
-extern int __gnat_symlink PARAMS ((char *, char *));
-extern int __gnat_try_lock PARAMS ((char *, char *));
-extern int __gnat_open_new PARAMS ((char *, int));
-extern int __gnat_open_new_temp PARAMS ((char *, int));
-extern int __gnat_mkdir PARAMS ((char *));
-extern int __gnat_stat PARAMS ((char *,
- struct stat *));
-extern int __gnat_open_read PARAMS ((char *, int));
-extern int __gnat_open_rw PARAMS ((char *, int));
-extern int __gnat_open_create PARAMS ((char *, int));
-extern int __gnat_open_append PARAMS ((char *, int));
-extern long __gnat_file_length PARAMS ((int));
-extern void __gnat_tmp_name PARAMS ((char *));
-extern char *__gnat_readdir PARAMS ((DIR *, char *));
-extern int __gnat_readdir_is_thread_safe PARAMS ((void));
-extern time_t __gnat_file_time_name PARAMS ((char *));
-extern time_t __gnat_file_time_fd PARAMS ((int));
-extern void __gnat_set_file_time_name PARAMS ((char *, time_t));
-extern void __gnat_get_env_value_ptr PARAMS ((char *, int *,
- char **));
-extern int __gnat_file_exists PARAMS ((char *));
-extern int __gnat_is_regular_file PARAMS ((char *));
-extern int __gnat_is_absolute_path PARAMS ((char *));
-extern int __gnat_is_directory PARAMS ((char *));
-extern int __gnat_is_writable_file PARAMS ((char *));
-extern int __gnat_portable_spawn PARAMS ((char *[]));
-extern int __gnat_portable_no_block_spawn PARAMS ((char *[]));
-extern int __gnat_portable_wait PARAMS ((int *));
-extern int __gnat_waitpid PARAMS ((int));
-extern char *__gnat_locate_exec PARAMS ((char *, char *));
-extern char *__gnat_locate_exec_on_path PARAMS ((char *));
-extern char *__gnat_locate_regular_file PARAMS ((char *, char *));
-extern void __gnat_maybe_glob_args PARAMS ((int *, char ***));
-extern void __gnat_os_exit PARAMS ((int));
-extern void __gnat_set_env_value PARAMS ((char *, char *));
-extern char *__gnat_get_libraries_from_registry PARAMS ((void));
-extern int __gnat_to_canonical_file_list_init PARAMS ((char *, int));
-extern char *__gnat_to_canonical_file_list_next PARAMS ((void));
-extern void __gnat_to_canonical_file_list_free PARAMS ((void));
-extern char *__gnat_to_canonical_dir_spec PARAMS ((char *, int));
-extern char *__gnat_to_canonical_file_spec PARAMS ((char *));
-extern char *__gnat_to_host_dir_spec PARAMS ((char *, int));
-extern char *__gnat_to_host_file_spec PARAMS ((char *));
-extern char *__gnat_to_canonical_path_spec PARAMS ((char *));
-extern void __gnat_adjust_os_resource_limits PARAMS ((void));
+typedef long OS_Time; /* Type corresponding to GNAT.OS_Lib.OS_Time */
-extern int __gnat_feof PARAMS ((FILE *));
-extern int __gnat_ferror PARAMS ((FILE *));
-extern int __gnat_fileno PARAMS ((FILE *));
-extern int __gnat_is_regular_file_fd PARAMS ((int));
-extern FILE *__gnat_constant_stderr PARAMS ((void));
-extern FILE *__gnat_constant_stdin PARAMS ((void));
-extern FILE *__gnat_constant_stdout PARAMS ((void));
-extern char *__gnat_full_name PARAMS ((char *, char *));
+extern int __gnat_max_path_len;
+extern void __gnat_to_gm_time (OS_Time *, int *,
+ int *, int *,
+ int *, int *,
+ int *);
+extern int __gnat_get_maximum_file_name_length (void);
+extern int __gnat_get_switches_case_sensitive (void);
+extern int __gnat_get_file_names_case_sensitive (void);
+extern char __gnat_get_default_identifier_character_set (void);
+extern void __gnat_get_current_dir (char *, int *);
+extern void __gnat_get_object_suffix_ptr (int *,
+ const char **);
+extern void __gnat_get_executable_suffix_ptr (int *,
+ const char **);
+extern void __gnat_get_debuggable_suffix_ptr (int *,
+ const char **);
+extern int __gnat_readlink (char *, char *,
+ size_t);
+extern int __gnat_symlink (char *, char *);
+extern int __gnat_try_lock (char *, char *);
+extern int __gnat_open_new (char *, int);
+extern int __gnat_open_new_temp (char *, int);
+extern int __gnat_mkdir (char *);
+extern int __gnat_stat (char *,
+ struct stat *);
+extern int __gnat_open_read (char *, int);
+extern int __gnat_open_rw (char *, int);
+extern int __gnat_open_create (char *, int);
+extern int __gnat_open_append (char *, int);
+extern long __gnat_file_length (int);
+extern void __gnat_tmp_name (char *);
+extern char *__gnat_readdir (DIR *, char *);
+extern int __gnat_readdir_is_thread_safe (void);
+extern time_t __gnat_file_time_name (char *);
+extern time_t __gnat_file_time_fd (int);
+extern void __gnat_set_file_time_name (char *, time_t);
+extern void __gnat_get_env_value_ptr (char *, int *,
+ char **);
+extern int __gnat_file_exists (char *);
+extern int __gnat_is_regular_file (char *);
+extern int __gnat_is_absolute_path (char *);
+extern int __gnat_is_directory (char *);
+extern int __gnat_is_writable_file (char *);
+extern int __gnat_is_readable_file (char *name);
+extern void __gnat_set_readonly (char *name);
+extern void __gnat_set_writable (char *name);
+extern int __gnat_is_symbolic_link (char *name);
+extern int __gnat_portable_spawn (char *[]);
+extern int __gnat_portable_no_block_spawn (char *[]);
+extern int __gnat_portable_wait (int *);
+extern int __gnat_waitpid (int);
+extern char *__gnat_locate_exec (char *, char *);
+extern char *__gnat_locate_exec_on_path (char *);
+extern char *__gnat_locate_regular_file (char *, char *);
+extern void __gnat_maybe_glob_args (int *, char ***);
+extern void __gnat_os_exit (int);
+extern void __gnat_set_env_value (char *, char *);
+extern char *__gnat_get_libraries_from_registry (void);
+extern int __gnat_to_canonical_file_list_init (char *, int);
+extern char *__gnat_to_canonical_file_list_next (void);
+extern void __gnat_to_canonical_file_list_free (void);
+extern char *__gnat_to_canonical_dir_spec (char *, int);
+extern char *__gnat_to_canonical_file_spec (char *);
+extern char *__gnat_to_host_dir_spec (char *, int);
+extern char *__gnat_to_host_file_spec (char *);
+extern char *__gnat_to_canonical_path_spec (char *);
+extern void __gnat_adjust_os_resource_limits (void);
+extern void convert_addresses (void *, int,
+ void *, int *);
+extern int __gnat_copy_attribs (char *, char *, int);
+extern int __gnat_feof (FILE *);
+extern int __gnat_ferror (FILE *);
+extern int __gnat_fileno (FILE *);
+extern int __gnat_is_regular_file_fd (int);
+extern FILE *__gnat_constant_stderr (void);
+extern FILE *__gnat_constant_stdin (void);
+extern FILE *__gnat_constant_stdout (void);
+extern char *__gnat_full_name (char *, char *);
-extern int __gnat_arg_count PARAMS ((void));
-extern int __gnat_len_arg PARAMS ((int));
-extern void __gnat_fill_arg PARAMS ((char *, int));
-extern int __gnat_env_count PARAMS ((void));
-extern int __gnat_len_env PARAMS ((int));
-extern void __gnat_fill_env PARAMS ((char *, int));
+extern int __gnat_arg_count (void);
+extern int __gnat_len_arg (int);
+extern void __gnat_fill_arg (char *, int);
+extern int __gnat_env_count (void);
+extern int __gnat_len_env (int);
+extern void __gnat_fill_env (char *, int);
/* Routines for interface to scanf and printf functions for integer values */
-extern int get_int PARAMS ((void));
-extern void put_int PARAMS ((int));
-extern void put_int_stderr PARAMS ((int));
-extern int get_char PARAMS ((void));
-extern void put_char PARAMS ((int));
-extern void put_char_stderr PARAMS ((int));
-extern char *mktemp PARAMS ((char *));
+extern int get_int (void);
+extern void put_int (int);
+extern void put_int_stderr (int);
+extern int get_char (void);
+extern void put_char (int);
+extern void put_char_stderr (int);
+extern char *mktemp (char *);
-extern void __gnat_set_exit_status PARAMS ((int));
+extern void __gnat_set_exit_status (int);
-extern int __gnat_expect_fork PARAMS ((void));
-extern void __gnat_expect_portable_execvp PARAMS ((char *, char *[]));
-extern int __gnat_pipe PARAMS ((int *));
-extern int __gnat_expect_poll PARAMS ((int *, int, int,
- int *));
-extern void __gnat_set_binary_mode PARAMS ((int));
-extern void __gnat_set_text_mode PARAMS ((int));
-extern char *__gnat_ttyname PARAMS ((int));
+extern int __gnat_expect_fork (void);
+extern void __gnat_expect_portable_execvp (char *, char *[]);
+extern int __gnat_pipe (int *);
+extern int __gnat_expect_poll (int *, int, int, int *);
+extern void __gnat_set_binary_mode (int);
+extern void __gnat_set_text_mode (int);
+extern char *__gnat_ttyname (int);
-extern void convert_addresses PARAMS ((char *[], int,
- void *, int *));
+#ifdef __MINGW32__
+extern void __gnat_plist_init (void);
+#endif
#ifdef IN_RTS
/* Portable definition of strdup, which is not available on all systems. */
#define xstrdup(S) strcpy ((char *) malloc (strlen (S) + 1), S)
#endif
+
+/* This function returns the version of GCC being used. Here it's GCC 3. */
+extern int get_gcc_version (void);
+
+/* This function offers a hook for libgnarl to set the
+ locking subprograms for libgcc_eh. */
+extern void __gnatlib_install_locks (void (*) (void),
+ void (*) (void));
diff --git a/gcc/ada/ali-util.adb b/gcc/ada/ali-util.adb
index e81edd7f694..2d5ed8d4ab8 100644
--- a/gcc/ada/ali-util.adb
+++ b/gcc/ada/ali-util.adb
@@ -24,17 +24,32 @@
-- --
------------------------------------------------------------------------------
+with Debug; use Debug;
with Binderr; use Binderr;
+with Lib; use Lib;
with Namet; use Namet;
with Opt; use Opt;
+with Output; use Output;
with Osint; use Osint;
with System.CRC32;
with System.Memory;
-with System.Address_To_Access_Conversions;
package body ALI.Util is
+ type Header_Num is range 0 .. 1_000;
+
+ function Hash (F : File_Name_Type) return Header_Num;
+ -- Function used to compute hash of ALI file name
+
+ package Interfaces is new Simple_HTable (
+ Header_Num => Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => File_Name_Type,
+ Hash => Hash,
+ Equal => "=");
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -87,20 +102,6 @@ package body ALI.Util is
use ASCII;
-- Make control characters visible
- procedure Free_Source;
- -- Free source file buffer
-
- procedure Free_Source is
-
- package SB is
- new System.Address_To_Access_Conversions (Big_Source_Buffer);
-
- begin
- System.Memory.Free (SB.To_Address (SB.Object_Pointer (Src)));
- end Free_Source;
-
- -- Start of processing for Get_File_Checksum
-
begin
Read_Source_File (Fname, 0, Hi, Src);
@@ -127,7 +128,7 @@ package body ALI.Util is
when EOF =>
if Ptr = Hi then
- Free_Source;
+ System.Memory.Free (Src.all'Address);
return Csum;
else
Ptr := Ptr + 1;
@@ -259,11 +260,19 @@ package body ALI.Util is
exception
when Bad =>
- Free_Source;
+ System.Memory.Free (Src.all'Address);
return Checksum_Error;
-
end Get_File_Checksum;
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : File_Name_Type) return Header_Num is
+ begin
+ return Header_Num (Int (F) rem Header_Num'Range_Length);
+ end Hash;
+
---------------------------
-- Initialize_ALI_Source --
---------------------------
@@ -281,6 +290,7 @@ package body ALI.Util is
end loop;
Source.Init;
+ Interfaces.Reset;
end Initialize_ALI_Source;
-------------------------
@@ -302,26 +312,41 @@ package body ALI.Util is
Idread : ALI_Id;
begin
- for I in ALIs.Table (Id).First_Unit .. ALIs.Table (Id).Last_Unit loop
- for J in Units.Table (I).First_With .. Units.Table (I).Last_With loop
+ -- Process all dependent units
- Afile := Withs.Table (J).Afile;
+ for U in ALIs.Table (Id).First_Unit .. ALIs.Table (Id).Last_Unit loop
+ for
+ W in Units.Table (U).First_With .. Units.Table (U).Last_With
+ loop
+ Afile := Withs.Table (W).Afile;
-- Only process if not a generic (Afile /= No_File) and if
-- file has not been processed already.
- if Afile /= No_File and then Get_Name_Table_Info (Afile) = 0 then
-
+ if Afile /= No_File
+ and then Get_Name_Table_Info (Afile) = 0
+ then
Text := Read_Library_Info (Afile);
+ -- Return with an error if source cannot be found and if this
+ -- is not a library generic (now we can, but does not have to
+ -- compile library generics)
+
if Text = null then
- Error_Msg_Name_1 := Afile;
- Error_Msg_Name_2 := Withs.Table (J).Sfile;
- Error_Msg ("% not found, % must be compiled");
- Set_Name_Table_Info (Afile, Int (No_Unit_Id));
- return;
+ if Generic_Separately_Compiled (Withs.Table (W).Sfile) then
+ Error_Msg_Name_1 := Afile;
+ Error_Msg_Name_2 := Withs.Table (W).Sfile;
+ Error_Msg ("% not found, % must be compiled");
+ Set_Name_Table_Info (Afile, Int (No_Unit_Id));
+ return;
+
+ else
+ goto Skip_Library_Generics;
+ end if;
end if;
+ -- Enter in ALIs table
+
Idread :=
Scan_ALI
(F => Afile,
@@ -332,23 +357,46 @@ package body ALI.Util is
Free (Text);
if ALIs.Table (Idread).Compile_Errors then
- Error_Msg_Name_1 := Withs.Table (J).Sfile;
+ Error_Msg_Name_1 := Withs.Table (W).Sfile;
Error_Msg ("% had errors, must be fixed, and recompiled");
Set_Name_Table_Info (Afile, Int (No_Unit_Id));
elsif ALIs.Table (Idread).No_Object then
- Error_Msg_Name_1 := Withs.Table (J).Sfile;
+ Error_Msg_Name_1 := Withs.Table (W).Sfile;
Error_Msg ("% must be recompiled");
Set_Name_Table_Info (Afile, Int (No_Unit_Id));
end if;
- -- Recurse to get new dependents
+ -- If the Unit is an Interface to a Stand-Alone Library,
+ -- set the Interface flag in the Withs table, so that its
+ -- dependant are not considered for elaboration order.
+
+ if ALIs.Table (Idread).Interface then
+ Withs.Table (W).Interface := True;
+ Interface_Library_Unit := True;
- Read_ALI (Idread);
+ -- Set the entry in the Interfaces hash table, so that other
+ -- units that import this unit will set the flag in their
+ -- entry in the Withs table.
+
+ Interfaces.Set (Afile, True);
+
+ else
+ -- Otherwise, recurse to get new dependents
+
+ Read_ALI (Idread);
+ end if;
+
+ <<Skip_Library_Generics>> null;
+
+ -- If the ALI file has already been processed and is an interface,
+ -- set the flag in the entry of the Withs table.
+
+ elsif Interface_Library_Unit and then Interfaces.Get (Afile) then
+ Withs.Table (W).Interface := True;
end if;
end loop;
end loop;
-
end Read_ALI;
----------------------
@@ -366,118 +414,120 @@ package body ALI.Util is
loop
F := Sdep.Table (D).Sfile;
- -- If this is the first time we are seeing this source file,
- -- then make a new entry in the source table.
+ if F /= No_Name then
- if Get_Name_Table_Info (F) = 0 then
- Source.Increment_Last;
- S := Source.Last;
- Set_Name_Table_Info (F, Int (S));
- Source.Table (S).Sfile := F;
- Source.Table (S).All_Timestamps_Match := True;
+ -- If this is the first time we are seeing this source file,
+ -- then make a new entry in the source table.
- -- Initialize checksum fields
+ if Get_Name_Table_Info (F) = 0 then
+ Source.Increment_Last;
+ S := Source.Last;
+ Set_Name_Table_Info (F, Int (S));
+ Source.Table (S).Sfile := F;
+ Source.Table (S).All_Timestamps_Match := True;
- Source.Table (S).Checksum := Sdep.Table (D).Checksum;
- Source.Table (S).All_Checksums_Match := True;
+ -- Initialize checksum fields
- -- In check source files mode, try to get time stamp from file
+ Source.Table (S).Checksum := Sdep.Table (D).Checksum;
+ Source.Table (S).All_Checksums_Match := True;
- if Opt.Check_Source_Files then
- Stamp := Source_File_Stamp (F);
+ -- In check source files mode, try to get time stamp from file
- -- If we got the stamp, then set the stamp in the source
- -- table entry and mark it as set from the source so that
- -- it does not get subsequently changed.
+ if Opt.Check_Source_Files then
+ Stamp := Source_File_Stamp (F);
- if Stamp (Stamp'First) /= ' ' then
- Source.Table (S).Stamp := Stamp;
- Source.Table (S).Source_Found := True;
+ -- If we got the stamp, then set the stamp in the source
+ -- table entry and mark it as set from the source so that
+ -- it does not get subsequently changed.
- -- If we could not find the file, then the stamp is set
- -- from the dependency table entry (to be possibly reset
- -- if we find a later stamp in subsequent processing)
+ if Stamp (Stamp'First) /= ' ' then
+ Source.Table (S).Stamp := Stamp;
+ Source.Table (S).Source_Found := True;
- else
- Source.Table (S).Stamp := Sdep.Table (D).Stamp;
- Source.Table (S).Source_Found := False;
+ -- If we could not find the file, then the stamp is set
+ -- from the dependency table entry (to be possibly reset
+ -- if we find a later stamp in subsequent processing)
+
+ else
+ Source.Table (S).Stamp := Sdep.Table (D).Stamp;
+ Source.Table (S).Source_Found := False;
- -- In All_Sources mode, flag error of file not found
+ -- In All_Sources mode, flag error of file not found
- if Opt.All_Sources then
- Error_Msg_Name_1 := F;
- Error_Msg ("cannot locate %");
+ if Opt.All_Sources then
+ Error_Msg_Name_1 := F;
+ Error_Msg ("cannot locate %");
+ end if;
end if;
- end if;
- -- First time for this source file, but Check_Source_Files
- -- is off, so simply initialize the stamp from the Sdep entry
+ -- First time for this source file, but Check_Source_Files
+ -- is off, so simply initialize the stamp from the Sdep entry
- else
- Source.Table (S).Source_Found := False;
- Source.Table (S).Stamp := Sdep.Table (D).Stamp;
- end if;
+ else
+ Source.Table (S).Source_Found := False;
+ Source.Table (S).Stamp := Sdep.Table (D).Stamp;
+ end if;
- -- Here if this is not the first time for this source file,
- -- so that the source table entry is already constructed.
+ -- Here if this is not the first time for this source file,
+ -- so that the source table entry is already constructed.
- else
- S := Source_Id (Get_Name_Table_Info (F));
+ else
+ S := Source_Id (Get_Name_Table_Info (F));
- -- Update checksum flag
+ -- Update checksum flag
- if not Checksums_Match
- (Sdep.Table (D).Checksum, Source.Table (S).Checksum)
- then
- Source.Table (S).All_Checksums_Match := False;
- end if;
+ if not Checksums_Match
+ (Sdep.Table (D).Checksum, Source.Table (S).Checksum)
+ then
+ Source.Table (S).All_Checksums_Match := False;
+ end if;
- -- Check for time stamp mismatch
+ -- Check for time stamp mismatch
- if Sdep.Table (D).Stamp /= Source.Table (S).Stamp then
- Source.Table (S).All_Timestamps_Match := False;
+ if Sdep.Table (D).Stamp /= Source.Table (S).Stamp then
+ Source.Table (S).All_Timestamps_Match := False;
- -- When we have a time stamp mismatch, we go look for the
- -- source file even if Check_Source_Files is false, since
- -- if we find it, then we can use it to resolve which of the
- -- two timestamps in the ALI files is likely to be correct.
+ -- When we have a time stamp mismatch, we go look for the
+ -- source file even if Check_Source_Files is false, since
+ -- if we find it, then we can use it to resolve which of the
+ -- two timestamps in the ALI files is likely to be correct.
- if not Check_Source_Files then
- Stamp := Source_File_Stamp (F);
+ if not Check_Source_Files then
+ Stamp := Source_File_Stamp (F);
- if Stamp (Stamp'First) /= ' ' then
- Source.Table (S).Stamp := Stamp;
- Source.Table (S).Source_Found := True;
+ if Stamp (Stamp'First) /= ' ' then
+ Source.Table (S).Stamp := Stamp;
+ Source.Table (S).Source_Found := True;
+ end if;
end if;
- end if;
- -- If the stamp in the source table entry was set from the
- -- source file, then we do not change it (the stamp in the
- -- source file is always taken as the "right" one).
+ -- If the stamp in the source table entry was set from the
+ -- source file, then we do not change it (the stamp in the
+ -- source file is always taken as the "right" one).
- if Source.Table (S).Source_Found then
- null;
+ if Source.Table (S).Source_Found then
+ null;
- -- Otherwise, we have no source file available, so we guess
- -- that the later of the two timestamps is the right one.
- -- Note that this guess only affects which error messages
- -- are issued later on, not correct functionality.
+ -- Otherwise, we have no source file available, so we guess
+ -- that the later of the two timestamps is the right one.
+ -- Note that this guess only affects which error messages
+ -- are issued later on, not correct functionality.
- else
- if Sdep.Table (D).Stamp > Source.Table (S).Stamp then
- Source.Table (S).Stamp := Sdep.Table (D).Stamp;
+ else
+ if Sdep.Table (D).Stamp > Source.Table (S).Stamp then
+ Source.Table (S).Stamp := Sdep.Table (D).Stamp;
+ end if;
end if;
end if;
end if;
- end if;
- -- Set the checksum value in the source table
+ -- Set the checksum value in the source table
- S := Source_Id (Get_Name_Table_Info (F));
- Source.Table (S).Checksum := Sdep.Table (D).Checksum;
+ S := Source_Id (Get_Name_Table_Info (F));
+ Source.Table (S).Checksum := Sdep.Table (D).Checksum;
+ end if;
end loop Sdep_Loop;
-
end Set_Source_Table;
----------------------
@@ -489,14 +539,17 @@ package body ALI.Util is
for A in ALIs.First .. ALIs.Last loop
Set_Source_Table (A);
end loop;
-
end Set_Source_Table;
-------------------------
-- Time_Stamp_Mismatch --
-------------------------
- function Time_Stamp_Mismatch (A : ALI_Id) return File_Name_Type is
+ function Time_Stamp_Mismatch
+ (A : ALI_Id;
+ Read_Only : Boolean := False)
+ return File_Name_Type
+ is
Src : Source_Id;
-- Source file Id for the current Sdep entry
@@ -507,7 +560,6 @@ package body ALI.Util is
if Opt.Minimal_Recompilation
and then Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
then
-
-- If minimal recompilation is in action, replace the stamp
-- of the source file in the table if checksums match.
@@ -523,15 +575,33 @@ package body ALI.Util is
end if;
- if not Source.Table (Src).Source_Found
- or else Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
- then
- return Source.Table (Src).Sfile;
+ if (not Read_Only) or else Source.Table (Src).Source_Found then
+ if not Source.Table (Src).Source_Found
+ or else Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
+ then
+ -- If -t debug flag set, output time stamp found/expected
+
+ if Source.Table (Src).Source_Found and Debug_Flag_T then
+ Write_Str ("Source: """);
+ Get_Name_String (Sdep.Table (D).Sfile);
+ Write_Str (Name_Buffer (1 .. Name_Len));
+ Write_Line ("""");
+
+ Write_Str (" time stamp expected: ");
+ Write_Line (String (Sdep.Table (D).Stamp));
+
+ Write_Str (" time stamp found: ");
+ Write_Line (String (Source.Table (Src).Stamp));
+ end if;
+
+ -- Return the source file
+
+ return Source.Table (Src).Sfile;
+ end if;
end if;
end loop;
return No_File;
-
end Time_Stamp_Mismatch;
end ALI.Util;
diff --git a/gcc/ada/ali-util.ads b/gcc/ada/ali-util.ads
index 1684e518488..f4a7f6f6059 100644
--- a/gcc/ada/ali-util.ads
+++ b/gcc/ada/ali-util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -104,9 +104,9 @@ package ALI.Util is
procedure Read_ALI (Id : ALI_Id);
-- Process an ALI file which has been read and scanned by looping
- -- through all withed units in the ALI file; checking if they have
- -- been processed; and for each that hasn't, reading, scanning, and
- -- recursively processing.
+ -- through all withed units in the ALI file, checking if they have
+ -- been processed. Each unit that has not yet been processed will
+ -- be read, scanned, and processed recursively.
procedure Set_Source_Table (A : ALI_Id);
-- Build source table entry corresponding to the ALI file whose id is A.
@@ -114,7 +114,10 @@ package ALI.Util is
procedure Set_Source_Table;
-- Build the entire source table.
- function Time_Stamp_Mismatch (A : ALI_Id) return File_Name_Type;
+ function Time_Stamp_Mismatch
+ (A : ALI_Id;
+ Read_Only : Boolean := False)
+ return File_Name_Type;
-- Looks in the Source_Table and checks time stamp mismatches between
-- the sources there and the sources in the Sdep section of ali file whose
-- id is A. If no time stamp mismatches are found No_File is returned.
@@ -123,6 +126,7 @@ package ALI.Util is
-- time stamp in the Source_Table should be the actual time stamp of the
-- source files. In minimal recompilation mode (Minimal_Recompilation set
-- to True, no mismatch is found if the file's timestamp has not changed.
+ -- If Read_Only is True, missing sources are not considered.
--------------------------------------------
-- Subprograms for manipulating checksums --
diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb
index 919bc87a144..0ad9d6e705e 100644
--- a/gcc/ada/ali.adb
+++ b/gcc/ada/ali.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -24,12 +24,13 @@
-- --
------------------------------------------------------------------------------
-with Butil; use Butil;
-with Debug; use Debug;
-with Fname; use Fname;
-with Namet; use Namet;
-with Osint; use Osint;
-with Output; use Output;
+with Butil; use Butil;
+with Debug; use Debug;
+with Fname; use Fname;
+with Namet; use Namet;
+with Opt; use Opt;
+with Osint; use Osint;
+with Output; use Output;
package body ALI is
@@ -45,12 +46,24 @@ package body ALI is
-- When (re)initializing ALI data structures the ALI user expects to
-- get a fresh set of data structures. Thus we first need to erase the
-- marks put in the name table by the previous set of ALI routine calls.
- -- This loop is empty and harmless the first time in.
+ -- These two loops are empty and harmless the first time in.
for J in ALIs.First .. ALIs.Last loop
Set_Name_Table_Info (ALIs.Table (J).Afile, 0);
end loop;
+ for J in Units.First .. Units.Last loop
+ Set_Name_Table_Info (Units.Table (J).Uname, 0);
+ end loop;
+
+ -- Free argument table strings
+
+ for J in Args.First .. Args.Last loop
+ Free (Args.Table (J));
+ end loop;
+
+ -- Initialize all tables
+
ALIs.Init;
Units.Init;
Withs.Init;
@@ -74,7 +87,6 @@ package body ALI is
No_Normalize_Scalars_Specified := False;
No_Object_Specified := False;
Normalize_Scalars_Specified := False;
- No_Run_Time_Specified := False;
Queuing_Policy_Specified := ' ';
Static_Elaboration_Model_Used := False;
Task_Dispatching_Policy_Specified := ' ';
@@ -88,12 +100,14 @@ package body ALI is
--------------
function Scan_ALI
- (F : File_Name_Type;
- T : Text_Buffer_Ptr;
- Ignore_ED : Boolean;
- Err : Boolean;
- Read_Xref : Boolean := False)
- return ALI_Id
+ (F : File_Name_Type;
+ T : Text_Buffer_Ptr;
+ Ignore_ED : Boolean;
+ Err : Boolean;
+ Read_Xref : Boolean := False;
+ Read_Lines : String := "";
+ Ignore_Lines : String := "X")
+ return ALI_Id
is
P : Text_Ptr := T'First;
Line : Logical_Line_Number := 1;
@@ -102,6 +116,14 @@ package body ALI is
NS_Found : Boolean;
First_Arg : Arg_Id;
+ Ignore : array (Character range 'A' .. 'Z') of Boolean;
+ -- Ignore (X) is set to True if lines starting with X are to
+ -- be ignored by Scan_ALI and skipped, and False if the lines
+ -- are to be read and processed.
+
+ Bad_ALI_Format : exception;
+ -- Exception raised by Fatal_Error if Err is True
+
function At_Eol return Boolean;
-- Test if at end of line
@@ -114,8 +136,6 @@ package body ALI is
procedure Checkc (C : Character);
-- Check next character is C. If so bump past it, if not fatal error
- Bad_ALI_Format : exception;
-
procedure Fatal_Error;
-- Generate fatal error message for badly formatted ALI file if
-- Err is false, or raise Bad_ALI_Format if Err is True.
@@ -123,19 +143,21 @@ package body ALI is
function Getc return Character;
-- Get next character, bumping P past the character obtained
- function Get_Name (Lower : Boolean := False) return Name_Id;
+ function Get_Name (Lower : Boolean := False;
+ Ignore_Spaces : Boolean := False) return Name_Id;
-- Skip blanks, then scan out a name (name is left in Name_Buffer with
-- length in Name_Len, as well as being returned in Name_Id form).
-- If Lower is set to True then the Name_Buffer will be converted to
-- all lower case, for systems where file names are not case sensitive.
-- This ensures that gnatbind works correctly regardless of the case
-- of the file name on all systems. The name is terminated by a either
- -- white space or a typeref bracket or an equal sign except for the
- -- special case of an operator name starting with a double quite which
- -- is terminated by another double quote.
+ -- white space (when Ignore_Spaces is False) or a typeref bracket or
+ -- an equal sign except for the special case of an operator name
+ -- starting with a double quite which is terminated by another double
+ -- quote.
function Get_Nat return Nat;
- -- Skip blanks, then scan out an unsigned integer value in Nat range
+ -- Skip blanks, then scan out an unsigned integer value in Nat range.
function Get_Stamp return Time_Stamp_Type;
-- Skip blanks, then scan out a time stamp
@@ -144,7 +166,11 @@ package body ALI is
-- Return current character without modifying pointer P
procedure Skip_Eol;
- -- Skip past end of line (fatal error if not at end of line)
+ -- Skip past spaces, then skip past end of line (fatal error if not
+ -- at end of line). Also skips past any following blank lines.
+
+ procedure Skip_Line;
+ -- Skip rest of current line and any following blank lines.
procedure Skip_Space;
-- Skip past white space (blanks or horizontal tab)
@@ -291,7 +317,8 @@ package body ALI is
-- Get_Name --
--------------
- function Get_Name (Lower : Boolean := False) return Name_Id is
+ function Get_Name (Lower : Boolean := False;
+ Ignore_Spaces : Boolean := False) return Name_Id is
begin
Name_Len := 0;
Skip_Space;
@@ -304,13 +331,13 @@ package body ALI is
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Getc;
- exit when At_End_Of_Field;
+ exit when At_End_Of_Field and not Ignore_Spaces;
if Name_Buffer (1) = '"' then
exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
else
- exit when At_End_Of_Field
+ exit when (At_End_Of_Field and not Ignore_Spaces)
or else Nextc = '(' or else Nextc = ')'
or else Nextc = '{' or else Nextc = '}'
or else Nextc = '<' or else Nextc = '>'
@@ -415,6 +442,7 @@ package body ALI is
procedure Skip_Eol is
begin
Skip_Space;
+
if not At_Eol then Fatal_Error; end if;
-- Loop to skip past blank lines (first time through skips this EOL)
@@ -428,6 +456,19 @@ package body ALI is
end loop;
end Skip_Eol;
+ ---------------
+ -- Skip_Line --
+ ---------------
+
+ procedure Skip_Line is
+ begin
+ while not At_Eol loop
+ P := P + 1;
+ end loop;
+
+ Skip_Eol;
+ end Skip_Line;
+
----------------
-- Skip_Space --
----------------
@@ -439,11 +480,36 @@ package body ALI is
end loop;
end Skip_Space;
- --------------------------------------
- -- Start of processing for Scan_ALI --
- --------------------------------------
+ -- Start of processing for Scan_ALI
begin
+ -- Acquire lines to be ignored
+
+ if Read_Xref then
+ Ignore := ('U' | 'W' | 'D' | 'X' => False, others => True);
+
+ -- Read_Lines parameter given
+
+ elsif Read_Lines /= "" then
+ Ignore := ('U' => False, others => True);
+
+ for J in Read_Lines'Range loop
+ Ignore (Read_Lines (J)) := False;
+ end loop;
+
+ -- Process Ignore_Lines parameter
+
+ else
+ Ignore := (others => False);
+
+ for J in Ignore_Lines'Range loop
+ pragma Assert (Ignore_Lines (J) /= 'U');
+ Ignore (Ignore_Lines (J)) := True;
+ end loop;
+ end if;
+
+ -- Setup ALI Table entry with appropriate defaults
+
ALIs.Increment_Last;
Id := ALIs.Last;
Set_Name_Table_Info (F, Int (Id));
@@ -451,16 +517,17 @@ package body ALI is
ALIs.Table (Id) := (
Afile => F,
Compile_Errors => False,
+ First_Interrupt_State => Interrupt_States.Last + 1,
First_Sdep => No_Sdep_Id,
First_Unit => No_Unit_Id,
Float_Format => 'I',
+ Last_Interrupt_State => Interrupt_States.Last,
Last_Sdep => No_Sdep_Id,
Last_Unit => No_Unit_Id,
Locking_Policy => ' ',
Main_Priority => -1,
Main_Program => None,
No_Object => False,
- No_Run_Time => False,
Normalize_Scalars => False,
Ofile_Full_Name => Full_Object_File_Name,
Queuing_Policy => ' ',
@@ -472,68 +539,87 @@ package body ALI is
Unit_Exception_Table => False,
Ver => (others => ' '),
Ver_Len => 0,
+ Interface => False,
Zero_Cost_Exceptions => False);
+ -- Now we acquire the input lines from the ALI file. Note that the
+ -- convention in the following code is that as we enter each section,
+ -- C is set to contain the first character of the following line.
+
+ C := Getc;
+
-- Acquire library version
- Checkc ('V');
- Checkc (' ');
- Skip_Space;
- Checkc ('"');
+ if C /= 'V' then
+ Fatal_Error;
- for J in 1 .. Ver_Len_Max loop
- C := Getc;
- exit when C = '"';
- ALIs.Table (Id).Ver (J) := C;
- ALIs.Table (Id).Ver_Len := J;
- end loop;
+ elsif Ignore ('V') then
+ Skip_Line;
+
+ else
+ Checkc (' ');
+ Skip_Space;
+ Checkc ('"');
- Skip_Eol;
+ for J in 1 .. Ver_Len_Max loop
+ C := Getc;
+ exit when C = '"';
+ ALIs.Table (Id).Ver (J) := C;
+ ALIs.Table (Id).Ver_Len := J;
+ end loop;
- -- Acquire main program line if present
+ Skip_Eol;
+ end if;
C := Getc;
- if C = 'M' then
- Checkc (' ');
- Skip_Space;
+ -- Acquire main program line if present
- C := Getc;
+ if C = 'M' then
+ if Ignore ('M') then
+ Skip_Line;
- if C = 'F' then
- ALIs.Table (Id).Main_Program := Func;
- elsif C = 'P' then
- ALIs.Table (Id).Main_Program := Proc;
else
- P := P - 1;
- Fatal_Error;
- end if;
+ Checkc (' ');
+ Skip_Space;
- Skip_Space;
+ C := Getc;
- if not At_Eol then
- if Nextc < 'A' then
- ALIs.Table (Id).Main_Priority := Get_Nat;
+ if C = 'F' then
+ ALIs.Table (Id).Main_Program := Func;
+ elsif C = 'P' then
+ ALIs.Table (Id).Main_Program := Proc;
+ else
+ P := P - 1;
+ Fatal_Error;
end if;
Skip_Space;
- if Nextc = 'T' then
- P := P + 1;
+ if not At_Eol then
+ if Nextc < 'A' then
+ ALIs.Table (Id).Main_Priority := Get_Nat;
+ end if;
+
+ Skip_Space;
+
+ if Nextc = 'T' then
+ P := P + 1;
+ Checkc ('=');
+ ALIs.Table (Id).Time_Slice_Value := Get_Nat;
+ end if;
+
+ Skip_Space;
+
+ Checkc ('W');
Checkc ('=');
- ALIs.Table (Id).Time_Slice_Value := Get_Nat;
+ ALIs.Table (Id).WC_Encoding := Getc;
end if;
- Skip_Space;
-
- Checkc ('W');
- Checkc ('=');
- ALIs.Table (Id).WC_Encoding := Getc;
+ Skip_Eol;
end if;
- Skip_Eol;
C := Getc;
-
end if;
-- Acquire argument lines
@@ -541,106 +627,151 @@ package body ALI is
First_Arg := Args.Last + 1;
Arg_Loop : while C = 'A' loop
- Checkc (' ');
- Name_Len := 0;
+ if Ignore ('A') then
+ Skip_Line;
- while not At_Eol loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Getc;
- end loop;
+ else
+ Checkc (' ');
+ Name_Len := 0;
+
+ while not At_Eol loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Getc;
+ end loop;
- Args.Increment_Last;
- Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
+ Args.Increment_Last;
+ Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len));
+
+ Skip_Eol;
+ end if;
- Skip_Eol;
C := Getc;
end loop Arg_Loop;
- -- Acquire P line, first set defaults
+ -- Acquire P line
if C /= 'P' then
Fatal_Error;
- end if;
- NS_Found := False;
+ elsif Ignore ('P') then
+ Skip_Line;
- while not At_Eol loop
- Checkc (' ');
- Skip_Space;
- C := Getc;
+ else
+ NS_Found := False;
- if C = 'C' then
- Checkc ('E');
- ALIs.Table (Id).Compile_Errors := True;
+ while not At_Eol loop
+ Checkc (' ');
+ Skip_Space;
+ C := Getc;
+
+ -- Processing for CE
- elsif C = 'F' then
- Float_Format_Specified := Getc;
- ALIs.Table (Id).Float_Format := Float_Format_Specified;
+ if C = 'C' then
+ Checkc ('E');
+ ALIs.Table (Id).Compile_Errors := True;
- elsif C = 'L' then
- Locking_Policy_Specified := Getc;
- ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
+ -- Processing for FD/FG/FI
- elsif C = 'N' then
- C := Getc;
+ elsif C = 'F' then
+ Float_Format_Specified := Getc;
+ ALIs.Table (Id).Float_Format := Float_Format_Specified;
- if C = 'O' then
- ALIs.Table (Id).No_Object := True;
- No_Object_Specified := True;
+ -- Processing for Lx
- elsif C = 'R' then
- No_Run_Time_Specified := True;
- ALIs.Table (Id).No_Run_Time := True;
+ elsif C = 'L' then
+ Locking_Policy_Specified := Getc;
+ ALIs.Table (Id).Locking_Policy := Locking_Policy_Specified;
+
+ -- Processing for flags starting with N
+
+ elsif C = 'N' then
+ C := Getc;
+
+ -- Processing for NO
+
+ if C = 'O' then
+ ALIs.Table (Id).No_Object := True;
+ No_Object_Specified := True;
+
+ -- Processing for NR
+
+ elsif C = 'R' then
+ No_Run_Time_Mode := True;
+ Configurable_Run_Time_Mode := True;
+
+ -- Processing for NS
+
+ elsif C = 'S' then
+ ALIs.Table (Id).Normalize_Scalars := True;
+ Normalize_Scalars_Specified := True;
+ NS_Found := True;
+
+ else
+ Fatal_Error;
+ end if;
+
+ -- Processing for Qx
+
+ elsif C = 'Q' then
+ Queuing_Policy_Specified := Getc;
+ ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
+
+ -- Processing for SL
elsif C = 'S' then
- ALIs.Table (Id).Normalize_Scalars := True;
- Normalize_Scalars_Specified := True;
- NS_Found := True;
+ Checkc ('L');
+ ALIs.Table (Id).Interface := True;
- else
- Fatal_Error;
- end if;
+ -- Processing for Tx
- elsif C = 'Q' then
- Queuing_Policy_Specified := Getc;
- ALIs.Table (Id).Queuing_Policy := Queuing_Policy_Specified;
+ elsif C = 'T' then
+ Task_Dispatching_Policy_Specified := Getc;
+ ALIs.Table (Id).Task_Dispatching_Policy :=
+ Task_Dispatching_Policy_Specified;
- elsif C = 'T' then
- Task_Dispatching_Policy_Specified := Getc;
- ALIs.Table (Id).Task_Dispatching_Policy :=
- Task_Dispatching_Policy_Specified;
+ -- Processing for UA
- elsif C = 'U' then
- if Nextc = 'A' then
- Unreserve_All_Interrupts_Specified := True;
- C := Getc;
+ elsif C = 'U' then
+ if Nextc = 'A' then
+ Unreserve_All_Interrupts_Specified := True;
+ C := Getc;
- else
+ -- Processing for UX
+
+ else
+ Checkc ('X');
+ ALIs.Table (Id).Unit_Exception_Table := True;
+ end if;
+
+ -- Processing for ZX
+
+ elsif C = 'Z' then
Checkc ('X');
- ALIs.Table (Id).Unit_Exception_Table := True;
- end if;
+ ALIs.Table (Id).Zero_Cost_Exceptions := True;
+ Zero_Cost_Exceptions_Specified := True;
- elsif C = 'Z' then
- Checkc ('X');
- ALIs.Table (Id).Zero_Cost_Exceptions := True;
- Zero_Cost_Exceptions_Specified := True;
+ else
+ Fatal_Error;
+ end if;
+ end loop;
- else
- Fatal_Error;
+ if not NS_Found then
+ No_Normalize_Scalars_Specified := True;
end if;
- end loop;
- if not NS_Found then
- No_Normalize_Scalars_Specified := True;
+ Skip_Eol;
end if;
- Skip_Eol;
+ C := Getc;
-- Acquire restrictions line
- if Getc /= 'R' then
+ if C /= 'R' then
Fatal_Error;
+ elsif Ignore ('R') then
+ Skip_Line;
+
else
Checkc (' ');
Skip_Space;
@@ -666,17 +797,48 @@ package body ALI is
end case;
end loop;
- if At_Eol then
- Skip_Eol;
- C := Getc;
+ Skip_Eol;
+ end if;
+
+ C := Getc;
+
+ -- Acquire 'I' lines if present
+
+ while C = 'I' loop
+ if Ignore ('I') then
+ Skip_Line;
+
else
- Fatal_Error;
+ declare
+ Int_Num : Nat;
+ I_State : Character;
+ Line_No : Nat;
+
+ begin
+ Int_Num := Get_Nat;
+ Skip_Space;
+ I_State := Getc;
+ Line_No := Get_Nat;
+
+ Interrupt_States.Append (
+ (Interrupt_Id => Int_Num,
+ Interrupt_State => I_State,
+ IS_Pragma_Line => Line_No));
+
+ ALIs.Table (Id).Last_Interrupt_State := Interrupt_States.Last;
+ Skip_Eol;
+ end;
end if;
- end if;
+
+ C := Getc;
+ end loop;
-- Loop to acquire unit entries
Unit_Loop : while C = 'U' loop
+
+ -- Note: as per spec, we never ignore U lines
+
Checkc (' ');
Skip_Space;
Units.Increment_Last;
@@ -708,6 +870,7 @@ package body ALI is
Units.Table (Units.Last).First_With := Withs.Last + 1;
Units.Table (Units.Last).First_Arg := First_Arg;
Units.Table (Units.Last).Elab_Position := 0;
+ Units.Table (Units.Last).Interface := ALIs.Table (Id).Interface;
if Debug_Flag_U then
Write_Str (" ----> reading unit ");
@@ -790,6 +953,13 @@ package body ALI is
Units.Table (Units.Last).Version (J) := C;
end loop;
+ -- BN parameter (Body needed)
+
+ elsif C = 'B' then
+ Checkc ('N');
+ Check_At_End_Of_Field;
+ Units.Table (Units.Last).Body_Needed_For_SAL := True;
+
-- DE parameter (Dynamic elaboration checks
elsif C = 'D' then
@@ -941,7 +1111,6 @@ package body ALI is
else
Fatal_Error;
end if;
-
end loop;
Skip_Eol;
@@ -954,64 +1123,71 @@ package body ALI is
Static_Elaboration_Model_Used := True;
end if;
- -- Scan out With lines for this unit
-
C := Getc;
- With_Loop : while C = 'W' loop
- Checkc (' ');
- Skip_Space;
- Withs.Increment_Last;
- Withs.Table (Withs.Last).Uname := Get_Name;
- Withs.Table (Withs.Last).Elaborate := False;
- Withs.Table (Withs.Last).Elaborate_All := False;
- Withs.Table (Withs.Last).Elab_All_Desirable := False;
+ -- Scan out With lines for this unit
- -- Generic case with no object file available
+ With_Loop : while C = 'W' loop
+ if Ignore ('W') then
+ Skip_Line;
- if At_Eol then
- Withs.Table (Withs.Last).Sfile := No_File;
- Withs.Table (Withs.Last).Afile := No_File;
+ else
+ Checkc (' ');
+ Skip_Space;
+ Withs.Increment_Last;
+ Withs.Table (Withs.Last).Uname := Get_Name;
+ Withs.Table (Withs.Last).Elaborate := False;
+ Withs.Table (Withs.Last).Elaborate_All := False;
+ Withs.Table (Withs.Last).Elab_All_Desirable := False;
+ Withs.Table (Withs.Last).Interface := False;
- -- Normal case
+ -- Generic case with no object file available
- else
- Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True);
- Withs.Table (Withs.Last).Afile := Get_Name;
+ if At_Eol then
+ Withs.Table (Withs.Last).Sfile := No_File;
+ Withs.Table (Withs.Last).Afile := No_File;
- -- Scan out possible E, EA, and NE parameters
+ -- Normal case
- while not At_Eol loop
- Skip_Space;
+ else
+ Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True);
+ Withs.Table (Withs.Last).Afile := Get_Name;
- if Nextc = 'E' then
- P := P + 1;
+ -- Scan out possible E, EA, and NE parameters
- if At_End_Of_Field then
- Withs.Table (Withs.Last).Elaborate := True;
+ while not At_Eol loop
+ Skip_Space;
- elsif Nextc = 'A' then
+ if Nextc = 'E' then
P := P + 1;
- Check_At_End_Of_Field;
- Withs.Table (Withs.Last).Elaborate_All := True;
- else
- Checkc ('D');
- Check_At_End_Of_Field;
+ if At_End_Of_Field then
+ Withs.Table (Withs.Last).Elaborate := True;
- -- Store ED indication unless ignore required
+ elsif Nextc = 'A' then
+ P := P + 1;
+ Check_At_End_Of_Field;
+ Withs.Table (Withs.Last).Elaborate_All := True;
+
+ else
+ Checkc ('D');
+ Check_At_End_Of_Field;
- if not Ignore_ED then
- Withs.Table (Withs.Last).Elab_All_Desirable := True;
+ -- Store ED indication unless ignore required
+
+ if not Ignore_ED then
+ Withs.Table (Withs.Last).Elab_All_Desirable :=
+ True;
+ end if;
end if;
end if;
- end if;
- end loop;
+ end loop;
+ end if;
+
+ Skip_Eol;
end if;
- Skip_Eol;
C := Getc;
-
end loop With_Loop;
Units.Table (Units.Last).Last_With := Withs.Last;
@@ -1022,64 +1198,72 @@ package body ALI is
Name_Len := 0;
Linker_Options_Loop : while C = 'L' loop
- Checkc (' ');
- Skip_Space;
- Checkc ('"');
-
- loop
- C := Getc;
-
- if C < Character'Val (16#20#)
- or else C > Character'Val (16#7E#)
- then
- Fatal_Error;
- elsif C = '{' then
- C := Character'Val (0);
+ if Ignore ('L') then
+ Skip_Line;
- declare
- V : Natural;
+ else
+ Checkc (' ');
+ Skip_Space;
+ Checkc ('"');
- begin
- V := 0;
- for J in 1 .. 2 loop
- C := Getc;
+ loop
+ C := Getc;
- if C in '0' .. '9' then
- V := V * 16 +
- Character'Pos (C) - Character'Pos ('0');
+ if C < Character'Val (16#20#)
+ or else C > Character'Val (16#7E#)
+ then
+ Fatal_Error;
- elsif C in 'A' .. 'F' then
- V := V * 16 +
- Character'Pos (C) - Character'Pos ('A') + 10;
+ elsif C = '{' then
+ C := Character'Val (0);
- else
- Fatal_Error;
- end if;
- end loop;
+ declare
+ V : Natural;
- Checkc ('}');
+ begin
+ V := 0;
+ for J in 1 .. 2 loop
+ C := Getc;
+
+ if C in '0' .. '9' then
+ V := V * 16 +
+ Character'Pos (C) -
+ Character'Pos ('0');
+
+ elsif C in 'A' .. 'F' then
+ V := V * 16 +
+ Character'Pos (C) -
+ Character'Pos ('A') +
+ 10;
+
+ else
+ Fatal_Error;
+ end if;
+ end loop;
+
+ Checkc ('}');
+ Add_Char_To_Name_Buffer (Character'Val (V));
+ end;
- Add_Char_To_Name_Buffer (Character'Val (V));
- end;
+ else
+ if C = '"' then
+ exit when Nextc /= '"';
+ C := Getc;
+ end if;
- else
- if C = '"' then
- exit when Nextc /= '"';
- C := Getc;
+ Add_Char_To_Name_Buffer (C);
end if;
+ end loop;
- Add_Char_To_Name_Buffer (C);
- end if;
- end loop;
-
- Add_Char_To_Name_Buffer (nul);
+ Add_Char_To_Name_Buffer (nul);
+ Skip_Eol;
+ end if;
- Skip_Eol;
C := Getc;
end loop Linker_Options_Loop;
- -- Store the linker options entry
+ -- Store the linker options entry if one was found
if Name_Len /= 0 then
Linker_Options.Increment_Last;
@@ -1126,24 +1310,30 @@ package body ALI is
-- Scan out external version references and put in hash table
while C = 'E' loop
- Checkc (' ');
- Skip_Space;
+ if Ignore ('E') then
+ Skip_Line;
- Name_Len := 0;
- Name_Len := 0;
- loop
- C := Getc;
+ else
+ Checkc (' ');
+ Skip_Space;
- if C < ' ' then
- Fatal_Error;
- end if;
+ Name_Len := 0;
+ Name_Len := 0;
+ loop
+ C := Getc;
- exit when At_End_Of_Field;
- Add_Char_To_Name_Buffer (C);
- end loop;
+ if C < ' ' then
+ Fatal_Error;
+ end if;
+
+ exit when At_End_Of_Field;
+ Add_Char_To_Name_Buffer (C);
+ end loop;
+
+ Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
+ Skip_Eol;
+ end if;
- Version_Ref.Set (new String'(Name_Buffer (1 .. Name_Len)), True);
- Skip_Eol;
C := Getc;
end loop;
@@ -1152,101 +1342,121 @@ package body ALI is
ALIs.Table (Id).First_Sdep := Sdep.Last + 1;
while C = 'D' loop
- Checkc (' ');
- Skip_Space;
- Sdep.Increment_Last;
- Sdep.Table (Sdep.Last).Sfile := Get_Name (Lower => True);
- Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
- Sdep.Table (Sdep.Last).Dummy_Entry :=
- (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
+ if Ignore ('D') then
+ Skip_Line;
- -- Acquire checksum value
+ else
+ Checkc (' ');
+ Skip_Space;
+ Sdep.Increment_Last;
+ Sdep.Table (Sdep.Last).Sfile := Get_Name (Lower => True);
+ Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
+ Sdep.Table (Sdep.Last).Dummy_Entry :=
+ (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
- Skip_Space;
+ -- Acquire checksum value
- declare
- Ctr : Natural;
- Chk : Word;
+ Skip_Space;
- begin
- Ctr := 0;
- Chk := 0;
+ declare
+ Ctr : Natural;
+ Chk : Word;
- loop
- exit when At_Eol or else Ctr = 8;
+ begin
+ Ctr := 0;
+ Chk := 0;
- if Nextc in '0' .. '9' then
- Chk := Chk * 16 +
- Character'Pos (Nextc) - Character'Pos ('0');
+ loop
+ exit when At_Eol or else Ctr = 8;
- elsif Nextc in 'a' .. 'f' then
- Chk := Chk * 16 +
- Character'Pos (Nextc) - Character'Pos ('a') + 10;
+ if Nextc in '0' .. '9' then
+ Chk := Chk * 16 +
+ Character'Pos (Nextc) - Character'Pos ('0');
- else
- exit;
- end if;
+ elsif Nextc in 'a' .. 'f' then
+ Chk := Chk * 16 +
+ Character'Pos (Nextc) - Character'Pos ('a') + 10;
- Ctr := Ctr + 1;
- P := P + 1;
- end loop;
+ else
+ exit;
+ end if;
- if Ctr = 8 and then At_End_Of_Field then
- Sdep.Table (Sdep.Last).Checksum := Chk;
- else
- Fatal_Error;
- end if;
- end;
+ Ctr := Ctr + 1;
+ P := P + 1;
+ end loop;
- -- Acquire subunit and reference file name entries
+ if Ctr = 8 and then At_End_Of_Field then
+ Sdep.Table (Sdep.Last).Checksum := Chk;
+ else
+ Fatal_Error;
+ end if;
+ end;
- Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
- Sdep.Table (Sdep.Last).Rfile := Sdep.Table (Sdep.Last).Sfile;
- Sdep.Table (Sdep.Last).Start_Line := 1;
+ -- Acquire subunit and reference file name entries
- if not At_Eol then
- Skip_Space;
+ Sdep.Table (Sdep.Last).Subunit_Name := No_Name;
+ Sdep.Table (Sdep.Last).Rfile :=
+ Sdep.Table (Sdep.Last).Sfile;
+ Sdep.Table (Sdep.Last).Start_Line := 1;
- -- Here for subunit name
+ if not At_Eol then
+ Skip_Space;
- if Nextc not in '0' .. '9' then
- Name_Len := 0;
+ -- Here for subunit name
- while not At_End_Of_Field loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Getc;
- end loop;
+ if Nextc not in '0' .. '9' then
+ Name_Len := 0;
- Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter;
- Skip_Space;
- end if;
+ while not At_End_Of_Field loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Getc;
+ end loop;
- -- Here for reference file name entry
+ Sdep.Table (Sdep.Last).Subunit_Name := Name_Enter;
+ Skip_Space;
+ end if;
- if Nextc in '0' .. '9' then
- Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
- Checkc (':');
+ -- Here for reference file name entry
- Name_Len := 0;
+ if Nextc in '0' .. '9' then
+ Sdep.Table (Sdep.Last).Start_Line := Get_Nat;
+ Checkc (':');
- while not At_End_Of_Field loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Getc;
- end loop;
+ Name_Len := 0;
+
+ while not At_End_Of_Field loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Getc;
+ end loop;
- Sdep.Table (Sdep.Last).Rfile := Name_Enter;
+ Sdep.Table (Sdep.Last).Rfile := Name_Enter;
+ end if;
end if;
+
+ Skip_Eol;
end if;
- Skip_Eol;
C := Getc;
end loop;
ALIs.Table (Id).Last_Sdep := Sdep.Last;
- -- Loop through Xref sections (skip loop if not reading xref stuff)
+ -- We must at this stage be at an Xref line or the end of file
- while Read_Xref and then C = 'X' loop
+ if C /= EOF and then C /= 'X' then
+ Fatal_Error;
+ end if;
+
+ -- If we are ignoring Xref sections we are done (we ignore all
+ -- remaining lines since only xref related lines follow X).
+
+ if Ignore ('X') and then not Debug_Flag_X then
+ return Id;
+ end if;
+
+ -- Loop through Xref sections
+
+ while C = 'X' loop
-- Make new entry in section table
@@ -1266,6 +1476,8 @@ package body ALI is
Current_File_Num := XS.File_Num;
+ Skip_Space;
+
Skip_Eol;
C := Nextc;
@@ -1339,6 +1551,8 @@ package body ALI is
XE.Lib := (Getc = '*');
XE.Entity := Get_Name;
+ Current_File_Num := XS.File_Num;
+
-- Renaming reference is present
if Nextc = '=' then
@@ -1379,7 +1593,8 @@ package body ALI is
XE.Tref_Line := 0;
XE.Tref_Type := ' ';
XE.Tref_Col := 0;
- XE.Tref_Standard_Entity := Get_Name;
+ XE.Tref_Standard_Entity :=
+ Get_Name (Ignore_Spaces => True);
else
N := Get_Nat;
@@ -1400,6 +1615,31 @@ package body ALI is
XE.Tref_Standard_Entity := No_Name;
end if;
+ -- ??? Temporary workaround for nested generics case:
+ -- 4i4 Directories{1|4I9[4|6[3|3]]}
+ -- See C918-002
+
+ declare
+ Nested_Brackets : Natural := 0;
+ C : Character;
+
+ begin
+ loop
+ case Nextc is
+ when '[' =>
+ Nested_Brackets := Nested_Brackets + 1;
+ when ']' =>
+ Nested_Brackets := Nested_Brackets - 1;
+ when others =>
+ if Nested_Brackets = 0 then
+ exit;
+ end if;
+ end case;
+
+ C := Getc;
+ end loop;
+ end;
+
P := P + 1; -- skip closing bracket
Skip_Space;
@@ -1417,8 +1657,6 @@ package body ALI is
-- Loop through cross-references for this entity
- Current_File_Num := XS.File_Num;
-
loop
Skip_Space;
@@ -1449,6 +1687,17 @@ package body ALI is
XR.Line := N;
XR.Rtype := Getc;
+
+ -- Imported entities reference as in:
+ -- 494b<c,__gnat_copy_attribs>25
+ -- ??? Simply skipped for now
+
+ if Nextc = '<' then
+ while Getc /= '>' loop
+ null;
+ end loop;
+ end if;
+
XR.Col := Get_Nat;
if Nextc = '[' then
diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads
index 1de7b4582e8..24f8d04725c 100644
--- a/gcc/ada/ali.ads
+++ b/gcc/ada/ali.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -64,6 +64,9 @@ package ALI is
type Source_Id is range 5_000_000 .. 5_999_999;
-- Id values used for Source table entries
+ type Interrupt_State_Id is range 6_000_000 .. 6_999_999;
+ -- Id values used for Interrupt_State table entries
+
--------------------
-- ALI File Table --
--------------------
@@ -96,10 +99,15 @@ package ALI is
-- this ALI file, since the body if present is always first).
Ver : String (1 .. Ver_Len_Max);
- -- Value of library version (V line in ALI file)
+ -- Value of library version (V line in ALI file). Not set if
+ -- V lines are ignored as a result of the Ignore_Lines parameter.
Ver_Len : Natural;
- -- Length of characters stored in Ver
+ -- Length of characters stored in Ver. Not set if V lines are
+ -- ignored as a result of the Ignore_Lines parameter.
+
+ Interface : Boolean;
+ -- Set True when this is an interface to a standalone library
First_Unit : Unit_Id;
-- Id of first Unit table entry for this file
@@ -114,63 +122,83 @@ package ALI is
-- Id of last Sdep table entry for this file
Main_Program : Main_Program_Type;
- -- Indicator of whether first unit can be used as main program
+ -- Indicator of whether first unit can be used as main program.
+ -- Not set if 'M' appears in Ignore_Lines.
Main_Priority : Int;
-- Indicates priority value if Main_Program field indicates that
-- this can be a main program. A value of -1 (No_Main_Priority)
-- indicates that no parameter was found, or no M line was present.
+ -- Not set if 'M' appears in Ignore_Lines.
Time_Slice_Value : Int;
-- Indicates value of time slice parameter from T=xxx on main program
-- line. A value of -1 indicates that no T=xxx parameter was found,
-- or no M line was present.
+ -- Not set if 'M' appears in Ignore_Lines.
WC_Encoding : Character;
-- Wide character encoding if main procedure. Otherwise not relevant.
+ -- Not set if 'M' appears in Ignore_Lines.
Locking_Policy : Character;
-- Indicates locking policy for units in this file. Space means
-- tasking was not used, or that no Locking_Policy pragma was
-- present or that this is a language defined unit. Otherwise set
-- to first character (upper case) of policy name.
+ -- Not set if 'P' appears in Ignore_Lines.
Queuing_Policy : Character;
-- Indicates queuing policy for units in this file. Space means
-- tasking was not used, or that no Queuing_Policy pragma was
-- present or that this is a language defined unit. Otherwise set
-- to first character (upper case) of policy name.
+ -- Not set if 'P' appears in Ignore_Lines.
Task_Dispatching_Policy : Character;
-- Indicates task dispatching policy for units in this file. Space
-- means tasking was not used, or that no Task_Dispatching_Policy
-- pragma was present or that this is a language defined unit.
-- Otherwise set to first character (upper case) of policy name.
+ -- Not set if 'P' appears in Ignore_Lines.
Compile_Errors : Boolean;
-- Set to True if compile errors for unit. Note that No_Object
-- will always be set as well in this case.
+ -- Not set if 'P' appears in Ignore_Lines.
Float_Format : Character;
- -- Set to float format (set to I if no float-format given)
+ -- Set to float format (set to I if no float-format given).
+ -- Not set if 'P' appears in Ignore_Lines.
No_Object : Boolean;
- -- Set to True if no object file generated
-
- No_Run_Time : Boolean;
- -- Set to True if file was compiled with pragma No_Run_Time
+ -- Set to True if no object file generated.
+ -- Not set if 'P' appears in Ignore_Lines.
Normalize_Scalars : Boolean;
- -- Set to True if file was compiled with Normalize_Scalars
+ -- Set to True if file was compiled with Normalize_Scalars.
+ -- Not set if 'P' appears in Ignore_Lines.
Unit_Exception_Table : Boolean;
- -- Set to True if unit exception table pointer generated
+ -- Set to True if unit exception table pointer generated.
+ -- Not set if 'P' appears in Ignore_Lines.
Zero_Cost_Exceptions : Boolean;
- -- Set to True if file was compiled with zero cost exceptions
+ -- Set to True if file was compiled with zero cost exceptions.
+ -- Not set if 'P' appears in Ignore_Lines.
Restrictions : Restrictions_String;
- -- Copy of restrictions letters from R line
+ -- Copy of restrictions letters from R line.
+ -- Not set if 'R' appears in Ignore_Lines.
+
+ First_Interrupt_State : Interrupt_State_Id;
+ Last_Interrupt_State : Interrupt_State_Id'Base;
+ -- These point to the first and last entries in the interrupt
+ -- state table for this unit. If there are no entries, then
+ -- Last_Interrupt_State = First_Interrupt_State - 1 (that's
+ -- why the 'Base reference is there, it can be one less than
+ -- the lower bound of the subtype).
+ -- Not set if 'I' appears in Ignore_Lines
end record;
@@ -308,6 +336,12 @@ package ALI is
-- Set True if IS qualifier appears in ALI file, indicating that
-- an Initialize_Scalars pragma applies to the unit.
+ Interface : Boolean;
+ -- Set True when this is an interface to a standalone library
+
+ Body_Needed_For_SAL : Boolean;
+ -- Indicates that the source for the body of the unit (subprogram,
+ -- package, or generic unit) must be included in a standalone library.
end record;
package Units is new Table.Table (
@@ -318,6 +352,34 @@ package ALI is
Table_Increment => 200,
Table_Name => "Unit");
+ ---------------------------
+ -- Interrupt State Table --
+ ---------------------------
+
+ -- An entry is made in this table for each I (interrupt state) line
+ -- encountered in the input ALI file. The First/Last_Interrupt_Id
+ -- fields of the ALI file entry show the range of entries defined
+ -- within a particular ALI file.
+
+ type Interrupt_State_Record is record
+ Interrupt_Id : Nat;
+ -- Id from interrupt state entry
+
+ Interrupt_State : Character;
+ -- State from interrupt state entry ('u'/'r'/'s')
+
+ IS_Pragma_Line : Nat;
+ -- Line number of Interrupt_State pragma
+ end record;
+
+ package Interrupt_States is new Table.Table (
+ Table_Component_Type => Interrupt_State_Record,
+ Table_Index_Type => Interrupt_State_Id'Base,
+ Table_Low_Bound => Interrupt_State_Id'First,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "Interrupt_States");
+
--------------
-- Switches --
--------------
@@ -325,8 +387,11 @@ package ALI is
-- These switches record status information about ali files that
-- have been read, for quick reference without searching tables.
+ -- Note: a switch will be left set at its default value if the line
+ -- which might otherwise set it is ignored (from Ignore_Lines).
+
Dynamic_Elaboration_Checks_Specified : Boolean := False;
- -- Set to False by Initialize_ALI. Set to True if Read_ALI reads
+ -- Set to False by Initialize_ALI. Set to True if Scan_ALI reads
-- a unit for which dynamic elaboration checking is enabled.
Float_Format_Specified : Character := ' ';
@@ -353,10 +418,6 @@ package ALI is
-- Set to False by Initialize_ALI. Set to True if an ali file indicates
-- that the file was compiled in Normalize_Scalars mode.
- No_Run_Time_Specified : Boolean := False;
- -- Set to False by Initialize_ALI, Set to True if an ali file indicates
- -- that the file was compiled in No_Run_Time mode.
-
Queuing_Policy_Specified : Character := ' ';
-- Set to blank by Initialize_ALI. Set to the appropriate queuing policy
-- character if an ali file contains a P line setting the queuing policy.
@@ -391,6 +452,8 @@ package ALI is
-- Each With line (W line) in an ALI file generates a Withs table entry
+ -- Note: there will be no entries in this table if 'W' lines are ignored
+
No_With_Id : constant With_Id := With_Id'First;
-- Special value indicating no withs table entry
@@ -417,6 +480,9 @@ package ALI is
Elab_All_Desirable : Boolean;
-- Indicates presence of ED parameter
+ Interface : Boolean := False;
+ -- True if the Unit is an Interface of a Stand-Alole Library
+
end record;
package Withs is new Table.Table (
@@ -433,6 +499,8 @@ package ALI is
-- Each Arg line (A line) in an ALI file generates an Args table entry
+ -- Note: there will be no entries in this table if 'A' lines are ignored
+
No_Arg_Id : constant Arg_Id := Arg_Id'First;
-- Special value indicating no args table entry
@@ -457,6 +525,8 @@ package ALI is
-- to form the entry in this table, using a NUL character as the
-- separator, and a final NUL character is appended to the end.
+ -- Note: there will be no entries in this table if 'L' lines are ignored
+
type Linker_Option_Record is record
Name : Name_Id;
-- Name entry containing concatenated list of Linker_Options
@@ -497,6 +567,8 @@ package ALI is
-- as read from E lines in the ali file. The stored values do not
-- include the terminating quote characters.
+ -- Note: there will be no entries in this table if 'E' lines are ignored
+
type Vindex is range 0 .. 98;
-- Type to define range of headers
@@ -521,6 +593,8 @@ package ALI is
-- Each source dependency (D line) in an ALI file generates an
-- entry in the Sdep table.
+ -- Note: there will be no entries in this table if 'D' lines are ignored
+
No_Sdep_Id : constant Sdep_Id := Sdep_Id'First;
-- Special value indicating no Sdep table entry
@@ -584,8 +658,8 @@ package ALI is
-- The following table records cross-reference sections, there is one
-- entry for each X header line in the ALI file for an xref section.
- -- Note that there will be no entries in this table if the Read_Xref
- -- parameter to Scan_ALI was set to False.
+
+ -- Note: there will be no entries in this table if 'X' lines are ignored
type Xref_Section_Record is record
File_Num : Sdep_Id;
@@ -599,7 +673,6 @@ package ALI is
Last_Entity : Nat;
-- Last entry in Xref_Entity table
-
end record;
package Xref_Section is new Table.Table (
@@ -627,7 +700,7 @@ package ALI is
Etype : Character;
-- Set to the identification character for the entity. See section
- -- "Cross-Reference Entity Identifiers in lib-xref.ads for details.
+ -- "Cross-Reference Entity Identifiers" in lib-xref.ads for details.
Col : Pos;
-- Column number of definition
@@ -665,7 +738,7 @@ package ALI is
-- This field is set to blank if no typeref is present, or if the
-- typeref refers to an entity in standard. Otherwise it contains
-- the identification character for the typeref entity. See section
- -- "Cross-Reference Entity Identifiers in lib-xref.ads for details.
+ -- "Cross-Reference Entity Identifiers" in lib-xref.ads for details.
Tref_Col : Nat;
-- This field is set to zero if no typeref is present, or if the
@@ -740,12 +813,14 @@ package ALI is
-- Initialize the ALI tables. Also resets all switch values to defaults.
function Scan_ALI
- (F : File_Name_Type;
- T : Text_Buffer_Ptr;
- Ignore_ED : Boolean;
- Err : Boolean;
- Read_Xref : Boolean := False)
- return ALI_Id;
+ (F : File_Name_Type;
+ T : Text_Buffer_Ptr;
+ Ignore_ED : Boolean;
+ Err : Boolean;
+ Read_Xref : Boolean := False;
+ Read_Lines : String := "";
+ Ignore_Lines : String := "X")
+ return ALI_Id;
-- Given the text, T, of an ALI file, F, scan and store the information
-- from the file, and return the Id of the resulting entry in the ALI
-- table. Switch settings may be modified as described above in the
@@ -760,8 +835,30 @@ package ALI is
-- is terminated. If Err is True, then no error message is output,
-- and No_ALI_Id is returned.
--
+ -- Ignore_Lines requests that Scan_ALI ignore any lines that start
+ -- with any given key character. The default value of X causes all
+ -- Xref lines to be ignored. The corresponding data in the ALI
+ -- tables will not be filled in in this case. It is not possible
+ -- to ignore U (unit) lines, they are always read.
+ --
+ -- Read_Lines requests that Scan_ALI process only lines that start
+ -- with one of the given characters. The corresponding data in the
+ -- ALI file for any characters not given in the list will not be
+ -- set. The default value of the null string indicates that all
+ -- lines should be read (unless Ignore_Lines is specified). U
+ -- (unit) lines are always read regardless of the value of this
+ -- parameter.
+ --
+ -- Note: either Ignore_Lines or Read_Lines should be non-null.
+ -- but not both. If both are given then only the Read_Lines
+ -- value is processed, and the Ignore_Lines parameter is
+ -- not processed.
+ --
-- Read_XREF is set True to read and acquire the cross-reference
- -- information, otherwise the scan is terminated when a cross-
- -- reference line is encountered.
+ -- information. If Read_XREF is set to True, then the effect is
+ -- to ignore all lines other than U, W, D and X lines and the
+ -- Ignore_Lines and Read_Lines parameters are ignored (i.e. the
+ -- use of True for Read_XREF is equivalent to specifying an
+ -- argument of "UWDX" for Read_Lines.
end ALI;
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 8cabfd136db..e27a63fa445 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -511,7 +511,6 @@ package body Atree is
return NL;
end if;
-
end Copy_List;
-------------------
@@ -664,7 +663,6 @@ package body Atree is
Delete_Field (Field3 (Node));
Delete_Field (Field4 (Node));
Delete_Field (Field5 (Node));
-
end Delete_Tree;
-----------
@@ -811,7 +809,6 @@ package body Atree is
then
Set_Parent (List_Id (Field), New_Node);
end if;
-
end Fix_Parent;
-----------------------------------
@@ -838,8 +835,12 @@ package body Atree is
procedure Initialize is
Dummy : Node_Id;
+ pragma Warnings (Off, Dummy);
begin
+ Atree_Private_Part.Nodes.Init;
+ Orig_Nodes.Init;
+
-- Allocate Empty node
Dummy := New_Node (N_Empty, No_Location);
@@ -1383,7 +1384,10 @@ package body Atree is
else
E := First_Elmt (Actual_Map);
while Present (E) loop
- if Old_Node = Associated_Node_For_Itype (Node (E)) then
+ if Is_Itype (Node (E))
+ and then
+ Old_Node = Associated_Node_For_Itype (Node (E))
+ then
Set_Associated_Node_For_Itype
(Node (Next_Elmt (E)), New_Node);
end if;
@@ -1590,7 +1594,7 @@ package body Atree is
Set_Associated_Node_For_Itype (Ent, New_Itype);
end if;
- -- Csae of hash tables not used
+ -- Case of hash tables not used
else
E := First_Elmt (Actual_Map);
@@ -1600,7 +1604,10 @@ package body Atree is
(New_Itype, Node (Next_Elmt (E)));
end if;
- if Old_Itype = Associated_Node_For_Itype (Node (E)) then
+ if Is_Type (Node (E))
+ and then
+ Old_Itype = Associated_Node_For_Itype (Node (E))
+ then
Set_Associated_Node_For_Itype
(Node (Next_Elmt (E)), New_Itype);
end if;
@@ -1813,9 +1820,15 @@ package body Atree is
New_Sloc : Source_Ptr)
return Entity_Id
is
+ Ent : Entity_Id;
+
procedure New_Entity_Debugging_Output;
-- Debugging routine for debug flag N
+ ---------------------------------
+ -- New_Entity_Debugging_Output --
+ ---------------------------------
+
procedure New_Entity_Debugging_Output is
begin
if Debug_Flag_N then
@@ -1837,7 +1850,16 @@ package body Atree is
pragma Assert (New_Node_Kind in N_Entity);
Nodes.Increment_Last;
- Current_Error_Node := Nodes.Last;
+ Ent := Nodes.Last;
+
+ -- If this is a node with a real location and we are generating
+ -- source nodes, then reset Current_Error_Node. This is useful
+ -- if we bomb during parsing to get a error location for the bomb.
+
+ if Default_Node.Comes_From_Source and then New_Sloc > No_Location then
+ Current_Error_Node := Ent;
+ end if;
+
Nodes.Table (Nodes.Last) := Default_Node;
Nodes.Table (Nodes.Last).Nkind := New_Node_Kind;
Nodes.Table (Nodes.Last).Sloc := New_Sloc;
@@ -1858,7 +1880,7 @@ package body Atree is
Orig_Nodes.Set_Last (Nodes.Last);
Allocate_List_Tables (Nodes.Last);
Node_Count := Node_Count + 1;
- return Current_Error_Node;
+ return Ent;
end New_Entity;
--------------
@@ -1870,9 +1892,15 @@ package body Atree is
New_Sloc : Source_Ptr)
return Node_Id
is
+ Nod : Node_Id;
+
procedure New_Node_Debugging_Output;
-- Debugging routine for debug flag N
+ --------------------------
+ -- New_Debugging_Output --
+ --------------------------
+
procedure New_Node_Debugging_Output is
begin
if Debug_Flag_N then
@@ -1897,13 +1925,21 @@ package body Atree is
Nodes.Table (Nodes.Last).Nkind := New_Node_Kind;
Nodes.Table (Nodes.Last).Sloc := New_Sloc;
pragma Debug (New_Node_Debugging_Output);
- Current_Error_Node := Nodes.Last;
- Node_Count := Node_Count + 1;
+ Nod := Nodes.Last;
+ -- If this is a node with a real location and we are generating
+ -- source nodes, then reset Current_Error_Node. This is useful
+ -- if we bomb during parsing to get a error location for the bomb.
+
+ if Default_Node.Comes_From_Source and then New_Sloc > No_Location then
+ Current_Error_Node := Nod;
+ end if;
+
+ Node_Count := Node_Count + 1;
Orig_Nodes.Increment_Last;
Allocate_List_Tables (Nodes.Last);
Orig_Nodes.Table (Nodes.Last) := Nodes.Last;
- return Nodes.Last;
+ return Nod;
end New_Node;
-----------
@@ -2032,6 +2068,14 @@ package body Atree is
-- not get set.
Set_Parent (New_Node, Parent (Source));
+
+ -- If the node being relocated was a rewriting of some original
+ -- node, then the relocated node has the same original node.
+
+ if Orig_Nodes.Table (Source) /= Source then
+ Orig_Nodes.Table (New_Node) := Orig_Nodes.Table (Source);
+ end if;
+
return New_Node;
end Relocate_Node;
@@ -2077,7 +2121,6 @@ package body Atree is
-- Finally delete the source, since it is now copied
Delete_Node (New_Node);
-
end Replace;
-------------
@@ -2126,7 +2169,7 @@ package body Atree is
Sav_Node := Nodes.Last;
Nodes.Table (Sav_Node) := Nodes.Table (Old_Node);
Nodes.Table (Sav_Node).In_List := False;
- Nodes.Table (Sav_Node).Link := Union_Id (Empty);
+ Nodes.Table (Sav_Node).Link := Union_Id (Parent (Old_Node));
Orig_Nodes.Increment_Last;
Allocate_List_Tables (Nodes.Last);
@@ -2152,7 +2195,6 @@ package body Atree is
Fix_Parent (Field3 (Old_Node), New_Node, Old_Node);
Fix_Parent (Field4 (Old_Node), New_Node, Old_Node);
Fix_Parent (Field5 (Old_Node), New_Node, Old_Node);
-
end Rewrite;
------------------
@@ -2281,7 +2323,9 @@ package body Atree is
-- Traverse descendent that is syntactic subtree node
- if Parent (Node_Id (Fld)) = Node then
+ if Parent (Node_Id (Fld)) = Node
+ or else Original_Node (Parent (Node_Id (Fld))) = Node
+ then
return Traverse_Func (Node_Id (Fld));
-- Node that is not a syntactic subtree
@@ -2296,8 +2340,9 @@ package body Atree is
-- Traverse descendent that is a syntactic subtree list
- if Parent (List_Id (Fld)) = Node then
-
+ if Parent (List_Id (Fld)) = Node
+ or else Original_Node (Parent (List_Id (Fld))) = Node
+ then
declare
Elmt : Node_Id := First (List_Id (Fld));
begin
@@ -2374,7 +2419,6 @@ package body Atree is
end if;
end;
end case;
-
end Traverse_Func;
-------------------
@@ -2384,6 +2428,7 @@ package body Atree is
procedure Traverse_Proc (Node : Node_Id) is
function Traverse is new Traverse_Func (Process);
Discard : Traverse_Result;
+ pragma Warnings (Off, Discard);
begin
Discard := Traverse (Node);
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index b9d2b9b26f1..e24d65d5b32 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -148,7 +148,7 @@ package Atree is
-- package in Atree allows for direct untyped accesses in such cases.
-- Flag4 Fifteen Boolean flags (use depends on Nkind and
- -- Flag5 Ekind, as described for Fieldn). Again the access
+ -- Flag5 Ekind, as described for FieldN). Again the access
-- Flag6 is usually via subprograms in Sinfo and Einfo which
-- Flag7 provide high-level synonyms for these flags, and
-- Flag8 contain debugging code that checks that the values
@@ -242,9 +242,9 @@ package Atree is
-- avoid posting related cascaded error messages, and to propagate
-- the error node if necessary.
- -----------------------
+ ------------------------
-- Current_Error_Node --
- -----------------------
+ ------------------------
-- The current error node is a global location indicating the current
-- node that is being processed for the purposes of placing a compiler
@@ -252,7 +252,15 @@ package Atree is
-- just a reasonably accurate best guess. It is used to output the
-- source location in the abort message by Comperr, and also to
-- implement the d3 debugging flag. This is also used by Rtsfind
- -- to generate error messages for No_Run_Time mode.
+ -- to generate error messages for high integrity mode.
+
+ -- There are two ways this gets set. During parsing, when new source
+ -- nodes are being constructed by calls to New_Node and New_Entity,
+ -- either one of these calls sets Current_Error_Node to the newly
+ -- created node. During semantic analysis, this mechanism is not
+ -- used, and instead Current_Error_Node is set by the subprograms in
+ -- Debug_A that mark the start and end of analysis/expansion of a
+ -- node in the tree.
Current_Error_Node : Node_Id;
-- Node to place error messages
@@ -285,7 +293,7 @@ package Atree is
-- A subpackage Atree.Unchecked_Access provides routines for reading and
-- writing the fields defined above (Field1-17, Node1-17, Flag1-88 etc).
- -- These unchecked access routines can be used for untyped traversals. In
+ -- These unchecked access routines can be used for untyped traversals.
-- In addition they are used in the implementations of the Sinfo and
-- Einfo packages. These packages both provide logical synonyms for
-- the generic fields, together with an appropriate set of access routines.
@@ -329,13 +337,17 @@ package Atree is
-- Allocates a completely new node with the given node type and source
-- location values. All other fields are set to their standard defaults:
--
- -- Empty for all Fieldn fields
- -- False for all Flagn fields
+ -- Empty for all FieldN fields
+ -- False for all FlagN fields
--
-- The usual approach is to build a new node using this function and
-- then, using the value returned, use the Set_xxx functions to set
-- fields of the node as required. New_Node can only be used for
-- non-entity nodes, i.e. it never generates an extended node.
+ --
+ -- If we are currently parsing, as indicated by a previous call to
+ -- Set_Comes_From_Source_Default (True), then this call also resets
+ -- the value of Current_Error_Node.
function New_Entity
(New_Node_Kind : Node_Kind;
@@ -347,7 +359,9 @@ package Atree is
procedure Set_Comes_From_Source_Default (Default : Boolean);
-- Sets value of Comes_From_Source flag to be used in all subsequent
-- New_Node and New_Entity calls until another call to this procedure
- -- changes the default.
+ -- changes the default. This value is set True during parsing and
+ -- False during semantic analysis. This is also used to determine
+ -- if New_Node and New_Entity should set Current_Error_Node.
function Get_Comes_From_Source_Default return Boolean;
pragma Inline (Get_Comes_From_Source_Default);
diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb
index 85cabaeaf0c..fd55b9144c7 100644
--- a/gcc/ada/bcheck.adb
+++ b/gcc/ada/bcheck.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- --
@@ -39,18 +39,21 @@ with Types; use Types;
package body Bcheck is
- -- Local subprograms
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
- -- The following checking subprograms make up the parts
- -- of the configuration consistency check.
+ -- The following checking subprograms make up the parts of the
+ -- configuration consistency check.
procedure Check_Consistent_Dynamic_Elaboration_Checking;
procedure Check_Consistent_Floating_Point_Format;
+ procedure Check_Consistent_Interrupt_States;
procedure Check_Consistent_Locking_Policy;
procedure Check_Consistent_Normalize_Scalars;
+ procedure Check_Consistent_Partition_Restrictions;
procedure Check_Consistent_Queuing_Policy;
procedure Check_Consistent_Zero_Cost_Exception_Handling;
- procedure Check_Partition_Restrictions;
procedure Consistency_Error_Msg (Msg : String);
-- Produce an error or a warning message, depending on whether
@@ -81,7 +84,8 @@ package body Bcheck is
Check_Consistent_Normalize_Scalars;
Check_Consistent_Dynamic_Elaboration_Checking;
- Check_Partition_Restrictions;
+ Check_Consistent_Partition_Restrictions;
+ Check_Consistent_Interrupt_States;
end Check_Configuration_Consistency;
---------------------------------------------------
@@ -198,6 +202,82 @@ package body Bcheck is
end loop Find_Format;
end Check_Consistent_Floating_Point_Format;
+ ---------------------------------------
+ -- Check_Consistent_Interrupt_States --
+ ---------------------------------------
+
+ -- The rule is that if the state of a given interrupt is specified
+ -- in more than one unit, it must be specified with a consistent state.
+
+ procedure Check_Consistent_Interrupt_States is
+ Max_Intrup : Nat;
+
+ begin
+ -- If no Interrupt_State entries, nothing to do
+
+ if Interrupt_States.Last < Interrupt_States.First then
+ return;
+ end if;
+
+ -- First find out the maximum interrupt value
+
+ Max_Intrup := 0;
+ for J in Interrupt_States.First .. Interrupt_States.Last loop
+ if Interrupt_States.Table (J).Interrupt_Id > Max_Intrup then
+ Max_Intrup := Interrupt_States.Table (J).Interrupt_Id;
+ end if;
+ end loop;
+
+ -- Now establish tables to be used for consistency checking
+
+ declare
+ Istate : array (0 .. Max_Intrup) of Character := (others => 'n');
+ -- Interrupt state entries, 'u'/'s'/'r' or 'n' to indicate an
+ -- entry that has not been set.
+
+ Afile : array (0 .. Max_Intrup) of ALI_Id;
+ -- ALI file that generated Istate entry for consistency message
+
+ Loc : array (0 .. Max_Intrup) of Nat;
+ -- Line numbers from IS pragma generating Istate entry
+
+ Inum : Nat;
+ -- Interrupt number from entry being tested
+
+ Stat : Character;
+ -- Interrupt state from entry being tested
+
+ Lnum : Nat;
+ -- Line number from entry being tested
+
+ begin
+ for F in ALIs.First .. ALIs.Last loop
+ for K in ALIs.Table (F).First_Interrupt_State ..
+ ALIs.Table (F).Last_Interrupt_State
+ loop
+ Inum := Interrupt_States.Table (K).Interrupt_Id;
+ Stat := Interrupt_States.Table (K).Interrupt_State;
+ Lnum := Interrupt_States.Table (K).IS_Pragma_Line;
+
+ if Istate (Inum) = 'n' then
+ Istate (Inum) := Stat;
+ Afile (Inum) := F;
+ Loc (Inum) := Lnum;
+
+ elsif Istate (Inum) /= Stat then
+ Error_Msg_Name_1 := ALIs.Table (Afile (Inum)).Sfile;
+ Error_Msg_Name_2 := ALIs.Table (F).Sfile;
+ Error_Msg_Nat_1 := Loc (Inum);
+ Error_Msg_Nat_2 := Lnum;
+
+ Consistency_Error_Msg
+ ("inconsistent interrupt states at %:# and %:#");
+ end if;
+ end loop;
+ end loop;
+ end;
+ end Check_Consistent_Interrupt_States;
+
-------------------------------------
-- Check_Consistent_Locking_Policy --
-------------------------------------
@@ -282,69 +362,9 @@ package body Bcheck is
end if;
end Check_Consistent_Normalize_Scalars;
- -------------------------------------
- -- Check_Consistent_Queuing_Policy --
- -------------------------------------
-
- -- The rule is that all files for which the queuing policy is
- -- significant must be compiled with the same setting.
-
- procedure Check_Consistent_Queuing_Policy is
- begin
- -- First search for a unit specifying a policy and then
- -- check all remaining units against it.
-
- Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A1).Queuing_Policy /= ' ' then
- Check_Policy : declare
- Policy : constant Character := ALIs.Table (A1).Queuing_Policy;
- begin
- for A2 in A1 + 1 .. ALIs.Last loop
- if ALIs.Table (A2).Queuing_Policy /= ' '
- and then
- ALIs.Table (A2).Queuing_Policy /= Policy
- then
- Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
- Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
-
- Consistency_Error_Msg
- ("% and % compiled with different queuing policies");
- exit Find_Policy;
- end if;
- end loop;
- end Check_Policy;
-
- exit Find_Policy;
- end if;
- end loop Find_Policy;
- end Check_Consistent_Queuing_Policy;
-
- ---------------------------------------------------
- -- Check_Consistent_Zero_Cost_Exception_Handling --
- ---------------------------------------------------
-
- -- Check consistent zero cost exception handling. The rule is that
- -- all units must have the same exception handling mechanism.
-
- procedure Check_Consistent_Zero_Cost_Exception_Handling is
- begin
- Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop
- if ALIs.Table (A1).Zero_Cost_Exceptions /=
- ALIs.Table (ALIs.First).Zero_Cost_Exceptions
-
- then
- Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
- Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile;
-
- Consistency_Error_Msg ("% and % compiled with different "
- & "exception handling mechanisms");
- end if;
- end loop Check_Mechanism;
- end Check_Consistent_Zero_Cost_Exception_Handling;
-
- ----------------------------------
- -- Check_Partition_Restrictions --
- ----------------------------------
+ ---------------------------------------------
+ -- Check_Consistent_Partition_Restrictions --
+ ---------------------------------------------
-- The rule is that if a restriction is specified in any unit,
-- then all units must obey the restriction. The check applies
@@ -355,8 +375,8 @@ package body Bcheck is
-- a unit specifying that restriction is found, if any.
-- Second, all units are verified against the specified restrictions.
- procedure Check_Partition_Restrictions is
- No_Restriction_List : array (All_Restrictions) of Boolean :=
+ procedure Check_Consistent_Partition_Restrictions is
+ No_Restriction_List : constant array (All_Restrictions) of Boolean :=
(No_Implicit_Conditionals => True,
-- This could modify and pessimize generated code
@@ -470,7 +490,6 @@ package body Bcheck is
declare
S : constant String := Restriction_Id'Image (J);
-
begin
Name_Len := S'Length;
Name_Buffer (1 .. Name_Len) := S;
@@ -483,7 +502,67 @@ package body Bcheck is
end if;
end loop;
end if;
- end Check_Partition_Restrictions;
+ end Check_Consistent_Partition_Restrictions;
+
+ -------------------------------------
+ -- Check_Consistent_Queuing_Policy --
+ -------------------------------------
+
+ -- The rule is that all files for which the queuing policy is
+ -- significant must be compiled with the same setting.
+
+ procedure Check_Consistent_Queuing_Policy is
+ begin
+ -- First search for a unit specifying a policy and then
+ -- check all remaining units against it.
+
+ Find_Policy : for A1 in ALIs.First .. ALIs.Last loop
+ if ALIs.Table (A1).Queuing_Policy /= ' ' then
+ Check_Policy : declare
+ Policy : constant Character := ALIs.Table (A1).Queuing_Policy;
+ begin
+ for A2 in A1 + 1 .. ALIs.Last loop
+ if ALIs.Table (A2).Queuing_Policy /= ' '
+ and then
+ ALIs.Table (A2).Queuing_Policy /= Policy
+ then
+ Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
+
+ Consistency_Error_Msg
+ ("% and % compiled with different queuing policies");
+ exit Find_Policy;
+ end if;
+ end loop;
+ end Check_Policy;
+
+ exit Find_Policy;
+ end if;
+ end loop Find_Policy;
+ end Check_Consistent_Queuing_Policy;
+
+ ---------------------------------------------------
+ -- Check_Consistent_Zero_Cost_Exception_Handling --
+ ---------------------------------------------------
+
+ -- Check consistent zero cost exception handling. The rule is that
+ -- all units must have the same exception handling mechanism.
+
+ procedure Check_Consistent_Zero_Cost_Exception_Handling is
+ begin
+ Check_Mechanism : for A1 in ALIs.First + 1 .. ALIs.Last loop
+ if ALIs.Table (A1).Zero_Cost_Exceptions /=
+ ALIs.Table (ALIs.First).Zero_Cost_Exceptions
+
+ then
+ Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile;
+
+ Consistency_Error_Msg ("% and % compiled with different "
+ & "exception handling mechanisms");
+ end if;
+ end loop Check_Mechanism;
+ end Check_Consistent_Zero_Cost_Exception_Handling;
-----------------------
-- Check_Consistency --
@@ -576,7 +655,22 @@ package body Bcheck is
end if;
else
- if Tolerate_Consistency_Errors then
+ if Osint.Is_Readonly_Library (ALIs.Table (A).Afile) then
+ Error_Msg_Name_2 :=
+ Osint.Find_File ((ALIs.Table (A).Afile), Osint.Library);
+
+ if Tolerate_Consistency_Errors then
+ Error_Msg ("?% should be recompiled");
+ Error_Msg_Name_1 := Error_Msg_Name_2;
+ Error_Msg ("?(% is obsolete and read-only)");
+
+ else
+ Error_Msg ("% must be compiled");
+ Error_Msg_Name_1 := Error_Msg_Name_2;
+ Error_Msg ("(% is obsolete and read-only)");
+ end if;
+
+ elsif Tolerate_Consistency_Errors then
Error_Msg
("?% should be recompiled (% has been modified)");
@@ -587,16 +681,23 @@ package body Bcheck is
if (not Tolerate_Consistency_Errors) and Verbose_Mode then
declare
- Msg : constant String := "file % has time stamp ";
+ Msg : constant String := "% time stamp ";
Buf : String (1 .. Msg'Length + Time_Stamp_Length);
begin
Buf (1 .. Msg'Length) := Msg;
Buf (Msg'Length + 1 .. Buf'Length) :=
String (Source.Table (Src).Stamp);
- Error_Msg_Name_1 := ALIs.Table (A).Sfile;
+ Error_Msg_Name_1 := Sdep.Table (D).Sfile;
Error_Msg (Buf);
+ end;
+ declare
+ Msg : constant String := " conflicts with % timestamp ";
+ Buf : String (1 .. Msg'Length + Time_Stamp_Length);
+
+ begin
+ Buf (1 .. Msg'Length) := Msg;
Buf (Msg'Length + 1 .. Buf'Length) :=
String (Sdep.Table (D).Stamp);
Error_Msg_Name_1 := Sdep.Table (D).Sfile;
diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb
index 9f6e2082f9e..d90c75ee064 100644
--- a/gcc/ada/binde.adb
+++ b/gcc/ada/binde.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -28,6 +28,7 @@ with Binderr; use Binderr;
with Butil; use Butil;
with Debug; use Debug;
with Fname; use Fname;
+with Lib; use Lib;
with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
@@ -765,11 +766,14 @@ package body Binde is
for W in
Units.Table (Before).First_With .. Units.Table (Before).Last_With
loop
- -- Skip if no ALI file for this with, happens with certain
+ -- Skip if this with is an interface to a stand-alone library.
+ -- Skip also if no ALI file for this with, happens with certain
-- specialized generic files that do not get compiled.
- if Withs.Table (W).Afile /= No_File then
-
+ if not Withs.Table (W).Interface
+ and then Withs.Table (W).Afile /= No_File
+ and then Generic_Separately_Compiled (Withs.Table (W).Sfile)
+ then
Elab_All_Links
(Unit_Id_Of (Withs.Table (W).Uname),
After,
@@ -840,7 +844,7 @@ package body Binde is
when Elab_Desirable =>
Error_Msg_Output
- (" reason: Elaborate_All probably needed in unit &",
+ (" reason: implicit Elaborate_All in unit &",
Info => True);
Error_Msg_Output
@@ -1003,100 +1007,113 @@ package body Binde is
for U in Units.First .. Units.Last loop
Cur_Unit := U;
- -- If there is a body and a spec, then spec must be elaborated first
+ -- If this is not an interface to a stand-alone library and
+ -- there is a body and a spec, then spec must be elaborated first
-- Note that the corresponding spec immediately follows the body
- if Units.Table (U).Utype = Is_Body then
+ if not Units.Table (U).Interface
+ and then Units.Table (U).Utype = Is_Body
+ then
Build_Link (Corresponding_Spec (U), U, Spec_First);
end if;
- -- Process WITH references for this unit ignoring generic units
+ -- If this unit is not an interface to a stand-alone library,
+ -- process WITH references for this unit ignoring generic units and
+ -- interfaces to stand-alone libraries.
- for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
- if Withs.Table (W).Sfile /= No_File then
+ if not Units.Table (U).Interface then
+ for
+ W in Units.Table (U).First_With .. Units.Table (U).Last_With
+ loop
+ if Withs.Table (W).Sfile /= No_File
+ and then (not Withs.Table (W).Interface)
+ then
+ -- Check for special case of withing a unit that does not
+ -- exist any more. If the unit was completely missing we
+ -- would already have detected this, but a nasty case arises
+ -- when we have a subprogram body with no spec, and some
+ -- obsolete unit with's a previous (now disappeared) spec.
+
+ if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then
+ Error_Msg_Name_1 := Units.Table (U).Sfile;
+ Error_Msg_Name_2 := Withs.Table (W).Uname;
+ Error_Msg ("% depends on & which no longer exists");
+ goto Next_With;
+ end if;
- -- Check for special case of withing a unit that does not
- -- exist any more. If the unit was completely missing we would
- -- already have detected this, but a nasty case arises when we
- -- have a subprogram body with no spec, and some obsolete unit
- -- with's a previous (now disappeared) spec.
+ Withed_Unit :=
+ Unit_Id (Unit_Id_Of (Withs.Table (W).Uname));
- if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then
- Error_Msg_Name_1 := Units.Table (U).Sfile;
- Error_Msg_Name_2 := Withs.Table (W).Uname;
- Error_Msg ("% depends on & which no longer exists");
- goto Next_With;
- end if;
+ -- Pragma Elaborate_All case, for this we use the recursive
+ -- Elab_All_Links procedure to establish the links.
- Withed_Unit :=
- Unit_Id (Unit_Id_Of (Withs.Table (W).Uname));
+ if Withs.Table (W).Elaborate_All then
- -- Pragma Elaborate_All case, for this we use the recursive
- -- Elab_All_Links procedure to establish the links.
+ -- Reset flags used to stop multiple visits to a given
+ -- node.
- if Withs.Table (W).Elaborate_All then
+ for Uref in UNR.First .. UNR.Last loop
+ UNR.Table (Uref).Visited := False;
+ end loop;
- -- Reset flags used to stop multiple visits to a given node
+ -- Now establish all the links we need
- for Uref in UNR.First .. UNR.Last loop
- UNR.Table (Uref).Visited := False;
- end loop;
+ Elab_All_Links
+ (Withed_Unit, U, Elab_All,
+ Make_Elab_Entry
+ (Withs.Table (W).Uname, No_Elab_All_Link));
- -- Now establish all the links we need
+ -- Elaborate_All_Desirable case, for this we establish
+ -- the same links as above, but with a different reason.
- Elab_All_Links
- (Withed_Unit, U, Elab_All,
- Make_Elab_Entry
- (Withs.Table (W).Uname, No_Elab_All_Link));
+ elsif Withs.Table (W).Elab_All_Desirable then
- -- Elaborate_All_Desirable case, for this we establish the
- -- same links as above, but with a different reason.
+ -- Reset flags used to stop multiple visits to a given
+ -- node.
- elsif Withs.Table (W).Elab_All_Desirable then
+ for Uref in UNR.First .. UNR.Last loop
+ UNR.Table (Uref).Visited := False;
+ end loop;
- -- Reset flags used to stop multiple visits to a given node
+ -- Now establish all the links we need
- for Uref in UNR.First .. UNR.Last loop
- UNR.Table (Uref).Visited := False;
- end loop;
+ Elab_All_Links
+ (Withed_Unit, U, Elab_Desirable,
+ Make_Elab_Entry
+ (Withs.Table (W).Uname, No_Elab_All_Link));
- -- Now establish all the links we need
+ -- Pragma Elaborate case. We must build a link for the
+ -- withed unit itself, and also the corresponding body
+ -- if there is one.
- Elab_All_Links
- (Withed_Unit, U, Elab_Desirable,
- Make_Elab_Entry
- (Withs.Table (W).Uname, No_Elab_All_Link));
+ -- However, skip this processing if there is no ALI file
+ -- for the WITH entry, because this means it is a
+ -- generic (even when we fix the generics so that an ALI
+ -- file is present, we probably still will have no ALI
+ -- file for unchecked and other special cases).
- -- Pragma Elaborate case. We must build a link for the withed
- -- unit itself, and also the corresponding body if there is one
+ elsif Withs.Table (W).Elaborate
+ and then Withs.Table (W).Afile /= No_File
+ then
+ Build_Link (Withed_Unit, U, Withed);
- -- However, skip this processing if there is no ALI file for
- -- the WITH entry, because this means it is a generic (even
- -- when we fix the generics so that an ALI file is present,
- -- we probably still will have no ALI file for unchecked
- -- and other special cases).
+ if Units.Table (Withed_Unit).Utype = Is_Spec then
+ Build_Link
+ (Corresponding_Body (Withed_Unit), U, Elab);
+ end if;
- elsif Withs.Table (W).Elaborate
- and then Withs.Table (W).Afile /= No_File
- then
- Build_Link (Withed_Unit, U, Withed);
+ -- Case of normal WITH with no elaboration pragmas, just
+ -- build the single link to the directly referenced unit
- if Units.Table (Withed_Unit).Utype = Is_Spec then
- Build_Link
- (Corresponding_Body (Withed_Unit), U, Elab);
+ else
+ Build_Link (Withed_Unit, U, Withed);
end if;
-
- -- Case of normal WITH with no elaboration pragmas, just
- -- build the single link to the directly referenced unit
-
- else
- Build_Link (Withed_Unit, U, Withed);
end if;
- end if;
- <<Next_With>>
+ <<Next_With>>
null;
- end loop;
+ end loop;
+ end if;
end loop;
end Gather_Dependencies;
diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb
index 08e4e7755f3..8db6a302ef0 100644
--- a/gcc/ada/bindgen.adb
+++ b/gcc/ada/bindgen.adb
@@ -37,8 +37,10 @@ with Opt; use Opt;
with Osint; use Osint;
with Osint.B; use Osint.B;
with Output; use Output;
+with Rident; use Rident;
+with Table; use Table;
+with Targparm; use Targparm;
with Types; use Types;
-with Sdefault; use Sdefault;
with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
@@ -52,7 +54,7 @@ package body Bindgen is
With_DECGNAT : Boolean := False;
-- Flag which indicates whether the program uses the DECGNAT library
- -- (presence of the unit System.Aux_DEC.DECLIB)
+ -- (presence of the unit DEC).
With_GNARL : Boolean := False;
-- Flag which indicates whether the program uses the GNARL library
@@ -61,6 +63,23 @@ package body Bindgen is
Num_Elab_Calls : Nat := 0;
-- Number of generated calls to elaboration routines
+ ----------------------------------
+ -- Interface_State Pragma Table --
+ ----------------------------------
+
+ -- This table assembles the interface state pragma information from
+ -- all the units in the partition. Note that Bcheck has already checked
+ -- that the information is consistent across partitions. The entries
+ -- in this table are n/u/r/s for not set/user/runtime/system.
+
+ package IS_Pragma_Settings is new Table.Table (
+ Table_Component_Type => Character,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "IS_Pragma_Settings");
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -68,11 +87,6 @@ package body Bindgen is
procedure WBI (Info : String) renames Osint.B.Write_Binder_Info;
-- Convenient shorthand used throughout
- procedure Resolve_Binder_Options;
- -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS
- -- since it tests for a package named "dec" which might cause a conflict
- -- on non-VMS systems.
-
procedure Gen_Adainit_Ada;
-- Generates the Adainit procedure (Ada code case)
@@ -127,10 +141,6 @@ package body Bindgen is
procedure Gen_Output_File_C (Filename : String);
-- Generate output file (C code case)
- procedure Gen_Scalar_Values;
- -- Generates scalar initialization values for -Snn. A single procedure
- -- handles both the Ada and C cases, since there is much common code.
-
procedure Gen_Versions_Ada;
-- Output series of definitions for unit versions (Ada code case)
@@ -146,9 +156,10 @@ package body Bindgen is
function Get_Main_Name return String;
-- This function is used in the Ada main output case to compute the
- -- correct external main program. It is "main" by default, except on
- -- VxWorks where it is the name of the Ada main name without the "_ada".
- -- the -Mname binder option overrides the default with name.
+ -- correct external main program. It is "main" by default, unless the
+ -- flag Use_Ada_Main_Program_Name_On_Target is set, in which case it
+ -- is the name of the Ada main name without the "_ada". This default
+ -- can be overridden explicitly using the -Mname binder switch.
function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
-- Compare linker options, when sorting, first according to
@@ -158,6 +169,15 @@ package body Bindgen is
procedure Move_Linker_Option (From : Natural; To : Natural);
-- Move routine for sorting linker options
+ procedure Public_Version_Warning;
+ -- Emit a warning concerning the use of the Public version under
+ -- certain circumstances. See details in body.
+
+ procedure Resolve_Binder_Options;
+ -- Set the value of With_GNARL and With_DECGNAT. The latter only on VMS
+ -- since it tests for a package named "dec" which might cause a conflict
+ -- on non-VMS systems.
+
procedure Set_Char (C : Character);
-- Set given character in Statement_Buffer at the Last + 1 position
-- and increment Last by one to reflect the stored character.
@@ -167,6 +187,9 @@ package body Bindgen is
-- starting at the Last + 1 position, and updating Last past the value.
-- A minus sign is output for a negative value.
+ procedure Set_IS_Pragma_Table;
+ -- Initializes contents of IS_Pragma_Settings table from ALI table
+
procedure Set_Main_Program_Name;
-- Given the main program name in Name_Buffer (length in Name_Len)
-- generate the name of the routine to be used in the call. The name
@@ -232,8 +255,7 @@ package body Bindgen is
procedure Gen_Adafinal_C is
begin
- WBI ("void " & Ada_Final_Name.all & " (void)");
- WBI ("{");
+ WBI ("void " & Ada_Final_Name.all & " () {");
WBI (" system__standard_library__adafinal ();");
WBI ("}");
WBI ("");
@@ -257,7 +279,7 @@ package body Bindgen is
U : Unit_Record renames Units.Table (Unum);
begin
- if U.Set_Elab_Entity then
+ if U.Set_Elab_Entity and then not U.Interface then
Set_String (" ");
Set_String ("E");
Set_Unit_Number (Unum);
@@ -302,11 +324,11 @@ package body Bindgen is
Write_Statement_Buffer;
- -- Case of No_Run_Time mode. The only global variable that might
- -- be needed (by the Ravenscar profile) is the priority of the
- -- environment. Also no exception tables are needed.
+ -- If the standard library is suppressed, then the only global variable
+ -- that might be needed (by the Ravenscar profile) is the priority of
+ -- the environment. Also no exception tables are needed.
- if No_Run_Time_Specified then
+ if Suppress_Standard_Library_On_Target then
if Main_Priority /= No_Main_Priority then
WBI (" Main_Priority : Integer;");
WBI (" pragma Import (C, Main_Priority," &
@@ -326,7 +348,7 @@ package body Bindgen is
WBI (" null;");
end if;
- -- Normal case (not No_Run_Time mode). The global values are
+ -- Normal case (standard library not suppressed). Global values are
-- assigned using the runtime routine Set_Globals (we have to use
-- the routine call, rather than define the globals in the binder
-- file to deal with cross-library calls in some systems.
@@ -346,6 +368,39 @@ package body Bindgen is
Write_Statement_Buffer;
WBI ("");
+ -- Generate Interrupt_State pragma string
+
+ Set_String (" Interrupt_States : constant String :=");
+ Write_Statement_Buffer;
+
+ declare
+ Col : Natural;
+
+ begin
+ Set_String (" """);
+ Col := 9;
+
+ for J in 0 .. IS_Pragma_Settings.Last loop
+ if Col > 72 then
+ Set_String (""" &");
+ Write_Statement_Buffer;
+ Set_String (" """);
+ Col := 9;
+
+ else
+ Col := Col + 1;
+ end if;
+
+ Set_Char (IS_Pragma_Settings.Table (J));
+ end loop;
+ end;
+
+ Set_String (""";");
+ Write_Statement_Buffer;
+ WBI ("");
+
+ -- Generate spec for Set_Globals procedure
+
WBI (" procedure Set_Globals");
WBI (" (Main_Priority : Integer;");
WBI (" Time_Slice_Value : Integer;");
@@ -354,14 +409,15 @@ package body Bindgen is
WBI (" Queuing_Policy : Character;");
WBI (" Task_Dispatching_Policy : Character;");
WBI (" Restrictions : System.Address;");
+ WBI (" Interrupt_States : System.Address;");
+ WBI (" Num_Interrupt_States : Integer;");
WBI (" Unreserve_All_Interrupts : Integer;");
WBI (" Exception_Tracebacks : Integer;");
WBI (" Zero_Cost_Exceptions : Integer);");
WBI (" pragma Import (C, Set_Globals, ""__gnat_set_globals"");");
-- Import entry point for elaboration time signal handler
- -- installation, and indication of whether it's been called
- -- previously
+ -- installation, and indication of if it's been called previously.
WBI ("");
WBI (" procedure Install_Handler;");
@@ -420,6 +476,14 @@ package body Bindgen is
WBI (" Restrictions => Restrictions'Address,");
+ WBI (" Interrupt_States => " &
+ "Interrupt_States'Address,");
+
+ Set_String (" Num_Interrupt_States => ");
+ Set_Int (IS_Pragma_Settings.Last + 1);
+ Set_Char (',');
+ Write_Statement_Buffer;
+
Set_String (" Unreserve_All_Interrupts => ");
if Unreserve_All_Interrupts_Specified then
@@ -428,7 +492,7 @@ package body Bindgen is
Set_String ("0");
end if;
- Set_String (",");
+ Set_Char (',');
Write_Statement_Buffer;
Set_String (" Exception_Tracebacks => ");
@@ -460,6 +524,21 @@ package body Bindgen is
WBI (" end if;");
end if;
+ -- Generate call to set Initialize_Scalar values if active
+
+ if Initialize_Scalars_Used then
+ WBI ("");
+ Set_String (" System.Scalar_Values.Initialize ('");
+ Set_Char (Initialize_Scalars_Mode1);
+ Set_String ("', '");
+ Set_Char (Initialize_Scalars_Mode2);
+ Set_String ("');");
+ Write_Statement_Buffer;
+ end if;
+
+ -- Generate elaboration calls
+
+ WBI ("");
Gen_Elab_Calls_Ada;
WBI (" end " & Ada_Init_Name.all & ";");
@@ -482,9 +561,8 @@ package body Bindgen is
declare
Unum : constant Unit_Id := Elab_Order.Table (E);
U : Unit_Record renames Units.Table (Unum);
-
begin
- if U.Set_Elab_Entity then
+ if U.Set_Elab_Entity and then not U.Interface then
Set_String (" extern char ");
Get_Name_String (U.Uname);
Set_Unit_Name;
@@ -496,11 +574,11 @@ package body Bindgen is
Write_Statement_Buffer;
- -- No run-time case
+ -- Standard library suppressed
- if No_Run_Time_Specified then
+ if Suppress_Standard_Library_On_Target then
- -- Case of No_Run_Time mode. Set __gl_main_priority if needed
+ -- Case of High_Integrity_Mode mode. Set __gl_main_priority if needed
-- for the Ravenscar profile.
if Main_Priority /= No_Main_Priority then
@@ -510,7 +588,7 @@ package body Bindgen is
Write_Statement_Buffer;
end if;
- -- Normal case (run time present)
+ -- Normal case (standard library not suppressed)
else
-- Generate definition for restrictions string
@@ -524,7 +602,20 @@ package body Bindgen is
Set_String (""";");
Write_Statement_Buffer;
- -- Code for normal case (not in No_Run_Time mode)
+ -- Generate definition for interrupt states string
+
+ Set_String (" const char *interrupt_states = """);
+
+ for J in 0 .. IS_Pragma_Settings.Last loop
+ Set_Char (IS_Pragma_Settings.Table (J));
+ end loop;
+
+ Set_String (""";");
+ Write_Statement_Buffer;
+
+ WBI ("");
+
+ -- Code for normal case (standard library not suppressed)
Gen_Exception_Table_C;
@@ -541,7 +632,7 @@ package body Bindgen is
Set_String (" ");
Set_Int (Main_Priority);
Set_Char (',');
- Tab_To (15);
+ Tab_To (24);
Set_String ("/* Main_Priority */");
Write_Statement_Buffer;
@@ -556,65 +647,80 @@ package body Bindgen is
end if;
Set_Char (',');
- Tab_To (20);
+ Tab_To (24);
Set_String ("/* Time_Slice_Value */");
Write_Statement_Buffer;
Set_String (" '");
Set_Char (ALIs.Table (ALIs.First).WC_Encoding);
Set_String ("',");
- Tab_To (20);
+ Tab_To (24);
Set_String ("/* WC_Encoding */");
Write_Statement_Buffer;
Set_String (" '");
Set_Char (Locking_Policy_Specified);
Set_String ("',");
- Tab_To (20);
+ Tab_To (24);
Set_String ("/* Locking_Policy */");
Write_Statement_Buffer;
Set_String (" '");
Set_Char (Queuing_Policy_Specified);
Set_String ("',");
- Tab_To (20);
+ Tab_To (24);
Set_String ("/* Queuing_Policy */");
Write_Statement_Buffer;
Set_String (" '");
Set_Char (Task_Dispatching_Policy_Specified);
Set_String ("',");
- Tab_To (20);
+ Tab_To (24);
Set_String ("/* Tasking_Dispatching_Policy */");
Write_Statement_Buffer;
Set_String (" ");
Set_String ("restrictions");
Set_String (",");
- Tab_To (20);
- Set_String ("/* Restrictions */");
+ Tab_To (24);
+ Set_String ("/* Restrictions */");
+ Write_Statement_Buffer;
+
+ Set_String (" ");
+ Set_String ("interrupt_states");
+ Set_String (",");
+ Tab_To (24);
+ Set_String ("/* Interrupt_States */");
+ Write_Statement_Buffer;
+
+ Set_String (" ");
+ Set_Int (IS_Pragma_Settings.Last + 1);
+ Set_String (",");
+ Tab_To (24);
+ Set_String ("/* Num_Interrupt_States */");
Write_Statement_Buffer;
Set_String (" ");
Set_Int (Boolean'Pos (Unreserve_All_Interrupts_Specified));
Set_String (",");
- Tab_To (20);
- Set_String ("/* Unreserve_All_Interrupts */");
+ Tab_To (24);
+ Set_String ("/* Unreserve_All_Interrupts */");
Write_Statement_Buffer;
Set_String (" ");
Set_Int (Boolean'Pos (Exception_Tracebacks));
Set_String (",");
- Tab_To (20);
- Set_String ("/* Exception_Tracebacks */");
+ Tab_To (24);
+ Set_String ("/* Exception_Tracebacks */");
Write_Statement_Buffer;
Set_String (" ");
Set_Int (Boolean'Pos (Zero_Cost_Exceptions_Specified));
Set_String (");");
- Tab_To (20);
- Set_String ("/* Zero_Cost_Exceptions */");
+ Tab_To (24);
+ Set_String ("/* Zero_Cost_Exceptions */");
Write_Statement_Buffer;
+ WBI ("");
-- Install elaboration time signal handler
@@ -624,6 +730,20 @@ package body Bindgen is
WBI (" }");
end if;
+ -- Generate call to set Initialize_Scalar values if needed
+
+ if Initialize_Scalars_Used then
+ WBI ("");
+ Set_String (" system__scalar_values__initialize('");
+ Set_Char (Initialize_Scalars_Mode1);
+ Set_String ("', '");
+ Set_Char (Initialize_Scalars_Mode2);
+ Set_String ("');");
+ Write_Statement_Buffer;
+ end if;
+
+ -- Generate elaboration calls
+
WBI ("");
Gen_Elab_Calls_C;
WBI ("}");
@@ -635,7 +755,6 @@ package body Bindgen is
procedure Gen_Elab_Calls_Ada is
begin
-
for E in Elab_Order.First .. Elab_Order.Last loop
declare
Unum : constant Unit_Id := Elab_Order.Table (E);
@@ -666,7 +785,7 @@ package body Bindgen is
-- to True, we do not need to test if this has already been
-- done, since it is quicker to set the flag than to test it.
- if U.Utype = Is_Body
+ if not U.Interface and then U.Utype = Is_Body
and then Units.Table (Unum_Spec).Set_Elab_Entity
then
Set_String (" E");
@@ -675,23 +794,35 @@ package body Bindgen is
Write_Statement_Buffer;
end if;
- -- Here if elaboration code is present. We generate:
+ -- Here if elaboration code is present. If binding a library
+ -- or if there is a non-Ada main subprogram then we generate:
-- if not uname_E then
-- uname'elab_[spec|body];
-- uname_E := True;
-- end if;
+ -- Otherwise, elaboration routines are called unconditionally:
+
+ -- uname'elab_[spec|body];
+ -- uname_E := True;
+
-- The uname_E assignment is skipped if this is a separate spec,
-- since the assignment will be done when we process the body.
- else
- Set_String (" if not E");
- Set_Unit_Number (Unum_Spec);
- Set_String (" then");
- Write_Statement_Buffer;
+ elsif not U.Interface then
+ if Force_Checking_Of_Elaboration_Flags or
+ Interface_Library_Unit or
+ (not Bind_Main_Program)
+ then
+ Set_String (" if not E");
+ Set_Unit_Number (Unum_Spec);
+ Set_String (" then");
+ Write_Statement_Buffer;
+ Set_String (" ");
+ end if;
- Set_String (" ");
+ Set_String (" ");
Get_Decoded_Name_String_With_Brackets (U.Uname);
if Name_Buffer (Name_Len) = 's' then
@@ -707,17 +838,28 @@ package body Bindgen is
Write_Statement_Buffer;
if U.Utype /= Is_Spec then
- Set_String (" E");
+ if Force_Checking_Of_Elaboration_Flags or
+ Interface_Library_Unit or
+ (not Bind_Main_Program)
+ then
+ Set_String (" ");
+ end if;
+
+ Set_String (" E");
Set_Unit_Number (Unum_Spec);
Set_String (" := True;");
Write_Statement_Buffer;
end if;
- WBI (" end if;");
+ if Force_Checking_Of_Elaboration_Flags or
+ Interface_Library_Unit or
+ (not Bind_Main_Program)
+ then
+ WBI (" end if;");
+ end if;
end if;
end;
end loop;
-
end Gen_Elab_Calls_Ada;
----------------------
@@ -757,7 +899,7 @@ package body Bindgen is
-- to True, we do not need to test if this has already been
-- done, since it is quicker to set the flag than to test it.
- if U.Utype = Is_Body
+ if not U.Interface and then U.Utype = Is_Body
and then Units.Table (Unum_Spec).Set_Elab_Entity
then
Set_String (" ");
@@ -767,7 +909,8 @@ package body Bindgen is
Write_Statement_Buffer;
end if;
- -- Here if elaboration code is present. We generate:
+ -- Here if elaboration code is present. If binding a library
+ -- or if there is a non-Ada main subprogram then we generate:
-- if (uname_E == 0) {
-- uname__elab[s|b] ();
@@ -777,14 +920,21 @@ package body Bindgen is
-- The uname_E assignment is skipped if this is a separate spec,
-- since the assignment will be done when we process the body.
- else
- Set_String (" if (");
+ elsif not U.Interface then
Get_Name_String (U.Uname);
- Set_Unit_Name;
- Set_String ("_E == 0) {");
- Write_Statement_Buffer;
- Set_String (" ");
+ if Force_Checking_Of_Elaboration_Flags or
+ Interface_Library_Unit or
+ (not Bind_Main_Program)
+ then
+ Set_String (" if (");
+ Set_Unit_Name;
+ Set_String ("_E == 0) {");
+ Write_Statement_Buffer;
+ Set_String (" ");
+ end if;
+
+ Set_String (" ");
Set_Unit_Name;
Set_String ("___elab");
Set_Char (Name_Buffer (Name_Len)); -- 's' or 'b' for spec/body
@@ -792,13 +942,25 @@ package body Bindgen is
Write_Statement_Buffer;
if U.Utype /= Is_Spec then
- Set_String (" ");
+ if Force_Checking_Of_Elaboration_Flags or
+ Interface_Library_Unit or
+ (not Bind_Main_Program)
+ then
+ Set_String (" ");
+ end if;
+
+ Set_String (" ");
Set_Unit_Name;
Set_String ("_E++;");
Write_Statement_Buffer;
end if;
- WBI (" }");
+ if Force_Checking_Of_Elaboration_Flags or
+ Interface_Library_Unit or
+ (not Bind_Main_Program)
+ then
+ WBI (" }");
+ end if;
end if;
end;
end loop;
@@ -838,16 +1000,16 @@ package body Bindgen is
procedure Gen_Elab_Order_Ada is
begin
WBI ("");
- WBI (" -- BEGIN ELABORATION ORDER");
+ WBI (" -- BEGIN ELABORATION ORDER");
for J in Elab_Order.First .. Elab_Order.Last loop
- Set_String (" -- ");
+ Set_String (" -- ");
Get_Unit_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
Set_Name_Buffer;
Write_Statement_Buffer;
end loop;
- WBI (" -- END ELABORATION ORDER");
+ WBI (" -- END ELABORATION ORDER");
end Gen_Elab_Order_Ada;
----------------------
@@ -910,7 +1072,9 @@ package body Bindgen is
Num := 0;
for A in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A).Unit_Exception_Table then
+ if not ALIs.Table (A).Interface
+ and then ALIs.Table (A).Unit_Exception_Table
+ then
Num := Num + 1;
Last := A;
end if;
@@ -946,7 +1110,9 @@ package body Bindgen is
Write_Statement_Buffer;
for A in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A).Unit_Exception_Table then
+ if not ALIs.Table (A).Interface
+ and then ALIs.Table (A).Unit_Exception_Table
+ then
Get_Decoded_Name_String_With_Brackets
(Units.Table (ALIs.Table (A).First_Unit).Uname);
Set_Casing (Mixed_Case);
@@ -975,10 +1141,14 @@ package body Bindgen is
-- If compiling for the JVM, we directly reference Adafinal because
-- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
- if Hostparm.Java_VM then
- Set_String (" System.Standard_Library.Adafinal'Code_Address");
- else
- Set_String (" Do_Finalize'Code_Address");
+ if not Restrictions_On_Target (No_Finalization) then
+ if Hostparm.Java_VM then
+ Set_String
+ (" System.Standard_Library.Adafinal'Code_Address");
+ else
+ Set_String
+ (" Do_Finalize'Code_Address");
+ end if;
end if;
for E in Elab_Order.First .. Elab_Order.Last loop
@@ -1062,7 +1232,9 @@ package body Bindgen is
Num := 0;
for A in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A).Unit_Exception_Table then
+ if not ALIs.Table (A).Interface
+ and then ALIs.Table (A).Unit_Exception_Table
+ then
Num := Num + 1;
Set_String (" extern void *__gnat_");
@@ -1090,7 +1262,9 @@ package body Bindgen is
Num2 := 0;
for A in ALIs.First .. ALIs.Last loop
- if ALIs.Table (A).Unit_Exception_Table then
+ if not ALIs.Table (A).Interface
+ and then ALIs.Table (A).Unit_Exception_Table
+ then
Num2 := Num2 + 1;
Set_String (" &__gnat_");
@@ -1132,7 +1306,10 @@ package body Bindgen is
Write_Statement_Buffer;
WBI (" " & Ada_Init_Name.all & ",");
- Set_String (" system__standard_library__adafinal");
+
+ if not Restrictions_On_Target (No_Finalization) then
+ Set_String (" system__standard_library__adafinal");
+ end if;
for E in Elab_Order.First .. Elab_Order.Last loop
Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
@@ -1168,32 +1345,42 @@ package body Bindgen is
------------------
procedure Gen_Main_Ada is
- Target : constant String_Ptr := Target_Name;
- VxWorks_Target : constant Boolean :=
- Target (Target'Last - 7 .. Target'Last) = "vxworks/"
- or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/";
-
begin
WBI ("");
- Set_String (" function ");
- Set_String (Get_Main_Name);
-
- if VxWorks_Target then
- Set_String (" return Integer is");
- Write_Statement_Buffer;
+ if Exit_Status_Supported_On_Target then
+ Set_String (" function ");
else
+ Set_String (" procedure ");
+ end if;
+
+ Set_String (Get_Main_Name);
+
+ if Command_Line_Args_On_Target then
Write_Statement_Buffer;
WBI (" (argc : Integer;");
WBI (" argv : System.Address;");
WBI (" envp : System.Address)");
- WBI (" return Integer");
+
+ if Exit_Status_Supported_On_Target then
+ WBI (" return Integer");
+ end if;
+
WBI (" is");
+
+ else
+ if Exit_Status_Supported_On_Target then
+ Set_String (" return Integer is");
+ else
+ Set_String (" is");
+ end if;
+
+ Write_Statement_Buffer;
end if;
- -- Initialize and Finalize are not used in No_Run_Time mode
+ -- Initialize and Finalize
- if not No_Run_Time_Specified then
+ if not Restrictions_On_Target (No_Finalization) then
WBI (" procedure initialize;");
WBI (" pragma Import (C, initialize, ""__gnat_initialize"");");
WBI ("");
@@ -1245,30 +1432,39 @@ package body Bindgen is
-- The reference stops Ada_Main_Program_Name from being optimized
-- away by smart linkers, such as the AiX linker.
- WBI
- (" Ensure_Reference : System.Address := " &
- "Ada_Main_Program_Name'Address;");
- WBI ("");
+ if Bind_Main_Program then
+ WBI
+ (" Ensure_Reference : System.Address := " &
+ "Ada_Main_Program_Name'Address;");
+ WBI ("");
+ end if;
WBI (" begin");
- -- On VxWorks, there are no command line arguments
+ -- Acquire command line arguments if present on target
- if VxWorks_Target then
- WBI (" gnat_argc := 0;");
- WBI (" gnat_argv := System.Null_Address;");
- WBI (" gnat_envp := System.Null_Address;");
-
- -- Normal case of command line arguments present
-
- else
+ if Command_Line_Args_On_Target then
WBI (" gnat_argc := argc;");
WBI (" gnat_argv := argv;");
WBI (" gnat_envp := envp;");
WBI ("");
+
+ -- If configurable run time and no command line args, then nothing
+ -- needs to be done since the gnat_argc/argv/envp variables are
+ -- suppressed in this case.
+
+ elsif Configurable_Run_Time_On_Target then
+ null;
+
+ -- Otherwise set dummy values (to be filled in by some other unit?)
+
+ else
+ WBI (" gnat_argc := 0;");
+ WBI (" gnat_argv := System.Null_Address;");
+ WBI (" gnat_envp := System.Null_Address;");
end if;
- if not No_Run_Time_Specified then
+ if not Restrictions_On_Target (No_Finalization) then
WBI (" Initialize;");
end if;
@@ -1284,9 +1480,9 @@ package body Bindgen is
end if;
end if;
- -- Adafinal is only called if we have a run time
+ -- Adafinal call is skipped if no finalization
- if not No_Run_Time_Specified then
+ if not Restrictions_On_Target (No_Finalization) then
-- If compiling for the JVM, we directly call Adafinal because
-- we don't import it via Do_Finalize (see Gen_Output_File_Ada).
@@ -1300,18 +1496,20 @@ package body Bindgen is
-- Finalize is only called if we have a run time
- if not No_Run_Time_Specified then
+ if not Restrictions_On_Target (No_Finalization) then
WBI (" Finalize;");
end if;
-- Return result
- if No_Main_Subprogram
- or else ALIs.Table (ALIs.First).Main_Program = Proc
- then
- WBI (" return (gnat_exit_status);");
- else
- WBI (" return (Result);");
+ if Exit_Status_Supported_On_Target then
+ if No_Main_Subprogram
+ or else ALIs.Table (ALIs.First).Main_Program = Proc
+ then
+ WBI (" return (gnat_exit_status);");
+ else
+ WBI (" return (Result);");
+ end if;
end if;
WBI (" end;");
@@ -1322,66 +1520,73 @@ package body Bindgen is
----------------
procedure Gen_Main_C is
- Target : constant String_Ptr := Target_Name;
- VxWorks_Target : constant Boolean :=
- Target (Target'Last - 7 .. Target'Last) = "vxworks/"
- or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/";
-
begin
- Set_String ("int ");
+ if Exit_Status_Supported_On_Target then
+ Set_String ("int ");
+ else
+ Set_String ("void ");
+ end if;
+
Set_String (Get_Main_Name);
- -- On VxWorks, there are no command line arguments
+ -- Generate command line args in prototype if present on target
- if VxWorks_Target then
- Set_String (" ()");
+ if Command_Line_Args_On_Target then
+ Write_Statement_Buffer (" (int argc, char **argv, char **envp)");
- -- Normal case with command line arguments present
+ -- Case of no command line arguments on target
else
- Set_String (" (int argc, char **argv, char **envp)");
+ Write_Statement_Buffer (" ()");
end if;
- Write_Statement_Buffer;
-
- -- VxWorks doesn't have the notion of argc/argv
-
- if VxWorks_Target then
- WBI ("{");
- WBI (" int result;");
- WBI (" gnat_argc = 0;");
- WBI (" gnat_argv = 0;");
- WBI (" gnat_envp = 0;");
+ WBI ("{");
- -- Normal case of arguments present
+ -- Generate a reference to __gnat_ada_main_program_name. This symbol
+ -- is not referenced elsewhere in the generated program, but is
+ -- needed by the debugger (that's why it is generated in the first
+ -- place). The reference stops Ada_Main_Program_Name from being
+ -- optimized away by smart linkers, such as the AiX linker.
- else
- WBI ("{");
+ if Bind_Main_Program then
+ WBI (" char *ensure_reference __attribute__ ((__unused__)) = " &
+ "__gnat_ada_main_program_name;");
+ WBI ("");
+ end if;
- -- Generate a reference to __gnat_ada_main_program_name. This symbol
- -- is not referenced elsewhere in the generated program, but is
- -- needed by the debugger (that's why it is generated in the first
- -- place). The reference stops Ada_Main_Program_Name from being
- -- optimized away by smart linkers, such as the AiX linker.
+ -- If main program is a function, generate result variable
- WBI
- (" char *ensure_reference __attribute__ ((__unused__)) = " &
- "__gnat_ada_main_program_name;");
- WBI ("");
+ if ALIs.Table (ALIs.First).Main_Program = Func then
+ WBI (" int result;");
+ end if;
- if ALIs.Table (ALIs.First).Main_Program = Func then
- WBI (" int result;");
- end if;
+ -- Set command line argument values from parameters if command line
+ -- arguments are present on target
+ if Command_Line_Args_On_Target then
WBI (" gnat_argc = argc;");
WBI (" gnat_argv = argv;");
WBI (" gnat_envp = envp;");
WBI (" ");
+
+ -- If configurable run-time, then nothing to do, since in this case
+ -- the gnat_argc/argv/envp variables are entirely suppressed.
+
+ elsif Configurable_Run_Time_On_Target then
+ null;
+
+ -- if no command line arguments on target, set dummy values
+
+ else
+ WBI (" int result;");
+ WBI (" gnat_argc = 0;");
+ WBI (" gnat_argv = 0;");
+ WBI (" gnat_envp = 0;");
end if;
-- The __gnat_initialize routine is used only if we have a run-time
- if not No_Run_Time_Specified then
+ if not Suppress_Standard_Library_On_Target then
WBI
(" __gnat_initialize ();");
end if;
@@ -1389,7 +1594,6 @@ package body Bindgen is
WBI (" " & Ada_Init_Name.all & " ();");
if not No_Main_Subprogram then
-
WBI (" __gnat_break_start ();");
WBI (" ");
@@ -1416,40 +1620,51 @@ package body Bindgen is
end if;
- -- Adafinal is called only when we have a run-time
+ -- Call adafinal if finalization active
- if not No_Run_Time_Specified then
+ if not Restrictions_On_Target (No_Finalization) then
WBI (" ");
WBI (" system__standard_library__adafinal ();");
end if;
-- The finalize routine is used only if we have a run-time
- if not No_Run_Time_Specified then
+ if not Suppress_Standard_Library_On_Target then
WBI (" __gnat_finalize ();");
end if;
- if ALIs.Table (ALIs.First).Main_Program = Func then
-
- if Hostparm.OpenVMS then
+ -- Case of main program is a function, so the value it returns
+ -- is the exit status in this case.
- -- VMS must use the Posix exit routine in order to get an
- -- Unix compatible exit status.
+ if ALIs.Table (ALIs.First).Main_Program = Func then
+ if Exit_Status_Supported_On_Target then
- WBI (" __posix_exit (result);");
+ -- VMS must use Posix exit routine in order to get the effect
+ -- of a Unix compatible setting of the program exit status.
+ -- For all other systems, we use the standard exit routine.
- else
- WBI (" exit (result);");
+ if OpenVMS_On_Target then
+ WBI (" __posix_exit (result);");
+ else
+ WBI (" exit (result);");
+ end if;
end if;
+ -- Case of main program is a procedure, in which case the exit
+ -- status is whatever was set by a Set_Exit call most recently
+
else
+ if Exit_Status_Supported_On_Target then
- if Hostparm.OpenVMS then
- -- VMS must use the Posix exit routine in order to get an
- -- Unix compatible exit status.
- WBI (" __posix_exit (gnat_exit_status);");
- else
- WBI (" exit (gnat_exit_status);");
+ -- VMS must use Posix exit routine in order to get the effect
+ -- of a Unix compatible setting of the program exit status.
+ -- For all other systems, we use the standard exit routine.
+
+ if OpenVMS_On_Target then
+ WBI (" __posix_exit (gnat_exit_status);");
+ else
+ WBI (" exit (gnat_exit_status);");
+ end if;
end if;
end if;
@@ -1510,14 +1725,16 @@ package body Bindgen is
begin
WBI ("");
- Write_Info_Ada_C ("--", "/*", " BEGIN Object file/option list");
+ Write_Info_Ada_C ("-- ", "/* ", " BEGIN Object file/option list");
for E in Elab_Order.First .. Elab_Order.Last loop
-- If not spec that has an associated body, then generate a
-- comment giving the name of the corresponding object file.
- if Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec then
+ if (not Units.Table (Elab_Order.Table (E)).Interface)
+ and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec
+ then
Get_Name_String
(ALIs.Table
(Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
@@ -1526,8 +1743,7 @@ package body Bindgen is
-- exists, then use it.
if not Hostparm.Exclude_Missing_Objects
- or else
- GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
+ or else GNAT.OS_Lib.Is_Regular_File (Name_Buffer (1 .. Name_Len))
then
Write_Info_Ada_C (" -- ", "", Name_Buffer (1 .. Name_Len));
if Output_Object_List then
@@ -1544,22 +1760,28 @@ package body Bindgen is
(ALIs.Table
(Units.Table (Elab_Order.Table (E)).My_ALI).Sfile)
then
- Opt.Shared_Libgnat := False;
- end if;
+ -- Special case for g-trasym.obj, which is not included
+ -- in libgnat.
+
+ Get_Name_String (ALIs.Table
+ (Units.Table (Elab_Order.Table (E)).My_ALI).Sfile);
+ if Name_Buffer (1 .. 8) /= "g-trasym" then
+ Opt.Shared_Libgnat := False;
+ end if;
+ end if;
end if;
end if;
end loop;
-- Add a "-Ldir" for each directory in the object path. We skip this
- -- in No_Run_Time mode, where we want more precise control of exactly
- -- what goes into the resulting object file
+ -- in Configurable_Run_Time mode, where we want more precise control
+ -- of exactly what goes into the resulting object file
- if not No_Run_Time_Specified then
+ if not Configurable_Run_Time_Mode then
for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
declare
- Dir : String_Ptr := Dir_In_Obj_Search_Path (J);
-
+ Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
begin
Name_Len := 0;
Add_Str_To_Name_Buffer ("-L");
@@ -1623,7 +1845,7 @@ package body Bindgen is
-- files. The reason for this decision is that libraries referenced
-- by internal routines may reference these standard library entries.
- if not (No_Run_Time_Specified or else Opt.No_Stdlib) then
+ if not (Configurable_Run_Time_Mode or else Opt.No_Stdlib) then
Name_Len := 0;
if Opt.Shared_Libgnat then
@@ -1661,11 +1883,10 @@ package body Bindgen is
end loop;
if Ada_Bind_File then
- WBI ("-- END Object file/option list ");
+ WBI ("-- END Object file/option list ");
else
- WBI (" END Object file/option list */");
+ WBI (" END Object file/option list */");
end if;
-
end Gen_Object_Files_Options;
---------------------
@@ -1673,8 +1894,14 @@ package body Bindgen is
---------------------
procedure Gen_Output_File (Filename : String) is
+ Public_Version : constant Boolean := Gnat_Version_Type = "PUBLIC ";
+ -- Set true if this is the public version of GNAT
begin
+ -- Acquire settings for Interrupt_State pragmas
+
+ Set_IS_Pragma_Table;
+
-- Override Ada_Bind_File and Bind_Main_Program for Java since
-- JGNAT only supports Ada code, and the main program is already
-- generated by the compiler.
@@ -1700,6 +1927,12 @@ package body Bindgen is
end if;
end loop;
+ -- Get the time stamp of the former bind for public version warning
+
+ if Public_Version then
+ Record_Time_From_Last_Bind;
+ end if;
+
-- Generate output file in appropriate language
if Ada_Bind_File then
@@ -1708,6 +1941,12 @@ package body Bindgen is
Gen_Output_File_C (Filename);
end if;
+ -- Periodically issue a warning when the public version is used on
+ -- big projects
+
+ if Public_Version then
+ Public_Version_Warning;
+ end if;
end Gen_Output_File;
-------------------------
@@ -1726,24 +1965,20 @@ package body Bindgen is
-- Name to be used for generated Ada main program. See the body of
-- function Get_Ada_Main_Name for details on the form of the name.
- Target : constant String_Ptr := Target_Name;
- VxWorks_Target : constant Boolean :=
- Target (Target'Last - 7 .. Target'Last) = "vxworks/"
- or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/";
-
begin
-- Create spec first
Create_Binder_Output (Filename, 's', Bfiles);
- if No_Run_Time_Specified then
- WBI ("pragma No_Run_Time;");
+ -- If we are operating in Restrictions (No_Exception_Handlers) mode,
+ -- then we need to make sure that the binder program is compiled with
+ -- the same restriction, so that no exception tables are generated.
+
+ if Restrictions_On_Target (No_Exception_Handlers) then
+ WBI ("pragma Restrictions (No_Exception_Handlers);");
end if;
- -- Generate with of System so we can reference System.Address, note
- -- that such a reference is safe even in No_Run_Time mode, since we
- -- do not need any run-time code for such a reference, and we output
- -- a pragma No_Run_Time for this compilation above.
+ -- Generate with of System so we can reference System.Address
WBI ("with System;");
@@ -1755,7 +1990,7 @@ package body Bindgen is
Resolve_Binder_Options;
- if not No_Run_Time_Specified then
+ if not Suppress_Standard_Library_On_Target then
-- Usually, adafinal is called using a pragma Import C. Since
-- Import C doesn't have the same semantics for JGNAT, we use
@@ -1767,36 +2002,44 @@ package body Bindgen is
end if;
WBI ("package " & Ada_Main & " is");
+ WBI (" pragma Warnings (Off);");
-- Main program case
if Bind_Main_Program then
- -- Generate argc/argv stuff
-
- WBI ("");
- WBI (" gnat_argc : Integer;");
- WBI (" gnat_argv : System.Address;");
- WBI (" gnat_envp : System.Address;");
-
- -- If we have a run time present, these variables are in the
- -- runtime data area for easy access from the runtime
+ -- Generate argc/argv stuff unless suppressed
- if not No_Run_Time_Specified then
+ if Command_Line_Args_On_Target
+ or not Configurable_Run_Time_On_Target
+ then
WBI ("");
- WBI (" pragma Import (C, gnat_argc);");
- WBI (" pragma Import (C, gnat_argv);");
- WBI (" pragma Import (C, gnat_envp);");
+ WBI (" gnat_argc : Integer;");
+ WBI (" gnat_argv : System.Address;");
+ WBI (" gnat_envp : System.Address;");
+
+ -- If the standard library is not suppressed, these variables are
+ -- in the runtime data area for easy access from the runtime
+
+ if not Suppress_Standard_Library_On_Target then
+ WBI ("");
+ WBI (" pragma Import (C, gnat_argc);");
+ WBI (" pragma Import (C, gnat_argv);");
+ WBI (" pragma Import (C, gnat_envp);");
+ end if;
end if;
-- Define exit status. Again in normal mode, this is in the
- -- run-time library, and is initialized there, but in the no
- -- run time case, the variable is here and initialized here.
+ -- run-time library, and is initialized there, but in the
+ -- configurable runtime case, the variable is declared and
+ -- initialized in this file.
WBI ("");
- if No_Run_Time_Specified then
- WBI (" gnat_exit_status : Integer := 0;");
+ if Configurable_Run_Time_Mode then
+ if Exit_Status_Supported_On_Target then
+ WBI (" gnat_exit_status : Integer := 0;");
+ end if;
else
WBI (" gnat_exit_status : Integer;");
WBI (" pragma Import (C, gnat_exit_status);");
@@ -1827,10 +2070,10 @@ package body Bindgen is
"""__gnat_ada_main_program_name"");");
end if;
- -- No need to generate a finalization routine if there is no
- -- runtime, since there is nothing to do in this case.
+ -- No need to generate a finalization routine if finalization
+ -- is restricted, since there is nothing to do in this case.
- if not No_Run_Time_Specified then
+ if not Restrictions_On_Target (No_Finalization) then
WBI ("");
WBI (" procedure " & Ada_Final_Name.all & ";");
WBI (" pragma Export (C, " & Ada_Final_Name.all & ", """ &
@@ -1844,38 +2087,57 @@ package body Bindgen is
if Bind_Main_Program then
- -- If we have a run time, then Break_Start is defined there, but
- -- if there is no run-time, Break_Start is defined in this file.
+ -- If we have the standard library, then Break_Start is defined
+ -- there, but when the standard library is suppressed, Break_Start
+ -- is defined here.
WBI ("");
WBI (" procedure Break_Start;");
- if No_Run_Time_Specified then
+ if Suppress_Standard_Library_On_Target then
WBI (" pragma Export (C, Break_Start, ""__gnat_break_start"");");
else
WBI (" pragma Import (C, Break_Start, ""__gnat_break_start"");");
end if;
WBI ("");
- WBI (" function " & Get_Main_Name);
- -- Generate argument list (except on VxWorks, where none is present)
+ if Exit_Status_Supported_On_Target then
+ Set_String (" function ");
+ else
+ Set_String (" procedure ");
+ end if;
+
+ Set_String (Get_Main_Name);
- if not VxWorks_Target then
+ -- Generate argument list if present
+
+ if Command_Line_Args_On_Target then
+ Write_Statement_Buffer;
WBI (" (argc : Integer;");
WBI (" argv : System.Address;");
- WBI (" envp : System.Address)");
+ Set_String
+ (" envp : System.Address)");
+
+ if Exit_Status_Supported_On_Target then
+ Write_Statement_Buffer;
+ WBI (" return Integer;");
+ else
+ Write_Statement_Buffer (";");
+ end if;
+
+ else
+ if Exit_Status_Supported_On_Target then
+ Write_Statement_Buffer (" return Integer;");
+ else
+ Write_Statement_Buffer (";");
+ end if;
end if;
- WBI (" return Integer;");
WBI (" pragma Export (C, " & Get_Main_Name & ", """ &
Get_Main_Name & """);");
end if;
- if Initialize_Scalars_Used then
- Gen_Scalar_Values;
- end if;
-
Gen_Versions_Ada;
Gen_Elab_Order_Ada;
@@ -1914,10 +2176,11 @@ package body Bindgen is
WBI ("");
WBI ("package body " & Ada_Main & " is");
+ WBI (" pragma Warnings (Off);");
- -- Import the finalization procedure only if there is a runtime.
+ -- Import the finalization procedure only if finalization active
- if not No_Run_Time_Specified then
+ if not Restrictions_On_Target (No_Finalization) then
-- In the Java case, pragma Import C cannot be used, so the
-- standard Ada constructs will be used instead.
@@ -1934,18 +2197,18 @@ package body Bindgen is
Gen_Adainit_Ada;
- -- No need to generate a finalization routine if there is no
- -- runtime, since there is nothing to do in this case.
+ -- No need to generate a finalization routine if no finalization
- if not No_Run_Time_Specified then
+ if not Restrictions_On_Target (No_Finalization) then
Gen_Adafinal_Ada;
end if;
if Bind_Main_Program then
- -- In No_Run_Time mode, generate dummy body for Break_Start
+ -- When suppressing the standard library then generate dummy body
+ -- for Break_Start
- if No_Run_Time_Specified then
+ if Suppress_Standard_Library_On_Target then
WBI ("");
WBI (" procedure Break_Start is");
WBI (" begin");
@@ -1980,16 +2243,32 @@ package body Bindgen is
Resolve_Binder_Options;
- WBI ("extern void __gnat_set_globals (int, int, int, int, int, int,");
- WBI (" const char *, int, int, int);");
+ WBI ("extern void __gnat_set_globals");
+ WBI (" (int, int, char, char, char, char,");
+ WBI (" const char *, const char *,");
+ WBI (" int, int, int, int);");
WBI ("extern void " & Ada_Final_Name.all & " (void);");
WBI ("extern void " & Ada_Init_Name.all & " (void);");
-
WBI ("extern void system__standard_library__adafinal (void);");
if not No_Main_Subprogram then
- WBI ("extern int main (int, char **, char **);");
- if Hostparm.OpenVMS then
+ Set_String ("extern ");
+
+ if Exit_Status_Supported_On_Target then
+ Set_String ("int");
+ else
+ Set_String ("void");
+ end if;
+
+ Set_String (" main ");
+
+ if Command_Line_Args_On_Target then
+ Write_Statement_Buffer ("(int, char **, char **);");
+ else
+ Write_Statement_Buffer ("(void);");
+ end if;
+
+ if OpenVMS_On_Target then
WBI ("extern void __posix_exit (int);");
else
WBI ("extern void exit (int);");
@@ -2010,7 +2289,7 @@ package body Bindgen is
Write_Statement_Buffer;
end if;
- if not No_Run_Time_Specified then
+ if not Suppress_Standard_Library_On_Target then
WBI ("extern void __gnat_initialize (void);");
WBI ("extern void __gnat_finalize (void);");
WBI ("extern void __gnat_install_handler (void);");
@@ -2023,25 +2302,32 @@ package body Bindgen is
-- Imported variable used to track elaboration/finalization phase.
-- Used only when we have a runtime.
- if not No_Run_Time_Specified then
+ if not Suppress_Standard_Library_On_Target then
WBI ("extern int __gnat_handler_installed;");
WBI ("");
end if;
- -- Write argv/argc stuff if main program case
+ -- Write argv/argc exit status stuff if main program case
if Bind_Main_Program then
- -- In the normal case, these are in the runtime library
+ -- First deal with argc/argv/envp. In the normal case they
+ -- are in the run-time library.
- if not No_Run_Time_Specified then
+ if not Configurable_Run_Time_On_Target then
WBI ("extern int gnat_argc;");
WBI ("extern char **gnat_argv;");
WBI ("extern char **gnat_envp;");
WBI ("extern int gnat_exit_status;");
- -- In the No_Run_Time case, they are right in the binder file
- -- and we initialize gnat_exit_status in the declaration.
+ -- If configurable run time and no command line args, then the
+ -- generation of these variables is entirely suppressed.
+
+ elsif not Command_Line_Args_On_Target then
+ null;
+
+ -- Otherwise, in the configurable run-time case they are right in
+ -- the binder file.
else
WBI ("int gnat_argc;");
@@ -2050,13 +2336,33 @@ package body Bindgen is
WBI ("int gnat_exit_status = 0;");
end if;
+ -- Similarly deal with exit status
+ -- are in the run-time library.
+
+ if not Configurable_Run_Time_On_Target then
+ WBI ("extern int gnat_exit_status;");
+
+ -- If configurable run time and no exit status on target, then
+ -- the generation of this variables is entirely suppressed.
+
+ elsif not Exit_Status_Supported_On_Target then
+ null;
+
+ -- Otherwise, in the configurable run-time case this variable is
+ -- right in the binder file, and initialized to zero there.
+
+ else
+ WBI ("int gnat_exit_status = 0;");
+ end if;
+
WBI ("");
end if;
- -- In no run-time mode, the __gnat_break_start routine (for the
- -- debugger to get initial control) is defined in this file.
+ -- When suppressing the standard library, the __gnat_break_start
+ -- routine (for the debugger to get initial control) is defined in
+ -- this file.
- if No_Run_Time_Specified then
+ if Suppress_Standard_Library_On_Target then
WBI ("");
WBI ("void __gnat_break_start () {}");
end if;
@@ -2081,7 +2387,7 @@ package body Bindgen is
-- Generate the adafinal routine. In no runtime mode, this is
-- not needed, since there is no finalization to do.
- if not No_Run_Time_Specified then
+ if not Restrictions_On_Target (No_Finalization) then
Gen_Adafinal_C;
end if;
@@ -2093,11 +2399,7 @@ package body Bindgen is
Gen_Main_C;
end if;
- -- Scalar values, versions and object files needed in both cases
-
- if Initialize_Scalars_Used then
- Gen_Scalar_Values;
- end if;
+ -- Generate versions, elaboration order, list of object files
Gen_Versions_C;
Gen_Elab_Order_C;
@@ -2108,301 +2410,6 @@ package body Bindgen is
Close_Binder_Output;
end Gen_Output_File_C;
- -----------------------
- -- Gen_Scalar_Values --
- -----------------------
-
- procedure Gen_Scalar_Values is
-
- -- Strings to hold hex values of initialization constants. Note that
- -- we store these strings in big endian order, but they are actually
- -- used to initialize integer values, so the actual generated data
- -- will automaticaly have the right endianess.
-
- IS_Is1 : String (1 .. 2);
- IS_Is2 : String (1 .. 4);
- IS_Is4 : String (1 .. 8);
- IS_Is8 : String (1 .. 16);
- IS_Iu1 : String (1 .. 2);
- IS_Iu2 : String (1 .. 4);
- IS_Iu4 : String (1 .. 8);
- IS_Iu8 : String (1 .. 16);
- IS_Isf : String (1 .. 8);
- IS_Ifl : String (1 .. 8);
- IS_Ilf : String (1 .. 16);
-
- -- The string for Long_Long_Float is special. This is used only on the
- -- ia32 with 80-bit extended float (stored in 96 bits by gcc). The
- -- value here is represented little-endian, since that's the only way
- -- it is ever generated (this is not used on big-endian machines.
-
- IS_Ill : String (1 .. 24);
-
- begin
- -- -Sin (invalid values)
-
- if Opt.Initialize_Scalars_Mode = 'I' then
- IS_Is1 := "80";
- IS_Is2 := "8000";
- IS_Is4 := "80000000";
- IS_Is8 := "8000000000000000";
- IS_Iu1 := "FF";
- IS_Iu2 := "FFFF";
- IS_Iu4 := "FFFFFFFF";
- IS_Iu8 := "FFFFFFFFFFFFFFFF";
- IS_Isf := IS_Iu4;
- IS_Ifl := IS_Iu4;
- IS_Ilf := IS_Iu8;
- IS_Ill := "00000000000000C0FFFF0000";
-
- -- -Slo (low values)
-
- elsif Opt.Initialize_Scalars_Mode = 'L' then
- IS_Is1 := "80";
- IS_Is2 := "8000";
- IS_Is4 := "80000000";
- IS_Is8 := "8000000000000000";
- IS_Iu1 := "00";
- IS_Iu2 := "0000";
- IS_Iu4 := "00000000";
- IS_Iu8 := "0000000000000000";
- IS_Isf := "FF800000";
- IS_Ifl := IS_Isf;
- IS_Ilf := "FFF0000000000000";
- IS_Ill := "0000000000000080FFFF0000";
-
- -- -Shi (high values)
-
- elsif Opt.Initialize_Scalars_Mode = 'H' then
- IS_Is1 := "7F";
- IS_Is2 := "7FFF";
- IS_Is4 := "7FFFFFFF";
- IS_Is8 := "7FFFFFFFFFFFFFFF";
- IS_Iu1 := "FF";
- IS_Iu2 := "FFFF";
- IS_Iu4 := "FFFFFFFF";
- IS_Iu8 := "FFFFFFFFFFFFFFFF";
- IS_Isf := "7F800000";
- IS_Ifl := IS_Isf;
- IS_Ilf := "7FF0000000000000";
- IS_Ill := "0000000000000080FF7F0000";
-
- -- -Shh (hex byte)
-
- else pragma Assert (Opt.Initialize_Scalars_Mode = 'X');
- IS_Is1 (1 .. 2) := Opt.Initialize_Scalars_Val;
- IS_Is2 (1 .. 2) := Opt.Initialize_Scalars_Val;
- IS_Is2 (3 .. 4) := Opt.Initialize_Scalars_Val;
-
- for J in 1 .. 4 loop
- IS_Is4 (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val;
- end loop;
-
- for J in 1 .. 8 loop
- IS_Is8 (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val;
- end loop;
-
- IS_Iu1 := IS_Is1;
- IS_Iu2 := IS_Is2;
- IS_Iu4 := IS_Is4;
- IS_Iu8 := IS_Is8;
-
- IS_Isf := IS_Is4;
- IS_Ifl := IS_Is4;
- IS_Ilf := IS_Is8;
-
- for J in 1 .. 12 loop
- IS_Ill (2 * J - 1 .. 2 * J) := Opt.Initialize_Scalars_Val;
- end loop;
- end if;
-
- -- Generate output, Ada case
-
- if Ada_Bind_File then
- WBI ("");
-
- Set_String (" IS_Is1 : constant System.Scalar_Values.Byte1 := 16#");
- Set_String (IS_Is1);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Is2 : constant System.Scalar_Values.Byte2 := 16#");
- Set_String (IS_Is2);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Is4 : constant System.Scalar_Values.Byte4 := 16#");
- Set_String (IS_Is4);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Is8 : constant System.Scalar_Values.Byte8 := 16#");
- Set_String (IS_Is8);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Iu1 : constant System.Scalar_Values.Byte1 := 16#");
- Set_String (IS_Iu1);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Iu2 : constant System.Scalar_Values.Byte2 := 16#");
- Set_String (IS_Iu2);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Iu4 : constant System.Scalar_Values.Byte4 := 16#");
- Set_String (IS_Iu4);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Iu8 : constant System.Scalar_Values.Byte8 := 16#");
- Set_String (IS_Iu8);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Isf : constant System.Scalar_Values.Byte4 := 16#");
- Set_String (IS_Isf);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Ifl : constant System.Scalar_Values.Byte4 := 16#");
- Set_String (IS_Ifl);
- Write_Statement_Buffer ("#;");
-
- Set_String (" IS_Ilf : constant System.Scalar_Values.Byte8 := 16#");
- Set_String (IS_Ilf);
- Write_Statement_Buffer ("#;");
-
- -- Special case of Long_Long_Float. This is a 10-byte value used
- -- only on the x86. We could omit it for other architectures, but
- -- we don't easily have that kind of target specialization in the
- -- binder, and it's only 10 bytes, and only if -Sxx is used. Note
- -- that for architectures where Long_Long_Float is the same as
- -- Long_Float, the expander uses the Long_Float constant for the
- -- initializations of Long_Long_Float values.
-
- WBI (" IS_Ill : constant array (1 .. 12) of");
- WBI (" System.Scalar_Values.Byte1 := (");
- Set_String (" ");
-
- for J in 1 .. 6 loop
- Set_String (" 16#");
- Set_Char (IS_Ill (2 * J - 1));
- Set_Char (IS_Ill (2 * J));
- Set_String ("#,");
- end loop;
-
- Write_Statement_Buffer;
- Set_String (" ");
-
- for J in 7 .. 12 loop
- Set_String (" 16#");
- Set_Char (IS_Ill (2 * J - 1));
- Set_Char (IS_Ill (2 * J));
-
- if J = 12 then
- Set_String ("#);");
- else
- Set_String ("#,");
- end if;
- end loop;
-
- Write_Statement_Buffer;
-
- -- Output export statements to export to System.Scalar_Values
-
- WBI ("");
-
- WBI (" pragma Export (Ada, IS_Is1, ""__gnat_Is1"");");
- WBI (" pragma Export (Ada, IS_Is2, ""__gnat_Is2"");");
- WBI (" pragma Export (Ada, IS_Is4, ""__gnat_Is4"");");
- WBI (" pragma Export (Ada, IS_Is8, ""__gnat_Is8"");");
- WBI (" pragma Export (Ada, IS_Iu1, ""__gnat_Iu1"");");
- WBI (" pragma Export (Ada, IS_Iu2, ""__gnat_Iu2"");");
- WBI (" pragma Export (Ada, IS_Iu4, ""__gnat_Iu4"");");
- WBI (" pragma Export (Ada, IS_Iu8, ""__gnat_Iu8"");");
- WBI (" pragma Export (Ada, IS_Isf, ""__gnat_Isf"");");
- WBI (" pragma Export (Ada, IS_Ifl, ""__gnat_Ifl"");");
- WBI (" pragma Export (Ada, IS_Ilf, ""__gnat_Ilf"");");
- WBI (" pragma Export (Ada, IS_Ill, ""__gnat_Ill"");");
-
- -- Generate output C case
-
- else
- -- The lines we generate in this case are of the form
- -- typ __gnat_I?? = 0x??;
- -- where typ is appropriate to the length
-
- WBI ("");
-
- Set_String ("unsigned char __gnat_Is1 = 0x");
- Set_String (IS_Is1);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned short __gnat_Is2 = 0x");
- Set_String (IS_Is2);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned __gnat_Is4 = 0x");
- Set_String (IS_Is4);
- Write_Statement_Buffer (";");
-
- Set_String ("long long unsigned __gnat_Is8 = 0x");
- Set_String (IS_Is8);
- Write_Statement_Buffer ("LL;");
-
- Set_String ("unsigned char __gnat_Iu1 = 0x");
- Set_String (IS_Is1);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned short __gnat_Iu2 = 0x");
- Set_String (IS_Is2);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned __gnat_Iu4 = 0x");
- Set_String (IS_Is4);
- Write_Statement_Buffer (";");
-
- Set_String ("long long unsigned __gnat_Iu8 = 0x");
- Set_String (IS_Is8);
- Write_Statement_Buffer ("LL;");
-
- Set_String ("unsigned __gnat_Isf = 0x");
- Set_String (IS_Isf);
- Write_Statement_Buffer (";");
-
- Set_String ("unsigned __gnat_Ifl = 0x");
- Set_String (IS_Ifl);
- Write_Statement_Buffer (";");
-
- Set_String ("long long unsigned __gnat_Ilf = 0x");
- Set_String (IS_Ilf);
- Write_Statement_Buffer ("LL;");
-
- -- For Long_Long_Float, we generate
- -- char __gnat_Ill[12] = {0x??, 0x??, 0x??, 0x??, 0x??, 0x??,
- -- 0x??, 0x??, 0x??, 0x??, 0x??, 0x??);
-
- Set_String ("unsigned char __gnat_Ill[12] = {");
-
- for J in 1 .. 6 loop
- Set_String ("0x");
- Set_Char (IS_Ill (2 * J - 1));
- Set_Char (IS_Ill (2 * J));
- Set_String (", ");
- end loop;
-
- Write_Statement_Buffer;
- Set_String (" ");
-
- for J in 7 .. 12 loop
- Set_String ("0x");
- Set_Char (IS_Ill (2 * J - 1));
- Set_Char (IS_Ill (2 * J));
-
- if J = 12 then
- Set_String ("};");
- else
- Set_String (", ");
- end if;
- end loop;
-
- Write_Statement_Buffer;
- end if;
- end Gen_Scalar_Values;
-
----------------------
-- Gen_Versions_Ada --
----------------------
@@ -2619,11 +2626,6 @@ package body Bindgen is
-------------------
function Get_Main_Name return String is
- Target : constant String_Ptr := Target_Name;
- VxWorks_Target : constant Boolean :=
- Target (Target'Last - 7 .. Target'Last) = "vxworks/"
- or else Target (Target'Last - 9 .. Target'Last) = "vxworksae/";
-
begin
-- Explicit name given with -M switch
@@ -2632,7 +2634,7 @@ package body Bindgen is
-- Case of main program name to be used directly
- elsif VxWorks_Target then
+ elsif Use_Ada_Main_Program_Name_On_Target then
-- Get main program name
@@ -2697,6 +2699,74 @@ package body Bindgen is
end Move_Linker_Option;
----------------------------
+ -- Public_Version_Warning --
+ ----------------------------
+
+ procedure Public_Version_Warning is
+
+ Time : constant Int := Time_From_Last_Bind;
+
+ -- Constants to help defining periods
+
+ Hour : constant := 60;
+ Day : constant := 24 * Hour;
+
+ Never : constant := Integer'Last;
+ -- Special value indicating no warnings should be given
+
+ -- Constants defining when the warning is issued. Programs with more
+ -- than Large Units will issue a warning every Period_Large amount of
+ -- time. Smaller programs will generate a warning every Period_Small
+ -- amount of time.
+
+ Large : constant := 20;
+ -- Threshold for considering a program small or large
+
+ Period_Large : constant := Day;
+ -- Periodic warning time for large programs
+
+ Period_Small : constant := Never;
+ -- Periodic warning time for small programs
+
+ Nb_Unit : Int;
+
+ begin
+ -- Compute the number of units that are not GNAT internal files
+
+ Nb_Unit := 0;
+ for A in ALIs.First .. ALIs.Last loop
+ if not Is_Internal_File_Name (ALIs.Table (A).Sfile) then
+ Nb_Unit := Nb_Unit + 1;
+ end if;
+ end loop;
+
+ -- Do not emit the message if the last message was emitted in the
+ -- specified period taking into account the number of units.
+
+ if Nb_Unit < Large and then Time <= Period_Small then
+ return;
+
+ elsif Time <= Period_Large then
+ return;
+ end if;
+
+ Write_Eol;
+ Write_Str ("IMPORTANT NOTICE:");
+ Write_Eol;
+ Write_Str (" This version of GNAT is unsupported"
+ & " and comes with absolutely no warranty.");
+ Write_Eol;
+ Write_Str (" If you intend to evaluate or use GNAT for building "
+ & "commercial applications,");
+ Write_Eol;
+ Write_Str (" please consult http://www.gnat.com/ for information");
+ Write_Eol;
+ Write_Str (" on the GNAT Professional product line.");
+ Write_Eol;
+ Write_Eol;
+ end Public_Version_Warning;
+
+ ----------------------------
-- Resolve_Binder_Options --
----------------------------
@@ -2706,14 +2776,14 @@ package body Bindgen is
Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
-- The procedure of looking for specific packages and setting
- -- flags is very wrong, but there isn't a good alternative at
- -- this time.
+ -- flags is somewhat dubious, but there isn't a good alternative
+ -- at the current time ???
if Name_Buffer (1 .. 19) = "system.os_interface" then
With_GNARL := True;
end if;
- if Hostparm.OpenVMS and then Name_Buffer (1 .. 3) = "dec" then
+ if Hostparm.OpenVMS and then Name_Buffer (1 .. 5) = "dec%s" then
With_DECGNAT := True;
end if;
end loop;
@@ -2750,6 +2820,33 @@ package body Bindgen is
end if;
end Set_Int;
+ -------------------------
+ -- Set_IS_Pragma_Table --
+ -------------------------
+
+ procedure Set_IS_Pragma_Table is
+ begin
+ for F in ALIs.First .. ALIs.Last loop
+ for K in ALIs.Table (F).First_Interrupt_State ..
+ ALIs.Table (F).Last_Interrupt_State
+ loop
+ declare
+ Inum : constant Int :=
+ Interrupt_States.Table (K).Interrupt_Id;
+ Stat : constant Character :=
+ Interrupt_States.Table (K).Interrupt_State;
+
+ begin
+ while IS_Pragma_Settings.Last < Inum loop
+ IS_Pragma_Settings.Append ('n');
+ end loop;
+
+ IS_Pragma_Settings.Table (Inum) := Stat;
+ end;
+ end loop;
+ end loop;
+ end Set_IS_Pragma_Table;
+
---------------------------
-- Set_Main_Program_Name --
---------------------------
@@ -2850,7 +2947,6 @@ package body Bindgen is
if Ada_Bind_File then
declare
S : String (1 .. Ada'Length + Common'Length);
-
begin
S (1 .. Ada'Length) := Ada;
S (Ada'Length + 1 .. S'Length) := Common;
@@ -2860,7 +2956,6 @@ package body Bindgen is
else
declare
S : String (1 .. C'Length + Common'Length);
-
begin
S (1 .. C'Length) := C;
S (C'Length + 1 .. S'Length) := Common;
diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb
index 163f92ed1cb..c5ccab92024 100644
--- a/gcc/ada/bindusg.adb
+++ b/gcc/ada/bindusg.adb
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GBIND BINDER COMPONENTS --
+-- GNAT COMPILER COMPONENTS --
-- --
-- B I N D U S G --
-- --
-- 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- --
@@ -84,6 +84,13 @@ begin
Write_Str (" -E Store tracebacks in Exception occurrences");
Write_Eol;
+ -- The -f switch is voluntarily omitted, because it is obsolete
+
+ -- Line for -F switch
+
+ Write_Str (" -F Force checking of elaboration Flags");
+ Write_Eol;
+
-- Line for -h switch
Write_Str (" -h Output this usage (help) infor");
@@ -123,7 +130,7 @@ begin
-- Line for -m switch
Write_Str (" -mnnn Limit number of detected error");
- Write_Str ("s to nnn (1-999)");
+ Write_Str ("s to nnn (1-999999)");
Write_Eol;
-- Line for -n switch
diff --git a/gcc/ada/bld-io.adb b/gcc/ada/bld-io.adb
new file mode 100644
index 00000000000..51c14cbc7ef
--- /dev/null
+++ b/gcc/ada/bld-io.adb
@@ -0,0 +1,273 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- B L D - I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions;
+with Ada.Text_IO;
+with Ada.Unchecked_Deallocation;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Osint;
+
+package body Bld.IO is
+
+ use Ada;
+
+ Initial_Number_Of_Lines : constant := 100;
+ Initial_Length_Of_Line : constant := 50;
+
+ type Line is record
+ Length : Natural := 0;
+ Value : String_Access;
+ Suppressed : Boolean := False;
+ end record;
+ -- One line of a Makefile.
+ -- Length is the position of the last column in the line.
+ -- Suppressed is set to True by procedure Suppress.
+
+ type Line_Array is array (Positive range <>) of Line;
+
+ type Buffer is access Line_Array;
+
+ procedure Free is new Ada.Unchecked_Deallocation (Line_Array, Buffer);
+
+ Lines : Buffer := new Line_Array (1 .. Initial_Number_Of_Lines);
+ -- The lines of a Makefile
+
+ Current : Positive := 1;
+ -- Position of the last line in the Makefile
+
+ File : Text_IO.File_Type;
+ -- The current Makefile
+
+ type File_Name_Data;
+ type File_Name_Ref is access File_Name_Data;
+
+ type File_Name_Data is record
+ Value : String_Access;
+ Next : File_Name_Ref;
+ end record;
+ -- Used to record the names of all Makefiles created, so that we may delete
+ -- them if necessary.
+
+ File_Names : File_Name_Ref;
+ -- List of all the Makefiles created so far.
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close is
+ begin
+ Flush;
+ Text_IO.Close (File);
+
+ exception
+ when X : others =>
+ Text_IO.Put_Line (Exceptions.Exception_Message (X));
+ Osint.Fail ("cannot close a Makefile");
+ end Close;
+
+ ------------
+ -- Create --
+ ------------
+
+ procedure Create (File_Name : String) is
+ begin
+ Text_IO.Create (File, Text_IO.Out_File, File_Name);
+ Current := 1;
+ Lines (1).Length := 0;
+ Lines (1).Suppressed := False;
+ File_Names :=
+ new File_Name_Data'(Value => new String'(File_Name),
+ Next => File_Names);
+ exception
+ when X : others =>
+ Text_IO.Put_Line (Exceptions.Exception_Message (X));
+ Osint.Fail ("cannot create """ & File_Name & '"');
+ end Create;
+
+ ----------------
+ -- Delete_All --
+ ----------------
+
+ procedure Delete_All is
+ Success : Boolean;
+ begin
+ if Text_IO.Is_Open (File) then
+ Text_IO.Delete (File);
+ File_Names := File_Names.Next;
+ end if;
+
+ while File_Names /= null loop
+ Delete_File (File_Names.Value.all, Success);
+ File_Names := File_Names.Next;
+ end loop;
+ end Delete_All;
+
+ -----------
+ -- Flush --
+ -----------
+
+ procedure Flush is
+ begin
+ if Lines (Current).Length /= 0 then
+ Osint.Fail ("INTERNAL ERROR: flushing before end of line: """ &
+ Lines (Current).Value
+ (1 .. Lines (Current).Length));
+ end if;
+
+ for J in 1 .. Current - 1 loop
+ if not Lines (J).Suppressed then
+ Text_IO.Put_Line (File, Lines (J).Value (1 .. Lines (J).Length));
+ end if;
+ end loop;
+
+ Current := 1;
+ Lines (1).Length := 0;
+ Lines (1).Suppressed := False;
+ end Flush;
+
+ ----------
+ -- Mark --
+ ----------
+
+ procedure Mark (Pos : out Position) is
+ begin
+ if Lines (Current).Length /= 0 then
+ Osint.Fail ("INTERNAL ERROR: marking before end of line: """ &
+ Lines (Current).Value
+ (1 .. Lines (Current).Length));
+ end if;
+
+ Pos := (Value => Current);
+ end Mark;
+
+ ------------------
+ -- Name_Of_File --
+ ------------------
+
+ function Name_Of_File return String is
+ begin
+ return Text_IO.Name (File);
+ end Name_Of_File;
+
+ --------------
+ -- New_Line --
+ --------------
+
+ procedure New_Line is
+ begin
+ Current := Current + 1;
+
+ if Current > Lines'Last then
+ declare
+ New_Lines : constant Buffer :=
+ new Line_Array (1 .. 2 * Lines'Last);
+
+ begin
+ New_Lines (1 .. Lines'Last) := Lines.all;
+ Free (Lines);
+ Lines := New_Lines;
+ end;
+ end if;
+
+ Lines (Current).Length := 0;
+ Lines (Current).Suppressed := False;
+
+ -- Allocate a new line, if necessary
+
+ if Lines (Current).Value = null then
+ Lines (Current).Value := new String (1 .. Initial_Length_Of_Line);
+ end if;
+ end New_Line;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put (S : String) is
+ Length : constant Natural := Lines (Current).Length;
+
+ begin
+ if Length + S'Length > Lines (Current).Value'Length then
+ declare
+ New_Line : String_Access;
+ New_Length : Positive := 2 * Lines (Current).Value'Length;
+ begin
+ while Length + S'Length > New_Length loop
+ New_Length := 2 * New_Length;
+ end loop;
+
+ New_Line := new String (1 .. New_Length);
+ New_Line (1 .. Length) := Lines (Current).Value (1 .. Length);
+ Free (Lines (Current).Value);
+ Lines (Current).Value := New_Line;
+ end;
+ end if;
+
+ Lines (Current).Value (Length + 1 .. Length + S'Length) := S;
+ Lines (Current).Length := Length + S'Length;
+ end Put;
+
+ -------------
+ -- Release --
+ -------------
+
+ procedure Release (Pos : Position) is
+ begin
+ if Lines (Current).Length /= 0 then
+ Osint.Fail ("INTERNAL ERROR: releasing before end of line: """ &
+ Lines (Current).Value
+ (1 .. Lines (Current).Length));
+ end if;
+
+ if Pos.Value > Current then
+ Osint.Fail ("INTERNAL ERROR: releasing ahead of current position");
+ end if;
+
+ Current := Pos.Value;
+ Lines (Current).Length := 0;
+ end Release;
+
+ --------------
+ -- Suppress --
+ --------------
+
+ procedure Suppress (Pos : Position) is
+ begin
+ if Pos.Value >= Current then
+ Osint.Fail ("INTERNAL ERROR: suppressing ahead of current position");
+ end if;
+
+ Lines (Pos.Value).Suppressed := True;
+ end Suppress;
+
+begin
+ -- Allocate the first line.
+ -- The other ones are allocated by New_Line.
+
+ Lines (1).Value := new String (1 .. Initial_Length_Of_Line);
+end Bld.IO;
diff --git a/gcc/ada/bld-io.ads b/gcc/ada/bld-io.ads
new file mode 100644
index 00000000000..c5df6274ad1
--- /dev/null
+++ b/gcc/ada/bld-io.ads
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- B L D - I O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- The following private package allows the ouput of text to Makefiles
+-- though buffers. It is possible to remove some lines from the buffers
+-- without putting them effectively in the Makefile.
+
+private package Bld.IO is
+
+ procedure Create (File_Name : String);
+ -- Create a new Makefile
+
+ procedure Flush;
+ -- Output all not suppressed lines to the Makefile
+
+ procedure Close;
+ -- Close the current Makefile
+
+ procedure Delete_All;
+ -- Delete all the Makefiles that have been created
+
+ function Name_Of_File return String;
+ -- Return the path name of the current Makefile
+
+ type Position is private;
+ -- Identification of a line in the Makefile
+
+ procedure Mark (Pos : out Position);
+ -- Record the current line.
+ -- No characters should have been already put on this line.
+
+ procedure Release (Pos : Position);
+ -- Suppress all line after this one, including this one.
+
+ procedure Suppress (Pos : Position);
+ -- Suppress a particular line
+
+ procedure Put (S : String);
+ -- Append a string to the current line
+
+ procedure New_Line;
+ -- End a line. Go to the next one (initially empty).
+
+private
+
+ type Position is record
+ Value : Positive := 1;
+ end record;
+
+end Bld.IO;
diff --git a/gcc/ada/bld.adb b/gcc/ada/bld.adb
new file mode 100644
index 00000000000..07add38e2e0
--- /dev/null
+++ b/gcc/ada/bld.adb
@@ -0,0 +1,3538 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- B L D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package is still a work in progress.
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Strings.Fixed; use Ada.Strings.Fixed;
+
+with Bld.IO;
+with Csets;
+
+with GNAT.HTable;
+with GNAT.Case_Util; use GNAT.Case_Util;
+with GNAT.Command_Line; use GNAT.Command_Line;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with Erroutc; use Erroutc;
+with Err_Vars; use Err_Vars;
+with Gnatvsn;
+with Namet; use Namet;
+with Opt; use Opt;
+with Output; use Output;
+with Prj; use Prj;
+with Prj.Com; use Prj.Com;
+with Prj.Err; use Prj.Err;
+with Prj.Part;
+with Prj.Tree; use Prj.Tree;
+with Snames;
+with Table;
+with Types; use Types;
+
+package body Bld is
+
+ function "=" (Left, Right : IO.Position) return Boolean
+ renames IO."=";
+
+ MAKE_ROOT : constant String := "MAKE_ROOT";
+
+ Process_All_Project_Files : Boolean := True;
+ -- Set to False by command line switch -R
+
+ Copyright_Displayed : Boolean := False;
+ -- To avoid displaying the Copyright line several times
+
+ Usage_Displayed : Boolean := False;
+ -- To avoid displaying the usage several times
+
+ type Expression_Kind_Type is (Undecided, Static_String, Other);
+
+ Expression_Kind : Expression_Kind_Type := Undecided;
+ -- After procedure Expression has been called, this global variable
+ -- indicates if the expression is a static string or not.
+ -- If it is a static string, then Expression_Value (1 .. Expression_Last)
+ -- is the static value of the expression.
+
+ Expression_Value : String_Access := new String (1 .. 10);
+ Expression_Last : Natural := 0;
+
+ -- The following variables indicates if the suffixs and the languages
+ -- are statically specified and, if they are, their values.
+
+ C_Suffix : String_Access := new String (1 .. 10);
+ C_Suffix_Last : Natural := 0;
+ C_Suffix_Static : Boolean := True;
+
+ Cxx_Suffix : String_Access := new String (1 .. 10);
+ Cxx_Suffix_Last : Natural := 0;
+ Cxx_Suffix_Static : Boolean := True;
+
+ Ada_Spec_Suffix : String_Access := new String (1 .. 10);
+ Ada_Spec_Suffix_Last : Natural := 0;
+ Ada_Spec_Suffix_Static : Boolean := True;
+
+ Ada_Body_Suffix : String_Access := new String (1 .. 10);
+ Ada_Body_Suffix_Last : Natural := 0;
+ Ada_Body_Suffix_Static : Boolean := True;
+
+ Languages : String_Access := new String (1 .. 50);
+ Languages_Last : Natural := 0;
+ Languages_Static : Boolean := True;
+
+ type Source_Kind_Type is (Unknown, Ada_Spec, Ada_Body, C, Cxx, None);
+ -- Used when post-processing Compiler'Switches to indicate the language
+ -- of a source.
+
+ -- The following variables are used to controlled what attributes
+ -- Default_Switches and Switches are allowed in expressions.
+
+ Default_Switches_Project : Project_Node_Id := Empty_Node;
+ Default_Switches_Package : Name_Id := No_Name;
+ Default_Switches_Language : Name_Id := No_Name;
+
+ Switches_Project : Project_Node_Id := Empty_Node;
+ Switches_Package : Name_Id := No_Name;
+ Switches_Language : Source_Kind_Type := Unknown;
+
+ -- Other attribute references are only allowed in attribute declarations
+ -- of the same package and of the same name.
+ -- Other_Attribute is True only during attribute declarations other than
+ -- Switches or Default_Switches.
+
+ Other_Attribute : Boolean := False;
+ Other_Attribute_Package : Name_Id := No_Name;
+ Other_Attribute_Name : Name_Id := No_Name;
+
+ type Declaration_Type is (False, May_Be, True);
+
+ Source_Files_Declaration : Declaration_Type := False;
+
+ Source_List_File_Declaration : Declaration_Type := False;
+
+ -- Names that are not in Snames
+
+ Name_Ide : Name_Id := No_Name;
+ Name_Compiler_Command : Name_Id := No_Name;
+ Name_Main_Language : Name_Id := No_Name;
+ Name_C_Plus_Plus : Name_Id := No_Name;
+
+ package Processed_Projects is new GNAT.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Project_Node_Id,
+ No_Element => Empty_Node,
+ Key => Name_Id,
+ Hash => Hash,
+ Equal => "=");
+ -- This hash table contains all processed projects.
+ -- It is used to avoid processing the same project file several times.
+
+ package Externals is new GNAT.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Natural,
+ No_Element => 0,
+ Key => Project_Node_Id,
+ Hash => Hash,
+ Equal => "=");
+ -- This hash table is used to store all the external references.
+ -- For each project file, the tree is first traversed and all
+ -- external references are put in variables. Each of these variables
+ -- are identified by a number, so that the can be referred to
+ -- later during the second traversal of the tree.
+
+ package Variable_Names is new Table.Table
+ (Table_Component_Type => Name_Id,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 10,
+ Table_Name => "Bld.Variable_Names");
+ -- This table stores all the variables declared in a package.
+ -- It is used to distinguish project level and package level
+ -- variables identified by simple names.
+ -- This table is reset for each package.
+
+ package Switches is new Table.Table
+ (Table_Component_Type => Name_Id,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 10,
+ Table_Name => "Bld.Switches");
+ -- This table stores all the indexs of associative array attribute
+ -- Compiler'Switches specified in a project file. It is reset for
+ -- each project file. At the end of processing of a project file
+ -- this table is traversed to output targets for those files
+ -- that may be C or C++ source files.
+
+ Last_External : Natural := 0;
+ -- For each external reference, this variable in incremented by 1,
+ -- and a Makefile variable <PROJECT>__EXTERNAL__<Last_External> is
+ -- declared. See procedure Process_Externals.
+
+ Last_Case_Construction : Natural := 0;
+ -- For each case construction, this variable is incremented by 1,
+ -- and a Makefile variable <PROJECT>__CASE__<Last_Case_Construction> is
+ -- declared. See procedure Process_Declarative_Items.
+
+ Saved_Suffix : constant String := ".saved";
+ -- Prefix to be added to the name of reserved variables (see below) when
+ -- used in external references.
+
+ -- A number of environment variables, whose names are used in the
+ -- Makefiles are saved at the beginning of the main Makefile.
+ -- Each reference to any such environment variable is replaced
+ -- in the Makefiles with the name of the saved variable.
+
+ Ada_Body_String : aliased String := "ADA_BODY";
+ Ada_Flags_String : aliased String := "ADA_FLAGS";
+ Ada_Mains_String : aliased String := "ADA_MAINS";
+ Ada_Sources_String : aliased String := "ADA_SOURCES";
+ Ada_Spec_String : aliased String := "ADA_SPEC";
+ Ar_Cmd_String : aliased String := "AR_CMD";
+ Ar_Ext_String : aliased String := "AR_EXT";
+ Base_Dir_String : aliased String := "BASE_DIR";
+ Cc_String : aliased String := "CC";
+ C_Ext_String : aliased String := "C_EXT";
+ Cflags_String : aliased String := "CFLAGS";
+ Cxx_String : aliased String := "CXX";
+ Cxx_Ext_String : aliased String := "CXX_EXT";
+ Cxxflags_String : aliased String := "CXXFLAGS";
+ Deps_Projects_String : aliased String := "DEPS_PROJECT";
+ Exec_String : aliased String := "EXEC";
+ Exec_Dir_String : aliased String := "EXEC_DIR";
+ Gnatmake_String : aliased String := "GNATMAKE";
+ Languages_String : aliased String := "LANGUAGES";
+ Ld_Flags_String : aliased String := "LD_FLAGS";
+ Libs_String : aliased String := "LIBS";
+ Main_String : aliased String := "MAIN";
+ Obj_Ext_String : aliased String := "OBJ_EXT";
+ Obj_Dir_String : aliased String := "OBJ_DIR";
+ Project_File_String : aliased String := "PROJECT_FILE";
+ Src_Dirs_String : aliased String := "SRC_DIRS";
+
+ type Reserved_Variable_Array is array (Positive range <>) of String_Access;
+ Reserved_Variables : constant Reserved_Variable_Array :=
+ (Ada_Body_String 'Access,
+ Ada_Flags_String 'Access,
+ Ada_Mains_String 'Access,
+ Ada_Sources_String 'Access,
+ Ada_Spec_String 'Access,
+ Ar_Cmd_String 'Access,
+ Ar_Ext_String 'Access,
+ Base_Dir_String 'Access,
+ Cc_String 'Access,
+ C_Ext_String 'Access,
+ Cflags_String 'Access,
+ Cxx_String 'Access,
+ Cxx_Ext_String 'Access,
+ Cxxflags_String 'Access,
+ Deps_Projects_String'Access,
+ Exec_String 'Access,
+ Exec_Dir_String 'Access,
+ Gnatmake_String 'Access,
+ Languages_String 'Access,
+ Ld_Flags_String 'Access,
+ Libs_String 'Access,
+ Main_String 'Access,
+ Obj_Ext_String 'Access,
+ Obj_Dir_String 'Access,
+ Project_File_String 'Access,
+ Src_Dirs_String 'Access);
+
+ Main_Project_File_Name : String_Access;
+ -- The name of the main project file, given as argument.
+
+ Project_Tree : Project_Node_Id;
+ -- The result of the parsing of the main project file.
+
+ procedure Add_To_Expression_Value (S : String);
+ procedure Add_To_Expression_Value (S : Name_Id);
+ -- Add a string to variable Expression_Value
+
+ procedure Display_Copyright;
+ -- Display name of the tool and the copyright
+
+ function Equal_String (Left, Right : Name_Id) return Boolean;
+ -- Return True if Left and Right are the same string, without considering
+ -- the case.
+
+ procedure Expression
+ (Project : Project_Node_Id;
+ First_Term : Project_Node_Id;
+ Kind : Variable_Kind;
+ In_Case : Boolean;
+ Reset : Boolean := False);
+ -- Process an expression.
+ -- If In_Case is True, all expressions are not static.
+
+ procedure New_Line;
+ -- Add a line terminator in the Makefile
+
+ procedure Process (Project : Project_Node_Id);
+ -- Process the project tree, result of the parsing.
+
+ procedure Process_Case_Construction
+ (Current_Project : Project_Node_Id;
+ Current_Pkg : Name_Id;
+ Case_Project : Project_Node_Id;
+ Case_Pkg : Name_Id;
+ Name : Name_Id;
+ Node : Project_Node_Id);
+ -- Process a case construction.
+ -- The Makefile declations may be suppressed if no declarative
+ -- items in the case items are to be put in the Makefile.
+
+ procedure Process_Declarative_Items
+ (Project : Project_Node_Id;
+ Pkg : Name_Id;
+ In_Case : Boolean;
+ Item : Project_Node_Id);
+ -- Process the declarative items for a project, a package
+ -- or a case item.
+ -- If In_Case is True, all expressions are not static
+
+ procedure Process_Externals (Project : Project_Node_Id);
+ -- Look for all external references in one project file, populate the
+ -- table Externals, and output the necessary declarations, if any.
+
+ procedure Put (S : String; With_Substitution : Boolean := False);
+ -- Add a string to the Makefile.
+ -- When With_Substitution is True, if the string is one of the reserved
+ -- variables, replace it with the name of the corresponding saved
+ -- variable.
+
+ procedure Put (S : Name_Id);
+ -- Add a string to the Makefile.
+
+ procedure Put (P : Positive);
+ -- Add the image of a number to the Makefile, without leading space
+
+ procedure Put_Attribute
+ (Project : Project_Node_Id;
+ Pkg : Name_Id;
+ Name : Name_Id;
+ Index : Name_Id);
+ -- Put the full name of an attribute in the Makefile
+
+ procedure Put_Directory_Separator;
+ -- Add a directory separator to the Makefile
+
+ procedure Put_Include_Project
+ (Included_Project_Path : Name_Id;
+ Included_Project : Project_Node_Id;
+ Including_Project_Name : String);
+ -- Output an include directive for a project
+
+ procedure Put_Line (S : String);
+ -- Add a string and a line terminator to the Makefile
+
+ procedure Put_L_Name (N : Name_Id);
+ -- Put a name in lower case in the Makefile
+
+ procedure Put_M_Name (N : Name_Id);
+ -- Put a name in mixed case in the Makefile
+
+ procedure Put_U_Name (N : Name_Id);
+ -- Put a name in upper case in the Makefile
+
+ procedure Special_Put_U_Name (S : Name_Id);
+ -- Put a name in upper case in the Makefile.
+ -- If "C++" change it to "CXX".
+
+ procedure Put_Variable
+ (Project : Project_Node_Id;
+ Pkg : Name_Id;
+ Name : Name_Id);
+ -- Put the full name of a variable in the Makefile
+
+ procedure Recursive_Process (Project : Project_Node_Id);
+ -- Process a project file and the project files it depends on iteratively
+ -- without processing twice the same project file.
+
+ procedure Reset_Suffixes_And_Languages;
+ -- Indicate that all suffixes and languages have the default values
+
+ function Source_Kind_Of (File_Name : Name_Id) return Source_Kind_Type;
+ -- From a source file name, returns the source kind of the file
+
+ function Suffix_Of
+ (Static : Boolean;
+ Value : String_Access;
+ Last : Natural;
+ Default : String)
+ return String;
+ -- Returns the current suffix, if it is statically known, or ""
+ -- if it is not statically known. Used on C_Suffix, Cxx_Suffix,
+ -- Ada_Body_Suffix and Ada_Spec_Suffix.
+
+ procedure Usage;
+ -- Display the usage of gnatbuild
+
+ -----------------------------
+ -- Add_To_Expression_Value --
+ -----------------------------
+
+ procedure Add_To_Expression_Value (S : String) is
+ begin
+ -- Check that the buffer is large enough.
+ -- If it is not, double it until it is large enough.
+
+ while Expression_Last + S'Length > Expression_Value'Last loop
+ declare
+ New_Value : constant String_Access :=
+ new String (1 .. 2 * Expression_Value'Last);
+
+ begin
+ New_Value (1 .. Expression_Last) :=
+ Expression_Value (1 .. Expression_Last);
+ Free (Expression_Value);
+ Expression_Value := New_Value;
+ end;
+ end loop;
+
+ Expression_Value (Expression_Last + 1 .. Expression_Last + S'Length)
+ := S;
+ Expression_Last := Expression_Last + S'Length;
+ end Add_To_Expression_Value;
+
+ procedure Add_To_Expression_Value (S : Name_Id) is
+ begin
+ Get_Name_String (S);
+ Add_To_Expression_Value (S => Name_Buffer (1 .. Name_Len));
+ end Add_To_Expression_Value;
+
+ -----------------------
+ -- Display_Copyright --
+ -----------------------
+
+ procedure Display_Copyright is
+ begin
+ if not Copyright_Displayed then
+ Copyright_Displayed := True;
+ Write_Str ("GPR2MAKE ");
+ Write_Str (Gnatvsn.Gnat_Version_String);
+ Write_Str (" Copyright 2002-2003 Free Software Foundation, Inc.");
+ Write_Eol;
+ Write_Eol;
+ end if;
+ end Display_Copyright;
+
+ ------------------
+ -- Equal_String --
+ ------------------
+
+ function Equal_String (Left, Right : Name_Id) return Boolean is
+ begin
+ Get_Name_String (Left);
+
+ declare
+ Left_Value : constant String :=
+ To_Lower (Name_Buffer (1 .. Name_Len));
+
+ begin
+ Get_Name_String (Right);
+ return Left_Value = To_Lower (Name_Buffer (1 .. Name_Len));
+ end;
+ end Equal_String;
+
+ ----------------
+ -- Expression --
+ ----------------
+
+ procedure Expression
+ (Project : Project_Node_Id;
+ First_Term : Project_Node_Id;
+ Kind : Variable_Kind;
+ In_Case : Boolean;
+ Reset : Boolean := False)
+ is
+ Term : Project_Node_Id := First_Term;
+ -- The term in the expression list
+
+ Current_Term : Project_Node_Id := Empty_Node;
+ -- The current term node id
+
+ begin
+ if In_Case then
+ Expression_Kind := Other;
+
+ elsif Reset then
+ Expression_Kind := Undecided;
+ Expression_Last := 0;
+ end if;
+
+ while Term /= Empty_Node loop
+
+ Current_Term := Tree.Current_Term (Term);
+
+ case Kind_Of (Current_Term) is
+
+ when N_Literal_String =>
+ -- If we are in a string list, we precede this literal string
+ -- with a space; it does not matter if the output list
+ -- has a leading space.
+ -- Otherwise we just output the literal string:
+ -- if it is not the first term of the expression, it will
+ -- concatenate with was previously output.
+
+ if Kind = List then
+ Put (" ");
+ end if;
+
+ -- If in a static string expression, add to expression value
+
+ if Expression_Kind = Undecided
+ or else Expression_Kind = Static_String
+ then
+ Expression_Kind := Static_String;
+
+ if Kind = List then
+ Add_To_Expression_Value (" ");
+ end if;
+
+ Add_To_Expression_Value (String_Value_Of (Current_Term));
+ end if;
+
+ Put (String_Value_Of (Current_Term));
+
+ when N_Literal_String_List =>
+ -- For string list, we repetedly call Expression with each
+ -- element of the list.
+
+ declare
+ String_Node : Project_Node_Id :=
+ First_Expression_In_List (Current_Term);
+
+ begin
+ if String_Node /= Empty_Node then
+
+ -- If String_Node is nil, it is an empty list,
+ -- there is nothing to do
+
+ Expression
+ (Project => Project,
+ First_Term => Tree.First_Term (String_Node),
+ Kind => Single,
+ In_Case => In_Case);
+
+ loop
+ -- Add the other element of the literal string list
+ -- one after the other
+
+ String_Node :=
+ Next_Expression_In_List (String_Node);
+
+ exit when String_Node = Empty_Node;
+
+ Put (" ");
+ Add_To_Expression_Value (" ");
+ Expression
+ (Project => Project,
+ First_Term => Tree.First_Term (String_Node),
+ Kind => Single,
+ In_Case => In_Case);
+ end loop;
+ end if;
+ end;
+
+ when N_Variable_Reference | N_Attribute_Reference =>
+ -- A variable or attribute reference is never static
+
+ Expression_Kind := Other;
+
+ -- A variable or an attribute is identified by:
+ -- - its project name,
+ -- - its package name, if any,
+ -- - its name, and
+ -- - its index (if an associative array attribute).
+
+ declare
+ Term_Project : Project_Node_Id :=
+ Project_Node_Of (Current_Term);
+ Term_Package : constant Project_Node_Id :=
+ Package_Node_Of (Current_Term);
+
+ Name : constant Name_Id := Name_Of (Current_Term);
+
+ Term_Package_Name : Name_Id := No_Name;
+
+ begin
+ if Term_Project = Empty_Node then
+ Term_Project := Project;
+ end if;
+
+ if Term_Package /= Empty_Node then
+ Term_Package_Name := Name_Of (Term_Package);
+ end if;
+
+ -- If we are in a string list, we precede this variable or
+ -- attribute reference with a space; it does not matter if
+ -- the output list has a leading space.
+
+ if Kind = List then
+ Put (" ");
+ end if;
+
+ Put ("$(");
+
+ if Kind_Of (Current_Term) = N_Variable_Reference then
+ Put_Variable
+ (Project => Term_Project,
+ Pkg => Term_Package_Name,
+ Name => Name);
+
+ else
+ -- Attribute reference.
+
+ -- If it is a Default_Switches attribute, check if it
+ -- is allowed in this expression (same package and same
+ -- language).
+
+ if Name = Snames.Name_Default_Switches then
+ if Default_Switches_Package /= Term_Package_Name
+ or else not Equal_String
+ (Default_Switches_Language,
+ Associative_Array_Index_Of
+ (Current_Term))
+ then
+ -- This Default_Switches attribute is not allowed
+ -- here; report an error and continue.
+ -- The Makefiles created will be deleted at the
+ -- end.
+
+ Error_Msg_Name_1 := Term_Package_Name;
+ Error_Msg
+ ("reference to `%''Default_Switches` " &
+ "not allowed here",
+ Location_Of (Current_Term));
+ end if;
+
+ -- If it is a Switches attribute, check if it is allowed
+ -- in this expression (same package and same source
+ -- kind).
+
+ elsif Name = Snames.Name_Switches then
+ if Switches_Package /= Term_Package_Name
+ or else Source_Kind_Of (Associative_Array_Index_Of
+ (Current_Term))
+ /= Switches_Language
+ then
+ -- This Switches attribute is not allowed here;
+ -- report an error and continue. The Makefiles
+ -- created will be deleted at the end.
+
+ Error_Msg_Name_1 := Term_Package_Name;
+ Error_Msg
+ ("reference to `%''Switches` " &
+ "not allowed here",
+ Location_Of (Current_Term));
+ end if;
+
+ else
+ -- Other attribute references are only allowed in
+ -- the declaration of an atribute of the same
+ -- package and of the same name.
+
+ if not Other_Attribute
+ or else Other_Attribute_Package /= Term_Package_Name
+ or else Other_Attribute_Name /= Name
+ then
+ if Term_Package_Name = No_Name then
+ Error_Msg_Name_1 := Name;
+ Error_Msg
+ ("reference to % not allowed here",
+ Location_Of (Current_Term));
+
+ else
+ Error_Msg_Name_1 := Term_Package_Name;
+ Error_Msg_Name_2 := Name;
+ Error_Msg
+ ("reference to `%''%` not allowed here",
+ Location_Of (Current_Term));
+ end if;
+ end if;
+ end if;
+
+ Put_Attribute
+ (Project => Term_Project,
+ Pkg => Term_Package_Name,
+ Name => Name,
+ Index => Associative_Array_Index_Of (Current_Term));
+ end if;
+
+ Put (")");
+ end;
+
+ when N_External_Value =>
+ -- An external reference is never static
+
+ Expression_Kind := Other;
+
+ -- As the external references have already been processed,
+ -- we just output the name of the variable that corresponds
+ -- to this external reference node.
+
+ Put ("$(");
+ Put_U_Name (Name_Of (Project));
+ Put (".external.");
+ Put (Externals.Get (Current_Term));
+ Put (")");
+
+ when others =>
+
+ -- Should never happen
+
+ pragma Assert
+ (False,
+ "illegal node kind in an expression");
+ raise Program_Error;
+ end case;
+
+ Term := Next_Term (Term);
+ end loop;
+ end Expression;
+
+ --------------
+ -- Gpr2make --
+ --------------
+
+ procedure Gpr2make is
+ begin
+ -- First, get the switches, if any
+
+ loop
+ case Getopt ("h q v R") is
+ when ASCII.NUL =>
+ exit;
+
+ -- -h: Help
+
+ when 'h' =>
+ Usage;
+
+ -- -q: Quiet
+
+ when 'q' =>
+ Opt.Quiet_Output := True;
+
+ -- -v: Verbose
+
+ when 'v' =>
+ Opt.Verbose_Mode := True;
+ Display_Copyright;
+
+ -- -R: no Recursivity
+
+ when 'R' =>
+ Process_All_Project_Files := False;
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end loop;
+
+ -- Now, get the project file (maximum one)
+
+ loop
+ declare
+ S : constant String := Get_Argument (Do_Expansion => True);
+ begin
+ exit when S'Length = 0;
+
+ if Main_Project_File_Name /= null then
+ Fail ("only one project file may be specified");
+
+ else
+ Main_Project_File_Name := new String'(S);
+ end if;
+ end;
+ end loop;
+
+ -- If no project file specified, display the usage and exit
+
+ if Main_Project_File_Name = null then
+ Usage;
+ return;
+ end if;
+
+ -- Do the necessary initializations
+
+ Csets.Initialize;
+ Namet.Initialize;
+
+ Snames.Initialize;
+
+ Prj.Initialize;
+
+ -- Parse the project file(s)
+
+ Prj.Part.Parse (Project_Tree, Main_Project_File_Name.all, False);
+
+ -- If parsing was successful, process the project tree
+
+ if Project_Tree /= Empty_Node then
+
+ -- Create some Name_Ids that are not in Snames
+
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "ide";
+ Name_Ide := Name_Find;
+
+ Name_Len := 16;
+ Name_Buffer (1 .. Name_Len) := "compiler_command";
+ Name_Compiler_Command := Name_Find;
+
+ Name_Len := 13;
+ Name_Buffer (1 .. Name_Len) := "main_language";
+ Name_Main_Language := Name_Find;
+
+ Name_Len := 3;
+ Name_Buffer (1 .. Name_Len) := "c++";
+ Name_C_Plus_Plus := Name_Find;
+
+ Process (Project_Tree);
+
+ if Compilation_Errors then
+ if not Verbose_Mode then
+ Write_Eol;
+ end if;
+
+ Prj.Err.Finalize;
+ Write_Eol;
+ IO.Delete_All;
+ Fail ("no Makefile created");
+ end if;
+ end if;
+ end Gpr2make;
+
+ --------------
+ -- New_Line --
+ --------------
+
+ procedure New_Line is
+ begin
+ IO.New_Line;
+ end New_Line;
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (Project : Project_Node_Id) is
+ begin
+ Processed_Projects.Reset;
+ Recursive_Process (Project);
+ end Process;
+
+ -------------------------------
+ -- Process_Case_Construction --
+ -------------------------------
+
+ procedure Process_Case_Construction
+ (Current_Project : Project_Node_Id;
+ Current_Pkg : Name_Id;
+ Case_Project : Project_Node_Id;
+ Case_Pkg : Name_Id;
+ Name : Name_Id;
+ Node : Project_Node_Id)
+ is
+ Case_Project_Name : constant Name_Id := Name_Of (Case_Project);
+ Before : IO.Position;
+ Start : IO.Position;
+ After : IO.Position;
+
+ procedure Put_Case_Construction;
+ -- Output the variable $<PROJECT>__CASE__#, specific to
+ -- this case construction. It contains the number of the
+ -- branch to follow.
+
+ procedure Recursive_Process
+ (Case_Item : Project_Node_Id;
+ Branch_Number : Positive);
+ -- A recursive procedure. Calls itself for each branch, increasing
+ -- Branch_Number by 1 each time.
+
+ procedure Put_Variable_Name;
+ -- Output the case variable
+
+ ---------------------------
+ -- Put_Case_Construction --
+ ---------------------------
+
+ procedure Put_Case_Construction is
+ begin
+ Put_U_Name (Case_Project_Name);
+ Put (".case.");
+ Put (Last_Case_Construction);
+ end Put_Case_Construction;
+
+ -----------------------
+ -- Recursive_Process --
+ -----------------------
+
+ procedure Recursive_Process
+ (Case_Item : Project_Node_Id;
+ Branch_Number : Positive)
+ is
+ Choice_String : Project_Node_Id := First_Choice_Of (Case_Item);
+
+ Before : IO.Position;
+ Start : IO.Position;
+ After : IO.Position;
+
+ No_Lines : Boolean := False;
+
+ begin
+ -- Nothing to do if Case_Item is empty.
+ -- That should happen only if the case construvtion is totally empty.
+ -- case Var is
+ -- end case;
+
+ if Case_Item /= Empty_Node then
+ -- Remember where we are, to be able to come back here if this
+ -- case item is empty.
+
+ IO.Mark (Before);
+
+ if Choice_String = Empty_Node then
+ -- when others =>
+
+ -- Output a comment "# when others => ..."
+
+ Put_Line ("# when others => ...");
+
+ -- Remember where we are, to detect if there is anything
+ -- put in the Makefile for this branch.
+
+ IO.Mark (Start);
+
+ -- Process the declarative items of this branch
+
+ Process_Declarative_Items
+ (Project => Current_Project,
+ Pkg => Current_Pkg,
+ In_Case => True,
+ Item => First_Declarative_Item_Of (Case_Item));
+
+ -- Where are we now?
+ IO.Mark (After);
+
+ -- If we are at the same place, the branch is totally empty:
+ -- suppress it completely.
+
+ if Start = After then
+ IO.Release (Before);
+ end if;
+ else
+ -- Case Item with one or several case labels
+
+ -- Output a comment
+ -- # case <label> => ...
+ -- or
+ -- # case <first_Label> | ... =>
+ -- depending on the number of case labels.
+
+ Put ("# when """);
+ Put (String_Value_Of (Choice_String));
+ Put ("""");
+
+ if Next_Literal_String (Choice_String) /= Empty_Node then
+ Put (" | ...");
+ end if;
+
+ Put (" => ...");
+ New_Line;
+
+ -- Check if the case variable is equal to the first case label
+ Put ("ifeq ($(");
+ Put_Variable_Name;
+ Put ("),");
+ Put (String_Value_Of (Choice_String));
+ Put (")");
+ New_Line;
+
+ if Next_Literal_String (Choice_String) /= Empty_Node then
+ -- Several choice strings. We need to use an auxiliary
+ -- variable <PROJECT.case.# to detect if we should follow
+ -- this branch.
+
+ loop
+ Put_Case_Construction;
+ Put (":=");
+ Put (Branch_Number);
+ New_Line;
+
+ Put_Line ("endif");
+
+ Choice_String := Next_Literal_String (Choice_String);
+
+ exit when Choice_String = Empty_Node;
+
+ Put ("ifeq ($(");
+ Put_Variable_Name;
+ Put ("),");
+ Put (String_Value_Of (Choice_String));
+ Put (")");
+ New_Line;
+ end loop;
+
+ -- Now, we test the auxiliary variable
+
+ Put ("ifeq ($(");
+ Put_Case_Construction;
+ Put ("),");
+ Put (Branch_Number);
+ Put (")");
+ New_Line;
+ end if;
+
+ -- Remember where we are before calling
+ -- Process_Declarative_Items.
+
+ IO.Mark (Start);
+
+ Process_Declarative_Items
+ (Project => Current_Project,
+ Pkg => Current_Pkg,
+ In_Case => True,
+ Item => First_Declarative_Item_Of (Case_Item));
+
+ -- Check where we are now, to detect if some lines have been
+ -- added to the Makefile.
+
+ IO.Mark (After);
+
+ No_Lines := Start = After;
+
+ -- If no lines have been added, then suppress completely this
+ -- branch.
+
+ if No_Lines then
+ IO.Release (Before);
+ end if;
+
+ -- If there is a next branch, process it
+
+ if Next_Case_Item (Case_Item) /= Empty_Node then
+ -- If this branch has not been suppressed, we need an "else"
+
+ if not No_Lines then
+ -- Mark the position of the "else"
+
+ IO.Mark (Before);
+
+ Put_Line ("else");
+
+ -- Mark the position before the next branch
+
+ IO.Mark (Start);
+ end if;
+
+ Recursive_Process
+ (Case_Item => Next_Case_Item (Case_Item),
+ Branch_Number => Branch_Number + 1);
+
+ if not No_Lines then
+ -- Where are we?
+ IO.Mark (After);
+
+ -- If we are at the same place, suppress the useless
+ -- "else".
+
+ if After = Start then
+ IO.Release (Before);
+ end if;
+ end if;
+ end if;
+
+ -- If the branch has not been suppressed, we need an "endif"
+
+ if not No_Lines then
+ Put_Line ("endif");
+ end if;
+ end if;
+ end if;
+ end Recursive_Process;
+
+ -----------------------
+ -- Put_Variable_Name --
+ -----------------------
+
+ procedure Put_Variable_Name is
+ begin
+ Put_Variable (Case_Project, Case_Pkg, Name);
+ end Put_Variable_Name;
+
+ -- Start of procedure Process_Case_Construction
+
+ begin
+ Last_Case_Construction := Last_Case_Construction + 1;
+
+ -- Remember where we are in case we suppress completely the case
+ -- construction.
+
+ IO.Mark (Before);
+
+ New_Line;
+
+ -- Output a comment line for this case construction
+
+ Put ("# case ");
+ Put_M_Name (Case_Project_Name);
+
+ if Case_Pkg /= No_Name then
+ Put (".");
+ Put_M_Name (Case_Pkg);
+ end if;
+
+ Put (".");
+ Put_M_Name (Name);
+ Put (" is ...");
+ New_Line;
+
+ -- Remember where we are, to detect if all branches have been suppressed
+
+ IO.Mark (Start);
+
+ -- Start at the first case item
+
+ Recursive_Process
+ (Case_Item => First_Case_Item_Of (Node),
+ Branch_Number => 1);
+
+ -- Where are we?
+
+ IO.Mark (After);
+
+ -- If we are at the same position, it means that all branches have been
+ -- suppressed: then we suppress completely the case construction.
+
+ if Start = After then
+ IO.Release (Before);
+
+ else
+ -- If the case construction is not completely suppressed, we issue
+ -- a comment indicating the end of the case construction.
+
+ Put_Line ("# end case;");
+
+ New_Line;
+ end if;
+ end Process_Case_Construction;
+
+ -------------------------------
+ -- Process_Declarative_Items --
+ -------------------------------
+
+ procedure Process_Declarative_Items
+ (Project : Project_Node_Id;
+ Pkg : Name_Id;
+ In_Case : Boolean;
+ Item : Project_Node_Id)
+ is
+ Current_Declarative_Item : Project_Node_Id := Item;
+ Current_Item : Project_Node_Id := Empty_Node;
+
+ Project_Name : constant String :=
+ To_Upper (Get_Name_String (Name_Of (Project)));
+ Item_Name : Name_Id := No_Name;
+
+ begin
+ -- For each declarative item
+
+ while Current_Declarative_Item /= Empty_Node loop
+ -- Get its data
+
+ Current_Item := Current_Item_Node (Current_Declarative_Item);
+
+ -- And set Current_Declarative_Item to the next declarative item
+ -- ready for the next iteration
+
+ Current_Declarative_Item := Next_Declarative_Item
+ (Current_Declarative_Item);
+
+ -- By default, indicate that Default_Switches and Switches
+ -- attribute references are not allowed in expressions.
+
+ Default_Switches_Project := Empty_Node;
+ Switches_Project := Empty_Node;
+ Other_Attribute := False;
+
+ -- Write_Line (Project_Node_Kind'Image (Kind_Of (Current_Item)));
+
+ case Kind_Of (Current_Item) is
+
+ when N_Package_Declaration =>
+ Item_Name := Name_Of (Current_Item);
+
+ declare
+ Real_Project : constant Project_Node_Id :=
+ Project_Of_Renamed_Package_Of
+ (Current_Item);
+
+ Before_Package : IO.Position;
+ Start_Of_Package : IO.Position;
+ End_Of_Package : IO.Position;
+
+ Decl_Item : Project_Node_Id;
+
+ begin
+ -- If it is a renaming package, we go to the original
+ -- package. This is guaranteed to work, otherwise the
+ -- parsing of the project file tree would have already
+ -- failed.
+
+ if Real_Project /= Empty_Node then
+ Decl_Item :=
+ First_Declarative_Item_Of
+ (Project_Declaration_Of (Real_Project));
+
+ -- Traverse the declarative items of the project,
+ -- until we find the renamed package.
+
+ while Decl_Item /= Empty_Node loop
+ Current_Item := Current_Item_Node (Decl_Item);
+ exit when Kind_Of (Current_Item)
+ = N_Package_Declaration
+ and then Name_Of (Current_Item) = Item_Name;
+ Decl_Item := Next_Declarative_Item (Decl_Item);
+ end loop;
+ end if;
+
+ -- Remember where we are, in case we want to completely
+ -- suppress this package.
+
+ IO.Mark (Before_Package);
+
+ New_Line;
+
+ -- Output comment line for this package
+
+ Put ("# package ");
+ Put_M_Name (Item_Name);
+ Put (" is ...");
+ New_Line;
+
+ -- Record where we are before calling
+ -- Process_Declarative_Items.
+
+ IO.Mark (Start_Of_Package);
+
+ -- And process the declarative items of this package
+
+ Process_Declarative_Items
+ (Project => Project,
+ Pkg => Item_Name,
+ In_Case => False,
+ Item => First_Declarative_Item_Of (Current_Item));
+
+ -- Reset the local variables once we have finished with
+ -- this package.
+
+ Variable_Names.Init;
+
+ -- Where are we?
+ IO.Mark (End_Of_Package);
+
+ -- If we are at the same place, suppress completely the
+ -- package.
+
+ if End_Of_Package = Start_Of_Package then
+ IO.Release (Before_Package);
+
+ else
+
+ -- otherwise, utput comment line for end of package
+
+ Put ("# end ");
+ Put_M_Name (Item_Name);
+ Put (";");
+ New_Line;
+
+ New_Line;
+ end if;
+ end;
+
+ when N_Variable_Declaration | N_Typed_Variable_Declaration =>
+ Item_Name := Name_Of (Current_Item);
+
+ -- Output comment line for this variable
+
+ Put ("# ");
+ Put_M_Name (Item_Name);
+ Put (" := ...");
+ New_Line;
+
+ -- If we are inside a package, the variable is a local
+ -- variable, not a project level variable.
+ -- So we check if its name is included in the Variables
+ -- table; if it is not already, we put it in the table.
+
+ if Pkg /= No_Name then
+ declare
+ Found : Boolean := False;
+
+ begin
+ for
+ Index in Variable_Names.First .. Variable_Names.Last
+ loop
+ if Variable_Names.Table (Index) = Item_Name then
+ Found := True;
+ exit;
+ end if;
+ end loop;
+
+ if not Found then
+ Variable_Names.Increment_Last;
+ Variable_Names.Table (Variable_Names.Last) :=
+ Item_Name;
+ end if;
+ end;
+ end if;
+
+ -- Output the line <variable_Name>:=<expression>
+
+ Put_Variable (Project, Pkg, Item_Name);
+
+ Put (":=");
+
+ Expression
+ (Project => Project,
+ First_Term => Tree.First_Term (Expression_Of (Current_Item)),
+ Kind => Expression_Kind_Of (Current_Item),
+ In_Case => In_Case);
+
+ New_Line;
+
+ when N_Attribute_Declaration =>
+ Item_Name := Name_Of (Current_Item);
+
+ declare
+ Index : constant Name_Id :=
+ Associative_Array_Index_Of (Current_Item);
+
+ Pos_Comment : IO.Position;
+ Put_Declaration : Boolean := True;
+
+ begin
+ -- If it is a Default_Switches attribute register the
+ -- project, the package and the language to indicate
+ -- what Default_Switches attribute references are allowed
+ -- in expressions.
+
+ if Item_Name = Snames.Name_Default_Switches then
+ Default_Switches_Project := Project;
+ Default_Switches_Package := Pkg;
+ Default_Switches_Language := Index;
+
+ -- If it is a Switches attribute register the project,
+ -- the package and the source kind to indicate what
+ -- Switches attribute references are allowed in expressions.
+
+ elsif Item_Name = Snames.Name_Switches then
+ Switches_Project := Project;
+ Switches_Package := Pkg;
+ Switches_Language := Source_Kind_Of (Index);
+
+ else
+ -- Set Other_Attribute to True to indicate that we are
+ -- in the declaration of an attribute other than
+ -- Switches or Default_Switches.
+
+ Other_Attribute := True;
+ Other_Attribute_Package := Pkg;
+ Other_Attribute_Name := Item_Name;
+ end if;
+
+ -- Record where we are to be able to suppress the
+ -- declaration.
+
+ IO.Mark (Pos_Comment);
+
+ -- Output comment line for this attribute
+
+ Put ("# for ");
+ Put_M_Name (Item_Name);
+
+ if Index /= No_Name then
+ Put (" (""");
+ Put (Index);
+ Put (""")");
+ end if;
+
+ Put (" use ...");
+ New_Line;
+
+ -- Output the line <attribute_name>:=<expression>
+
+ Put_Attribute (Project, Pkg, Item_Name, Index);
+ Put (":=");
+ Expression
+ (Project => Project,
+ First_Term =>
+ Tree.First_Term (Expression_Of (Current_Item)),
+ Kind => Expression_Kind_Of (Current_Item),
+ In_Case => In_Case,
+ Reset => True);
+ New_Line;
+
+ -- Remove any Default_Switches attribute declaration for
+ -- languages other than C or C++.
+
+ if Item_Name = Snames.Name_Default_Switches then
+ Get_Name_String (Index);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ Put_Declaration :=
+ Name_Buffer (1 .. Name_Len) = "c" or else
+ Name_Buffer (1 .. Name_Len) = "c++";
+
+ -- Remove any Switches attribute declaration for source
+ -- kinds other than C, C++ or unknown.
+
+ elsif Item_Name = Snames.Name_Switches then
+ Put_Declaration :=
+ Switches_Language = Unknown
+ or else Switches_Language = C
+ or else Switches_Language = Cxx;
+
+ end if;
+
+ -- Attributes in packages other than Naming, Compiler or
+ -- IDE are of no interest; suppress their declarations.
+
+ Put_Declaration := Put_Declaration and
+ (Pkg = No_Name
+ or else Pkg = Snames.Name_Naming
+ or else Pkg = Snames.Name_Compiler
+ or else Pkg = Name_Ide);
+
+ if Put_Declaration then
+ -- Some attributes are converted into reserved variables
+
+ if Pkg = No_Name then
+
+ -- Project level attribute
+
+ if Item_Name = Snames.Name_Languages then
+
+ -- for Languages use ...
+
+ -- Attribute Languages is converted to variable
+ -- LANGUAGES. The actual string is put in lower
+ -- case.
+
+ Put ("LANGUAGES:=");
+
+ -- If the expression is static (expected to be so
+ -- most of the cases), then just give to LANGUAGES
+ -- the lower case value of the expression.
+
+ if Expression_Kind = Static_String then
+ Put (To_Lower (Expression_Value
+ (1 .. Expression_Last)));
+
+ else
+ -- Otherwise, call to_lower on the value
+ -- of the attribute.
+
+ Put ("$(shell gprcmd to_lower $(");
+ Put_Attribute
+ (Project, No_Name, Item_Name, No_Name);
+ Put ("))");
+ end if;
+
+ New_Line;
+
+ -- Record value of Languages if expression is
+ -- static and if Languages_Static is True.
+
+ if Expression_Kind /= Static_String then
+ Languages_Static := False;
+
+ elsif Languages_Static then
+ To_Lower
+ (Expression_Value (1 .. Expression_Last));
+
+ if Languages_Last = 0 then
+ if Languages'Last < Expression_Last + 2 then
+ Free (Languages);
+ Languages :=
+ new String (1 .. Expression_Last + 2);
+ end if;
+
+ Languages (1) := ' ';
+ Languages (2 .. Expression_Last + 1) :=
+ Expression_Value (1 .. Expression_Last);
+ Languages_Last := Expression_Last + 2;
+ Languages (Languages_Last) := ' ';
+
+ else
+ Languages_Static :=
+ Languages (2 .. Languages_Last - 1) =
+ Expression_Value (1 .. Expression_Last);
+ end if;
+ end if;
+
+ elsif Item_Name = Snames.Name_Source_Dirs then
+
+ -- for Source_Dirs use ...
+
+ -- String list attribute Source_Dirs is converted
+ -- to variable <PROJECT>.src_dirs, each element
+ -- being an absolute directory name.
+
+ Put (Project_Name &
+ ".src_dirs:=$(shell gprcmd extend $(");
+ Put (Project_Name);
+ Put (".base_dir) '$(");
+ Put_Attribute (Project, Pkg, Item_Name, No_Name);
+ Put_Line (")')");
+
+ elsif Item_Name = Snames.Name_Source_Files then
+
+ -- for Source_Files use ...
+
+ -- String list Source_Files is converted to
+ -- variable <PROJECT>.src_files
+
+ Put (Project_Name);
+ Put (".src_files:=$(");
+ Put_Attribute (Project, Pkg, Item_Name, No_Name);
+ Put (")");
+ New_Line;
+
+ if In_Case then
+ if Source_Files_Declaration = False then
+ Source_Files_Declaration := May_Be;
+ end if;
+
+ if Source_Files_Declaration /= True then
+
+ -- Variable src_files.specified is set to
+ -- TRUE. It will be tested to decide if there
+ -- is a need to look for source files either
+ -- in the source directories or in a source
+ -- list file.
+
+ Put_Line ("src_files.specified:=TRUE");
+ end if;
+
+ else
+ Source_Files_Declaration := True;
+ end if;
+
+ elsif Item_Name = Snames.Name_Source_List_File then
+
+ -- for Source_List_File use ...
+
+ -- Single string Source_List_File is converted to
+ -- variable src.list_file. It will be used
+ -- later, if necessary, to get the source
+ -- file names from the specified file.
+ -- The file name is converted to an absolute path
+ -- name if necessary.
+
+ Put ("src.list_file:=" &
+ "$(strip $(shell gprcmd to_absolute $(");
+ Put (Project_Name);
+ Put (".base_dir) $(");
+ Put_Attribute (Project, Pkg, Item_Name, No_Name);
+ Put_Line (")))");
+
+ if In_Case then
+ if Source_List_File_Declaration = False then
+ Source_List_File_Declaration := May_Be;
+ end if;
+
+ if Source_Files_Declaration /= True
+ and then Source_List_File_Declaration /= True
+ then
+ -- Variable src_list_file.specified is set to
+ -- TRUE. It will be tested later, if
+ -- necessary, to read the source list file.
+
+ Put_Line ("src_list_file.specified:=TRUE");
+ end if;
+
+ else
+ Source_List_File_Declaration := True;
+ end if;
+
+ elsif Item_Name = Snames.Name_Object_Dir then
+
+ -- for Object_Dir use ...
+
+ -- Single string attribute Object_Dir is converted
+ -- to variable <PROJECT>.obj_dir. The directory is
+ -- converted to an absolute path name,
+ -- if necessary.
+
+ Put (Project_Name);
+ Put (".obj_dir:=" &
+ "$(strip $(shell gprcmd to_absolute $(");
+ Put (Project_Name);
+ Put (".base_dir) $(");
+ Put_Attribute (Project, Pkg, Item_Name, No_Name);
+ Put_Line (")))");
+
+ elsif Item_Name = Snames.Name_Exec_Dir then
+
+ -- for Exec_Dir use ...
+
+ -- Single string attribute Exec_Dir is converted
+ -- to variable EXEC_DIR. The directory is
+ -- converted to an absolute path name,
+ -- if necessary.
+
+ Put ("EXEC_DIR:=" &
+ "$(strip $(shell gprcmd to_absolute $(");
+ Put (Project_Name);
+ Put (".base_dir) $(");
+ Put_Attribute (Project, Pkg, Item_Name, No_Name);
+ Put_Line (")))");
+
+ elsif Item_Name = Snames.Name_Main then
+
+ -- for Mains use ...
+
+ -- String list attribute Main is converted to
+ -- variable ADA_MAINS.
+
+ Put ("ADA_MAINS:=$(");
+ Put_Attribute (Project, Pkg, Item_Name, No_Name);
+ Put (")");
+ New_Line;
+
+ elsif Item_Name = Name_Main_Language then
+
+ -- for Main_Language use ...
+
+ Put ("MAIN:=");
+
+ -- If the expression is static (expected to be so
+ -- most of the cases), then just give to MAIN
+ -- the lower case value of the expression.
+
+ if Expression_Kind = Static_String then
+ Put (To_Lower (Expression_Value
+ (1 .. Expression_Last)));
+
+ else
+ -- Otherwise, call to_lower on the value
+ -- of the attribute.
+
+ Put ("$(shell gprcmd to_lower $(");
+ Put_Attribute
+ (Project, No_Name, Item_Name, No_Name);
+ Put ("))");
+ end if;
+
+ New_Line;
+
+ else
+ -- Other attribute are of no interest; suppress
+ -- their declarations.
+
+ Put_Declaration := False;
+ end if;
+
+ elsif Pkg = Snames.Name_Compiler then
+ -- Attribute of package Compiler
+
+ if Item_Name = Snames.Name_Switches then
+
+ -- for Switches (<file_name>) use ...
+
+ -- As the C and C++ extension may not be known
+ -- statically, at the end of the processing of this
+ -- project file, a test will done to decide if the
+ -- file name (the index) has a C or C++ extension.
+ -- The index is recorded in the table Switches,
+ -- making sure that it appears only once.
+
+ declare
+ Found : Boolean := False;
+ begin
+ for J in Switches.First .. Switches.Last loop
+ if Switches.Table (J) = Index then
+ Found := True;
+ exit;
+ end if;
+ end loop;
+
+ if not Found then
+ Switches.Increment_Last;
+ Switches.Table (Switches.Last) := Index;
+ end if;
+ end;
+
+ elsif Item_Name = Snames.Name_Default_Switches then
+ Get_Name_String (Index);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+
+ if Name_Buffer (1 .. Name_Len) = "c" then
+ Put ("CFLAGS:=$(");
+ Put_Attribute (Project, Pkg, Item_Name, Index);
+ Put (")");
+ New_Line;
+
+ elsif Name_Buffer (1 .. Name_Len) = "c++" then
+ Put ("CXXFLAGS:=$(");
+ Put_Attribute (Project, Pkg, Item_Name, Index);
+ Put (")");
+ New_Line;
+ end if;
+ else
+ -- Other attribute are of no interest; suppress
+ -- their declarations.
+
+ Put_Declaration := False;
+ end if;
+
+ elsif Pkg = Name_Ide then
+
+ -- Attributes of package IDE
+
+ if Item_Name = Name_Compiler_Command then
+
+ -- for Compiler_Command (<language>) use ...
+
+ declare
+ Index_Name : Name_Id := No_Name;
+
+ begin
+ Get_Name_String (Index);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ Index_Name := Name_Find;
+
+ -- Only "Ada", "C" and "C++" are of interest
+
+ if Index_Name = Snames.Name_Ada then
+
+ -- For "Ada", we set the variable $GNATMAKE
+
+ Put ("GNATMAKE:=$(");
+ Put_Attribute
+ (Project, Pkg, Item_Name, Index);
+ Put (")");
+ New_Line;
+
+ elsif Index_Name = Snames.Name_C then
+
+ -- For "C", we set the variable $CC
+
+ Put ("CC:=$(");
+ Put_Attribute
+ (Project, Pkg, Item_Name, Index);
+ Put (")");
+ New_Line;
+
+ elsif Index_Name = Name_C_Plus_Plus then
+
+ -- For "C++", we set the variable $CXX
+
+ Put ("CXX:=$(");
+ Put_Attribute
+ (Project, Pkg, Item_Name, Index);
+ Put (")");
+ New_Line;
+ end if;
+ end;
+ else
+ -- Other attribute are of no interest; suppress
+ -- their declarations.
+
+ Put_Declaration := False;
+ end if;
+
+ elsif Pkg = Snames.Name_Naming then
+ -- Attributes of package Naming
+
+ if Item_Name = Snames.Name_Body_Suffix then
+
+ -- for Body_Suffix (<language>) use ...
+
+ declare
+ Index_Name : Name_Id := No_Name;
+
+ begin
+ Get_Name_String (Index);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ Index_Name := Name_Find;
+
+ -- Languages "C", "C++" & "Ada" are of interest
+
+ if Index_Name = Snames.Name_C then
+
+ -- For "C", we set the variable C_EXT
+
+ Put ("C_EXT:=$(");
+ Put_Attribute
+ (Project, Pkg, Item_Name, Index);
+ Put (")");
+ New_Line;
+
+ if Expression_Kind /= Static_String then
+ C_Suffix_Static := False;
+
+ elsif C_Suffix_Static then
+ if C_Suffix_Last = 0 then
+ if C_Suffix'Last < Expression_Last then
+ Free (C_Suffix);
+ C_Suffix := new String'
+ (Expression_Value
+ (1 .. Expression_Last));
+
+ else
+ C_Suffix (1 .. Expression_Last) :=
+ Expression_Value
+ (1 .. Expression_Last);
+ end if;
+
+ C_Suffix_Last := Expression_Last;
+
+ else
+ C_Suffix_Static :=
+ Expression_Value
+ (1 .. Expression_Last) =
+ C_Suffix (1 .. C_Suffix_Last);
+ end if;
+ end if;
+
+ elsif Index_Name = Name_C_Plus_Plus then
+
+ -- For "C++", we set the variable CXX_EXT
+
+ Put ("CXX_EXT:=$(");
+ Put_Attribute
+ (Project, Pkg, Item_Name, Index);
+ Put (")");
+ New_Line;
+
+ if Expression_Kind /= Static_String then
+ Cxx_Suffix_Static := False;
+
+ elsif Cxx_Suffix_Static then
+ if Cxx_Suffix_Last = 0 then
+ if
+ Cxx_Suffix'Last < Expression_Last
+ then
+ Free (Cxx_Suffix);
+ Cxx_Suffix := new String'
+ (Expression_Value
+ (1 .. Expression_Last));
+
+ else
+ Cxx_Suffix (1 .. Expression_Last) :=
+ Expression_Value
+ (1 .. Expression_Last);
+ end if;
+
+ Cxx_Suffix_Last := Expression_Last;
+
+ else
+ Cxx_Suffix_Static :=
+ Expression_Value
+ (1 .. Expression_Last) =
+ Cxx_Suffix (1 .. Cxx_Suffix_Last);
+ end if;
+ end if;
+
+ elsif Item_Name = Snames.Name_Ada then
+
+ -- For "Ada", we set the variable ADA_BODY
+
+ Put ("ADA_BODY:=$(");
+ Put_Attribute
+ (Project, Pkg, Item_Name, Index);
+ Put (")");
+ New_Line;
+
+ if Expression_Kind /= Static_String then
+ Ada_Body_Suffix_Static := False;
+
+ elsif Ada_Body_Suffix_Static then
+ if Ada_Body_Suffix_Last = 0 then
+ if
+ Ada_Body_Suffix'Last < Expression_Last
+ then
+ Free (Ada_Body_Suffix);
+ Ada_Body_Suffix := new String'
+ (Expression_Value
+ (1 .. Expression_Last));
+
+ else
+ Ada_Body_Suffix
+ (1 .. Expression_Last) :=
+ Expression_Value
+ (1 .. Expression_Last);
+ end if;
+
+ Ada_Body_Suffix_Last := Expression_Last;
+
+ else
+ Ada_Body_Suffix_Static :=
+ Expression_Value
+ (1 .. Expression_Last) =
+ Ada_Body_Suffix
+ (1 .. Ada_Body_Suffix_Last);
+ end if;
+ end if;
+ end if;
+ end;
+
+ elsif Item_Name = Snames.Name_Spec_Suffix then
+
+ -- for Spec_Suffix (<language>) use ...
+
+ declare
+ Index_Name : Name_Id := No_Name;
+
+ begin
+ Get_Name_String (Index);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ Index_Name := Name_Find;
+
+ -- Only "Ada" is of interest
+
+ if Index_Name = Snames.Name_Ada then
+
+ -- For "Ada", we set the variable ADA_SPEC
+
+ Put ("ADA_SPEC:=$(");
+ Put_Attribute
+ (Project, Pkg, Item_Name, Index);
+ Put (")");
+ New_Line;
+
+ if Expression_Kind /= Static_String then
+ Ada_Spec_Suffix_Static := False;
+
+ elsif Ada_Spec_Suffix_Static then
+ if Ada_Spec_Suffix_Last = 0 then
+ if
+ Ada_Spec_Suffix'Last < Expression_Last
+ then
+ Free (Ada_Spec_Suffix);
+ Ada_Spec_Suffix := new String'
+ (Expression_Value
+ (1 .. Expression_Last));
+
+ else
+ Ada_Spec_Suffix
+ (1 .. Expression_Last) :=
+ Expression_Value
+ (1 .. Expression_Last);
+ end if;
+
+ Ada_Spec_Suffix_Last := Expression_Last;
+
+ else
+ Ada_Spec_Suffix_Static :=
+ Expression_Value
+ (1 .. Expression_Last) =
+ Ada_Spec_Suffix
+ (1 .. Ada_Spec_Suffix_Last);
+ end if;
+ end if;
+ end if;
+ end;
+ else
+ -- Other attribute are of no interest; suppress
+ -- their declarations.
+
+ Put_Declaration := False;
+ end if;
+ end if;
+ end if;
+
+ -- Suppress the attribute declaration if not needed
+
+ if not Put_Declaration then
+ IO.Release (Pos_Comment);
+ end if;
+ end;
+
+ when N_Case_Construction =>
+
+ -- case <typed_string_variable> is ...
+
+ declare
+ Case_Project : Project_Node_Id := Project;
+ Case_Pkg : Name_Id := No_Name;
+ Variable_Node : constant Project_Node_Id :=
+ Case_Variable_Reference_Of (Current_Item);
+ Variable_Name : constant Name_Id := Name_Of (Variable_Node);
+
+ begin
+ if Project_Node_Of (Variable_Node) /= Empty_Node then
+ Case_Project := Project_Node_Of (Variable_Node);
+ end if;
+
+ if Package_Node_Of (Variable_Node) /= Empty_Node then
+ Case_Pkg := Name_Of (Package_Node_Of (Variable_Node));
+ end if;
+
+ -- If we are in a package, and no package is specified
+ -- for the case variable, we look into the table
+ -- Variables_Names to decide if it is a variable local
+ -- to the package or a project level variable.
+
+ if Pkg /= No_Name
+ and then Case_Pkg = No_Name
+ and then Case_Project = Project
+ then
+ for
+ Index in Variable_Names.First .. Variable_Names.Last
+ loop
+ if Variable_Names.Table (Index) = Variable_Name then
+ Case_Pkg := Pkg;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ -- The real work is done in Process_Case_Construction.
+
+ Process_Case_Construction
+ (Current_Project => Project,
+ Current_Pkg => Pkg,
+ Case_Project => Case_Project,
+ Case_Pkg => Case_Pkg,
+ Name => Variable_Name,
+ Node => Current_Item);
+ end;
+
+ when others =>
+ null;
+
+ end case;
+ end loop;
+ end Process_Declarative_Items;
+
+ -----------------------
+ -- Process_Externals --
+ -----------------------
+ procedure Process_Externals (Project : Project_Node_Id) is
+ Project_Name : constant Name_Id := Name_Of (Project);
+
+ No_External_Yet : Boolean := True;
+
+ procedure Expression (First_Term : Project_Node_Id);
+ -- Look for external reference in the term of an expression.
+ -- If one is found, build the Makefile external reference variable.
+
+ procedure Process_Declarative_Items (Item : Project_Node_Id);
+ -- Traverse the declarative items of a project file to find all
+ -- external references.
+
+ ----------------
+ -- Expression --
+ ----------------
+
+ procedure Expression (First_Term : Project_Node_Id) is
+ Term : Project_Node_Id := First_Term;
+ -- The term in the expression list
+
+ Current_Term : Project_Node_Id := Empty_Node;
+ -- The current term node id
+
+ Default : Project_Node_Id;
+
+ begin
+ -- Check each term of the expression
+
+ while Term /= Empty_Node loop
+ Current_Term := Tree.Current_Term (Term);
+
+ if Kind_Of (Current_Term) = N_External_Value then
+
+ -- If it is the first external reference of this project file,
+ -- output a comment
+
+ if No_External_Yet then
+ No_External_Yet := False;
+ New_Line;
+
+ Put_Line ("# external references");
+
+ New_Line;
+ end if;
+
+ -- Increase Last_External and record the node of the external
+ -- reference in table Externals, so that the external reference
+ -- variable can be identified later.
+
+ Last_External := Last_External + 1;
+ Externals.Set (Current_Term, Last_External);
+
+ Default := External_Default_Of (Current_Term);
+
+ Get_Name_String
+ (String_Value_Of (External_Reference_Of (Current_Term)));
+
+ declare
+ External_Name : constant String :=
+ Name_Buffer (1 .. Name_Len);
+
+ begin
+ -- Output a comment for this external reference
+
+ Put ("# external (""");
+ Put (External_Name);
+
+ if Default /= Empty_Node then
+ Put (""", """);
+ Put (String_Value_Of (Default));
+ end if;
+
+ Put (""")");
+ New_Line;
+
+ -- If there is no default, output one line:
+
+ -- <PROJECT>__EXTERNAL__#:=$(<external name>)
+
+ if Default = Empty_Node then
+ Put_U_Name (Project_Name);
+ Put (".external.");
+ Put (Last_External);
+ Put (":=$(");
+ Put (External_Name, With_Substitution => True);
+ Put (")");
+ New_Line;
+
+ else
+ -- When there is a default, output the following lines:
+
+ -- ifeq ($(<external_name),)
+ -- <PROJECT>__EXTERNAL__#:=<default>
+ -- else
+ -- <PROJECT>__EXTERNAL__#:=$(<external_name>)
+ -- endif
+
+ Put ("ifeq ($(");
+ Put (External_Name, With_Substitution => True);
+ Put ("),)");
+ New_Line;
+
+ Put (" ");
+ Put_U_Name (Project_Name);
+ Put (".external.");
+ Put (Last_External);
+ Put (":=");
+ Put (String_Value_Of (Default));
+ New_Line;
+
+ Put_Line ("else");
+
+ Put (" ");
+ Put_U_Name (Project_Name);
+ Put (".external.");
+ Put (Last_External);
+ Put (":=$(");
+ Put (External_Name, With_Substitution => True);
+ Put (")");
+ New_Line;
+
+ Put_Line ("endif");
+ end if;
+ end;
+ end if;
+
+ Term := Next_Term (Term);
+ end loop;
+ end Expression;
+
+ -------------------------------
+ -- Process_Declarative_Items --
+ -------------------------------
+
+ procedure Process_Declarative_Items (Item : Project_Node_Id) is
+ Current_Declarative_Item : Project_Node_Id := Item;
+ Current_Item : Project_Node_Id := Empty_Node;
+
+ begin
+ -- For each declarative item
+
+ while Current_Declarative_Item /= Empty_Node loop
+ Current_Item := Current_Item_Node (Current_Declarative_Item);
+
+ -- Set Current_Declarative_Item to the next declarative item
+ -- ready for the next iteration
+
+ Current_Declarative_Item := Next_Declarative_Item
+ (Current_Declarative_Item);
+
+ -- Write_Line (Project_Node_Kind'Image (Kind_Of (Current_Item)));
+
+ case Kind_Of (Current_Item) is
+
+ when N_Package_Declaration =>
+
+ -- Recursive call the declarative items of a package
+
+ if
+ Project_Of_Renamed_Package_Of (Current_Item) = Empty_Node
+ then
+ Process_Declarative_Items
+ (First_Declarative_Item_Of (Current_Item));
+ end if;
+
+ when N_Attribute_Declaration |
+ N_Typed_Variable_Declaration |
+ N_Variable_Declaration =>
+
+ -- Process the expression to look for external references
+
+ Expression
+ (First_Term => Tree.First_Term
+ (Expression_Of (Current_Item)));
+
+ when N_Case_Construction =>
+
+ -- Recursive calls to process the declarative items of
+ -- each case item.
+
+ declare
+ Case_Item : Project_Node_Id :=
+ First_Case_Item_Of (Current_Item);
+
+ begin
+ while Case_Item /= Empty_Node loop
+ Process_Declarative_Items
+ (First_Declarative_Item_Of (Case_Item));
+ Case_Item := Next_Case_Item (Case_Item);
+ end loop;
+ end;
+
+ when others =>
+ null;
+ end case;
+ end loop;
+ end Process_Declarative_Items;
+
+ -- Start of procedure Process_Externals
+
+ begin
+ Process_Declarative_Items
+ (First_Declarative_Item_Of (Project_Declaration_Of (Project)));
+
+ if not No_External_Yet then
+ Put_Line ("# end of external references");
+ New_Line;
+ end if;
+ end Process_Externals;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put (S : String; With_Substitution : Boolean := False) is
+ begin
+ IO.Put (S);
+
+ -- If With_Substitution is True, check if S is one of the reserved
+ -- variables. If it is, append to it the Saved_Suffix.
+
+ if With_Substitution then
+ for J in Reserved_Variables'Range loop
+ if S = Reserved_Variables (J).all then
+ IO.Put (Saved_Suffix);
+ exit;
+ end if;
+ end loop;
+ end if;
+ end Put;
+
+ procedure Put (P : Positive) is
+ Image : constant String := P'Img;
+
+ begin
+ Put (Image (Image'First + 1 .. Image'Last));
+ end Put;
+
+ procedure Put (S : Name_Id) is
+ begin
+ Get_Name_String (S);
+ Put (Name_Buffer (1 .. Name_Len));
+ end Put;
+
+ -------------------
+ -- Put_Attribute --
+ -------------------
+
+ procedure Put_Attribute
+ (Project : Project_Node_Id;
+ Pkg : Name_Id;
+ Name : Name_Id;
+ Index : Name_Id)
+ is
+ begin
+ Put_U_Name (Name_Of (Project));
+
+ if Pkg /= No_Name then
+ Put (".");
+ Put_L_Name (Pkg);
+ end if;
+
+ Put (".");
+ Put_L_Name (Name);
+
+ if Index /= No_Name then
+ Put (".");
+
+ -- For attribute Switches, we don't want to change the file name
+
+ if Name = Snames.Name_Switches then
+ Get_Name_String (Index);
+ Put (Name_Buffer (1 .. Name_Len));
+
+ else
+ Special_Put_U_Name (Index);
+ end if;
+ end if;
+ end Put_Attribute;
+
+ -----------------------------
+ -- Put_Directory_Separator --
+ -----------------------------
+
+ procedure Put_Directory_Separator is
+ begin
+ Put (S => (1 => Directory_Separator));
+ end Put_Directory_Separator;
+
+ -------------------------
+ -- Put_Include_Project --
+ -------------------------
+
+ procedure Put_Include_Project
+ (Included_Project_Path : Name_Id;
+ Included_Project : Project_Node_Id;
+ Including_Project_Name : String)
+ is
+ begin
+ -- If path is null, there is nothing to do.
+ -- This happens when there is no project being extended.
+
+ if Included_Project_Path /= No_Name then
+ Get_Name_String (Included_Project_Path);
+
+ declare
+ Included_Project_Name : constant String :=
+ Get_Name_String (Name_Of (Included_Project));
+ Included_Directory_Path : constant String :=
+ Dir_Name (Name_Buffer (1 .. Name_Len));
+ Last : Natural := Included_Directory_Path'Last;
+
+ begin
+ -- Remove a possible directory separator at the end of the
+ -- directory.
+
+ if Last >= Included_Directory_Path'First
+ and then Included_Directory_Path (Last) = Directory_Separator
+ then
+ Last := Last - 1;
+ end if;
+
+ Put ("BASE_DIR=");
+
+ -- If it is a relative path, precede the directory with
+ -- $(<PROJECT>.base_dir)/
+
+ if not Is_Absolute_Path (Included_Directory_Path) then
+ Put ("$(");
+ Put (Including_Project_Name);
+ Put (".base_dir)" & Directory_Separator);
+ end if;
+
+ Put (Included_Directory_Path
+ (Included_Directory_Path'First .. Last));
+ New_Line;
+
+ -- Include the Makefile
+
+ Put ("include $(BASE_DIR)");
+ Put_Directory_Separator;
+ Put ("Makefile.");
+ Put (To_Lower (Included_Project_Name));
+ New_Line;
+
+ New_Line;
+ end;
+ end if;
+ end Put_Include_Project;
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line (S : String) is
+ begin
+ IO.Put (S);
+ IO.New_Line;
+ end Put_Line;
+
+ ----------------
+ -- Put_L_Name --
+ ----------------
+
+ procedure Put_L_Name (N : Name_Id) is
+ begin
+ Put (To_Lower (Get_Name_String (N)));
+ end Put_L_Name;
+
+ ----------------
+ -- Put_M_Name --
+ ----------------
+
+ procedure Put_M_Name (N : Name_Id) is
+ Name : String := Get_Name_String (N);
+
+ begin
+ To_Mixed (Name);
+ Put (Name);
+ end Put_M_Name;
+
+ ----------------
+ -- Put_U_Name --
+ ----------------
+
+ procedure Put_U_Name (N : Name_Id) is
+ begin
+ Put (To_Upper (Get_Name_String (N)));
+ end Put_U_Name;
+
+ ------------------
+ -- Put_Variable --
+ ------------------
+
+ procedure Put_Variable
+ (Project : Project_Node_Id;
+ Pkg : Name_Id;
+ Name : Name_Id)
+ is
+ begin
+ Put_U_Name (Name_Of (Project));
+
+ if Pkg /= No_Name then
+ Put (".");
+ Put_L_Name (Pkg);
+ end if;
+
+ Put (".");
+ Put_U_Name (Name);
+ end Put_Variable;
+
+ -----------------------
+ -- Recursive_Process --
+ -----------------------
+
+ procedure Recursive_Process (Project : Project_Node_Id) is
+ With_Clause : Project_Node_Id;
+ Last_Case : Natural := Last_Case_Construction;
+ There_Are_Cases : Boolean := False;
+ May_Be_C_Sources : Boolean := False;
+ May_Be_Cxx_Sources : Boolean := False;
+ Post_Processing : Boolean := False;
+ Src_Files_Init : IO.Position;
+ Src_List_File_Init : IO.Position;
+ begin
+ -- Nothing to do if Project is nil.
+
+ if Project /= Empty_Node then
+ declare
+ Declaration_Node : constant Project_Node_Id :=
+ Project_Declaration_Of (Project);
+ -- Used to get the project being extended, if any, and the
+ -- declarative items of the project to be processed.
+
+ Name : constant Name_Id := Name_Of (Project);
+ -- Name of the project being processed
+
+ Directory : constant Name_Id := Directory_Of (Project);
+ -- Directory of the project being processed. Used as default
+ -- for the object directory and the source directories.
+
+ Lname : constant String := To_Lower (Get_Name_String (Name));
+ -- <project>: name of the project in lower case
+
+ Uname : constant String := To_Upper (Lname);
+ -- <PROJECT>: name of the project in upper case
+
+ begin
+ -- Nothing to do if project file has already been processed
+
+ if Processed_Projects.Get (Name) = Empty_Node then
+
+ -- Put project name in table Processed_Projects to avoid
+ -- processing the project several times.
+
+ Processed_Projects.Set (Name, Project);
+
+ -- Process all the projects imported, if any
+
+ if Process_All_Project_Files then
+ With_Clause := First_With_Clause_Of (Project);
+
+ while With_Clause /= Empty_Node loop
+ Recursive_Process (Project_Node_Of (With_Clause));
+ With_Clause := Next_With_Clause_Of (With_Clause);
+ end loop;
+
+ -- Process the project being extended, if any.
+ -- If there is no project being extended,
+ -- Process_Declarative_Items will be called with Empty_Node
+ -- and nothing will happen.
+
+ Recursive_Process (Extended_Project_Of (Declaration_Node));
+ end if;
+
+ Source_Files_Declaration := False;
+ Source_List_File_Declaration := False;
+
+ -- Build in Name_Buffer the path name of the Makefile
+
+ -- Start with the directory of the project file
+
+ Get_Name_String (Directory);
+
+ -- Add a directory separator, if needed
+
+ if Name_Buffer (Name_Len) /= Directory_Separator then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Directory_Separator;
+ end if;
+
+ -- Add the filename of the Makefile: "Makefile.<project>"
+
+ Name_Buffer (Name_Len + 1 .. Name_Len + 9) := "Makefile.";
+ Name_Len := Name_Len + 9;
+
+ Name_Buffer (Name_Len + 1 .. Name_Len + Lname'Length) :=
+ Lname;
+ Name_Len := Name_Len + Lname'Length;
+
+ IO.Create (Name_Buffer (1 .. Name_Len));
+
+ -- Display the Makefile being created, but only if not in
+ -- quiet output.
+
+ if not Opt.Quiet_Output then
+ Write_Str ("creating """);
+ Write_Str (IO.Name_Of_File);
+ Write_Line ("""");
+ end if;
+
+ -- And create the Makefile
+
+ New_Line;
+
+ -- Outut a comment with the path name of the Makefile
+ Put ("# ");
+ Put_Line (IO.Name_Of_File);
+
+ New_Line;
+
+ -- The Makefile is a big ifeq to avoid multiple inclusion
+ -- ifeq ($(<PROJECT>.project),)
+ -- <PROJECT>.project:=True
+ -- ...
+ -- endif
+
+ Put ("ifeq ($(");
+ Put (Uname);
+ Put (".project),)");
+ New_Line;
+
+ Put (Uname);
+ Put (".project=True");
+ New_Line;
+
+ New_Line;
+
+ -- If it is the main Makefile (BASE_DIR is empty)
+
+ Put_Line ("ifeq ($(BASE_DIR),)");
+
+ -- Set <PROJECT>.root to True
+
+ Put (" ");
+ Put (Uname);
+ Put (".root=True");
+ New_Line;
+
+ Put (" ");
+ Put (Uname);
+ Put (".base_dir:=$(shell gprcmd pwd)");
+ New_Line;
+
+ -- Include some utility functions and saved all reserved
+ -- env. vars. by including Makefile.prolog.
+
+ Put (" ifeq ($(");
+ Put (MAKE_ROOT);
+ Put ("),)");
+ New_Line;
+
+ Put (" $(error ");
+ Put (MAKE_ROOT);
+ Put (" variable is undefined, ");
+ Put ("Makefile.prolog cannot be loaded)");
+ New_Line;
+
+ Put_Line (" else");
+
+ Put (" include $(");
+ Put (MAKE_ROOT);
+ Put (")");
+ Put_Directory_Separator;
+ Put ("share");
+ Put_Directory_Separator;
+ Put ("make");
+ Put_Directory_Separator;
+ Put ("Makefile.prolog");
+ New_Line;
+
+ Put_Line (" endif");
+
+ -- Initialize some defaults
+
+ Put (" OBJ_EXT:=");
+ Put (Get_Object_Suffix.all);
+ New_Line;
+
+ Put_Line ("else");
+
+ -- When not the main Makefile, set <PROJECT>.root to False
+
+ Put (" ");
+ Put (Uname);
+ Put (".root=False");
+ New_Line;
+
+ Put (" ");
+ Put (Uname);
+ Put (".base_dir:=$(BASE_DIR)");
+ New_Line;
+
+ Put_Line ("endif");
+ New_Line;
+
+ -- For each imported project, if any, set BASE_DIR to the
+ -- directory of the imported project, and add an include
+ -- directive for the Makefile of the imported project.
+
+ With_Clause := First_With_Clause_Of (Project);
+
+ while With_Clause /= Empty_Node loop
+ Put_Include_Project
+ (String_Value_Of (With_Clause),
+ Project_Node_Of (With_Clause),
+ Uname);
+ With_Clause := Next_With_Clause_Of (With_Clause);
+ end loop;
+
+ -- Do the same if there is a project being extended.
+ -- If there is no project being extended, Put_Include_Project
+ -- will return immediately.
+
+ Put_Include_Project
+ (Extended_Project_Path_Of (Project),
+ Extended_Project_Of (Declaration_Node),
+ Uname);
+
+ -- Set defaults to some variables
+
+ IO.Mark (Src_Files_Init);
+ Put_Line ("src_files.specified:=FALSE");
+
+ IO.Mark (Src_List_File_Init);
+ Put_Line ("src_list_file.specified:=FALSE");
+
+ -- <PROJECT>.src_dirs is set by default to the project
+ -- directory.
+
+ Put (Uname);
+ Put (".src_dirs:=$(");
+ Put (Uname);
+ Put (".base_dir)");
+ New_Line;
+
+ -- <PROJECT>.obj_dir is set by default to the project
+ -- directory.
+
+ Put (Uname);
+ Put (".obj_dir:=$(");
+ Put (Uname);
+ Put (".base_dir)");
+ New_Line;
+
+ -- PROJECT_FILE:=<project>
+
+ Put ("PROJECT_FILE:=");
+ Put (Lname);
+ New_Line;
+
+ -- Output a comment indicating the name of the project being
+ -- processed.
+
+ Put ("# project ");
+ Put_M_Name (Name);
+ New_Line;
+
+ -- Process the external references of this project file
+
+ Process_Externals (Project);
+
+ New_Line;
+
+ -- Reset the compiler switches, the suffixes and the languages
+
+ Switches.Init;
+ Reset_Suffixes_And_Languages;
+
+ -- Record the current value of Last_Case_Construction to
+ -- detect if there are case constructions in this project file.
+
+ Last_Case := Last_Case_Construction;
+
+ -- Process the declarative items of this project file
+
+ Process_Declarative_Items
+ (Project => Project,
+ Pkg => No_Name,
+ In_Case => False,
+ Item => First_Declarative_Item_Of (Declaration_Node));
+
+ -- Set There_Are_Case to True if there are case constructions
+ -- in this project file.
+
+ There_Are_Cases := Last_Case /= Last_Case_Construction;
+
+ -- If the suffixs and the languages have not been specified,
+ -- give them the default values.
+
+ if C_Suffix_Static and then C_Suffix_Last = 0 then
+ C_Suffix_Last := 2;
+ C_Suffix (1 .. 2) := ".c";
+ end if;
+
+ if Cxx_Suffix_Static and then Cxx_Suffix_Last = 0 then
+ Cxx_Suffix_Last := 3;
+ Cxx_Suffix (1 .. 3) := ".cc";
+ end if;
+
+ if Ada_Body_Suffix_Static and then Ada_Body_Suffix_Last = 0 then
+ Ada_Body_Suffix_Last := 4;
+ Ada_Body_Suffix (1 .. 4) := ".adb";
+ end if;
+
+ if Ada_Spec_Suffix_Static and then Ada_Spec_Suffix_Last = 0 then
+ Ada_Spec_Suffix_Last := 4;
+ Ada_Spec_Suffix (1 .. 4) := ".ads";
+ end if;
+
+ if Languages_Static and then Languages_Last = 0 then
+ Languages_Last := 5;
+ Languages (1 .. 5) := " ada ";
+ end if;
+
+ -- There may be C sources if the languages are not known
+ -- statically or if the languages include "C".
+
+ May_Be_C_Sources := (not Languages_Static)
+ or else Index
+ (Source => Languages (1 .. Languages_Last),
+ Pattern => " c ") /= 0;
+
+ -- There may be C++ sources if the languages are not known
+ -- statically or if the languages include "C++".
+
+ May_Be_Cxx_Sources := (not Languages_Static)
+ or else Index
+ (Source => Languages (1 .. Languages_Last),
+ Pattern => " c++ ") /= 0;
+
+ New_Line;
+
+ -- If there are attribute Switches specified in package
+ -- Compiler of this project, post-process them.
+
+ if Switches.Last >= Switches.First then
+
+ -- Output a comment indicating this post-processing
+
+ for Index in Switches.First .. Switches.Last loop
+ Get_Name_String (Switches.Table (Index));
+
+ declare
+ File : constant String :=
+ Name_Buffer (1 .. Name_Len);
+ Source_Kind : Source_Kind_Type := Unknown;
+
+ begin
+ -- First, attempt to determine the language
+
+ if Ada_Body_Suffix_Static then
+ if File'Length > Ada_Body_Suffix_Last
+ and then
+ File (File'Last - Ada_Body_Suffix_Last + 1 ..
+ File'Last) =
+ Ada_Body_Suffix
+ (1 .. Ada_Body_Suffix_Last)
+ then
+ Source_Kind := Ada_Body;
+ end if;
+ end if;
+
+ if Source_Kind = Unknown
+ and then Ada_Spec_Suffix_Static
+ then
+ if File'Length > Ada_Spec_Suffix_Last
+ and then
+ File (File'Last - Ada_Spec_Suffix_Last + 1 ..
+ File'Last) =
+ Ada_Spec_Suffix
+ (1 .. Ada_Spec_Suffix_Last)
+ then
+ Source_Kind := Ada_Spec;
+ end if;
+ end if;
+
+ if Source_Kind = Unknown
+ and then C_Suffix_Static
+ then
+ if File'Length > C_Suffix_Last
+ and then
+ File (File'Last - C_Suffix_Last + 1
+ .. File'Last) =
+ C_Suffix (1 .. C_Suffix_Last)
+ then
+ Source_Kind := C;
+ end if;
+ end if;
+
+ if Source_Kind = Unknown
+ and then Cxx_Suffix_Static
+ then
+ if File'Length > Cxx_Suffix_Last
+ and then
+ File (File'Last - Cxx_Suffix_Last + 1
+ .. File'Last) =
+ Cxx_Suffix (1 .. Cxx_Suffix_Last)
+ then
+ Source_Kind := Cxx;
+ end if;
+ end if;
+
+ -- If we still don't know the language, and all
+ -- suffixs are static, then it cannot any of the
+ -- processed languages.
+
+ if Source_Kind = Unknown
+ and then Ada_Body_Suffix_Static
+ and then Ada_Spec_Suffix_Static
+ and then C_Suffix_Static
+ and then Cxx_Suffix_Static
+ then
+ Source_Kind := None;
+ end if;
+
+ -- If it can be "C" or "C++", post-process
+
+ if (Source_Kind = Unknown and
+ (May_Be_C_Sources or May_Be_Cxx_Sources))
+ or else (May_Be_C_Sources and Source_Kind = C)
+ or else (May_Be_Cxx_Sources and Source_Kind = Cxx)
+ then
+ if not Post_Processing then
+ Post_Processing := True;
+ Put_Line
+ ("# post-processing of Compiler'Switches");
+ end if;
+
+ New_Line;
+
+ -- Output a comment:
+ -- # for Switches (<file>) use ...
+
+ Put ("# for Switches (""");
+ Put (File);
+ Put (""") use ...");
+ New_Line;
+
+ if There_Are_Cases then
+
+ -- Check that effectively there was Switches
+ -- specified for this file: the attribute
+ -- declaration may be in a case branch which was
+ -- not followed.
+
+ Put ("ifneq ($(");
+ Put (Uname);
+ Put (".compiler.switches.");
+ Put (File);
+ Put ("),)");
+ New_Line;
+ end if;
+
+ if May_Be_C_Sources
+ and then
+ (Source_Kind = Unknown or else Source_Kind = C)
+ then
+ -- If it is definitely a C file, no need to test
+
+ if Source_Kind = C then
+ Put (File (1 .. File'Last - C_Suffix_Last));
+ Put (Get_Object_Suffix.all);
+ Put (": ");
+ Put (File);
+ New_Line;
+
+ else
+ -- May be a C file: test to know
+
+ Put ("ifeq ($(filter %$(C_EXT),");
+ Put (File);
+ Put ("),");
+ Put (File);
+ Put (")");
+ New_Line;
+
+ -- If it is, output a rule for the object
+
+ Put ("$(subst $(C_EXT),$(OBJ_EXT),");
+ Put (File);
+ Put ("): ");
+ Put (File);
+ New_Line;
+ end if;
+
+ Put (ASCII.HT & "@echo $(CC) -c $(");
+ Put (Uname);
+ Put (".compiler.switches.");
+ Put (File);
+ Put (") $< -o $(OBJ_DIR)/$@");
+ New_Line;
+
+ -- If FAKE_COMPILE is defined, do not issue
+ -- the compile command.
+
+ Put_Line ("ifndef FAKE_COMPILE");
+
+ Put (ASCII.HT & "@$(CC) -c $(");
+ Put (Uname);
+ Put (".compiler.switches.");
+ Put (File);
+ Put (") $(C_INCLUDES) $(DEP_CFLAGS) " &
+ "$< -o $(OBJ_DIR)/$@");
+ New_Line;
+
+ Put_Line (ASCII.HT & "@$(post-compile)");
+
+ Put_Line ("endif");
+
+ if Source_Kind = Unknown then
+ Put_Line ("endif");
+ end if;
+ end if;
+
+ -- Now, test if it is a C++ file
+
+ if May_Be_Cxx_Sources
+ and then
+ (Source_Kind = Unknown
+ or else
+ Source_Kind = Cxx)
+ then
+ -- No need to test if definitely a C++ file
+
+ if Source_Kind = Cxx then
+ Put (File (1 .. File'Last - Cxx_Suffix_Last));
+ Put (Get_Object_Suffix.all);
+ Put (": ");
+ Put (File);
+ New_Line;
+
+ else
+ -- May be a C++ file: test to know
+
+ Put ("ifeq ($(filter %$(CXX_EXT),");
+ Put (File);
+ Put ("),");
+ Put (File);
+ Put (")");
+ New_Line;
+
+ -- If it is, output a rule for the object
+
+ Put ("$(subst $(CXX_EXT),$(OBJ_EXT),");
+ Put (File);
+ Put ("): $(");
+ Put (Uname);
+ Put (".absolute.");
+ Put (File);
+ Put (")");
+ New_Line;
+ end if;
+
+ Put (ASCII.HT & "@echo $(CXX) -c $(");
+ Put (Uname);
+ Put (".compiler.switches.");
+ Put (File);
+ Put (") $< -o $(OBJ_DIR)/$@");
+ New_Line;
+
+ -- If FAKE_COMPILE is defined, do not issue
+ -- the compile command
+
+ Put_Line ("ifndef FAKE_COMPILE");
+
+ Put (ASCII.HT & "@$(CXX) -c $(");
+ Put (Uname);
+ Put (".compiler.switches.");
+ Put (File);
+ Put (") $(C_INCLUDES) $(DEP_CFLAGS) " &
+ "$< -o $(OBJ_DIR)/$@");
+ New_Line;
+
+ Put_Line (ASCII.HT & "@$(post-compile)");
+
+ Put_Line ("endif");
+
+ if Source_Kind = Unknown then
+ Put_Line ("endif");
+ end if;
+
+ end if;
+
+ if There_Are_Cases then
+ Put_Line ("endif");
+ end if;
+
+ New_Line;
+ end if;
+ end;
+ end loop;
+
+ -- Output a comment indication end of post-processing
+ -- of Switches, if we have done some post-processing
+
+ if Post_Processing then
+ Put_Line
+ ("# end of post-processing of Compiler'Switches");
+
+ New_Line;
+ end if;
+ end if;
+
+ -- Add source dirs of this project file to variable SRC_DIRS
+
+ Put ("SRC_DIRS:=$(SRC_DIRS) $(");
+ Put (Uname);
+ Put (".src_dirs)");
+ New_Line;
+
+ -- Set OBJ_DIR to the object directory
+
+ Put ("OBJ_DIR:=$(");
+ Put (Uname);
+ Put (".obj_dir)");
+ New_Line;
+
+ New_Line;
+
+ if Source_Files_Declaration = True then
+
+ -- It is guaranteed that Source_Files has been specified.
+ -- We then suppress the two lines that initialize
+ -- the variables src_files.specified and
+ -- src_list_file.specified. Nothing else to do.
+
+ IO.Suppress (Src_Files_Init);
+ IO.Suppress (Src_List_File_Init);
+
+ else
+ if Source_Files_Declaration = May_Be then
+
+ -- Need to test if attribute Source_Files was specified
+
+ Put_Line ("# get the source files, if necessary");
+ Put_Line ("ifeq ($(src_files.specified),FALSE)");
+
+ else
+ Put_Line ("# get the source files");
+
+ -- We may suppress initialization of src_files.specified
+
+ IO.Suppress (Src_Files_Init);
+ end if;
+
+ if Source_List_File_Declaration /= May_Be then
+ IO.Suppress (Src_List_File_Init);
+ end if;
+
+ case Source_List_File_Declaration is
+
+ -- Source_List_File was specified
+
+ when True =>
+ if Source_Files_Declaration = May_Be then
+ Put (" ");
+ end if;
+
+ Put (Uname);
+ Put (".src_files:= $(shell gprcmd cat " &
+ "$(src.list_file))");
+ New_Line;
+
+ -- Source_File_List was NOT specified
+
+ when False =>
+ if Source_Files_Declaration = May_Be then
+ Put (" ");
+ end if;
+
+ Put (Uname);
+ Put (".src_files:= $(foreach name,$(");
+ Put (Uname);
+ Put (".src_dirs),$(notdir $(wildcard $(name)/*)))");
+ New_Line;
+
+ when May_Be =>
+ if Source_Files_Declaration = May_Be then
+ Put (" ");
+ end if;
+
+ Put_Line ("ifeq ($(src_list_file.specified),TRUE)");
+
+ -- Get the source files from the file
+
+ if Source_Files_Declaration = May_Be then
+ Put (" ");
+ end if;
+
+ Put (" ");
+ Put (Uname);
+ Put (".src_files:= $(shell gprcmd cat " &
+ "$(SRC__$LIST_FILE))");
+ New_Line;
+
+ if Source_Files_Declaration = May_Be then
+ Put (" ");
+ end if;
+
+ Put_Line ("else");
+
+ -- Otherwise get source from the source directories
+
+ if Source_Files_Declaration = May_Be then
+ Put (" ");
+ end if;
+
+ Put (" ");
+ Put (Uname);
+ Put (".src_files:= $(foreach name,$(");
+ Put (Uname);
+ Put (".src_dirs),$(notdir $(wildcard $(name)/*)))");
+ New_Line;
+
+ if Source_Files_Declaration = May_Be then
+ Put (" ");
+ end if;
+
+ Put_Line ("endif");
+ end case;
+
+ if Source_Files_Declaration = May_Be then
+ Put_Line ("endif");
+ end if;
+
+ New_Line;
+ end if;
+
+ if not Languages_Static then
+
+ -- If Languages include "c", get the C sources
+
+ Put_Line
+ ("# get the C source files, if C is one of the languages");
+
+ Put_Line ("ifeq ($(filter c,$(LANGUAGES)),c)");
+
+ Put (" C_SRCS:=$(filter %$(C_EXT),$(");
+ Put (Uname);
+ Put (".src_files))");
+ New_Line;
+ Put_Line (" C_SRCS_DEFINED:=True");
+
+ -- Otherwise set C_SRCS to empty
+
+ Put_Line ("else");
+ Put_Line (" C_SRCS=");
+ Put_Line ("endif");
+ New_Line;
+
+ -- If Languages include "C++", get the C++ sources
+
+ Put_Line
+ ("# get the C++ source files, " &
+ "if C++ is one of the languages");
+
+ Put_Line ("ifeq ($(filter c++,$(LANGUAGES)),c++)");
+
+ Put (" CXX_SRCS:=$(filter %$(CXX_EXT),$(");
+ Put (Uname);
+ Put (".src_files))");
+ New_Line;
+ Put_Line (" CXX_SRCS_DEFINED:=True");
+
+ -- Otherwise set CXX_SRCS to empty
+
+ Put_Line ("else");
+ Put_Line (" CXX_SRCS=");
+ Put_Line ("endif");
+ New_Line;
+
+ else
+ if Ada.Strings.Fixed.Index
+ (Languages (1 .. Languages_Last), " c ") /= 0
+ then
+ Put_Line ("# get the C sources");
+ Put ("C_SRCS:=$(filter %$(C_EXT),$(");
+ Put (Uname);
+ Put (".src_files))");
+ New_Line;
+ Put_Line ("C_SRCS_DEFINED:=True");
+
+ else
+ Put_Line ("# no C sources");
+
+ Put_Line ("C_SRCS=");
+ end if;
+
+ New_Line;
+
+ if Ada.Strings.Fixed.Index
+ (Languages (1 .. Languages_Last), " c++ ") /= 0
+ then
+ Put_Line ("# get the C++ sources");
+ Put ("CXX_SRCS:=$(filter %$(CXX_EXT),$(");
+ Put (Uname);
+ Put (".src_files))");
+ New_Line;
+ Put_Line ("CXX_SRCS_DEFINED:=True");
+
+ else
+ Put_Line ("# no C++ sources");
+
+ Put_Line ("CXX_SRCS=");
+ end if;
+
+ New_Line;
+ end if;
+
+ declare
+ C_Present : constant Boolean :=
+ (not Languages_Static) or else
+ Ada.Strings.Fixed.Index
+ (Languages (1 .. Languages_Last), " c ")
+ /= 0;
+
+ Cxx_Present : constant Boolean :=
+ (not Languages_Static) or else
+ Ada.Strings.Fixed.Index
+ (Languages (1 .. Languages_Last), " c++ ")
+ /= 0;
+
+ begin
+ if C_Present or Cxx_Present then
+
+ -- If there are C or C++ sources,
+ -- add a library name to variable LIBS.
+
+ Put ("# if there are ");
+
+ if C_Present then
+ if Cxx_Present then
+ Put ("C or C++");
+
+ else
+ Put ("C");
+ end if;
+
+ else
+ Put ("C++");
+ end if;
+
+ Put (" sources, add the library");
+ New_Line;
+
+ Put ("ifneq ($(strip");
+
+ if C_Present then
+ Put (" $(C_SRCS)");
+ end if;
+
+ if Cxx_Present then
+ Put (" $(CXX_SRCS)");
+ end if;
+
+ Put ("),)");
+ New_Line;
+
+ Put (" LIBS:=$(");
+ Put (Uname);
+ Put (".obj_dir)/lib");
+ Put (Lname);
+ Put ("$(AR_EXT) $(LIBS)");
+ New_Line;
+
+ Put_Line ("endif");
+
+ New_Line;
+
+ end if;
+ end;
+
+ -- If this is the main Makefile, include Makefile.Generic
+
+ Put ("ifeq ($(");
+ Put (Uname);
+ Put_Line (".root),True)");
+
+ -- Include Makefile.generic
+
+ Put (" include $(");
+ Put (MAKE_ROOT);
+ Put (")");
+ Put_Directory_Separator;
+ Put ("share");
+ Put_Directory_Separator;
+ Put ("make");
+ Put_Directory_Separator;
+ Put ("Makefile.generic");
+ New_Line;
+
+ -- If it is not the main Makefile, add the project to
+ -- variable DEPS_PROJECTS.
+
+ Put_Line ("else");
+
+ Put (" DEPS_PROJECTS:=$(strip $(DEPS_PROJECTS) $(");
+ Put (Uname);
+ Put (".base_dir)/");
+ Put (Lname);
+ Put (")");
+ New_Line;
+
+ Put_Line ("endif");
+ New_Line;
+
+ Put_Line ("endif");
+ New_Line;
+
+ -- Close the Makefile, so that another Makefile can be created
+ -- with the same File_Type variable.
+
+ IO.Close;
+ end if;
+ end;
+ end if;
+ end Recursive_Process;
+
+ ----------------------------------
+ -- Reset_Suffixes_And_Languages --
+ ----------------------------------
+
+ procedure Reset_Suffixes_And_Languages is
+ begin
+ -- Last = 0 indicates that this is the default, which is static,
+ -- of course.
+
+ C_Suffix_Last := 0;
+ C_Suffix_Static := True;
+ Cxx_Suffix_Last := 0;
+ Cxx_Suffix_Static := True;
+ Ada_Body_Suffix_Last := 0;
+ Ada_Body_Suffix_Static := True;
+ Ada_Spec_Suffix_Last := 0;
+ Ada_Spec_Suffix_Static := True;
+ Languages_Last := 0;
+ Languages_Static := True;
+ end Reset_Suffixes_And_Languages;
+
+ --------------------
+ -- Source_Kind_Of --
+ --------------------
+
+ function Source_Kind_Of (File_Name : Name_Id) return Source_Kind_Type is
+ Source_C_Suffix : constant String :=
+ Suffix_Of (C_Suffix_Static, C_Suffix, C_Suffix_Last, ".c");
+
+ Source_Cxx_Suffix : constant String :=
+ Suffix_Of (Cxx_Suffix_Static, Cxx_Suffix, Cxx_Suffix_Last, ".cc");
+
+ Body_Ada_Suffix : constant String :=
+ Suffix_Of
+ (Ada_Body_Suffix_Static,
+ Ada_Body_Suffix,
+ Ada_Body_Suffix_Last,
+ ".adb");
+
+ Spec_Ada_Suffix : constant String :=
+ Suffix_Of
+ (Ada_Spec_Suffix_Static,
+ Ada_Spec_Suffix,
+ Ada_Spec_Suffix_Last,
+ ".ads");
+
+ begin
+ -- Get the name of the file
+
+ Get_Name_String (File_Name);
+
+ -- If the C suffix is static, check if it is a C file
+
+ if Source_C_Suffix /= ""
+ and then Name_Len > Source_C_Suffix'Length
+ and then Name_Buffer (Name_Len - Source_C_Suffix'Length + 1
+ .. Name_Len) = Source_C_Suffix
+ then
+ return C;
+
+ -- If the C++ suffix is static, check if it is a C++ file
+
+ elsif Source_Cxx_Suffix /= ""
+ and then Name_Len > Source_Cxx_Suffix'Length
+ and then Name_Buffer (Name_Len - Source_Cxx_Suffix'Length + 1
+ .. Name_Len) = Source_Cxx_Suffix
+ then
+ return Cxx;
+
+ -- If the Ada body suffix is static, check if it is an Ada body
+
+ elsif Body_Ada_Suffix /= ""
+ and then Name_Len > Body_Ada_Suffix'Length
+ and then Name_Buffer (Name_Len - Body_Ada_Suffix'Length + 1
+ .. Name_Len) = Body_Ada_Suffix
+ then
+ return Ada_Body;
+
+ -- If the Ada spec suffix is static, check if it is an Ada spec
+
+ elsif Spec_Ada_Suffix /= ""
+ and then Name_Len > Spec_Ada_Suffix'Length
+ and then Name_Buffer (Name_Len - Spec_Ada_Suffix'Length + 1
+ .. Name_Len) = Spec_Ada_Suffix
+ then
+ return Ada_Body;
+
+ -- If the C or C++ suffix is not static, then return Unknown
+
+ elsif Source_C_Suffix = "" or else Source_Cxx_Suffix = "" then
+ return Unknown;
+
+ -- Otherwise return None
+
+ else
+ return None;
+ end if;
+ end Source_Kind_Of;
+
+ ------------------------
+ -- Special_Put_U_Name --
+ ------------------------
+
+ procedure Special_Put_U_Name (S : Name_Id) is
+ begin
+ Get_Name_String (S);
+ To_Upper (Name_Buffer (1 .. Name_Len));
+
+ -- If string is "C++", change it to "CXX"
+
+ if Name_Buffer (1 .. Name_Len) = "C++" then
+ Put ("CXX");
+ else
+ Put (Name_Buffer (1 .. Name_Len));
+ end if;
+ end Special_Put_U_Name;
+
+ ---------------
+ -- Suffix_Of --
+ ---------------
+
+ function Suffix_Of
+ (Static : Boolean;
+ Value : String_Access;
+ Last : Natural;
+ Default : String)
+ return String
+ is
+ begin
+ if Static then
+
+ -- If the suffix is static, Last = 0 indicates that it is the default
+ -- suffix: return the default.
+
+ if Last = 0 then
+ return Default;
+
+ -- Otherwise, return the current suffix
+
+ else
+ return Value (1 .. Last);
+ end if;
+
+ -- If the suffix is not static, return ""
+
+ else
+ return "";
+ end if;
+ end Suffix_Of;
+
+ -----------
+ -- Usage --
+ -----------
+
+ procedure Usage is
+ begin
+ if not Usage_Displayed then
+ Usage_Displayed := True;
+ Display_Copyright;
+ Write_Line ("Usage: gpr2make switches project-file");
+ Write_Eol;
+ Write_Line (" -h Display this usage");
+ Write_Line (" -q Quiet output");
+ Write_Line (" -v Verbose mode");
+ Write_Line (" -R not Recursive: only one project file");
+ Write_Eol;
+ end if;
+ end Usage;
+end Bld;
diff --git a/gcc/ada/s-expflt.ads b/gcc/ada/bld.ads
index ff5febd5216..1389dc582c8 100644
--- a/gcc/ada/s-expflt.ads
+++ b/gcc/ada/bld.ads
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . E X P F L T --
+-- B L D --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -19,25 +19,20 @@
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
--- Float exponentiation (checks on)
-
-with System.Exp_Gen;
+-- The following package implements the facilities to build Makefiles
+-- for multi-language GNAT project files, so that building a complete
+-- multi-language system can be done easily, using GNU make.
-package System.Exp_Flt is
-pragma Pure (Exp_Flt);
+package Bld is
- function Exp_Float is new System.Exp_Gen.Exp_Float_Type (Float);
+ procedure Gpr2make;
+ -- Parse a project file and all the other project files it depends on
+ -- into a project tree; then from the project tree, produce one Makefile
+ -- for each project file in the project tree.
-end System.Exp_Flt;
+end Bld;
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index 597c439a6a4..04a4c048d75 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,18 +32,23 @@ with Exp_Ch2; use Exp_Ch2;
with Exp_Util; use Exp_Util;
with Elists; use Elists;
with Freeze; use Freeze;
+with Lib; use Lib;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
+with Output; use Output;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
+with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
+with Sinput; use Sinput;
with Snames; use Snames;
+with Sprint; use Sprint;
with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
@@ -71,9 +76,115 @@ package body Checks is
-- the ability to emit constraint error warning for static expressions
-- even when we are not generating code.
- ----------------------------
- -- Local Subprogram Specs --
- ----------------------------
+ -------------------------------------
+ -- Suppression of Redundant Checks --
+ -------------------------------------
+
+ -- This unit implements a limited circuit for removal of redundant
+ -- checks. The processing is based on a tracing of simple sequential
+ -- flow. For any sequence of statements, we save expressions that are
+ -- marked to be checked, and then if the same expression appears later
+ -- with the same check, then under certain circumstances, the second
+ -- check can be suppressed.
+
+ -- Basically, we can suppress the check if we know for certain that
+ -- the previous expression has been elaborated (together with its
+ -- check), and we know that the exception frame is the same, and that
+ -- nothing has happened to change the result of the exception.
+
+ -- Let us examine each of these three conditions in turn to describe
+ -- how we ensure that this condition is met.
+
+ -- First, we need to know for certain that the previous expression has
+ -- been executed. This is done principly by the mechanism of calling
+ -- Conditional_Statements_Begin at the start of any statement sequence
+ -- and Conditional_Statements_End at the end. The End call causes all
+ -- checks remembered since the Begin call to be discarded. This does
+ -- miss a few cases, notably the case of a nested BEGIN-END block with
+ -- no exception handlers. But the important thing is to be conservative.
+ -- The other protection is that all checks are discarded if a label
+ -- is encountered, since then the assumption of sequential execution
+ -- is violated, and we don't know enough about the flow.
+
+ -- Second, we need to know that the exception frame is the same. We
+ -- do this by killing all remembered checks when we enter a new frame.
+ -- Again, that's over-conservative, but generally the cases we can help
+ -- with are pretty local anyway (like the body of a loop for example).
+
+ -- Third, we must be sure to forget any checks which are no longer valid.
+ -- This is done by two mechanisms, first the Kill_Checks_Variable call is
+ -- used to note any changes to local variables. We only attempt to deal
+ -- with checks involving local variables, so we do not need to worry
+ -- about global variables. Second, a call to any non-global procedure
+ -- causes us to abandon all stored checks, since such a all may affect
+ -- the values of any local variables.
+
+ -- The following define the data structures used to deal with remembering
+ -- checks so that redundant checks can be eliminated as described above.
+
+ -- Right now, the only expressions that we deal with are of the form of
+ -- simple local objects (either declared locally, or IN parameters) or
+ -- such objects plus/minus a compile time known constant. We can do
+ -- more later on if it seems worthwhile, but this catches many simple
+ -- cases in practice.
+
+ -- The following record type reflects a single saved check. An entry
+ -- is made in the stack of saved checks if and only if the expression
+ -- has been elaborated with the indicated checks.
+
+ type Saved_Check is record
+ Killed : Boolean;
+ -- Set True if entry is killed by Kill_Checks
+
+ Entity : Entity_Id;
+ -- The entity involved in the expression that is checked
+
+ Offset : Uint;
+ -- A compile time value indicating the result of adding or
+ -- subtracting a compile time value. This value is to be
+ -- added to the value of the Entity. A value of zero is
+ -- used for the case of a simple entity reference.
+
+ Check_Type : Character;
+ -- This is set to 'R' for a range check (in which case Target_Type
+ -- is set to the target type for the range check) or to 'O' for an
+ -- overflow check (in which case Target_Type is set to Empty).
+
+ Target_Type : Entity_Id;
+ -- Used only if Do_Range_Check is set. Records the target type for
+ -- the check. We need this, because a check is a duplicate only if
+ -- it has a the same target type (or more accurately one with a
+ -- range that is smaller or equal to the stored target type of a
+ -- saved check).
+ end record;
+
+ -- The following table keeps track of saved checks. Rather than use an
+ -- extensible table. We just use a table of fixed size, and we discard
+ -- any saved checks that do not fit. That's very unlikely to happen and
+ -- this is only an optimization in any case.
+
+ Saved_Checks : array (Int range 1 .. 200) of Saved_Check;
+ -- Array of saved checks
+
+ Num_Saved_Checks : Nat := 0;
+ -- Number of saved checks
+
+ -- The following stack keeps track of statement ranges. It is treated
+ -- as a stack. When Conditional_Statements_Begin is called, an entry
+ -- is pushed onto this stack containing the value of Num_Saved_Checks
+ -- at the time of the call. Then when Conditional_Statements_End is
+ -- called, this value is popped off and used to reset Num_Saved_Checks.
+
+ -- Note: again, this is a fixed length stack with a size that should
+ -- always be fine. If the value of the stack pointer goes above the
+ -- limit, then we just forget all saved checks.
+
+ Saved_Checks_Stack : array (Int range 1 .. 100) of Nat;
+ Saved_Checks_TOS : Nat := 0;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
procedure Apply_Selected_Length_Checks
(Ck_Node : Node_Id;
@@ -95,6 +206,26 @@ package body Checks is
-- routine. The Do_Static flag indicates that only a static check is
-- to be done.
+ procedure Find_Check
+ (Expr : Node_Id;
+ Check_Type : Character;
+ Target_Type : Entity_Id;
+ Entry_OK : out Boolean;
+ Check_Num : out Nat;
+ Ent : out Entity_Id;
+ Ofs : out Uint);
+ -- This routine is used by Enable_Range_Check and Enable_Overflow_Check
+ -- to see if a check is of the form for optimization, and if so, to see
+ -- if it has already been performed. Expr is the expression to check,
+ -- and Check_Type is 'R' for a range check, 'O' for an overflow check.
+ -- Target_Type is the target type for a range check, and Empty for an
+ -- overflow check. If the entry is not of the form for optimization,
+ -- then Entry_OK is set to False, and the remaining out parameters
+ -- are undefined. If the entry is OK, then Ent/Ofs are set to the
+ -- entity and offset from the expression. Check_Num is the number of
+ -- a matching saved entry in Saved_Checks, or zero if no such entry
+ -- is located.
+
function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id;
-- If a discriminal is used in constraining a prival, Return reference
-- to the discriminal of the protected body (which renames the parameter
@@ -142,8 +273,11 @@ package body Checks is
function Access_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Access_Checks
- or else (Present (E) and then Suppress_Access_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Access_Check);
+ else
+ return Scope_Suppress (Access_Check);
+ end if;
end Access_Checks_Suppressed;
-------------------------------------
@@ -152,8 +286,11 @@ package body Checks is
function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Accessibility_Checks
- or else (Present (E) and then Suppress_Accessibility_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Accessibility_Check);
+ else
+ return Scope_Suppress (Accessibility_Check);
+ end if;
end Accessibility_Checks_Suppressed;
-------------------------
@@ -167,8 +304,9 @@ package body Checks is
Static_Sloc : Source_Ptr;
Flag_Node : Node_Id)
is
- Internal_Flag_Node : Node_Id := Flag_Node;
- Internal_Static_Sloc : Source_Ptr := Static_Sloc;
+ Internal_Flag_Node : constant Node_Id := Flag_Node;
+ Internal_Static_Sloc : constant Source_Ptr := Static_Sloc;
+
Checks_On : constant Boolean :=
(not Index_Checks_Suppressed (Suppress_Typ))
or else
@@ -219,17 +357,53 @@ package body Checks is
Check_Unset_Reference (P);
end if;
- if Is_Entity_Name (P)
- and then Access_Checks_Suppressed (Entity (P))
- then
+ -- Don't need access check if prefix is known to be non-null
+
+ if Known_Non_Null (P) then
return;
+ -- Don't need access checks if they are suppressed on the type
+
elsif Access_Checks_Suppressed (Etype (P)) then
return;
+ end if;
- else
- Set_Do_Access_Check (N, True);
+ -- Case where P is an entity name
+
+ if Is_Entity_Name (P) then
+ declare
+ Ent : constant Entity_Id := Entity (P);
+
+ begin
+ if Access_Checks_Suppressed (Ent) then
+ return;
+ end if;
+
+ -- Otherwise we are going to generate an access check, and
+ -- are we have done it, the entity will now be known non null
+ -- But we have to check for safe sequential semantics here!
+
+ if Safe_To_Capture_Value (N, Ent) then
+ Set_Is_Known_Non_Null (Ent);
+ end if;
+ end;
end if;
+
+ -- Access check is required
+
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Sloc (N),
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (P),
+ Right_Opnd =>
+ Make_Null (Loc)),
+ Reason => CE_Access_Check_Failed));
+ end;
end Apply_Access_Check;
-------------------------------
@@ -290,7 +464,13 @@ package body Checks is
Loc : Source_Ptr;
begin
- if No (AC) or else Range_Checks_Suppressed (E) then
+ -- See if check needed. Note that we never need a check if the
+ -- maximum alignment is one, since the check will always succeed
+
+ if No (AC)
+ or else not Check_Address_Alignment (AC)
+ or else Maximum_Alignment = 1
+ then
return;
end if;
@@ -341,7 +521,7 @@ package body Checks is
Left_Opnd =>
Unchecked_Convert_To
(RTE (RE_Integer_Address),
- Duplicate_Subexpr (Expr)),
+ Duplicate_Subexpr_No_Checks (Expr)),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (E, Loc),
@@ -353,6 +533,10 @@ package body Checks is
end if;
return;
+
+ exception
+ when RE_Not_Available =>
+ return;
end Apply_Alignment_Check;
-------------------------------------
@@ -376,11 +560,11 @@ package body Checks is
Ctyp : Entity_Id;
Opnd : Node_Id;
Cent : RE_Id;
- Lo : Uint;
- Hi : Uint;
- OK : Boolean;
begin
+ -- Skip this if overflow checks are done in back end, or the overflow
+ -- flag is not set anyway, or we are not doing code expansion.
+
if Backend_Overflow_Checks_On_Target
or not Do_Overflow_Check (N)
or not Expander_Active
@@ -388,36 +572,8 @@ package body Checks is
return;
end if;
- -- Nothing to do if the range of the result is known OK
-
- Determine_Range (N, OK, Lo, Hi);
-
- -- Note in the test below that we assume that if a bound of the
- -- range is equal to that of the type. That's not quite accurate
- -- but we do this for the following reasons:
-
- -- a) The way that Determine_Range works, it will typically report
- -- the bounds of the value are the bounds of the type, because
- -- it either can't tell anything more precise, or does not think
- -- it is worth the effort to be more precise.
-
- -- b) It is very unusual to have a situation in which this would
- -- generate an unnecessary overflow check (an example would be
- -- a subtype with a range 0 .. Integer'Last - 1 to which the
- -- literal value one is added.
-
- -- c) The alternative is a lot of special casing in this routine
- -- which would partially duplicate the Determine_Range processing.
-
- if OK
- and then Lo > Expr_Value (Type_Low_Bound (Typ))
- and then Hi < Expr_Value (Type_High_Bound (Typ))
- then
- return;
- end if;
-
- -- None of the special case optimizations worked, so there is nothing
- -- for it but to generate the full general case code:
+ -- Otherwise, we generate the full general code for front end overflow
+ -- detection, which works by doing arithmetic in a larger type:
-- x op y
@@ -503,13 +659,30 @@ package body Checks is
-- Now build the outer conversion
Opnd := OK_Convert_To (Typ, Opnod);
-
Analyze (Opnd);
Set_Etype (Opnd, Typ);
- Set_Analyzed (Opnd, True);
- Set_Do_Overflow_Check (Opnd, True);
- Rewrite (N, Opnd);
+ -- In the discrete type case, we directly generate the range check
+ -- for the outer operand. This range check will implement the required
+ -- overflow check.
+
+ if Is_Discrete_Type (Typ) then
+ Rewrite (N, Opnd);
+ Generate_Range_Check (Expression (N), Typ, CE_Overflow_Check_Failed);
+
+ -- For other types, we enable overflow checking on the conversion,
+ -- after setting the node as analyzed to prevent recursive attempts
+ -- to expand the conversion node.
+
+ else
+ Set_Analyzed (Opnd, True);
+ Enable_Overflow_Check (Opnd);
+ Rewrite (N, Opnd);
+ end if;
+
+ exception
+ when RE_Not_Available =>
+ return;
end Apply_Arithmetic_Overflow_Check;
----------------------------
@@ -605,7 +778,7 @@ package body Checks is
return;
end if;
- -- It is pointless to insert this check inside an _init_proc, because
+ -- It is pointless to insert this check inside an init proc, because
-- that's too late, we have already built the object to be the right
-- size, and if it's too large, too bad!
@@ -688,9 +861,7 @@ package body Checks is
Insert_Action (N,
Make_Raise_Storage_Error (Loc,
Reason => SE_Object_Too_Large));
- Warn_On_Instance := True;
Error_Msg_N ("?Storage_Error will be raised at run-time", N);
- Warn_On_Instance := False;
Uintp.Release (Umark);
return;
end if;
@@ -715,13 +886,12 @@ package body Checks is
Sizx :=
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ctyp, Loc),
+ Prefix => New_Occurrence_Of (Ctyp, Loc),
Attribute_Name => Name_Size);
Indx := First_Index (Typ);
for J in 1 .. Number_Dimensions (Typ) loop
-
if Sloc (Etype (Indx)) = Sloc (N) then
Ensure_Defined (Etype (Indx), N);
end if;
@@ -942,8 +1112,7 @@ package body Checks is
if Nkind (Original_Node (N)) /= N_Allocator
and then (No (Lhs)
or else not Is_Entity_Name (Lhs)
- or else (Ekind (Entity (Lhs)) /= E_In_Out_Parameter
- and then Ekind (Entity (Lhs)) /= E_Out_Parameter))
+ or else No (Param_Entity (Lhs)))
then
if (Etype (N) = Typ
or else (Do_Access and then Designated_Type (Typ) = S_Typ))
@@ -960,7 +1129,8 @@ package body Checks is
and then Is_Entity_Name (Expression (Original_Node (N)))
then
declare
- Alloc_Typ : Entity_Id := Entity (Expression (Original_Node (N)));
+ Alloc_Typ : constant Entity_Id :=
+ Entity (Expression (Original_Node (N)));
begin
if Alloc_Typ = T_Typ
@@ -979,7 +1149,7 @@ package body Checks is
-- all the constraints are constants. In this case, we can do the
-- check successfully at compile time.
- -- we skip this check for the case where the node is a rewritten`
+ -- We skip this check for the case where the node is a rewritten`
-- allocator, because it already carries the context subtype, and
-- extracting the discriminants from the aggregate is messy.
@@ -1079,7 +1249,6 @@ package body Checks is
Make_Raise_Constraint_Error (Loc,
Condition => Cond,
Reason => CE_Discriminant_Check_Failed));
-
end Apply_Discriminant_Check;
------------------------
@@ -1116,7 +1285,7 @@ package body Checks is
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (Right),
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
Right_Opnd => Make_Integer_Literal (Loc, 0)),
Reason => CE_Divide_By_Zero));
end if;
@@ -1142,11 +1311,13 @@ package body Checks is
Make_And_Then (Loc,
Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (Left),
+ Left_Opnd =>
+ Duplicate_Subexpr_Move_Checks (Left),
Right_Opnd => Make_Integer_Literal (Loc, LLB)),
Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (Right),
+ Left_Opnd =>
+ Duplicate_Subexpr (Right),
Right_Opnd =>
Make_Integer_Literal (Loc, -1))),
Reason => CE_Overflow_Check_Failed));
@@ -1218,6 +1389,10 @@ package body Checks is
procedure Bad_Value;
-- Procedure called if value is determined to be out of range
+ ---------------
+ -- Bad_Value --
+ ---------------
+
procedure Bad_Value is
begin
Apply_Compile_Time_Constraint_Error
@@ -1226,6 +1401,8 @@ package body Checks is
Typ => Target_Typ);
end Bad_Value;
+ -- Start of processing for Apply_Scalar_Range_Check
+
begin
if Inside_A_Generic then
return;
@@ -1261,21 +1438,21 @@ package body Checks is
-- Check array type and its base type
if Index_Checks_Suppressed (Arr_Typ)
- or else Suppress_Index_Checks (Base_Type (Arr_Typ))
+ or else Index_Checks_Suppressed (Base_Type (Arr_Typ))
then
return;
-- Check array itself if it is an entity name
elsif Is_Entity_Name (Arr)
- and then Suppress_Index_Checks (Entity (Arr))
+ and then Index_Checks_Suppressed (Entity (Arr))
then
return;
-- Check expression itself if it is an entity name
elsif Is_Entity_Name (Expr)
- and then Suppress_Index_Checks (Entity (Expr))
+ and then Index_Checks_Suppressed (Entity (Expr))
then
return;
end if;
@@ -1286,14 +1463,14 @@ package body Checks is
-- Check target type and its base type
if Range_Checks_Suppressed (Target_Typ)
- or else Suppress_Range_Checks (Base_Type (Target_Typ))
+ or else Range_Checks_Suppressed (Base_Type (Target_Typ))
then
return;
-- Check expression itself if it is an entity name
elsif Is_Entity_Name (Expr)
- and then Suppress_Range_Checks (Entity (Expr))
+ and then Range_Checks_Suppressed (Entity (Expr))
then
return;
@@ -1302,13 +1479,30 @@ package body Checks is
elsif Nkind (Parnt) = N_Assignment_Statement
and then Is_Entity_Name (Name (Parnt))
- and then Suppress_Range_Checks (Entity (Name (Parnt)))
+ and then Range_Checks_Suppressed (Entity (Name (Parnt)))
then
return;
end if;
end if;
end if;
+ -- Do not set range checks if they are killed
+
+ if Nkind (Expr) = N_Unchecked_Type_Conversion
+ and then Kill_Range_Check (Expr)
+ then
+ return;
+ end if;
+
+ -- Do not set range checks for any values from System.Scalar_Values
+ -- since the whole idea of such values is to avoid checking them!
+
+ if Is_Entity_Name (Expr)
+ and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values)
+ then
+ return;
+ end if;
+
-- Now see if we need a check
if No (Source_Typ) then
@@ -1325,7 +1519,8 @@ package body Checks is
Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
-- Always do a range check if the source type includes infinities
- -- and the target type does not include infinities.
+ -- and the target type does not include infinities. We do not do
+ -- this if range checks are killed.
if Is_Floating_Point_Type (S_Typ)
and then Has_Infinities (S_Typ)
@@ -1360,23 +1555,44 @@ package body Checks is
if Compile_Time_Known_Value (Tlo)
and then Compile_Time_Known_Value (Thi)
then
- Determine_Range (Expr, OK, Lo, Hi);
+ declare
+ Lov : constant Uint := Expr_Value (Tlo);
+ Hiv : constant Uint := Expr_Value (Thi);
- if OK then
- declare
- Lov : constant Uint := Expr_Value (Tlo);
- Hiv : constant Uint := Expr_Value (Thi);
+ begin
+ -- If range is null, we for sure have a constraint error
+ -- (we don't even need to look at the value involved,
+ -- since all possible values will raise CE).
+
+ if Lov > Hiv then
+ Bad_Value;
+ return;
+ end if;
+
+ -- Otherwise determine range of value
+
+ Determine_Range (Expr, OK, Lo, Hi);
+
+ if OK then
+
+ -- If definitely in range, all OK
- begin
if Lo >= Lov and then Hi <= Hiv then
return;
+ -- If definitely not in range, warn
+
elsif Lov > Hi or else Hiv < Lo then
Bad_Value;
return;
+
+ -- Otherwise we don't know
+
+ else
+ null;
end if;
- end;
- end if;
+ end if;
+ end;
end if;
end;
end if;
@@ -1386,10 +1602,9 @@ package body Checks is
or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
-- Check if we can determine at compile time whether Expr is in the
- -- range of the target type. Note that if S_Typ is within the
- -- bounds of Target_Typ then this must be the case. This checks is
- -- only meaningful if this is not a conversion between integer and
- -- real types.
+ -- range of the target type. Note that if S_Typ is within the bounds
+ -- of Target_Typ then this must be the case. This check is meaningful
+ -- only if this is not a conversion between integer and real types.
if not Is_Unconstrained_Subscr_Ref
and then
@@ -1405,27 +1620,21 @@ package body Checks is
Bad_Value;
return;
- -- Do not set range checks if they are killed
+ -- In the floating-point case, we only do range checks if the
+ -- type is constrained. We definitely do NOT want range checks
+ -- for unconstrained types, since we want to have infinities
- elsif Nkind (Expr) = N_Unchecked_Type_Conversion
- and then Kill_Range_Check (Expr)
- then
- return;
+ elsif Is_Floating_Point_Type (S_Typ) then
+ if Is_Constrained (S_Typ) then
+ Enable_Range_Check (Expr);
+ end if;
- -- ??? We only need a runtime check if the target type is constrained
- -- (the predefined type Float is not for instance).
- -- so the following should really be
- --
- -- elsif Is_Constrained (Target_Typ) then
- --
- -- but it isn't because certain types do not have the Is_Constrained
- -- flag properly set (see 1503-003).
+ -- For all other cases we enable a range check unconditionally
else
Enable_Range_Check (Expr);
return;
end if;
-
end Apply_Scalar_Range_Check;
----------------------------------
@@ -1457,7 +1666,6 @@ package body Checks is
Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
for J in 1 .. 2 loop
-
R_Cno := R_Result (J);
exit when No (R_Cno);
@@ -1613,9 +1821,7 @@ package body Checks is
else
Install_Static_Check (R_Cno, Loc);
end if;
-
end loop;
-
end Apply_Selected_Range_Checks;
-------------------------------
@@ -1667,9 +1873,8 @@ package body Checks is
procedure Apply_Type_Conversion_Checks (N : Node_Id) is
Target_Type : constant Entity_Id := Etype (N);
Target_Base : constant Entity_Id := Base_Type (Target_Type);
-
- Expr : constant Node_Id := Expression (N);
- Expr_Type : constant Entity_Id := Etype (Expr);
+ Expr : constant Node_Id := Expression (N);
+ Expr_Type : constant Entity_Id := Etype (Expr);
begin
if Inside_A_Generic then
@@ -1682,14 +1887,10 @@ package body Checks is
return;
-- Scalar type conversions of the form Target_Type (Expr) require
- -- two checks:
- --
- -- - First there is an overflow check to insure that Expr is
- -- in the base type of Target_Typ (4.6 (28)),
- --
- -- - After we know Expr fits into the base type, we must perform a
- -- range check to ensure that Expr meets the constraints of the
- -- Target_Type.
+ -- a range check if we cannot be sure that Expr is in the base type
+ -- of Target_Typ and also that Expr is in the range of Target_Typ.
+ -- These are not quite the same condition from an implementation
+ -- point of view, but clearly the second includes the first.
elsif Is_Scalar_Type (Target_Type) then
declare
@@ -1699,8 +1900,6 @@ package body Checks is
-- then fixed point values must be read as integral values.
begin
- -- Overflow check.
-
if not Overflow_Checks_Suppressed (Target_Base)
and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
then
@@ -1720,26 +1919,28 @@ package body Checks is
and then Is_Derived_Type (Target_Type)
and then not Is_Tagged_Type (Target_Type)
and then not Is_Constrained (Target_Type)
- and then Present (Girder_Constraint (Target_Type))
+ and then Present (Stored_Constraint (Target_Type))
then
- -- A unconstrained derived type may have inherited discriminants.
- -- Build an actual discriminant constraint list using the girder
+ -- An unconstrained derived type may have inherited discriminant
+ -- Build an actual discriminant constraint list using the stored
-- constraint, to verify that the expression of the parent type
-- satisfies the constraints imposed by the (unconstrained!)
-- derived type. This applies to value conversions, not to view
-- conversions of tagged types.
declare
- Loc : constant Source_Ptr := Sloc (N);
- Cond : Node_Id;
- Constraint : Elmt_Id;
- Discr_Value : Node_Id;
- Discr : Entity_Id;
- New_Constraints : Elist_Id := New_Elmt_List;
- Old_Constraints : Elist_Id := Discriminant_Constraint (Expr_Type);
+ Loc : constant Source_Ptr := Sloc (N);
+ Cond : Node_Id;
+ Constraint : Elmt_Id;
+ Discr_Value : Node_Id;
+ Discr : Entity_Id;
+
+ New_Constraints : constant Elist_Id := New_Elmt_List;
+ Old_Constraints : constant Elist_Id :=
+ Discriminant_Constraint (Expr_Type);
begin
- Constraint := First_Elmt (Girder_Constraint (Target_Type));
+ Constraint := First_Elmt (Stored_Constraint (Target_Type));
while Present (Constraint) loop
Discr_Value := Node (Constraint);
@@ -1755,13 +1956,14 @@ package body Checks is
-- Parent is constrained by new discriminant. Obtain
-- Value of original discriminant in expression. If
-- the new discriminant has been used to constrain more
- -- than one of the girder ones, this will provide the
- -- required consistency check.
+ -- than one of the stored discriminants, this will
+ -- provide the required consistency check.
Append_Elmt (
Make_Selected_Component (Loc,
Prefix =>
- Duplicate_Subexpr (Expr, Name_Req => True),
+ Duplicate_Subexpr_No_Checks
+ (Expr, Name_Req => True),
Selector_Name =>
Make_Identifier (Loc, Chars (Discr))),
New_Constraints);
@@ -1773,11 +1975,12 @@ package body Checks is
end if;
-- Derived type definition has an explicit value for
- -- this girder discriminant.
+ -- this stored discriminant.
else
Append_Elmt
- (Duplicate_Subexpr (Discr_Value), New_Constraints);
+ (Duplicate_Subexpr_No_Checks (Discr_Value),
+ New_Constraints);
end if;
Next_Elmt (Constraint);
@@ -1797,12 +2000,14 @@ package body Checks is
Reason => CE_Discriminant_Check_Failed));
end;
- -- should there be other checks here for array types ???
+ -- For arrays, conversions are applied during expansion, to take
+ -- into accounts changes of representation. The checks become range
+ -- checks on the base type or length checks on the subtype, depending
+ -- on whether the target type is unconstrained or constrained.
else
null;
end if;
-
end Apply_Type_Conversion_Checks;
----------------------------------------------
@@ -1832,6 +2037,18 @@ package body Checks is
elsif not Comes_From_Source (N) then
return;
+ -- If the prefix is a selected component that depends on a discriminant
+ -- the check may improperly expose a discriminant instead of using
+ -- the bounds of the object itself. Set the type of the attribute to
+ -- the base type of the context, so that a check will be imposed when
+ -- needed (e.g. if the node appears as an index).
+
+ elsif Nkind (Prefix (N)) = N_Selected_Component
+ and then Ekind (Typ) = E_Signed_Integer_Subtype
+ and then Depends_On_Discriminant (Scalar_Range (Typ))
+ then
+ Set_Etype (N, Base_Type (Typ));
+
-- Otherwise, replace the attribute node with a type conversion
-- node whose expression is the attribute, retyped to universal
-- integer, and whose subtype mark is the target type. The call
@@ -1866,14 +2083,14 @@ package body Checks is
Cond : Node_Id;
Disc : Elmt_Id;
Disc_Ent : Entity_Id;
+ Dref : Node_Id;
Dval : Node_Id;
begin
Cond := Empty;
Disc := First_Elmt (Discriminant_Constraint (T_Typ));
- -- For a fully private type, use the discriminants of the parent
- -- type.
+ -- For a fully private type, use the discriminants of the parent type
if Is_Private_Type (T_Typ)
and then No (Full_View (T_Typ))
@@ -1884,7 +2101,6 @@ package body Checks is
end if;
while Present (Disc) loop
-
Dval := Node (Disc);
if Nkind (Dval) = N_Identifier
@@ -1892,17 +2108,21 @@ package body Checks is
then
Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
else
- Dval := Duplicate_Subexpr (Dval);
+ Dval := Duplicate_Subexpr_No_Checks (Dval);
end if;
+ Dref :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Duplicate_Subexpr_No_Checks (N, Name_Req => True),
+ Selector_Name =>
+ Make_Identifier (Loc, Chars (Disc_Ent)));
+
+ Set_Is_In_Discriminant_Check (Dref);
+
Evolve_Or_Else (Cond,
Make_Op_Ne (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix =>
- Duplicate_Subexpr (N, Name_Req => True),
- Selector_Name =>
- Make_Identifier (Loc, Chars (Disc_Ent))),
+ Left_Opnd => Dref,
Right_Opnd => Dval));
Next_Elmt (Disc);
@@ -1949,6 +2169,63 @@ package body Checks is
end if;
end Check_Valid_Lvalue_Subscripts;
+ ----------------------------------
+ -- Conditional_Statements_Begin --
+ ----------------------------------
+
+ procedure Conditional_Statements_Begin is
+ begin
+ Saved_Checks_TOS := Saved_Checks_TOS + 1;
+
+ -- If stack overflows, kill all checks, that way we know to
+ -- simply reset the number of saved checks to zero on return.
+ -- This should never occur in practice.
+
+ if Saved_Checks_TOS > Saved_Checks_Stack'Last then
+ Kill_All_Checks;
+
+ -- In the normal case, we just make a new stack entry saving
+ -- the current number of saved checks for a later restore.
+
+ else
+ Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks;
+
+ if Debug_Flag_CC then
+ w ("Conditional_Statements_Begin: Num_Saved_Checks = ",
+ Num_Saved_Checks);
+ end if;
+ end if;
+ end Conditional_Statements_Begin;
+
+ --------------------------------
+ -- Conditional_Statements_End --
+ --------------------------------
+
+ procedure Conditional_Statements_End is
+ begin
+ pragma Assert (Saved_Checks_TOS > 0);
+
+ -- If the saved checks stack overflowed, then we killed all
+ -- checks, so setting the number of saved checks back to
+ -- zero is correct. This should never occur in practice.
+
+ if Saved_Checks_TOS > Saved_Checks_Stack'Last then
+ Num_Saved_Checks := 0;
+
+ -- In the normal case, restore the number of saved checks
+ -- from the top stack entry.
+
+ else
+ Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
+ if Debug_Flag_CC then
+ w ("Conditional_Statements_End: Num_Saved_Checks = ",
+ Num_Saved_Checks);
+ end if;
+ end if;
+
+ Saved_Checks_TOS := Saved_Checks_TOS - 1;
+ end Conditional_Statements_End;
+
---------------------
-- Determine_Range --
---------------------
@@ -2175,12 +2452,14 @@ package body Checks is
when N_Op_Mod =>
if OK_Operands then
- if Lo_Right = Hi_Right then
+ if Lo_Right = Hi_Right
+ and then Lo_Right /= 0
+ then
if Lo_Right > 0 then
Lor := Uint_0;
Hir := Lo_Right - 1;
- elsif Lo_Right < 0 then
+ else -- Lo_Right < 0
Lor := Lo_Right + 1;
Hir := Uint_0;
end if;
@@ -2195,7 +2474,9 @@ package body Checks is
when N_Op_Rem =>
if OK_Operands then
- if Lo_Right = Hi_Right then
+ if Lo_Right = Hi_Right
+ and then Lo_Right /= 0
+ then
declare
Dval : constant Uint := (abs Lo_Right) - 1;
@@ -2386,7 +2667,6 @@ package body Checks is
Hi := No_Uint;
return;
end if;
-
end Determine_Range;
------------------------------------
@@ -2395,8 +2675,15 @@ package body Checks is
function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Discriminant_Checks
- or else (Present (E) and then Suppress_Discriminant_Checks (E));
+ if Present (E) then
+ if Is_Unchecked_Union (E) then
+ return True;
+ elsif Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Discriminant_Check);
+ end if;
+ end if;
+
+ return Scope_Suppress (Discriminant_Check);
end Discriminant_Checks_Suppressed;
--------------------------------
@@ -2405,8 +2692,11 @@ package body Checks is
function Division_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Division_Checks
- or else (Present (E) and then Suppress_Division_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Division_Check);
+ else
+ return Scope_Suppress (Division_Check);
+ end if;
end Division_Checks_Suppressed;
-----------------------------------
@@ -2415,23 +2705,354 @@ package body Checks is
function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Elaboration_Checks
- or else (Present (E) and then Suppress_Elaboration_Checks (E));
+ if Present (E) then
+ if Kill_Elaboration_Checks (E) then
+ return True;
+ elsif Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Elaboration_Check);
+ end if;
+ end if;
+
+ return Scope_Suppress (Elaboration_Check);
end Elaboration_Checks_Suppressed;
+ ---------------------------
+ -- Enable_Overflow_Check --
+ ---------------------------
+
+ procedure Enable_Overflow_Check (N : Node_Id) is
+ Typ : constant Entity_Id := Base_Type (Etype (N));
+ Chk : Nat;
+ OK : Boolean;
+ Ent : Entity_Id;
+ Ofs : Uint;
+ Lo : Uint;
+ Hi : Uint;
+
+ begin
+ if Debug_Flag_CC then
+ w ("Enable_Overflow_Check for node ", Int (N));
+ Write_Str (" Source location = ");
+ wl (Sloc (N));
+ pg (N);
+ end if;
+
+ -- Nothing to do if the range of the result is known OK. We skip
+ -- this for conversions, since the caller already did the check,
+ -- and in any case the condition for deleting the check for a
+ -- type conversion is different in any case.
+
+ if Nkind (N) /= N_Type_Conversion then
+ Determine_Range (N, OK, Lo, Hi);
+
+ -- Note in the test below that we assume that if a bound of the
+ -- range is equal to that of the type. That's not quite accurate
+ -- but we do this for the following reasons:
+
+ -- a) The way that Determine_Range works, it will typically report
+ -- the bounds of the value as being equal to the bounds of the
+ -- type, because it either can't tell anything more precise, or
+ -- does not think it is worth the effort to be more precise.
+
+ -- b) It is very unusual to have a situation in which this would
+ -- generate an unnecessary overflow check (an example would be
+ -- a subtype with a range 0 .. Integer'Last - 1 to which the
+ -- literal value one is added.
+
+ -- c) The alternative is a lot of special casing in this routine
+ -- which would partially duplicate Determine_Range processing.
+
+ if OK
+ and then Lo > Expr_Value (Type_Low_Bound (Typ))
+ and then Hi < Expr_Value (Type_High_Bound (Typ))
+ then
+ if Debug_Flag_CC then
+ w ("No overflow check required");
+ end if;
+
+ return;
+ end if;
+ end if;
+
+ -- If not in optimizing mode, set flag and we are done. We are also
+ -- done (and just set the flag) if the type is not a discrete type,
+ -- since it is not worth the effort to eliminate checks for other
+ -- than discrete types. In addition, we take this same path if we
+ -- have stored the maximum number of checks possible already (a
+ -- very unlikely situation, but we do not want to blow up!)
+
+ if Optimization_Level = 0
+ or else not Is_Discrete_Type (Etype (N))
+ or else Num_Saved_Checks = Saved_Checks'Last
+ then
+ Set_Do_Overflow_Check (N, True);
+
+ if Debug_Flag_CC then
+ w ("Optimization off");
+ end if;
+
+ return;
+ end if;
+
+ -- Otherwise evaluate and check the expression
+
+ Find_Check
+ (Expr => N,
+ Check_Type => 'O',
+ Target_Type => Empty,
+ Entry_OK => OK,
+ Check_Num => Chk,
+ Ent => Ent,
+ Ofs => Ofs);
+
+ if Debug_Flag_CC then
+ w ("Called Find_Check");
+ w (" OK = ", OK);
+
+ if OK then
+ w (" Check_Num = ", Chk);
+ w (" Ent = ", Int (Ent));
+ Write_Str (" Ofs = ");
+ pid (Ofs);
+ end if;
+ end if;
+
+ -- If check is not of form to optimize, then set flag and we are done
+
+ if not OK then
+ Set_Do_Overflow_Check (N, True);
+ return;
+ end if;
+
+ -- If check is already performed, then return without setting flag
+
+ if Chk /= 0 then
+ if Debug_Flag_CC then
+ w ("Check suppressed!");
+ end if;
+
+ return;
+ end if;
+
+ -- Here we will make a new entry for the new check
+
+ Set_Do_Overflow_Check (N, True);
+ Num_Saved_Checks := Num_Saved_Checks + 1;
+ Saved_Checks (Num_Saved_Checks) :=
+ (Killed => False,
+ Entity => Ent,
+ Offset => Ofs,
+ Check_Type => 'O',
+ Target_Type => Empty);
+
+ if Debug_Flag_CC then
+ w ("Make new entry, check number = ", Num_Saved_Checks);
+ w (" Entity = ", Int (Ent));
+ Write_Str (" Offset = ");
+ pid (Ofs);
+ w (" Check_Type = O");
+ w (" Target_Type = Empty");
+ end if;
+
+ -- If we get an exception, then something went wrong, probably because
+ -- of an error in the structure of the tree due to an incorrect program.
+ -- Or it may be a bug in the optimization circuit. In either case the
+ -- safest thing is simply to set the check flag unconditionally.
+
+ exception
+ when others =>
+ Set_Do_Overflow_Check (N, True);
+
+ if Debug_Flag_CC then
+ w (" exception occurred, overflow flag set");
+ end if;
+
+ return;
+ end Enable_Overflow_Check;
+
------------------------
-- Enable_Range_Check --
------------------------
procedure Enable_Range_Check (N : Node_Id) is
+ Chk : Nat;
+ OK : Boolean;
+ Ent : Entity_Id;
+ Ofs : Uint;
+ Ttyp : Entity_Id;
+ P : Node_Id;
+
begin
+ -- Return if unchecked type conversion with range check killed.
+ -- In this case we never set the flag (that's what Kill_Range_Check
+ -- is all about!)
+
if Nkind (N) = N_Unchecked_Type_Conversion
and then Kill_Range_Check (N)
then
return;
+ end if;
+
+ -- Debug trace output
+
+ if Debug_Flag_CC then
+ w ("Enable_Range_Check for node ", Int (N));
+ Write_Str (" Source location = ");
+ wl (Sloc (N));
+ pg (N);
+ end if;
+
+ -- If not in optimizing mode, set flag and we are done. We are also
+ -- done (and just set the flag) if the type is not a discrete type,
+ -- since it is not worth the effort to eliminate checks for other
+ -- than discrete types. In addition, we take this same path if we
+ -- have stored the maximum number of checks possible already (a
+ -- very unlikely situation, but we do not want to blow up!)
+
+ if Optimization_Level = 0
+ or else No (Etype (N))
+ or else not Is_Discrete_Type (Etype (N))
+ or else Num_Saved_Checks = Saved_Checks'Last
+ then
+ Set_Do_Range_Check (N, True);
+
+ if Debug_Flag_CC then
+ w ("Optimization off");
+ end if;
+
+ return;
+ end if;
+
+ -- Otherwise find out the target type
+
+ P := Parent (N);
+
+ -- For assignment, use left side subtype
+
+ if Nkind (P) = N_Assignment_Statement
+ and then Expression (P) = N
+ then
+ Ttyp := Etype (Name (P));
+
+ -- For indexed component, use subscript subtype
+
+ elsif Nkind (P) = N_Indexed_Component then
+ declare
+ Atyp : Entity_Id;
+ Indx : Node_Id;
+ Subs : Node_Id;
+
+ begin
+ Atyp := Etype (Prefix (P));
+
+ if Is_Access_Type (Atyp) then
+ Atyp := Designated_Type (Atyp);
+ end if;
+
+ Indx := First_Index (Atyp);
+ Subs := First (Expressions (P));
+ loop
+ if Subs = N then
+ Ttyp := Etype (Indx);
+ exit;
+ end if;
+
+ Next_Index (Indx);
+ Next (Subs);
+ end loop;
+ end;
+
+ -- For now, ignore all other cases, they are not so interesting
+
else
+ if Debug_Flag_CC then
+ w (" target type not found, flag set");
+ end if;
+
+ Set_Do_Range_Check (N, True);
+ return;
+ end if;
+
+ -- Evaluate and check the expression
+
+ Find_Check
+ (Expr => N,
+ Check_Type => 'R',
+ Target_Type => Ttyp,
+ Entry_OK => OK,
+ Check_Num => Chk,
+ Ent => Ent,
+ Ofs => Ofs);
+
+ if Debug_Flag_CC then
+ w ("Called Find_Check");
+ w ("Target_Typ = ", Int (Ttyp));
+ w (" OK = ", OK);
+
+ if OK then
+ w (" Check_Num = ", Chk);
+ w (" Ent = ", Int (Ent));
+ Write_Str (" Ofs = ");
+ pid (Ofs);
+ end if;
+ end if;
+
+ -- If check is not of form to optimize, then set flag and we are done
+
+ if not OK then
+ if Debug_Flag_CC then
+ w (" expression not of optimizable type, flag set");
+ end if;
+
Set_Do_Range_Check (N, True);
+ return;
+ end if;
+
+ -- If check is already performed, then return without setting flag
+
+ if Chk /= 0 then
+ if Debug_Flag_CC then
+ w ("Check suppressed!");
+ end if;
+
+ return;
+ end if;
+
+ -- Here we will make a new entry for the new check
+
+ Set_Do_Range_Check (N, True);
+ Num_Saved_Checks := Num_Saved_Checks + 1;
+ Saved_Checks (Num_Saved_Checks) :=
+ (Killed => False,
+ Entity => Ent,
+ Offset => Ofs,
+ Check_Type => 'R',
+ Target_Type => Ttyp);
+
+ if Debug_Flag_CC then
+ w ("Make new entry, check number = ", Num_Saved_Checks);
+ w (" Entity = ", Int (Ent));
+ Write_Str (" Offset = ");
+ pid (Ofs);
+ w (" Check_Type = R");
+ w (" Target_Type = ", Int (Ttyp));
+ pg (Ttyp);
end if;
+
+ -- If we get an exception, then something went wrong, probably because
+ -- of an error in the structure of the tree due to an incorrect program.
+ -- Or it may be a bug in the optimization circuit. In either case the
+ -- safest thing is simply to set the check flag unconditionally.
+
+ exception
+ when others =>
+ Set_Do_Range_Check (N, True);
+
+ if Debug_Flag_CC then
+ w (" exception occurred, range flag set");
+ end if;
+
+ return;
end Enable_Range_Check;
------------------
@@ -2447,14 +3068,24 @@ package body Checks is
if not Validity_Checks_On then
return;
+ -- Ignore call if range checks suppressed on entity in question
+
+ elsif Is_Entity_Name (Expr)
+ and then Range_Checks_Suppressed (Entity (Expr))
+ then
+ return;
+
-- No check required if expression is from the expander, we assume
-- the expander will generate whatever checks are needed. Note that
-- this is not just an optimization, it avoids infinite recursions!
-- Unchecked conversions must be checked, unless they are initialized
- -- scalar values, as in a component assignment in an init_proc.
+ -- scalar values, as in a component assignment in an init proc.
+
+ -- In addition, we force a check if Force_Validity_Checks is set
elsif not Comes_From_Source (Expr)
+ and then not Force_Validity_Checks
and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
or else Kill_Range_Check (Expr))
then
@@ -2515,11 +3146,19 @@ package body Checks is
end if;
-- Only need to worry if we are argument of a procedure
- -- call since functions don't have out parameters.
+ -- call since functions don't have out parameters. If this
+ -- is an indirect or dispatching call, get signature from
+ -- the subprogram type.
if Nkind (P) = N_Procedure_Call_Statement then
L := Parameter_Associations (P);
- E := Entity (Name (P));
+
+ if Is_Entity_Name (Name (P)) then
+ E := Entity (Name (P));
+ else
+ pragma Assert (Nkind (Name (P)) = N_Explicit_Dereference);
+ E := Etype (Name (P));
+ end if;
-- Only need to worry if there are indeed actuals, and
-- if this could be a procedure call, otherwise we cannot
@@ -2647,6 +3286,683 @@ package body Checks is
end if;
end Expr_Known_Valid;
+ ----------------
+ -- Find_Check --
+ ----------------
+
+ procedure Find_Check
+ (Expr : Node_Id;
+ Check_Type : Character;
+ Target_Type : Entity_Id;
+ Entry_OK : out Boolean;
+ Check_Num : out Nat;
+ Ent : out Entity_Id;
+ Ofs : out Uint)
+ is
+ function Within_Range_Of
+ (Target_Type : Entity_Id;
+ Check_Type : Entity_Id)
+ return Boolean;
+ -- Given a requirement for checking a range against Target_Type, and
+ -- and a range Check_Type against which a check has already been made,
+ -- determines if the check against check type is sufficient to ensure
+ -- that no check against Target_Type is required.
+
+ ---------------------
+ -- Within_Range_Of --
+ ---------------------
+
+ function Within_Range_Of
+ (Target_Type : Entity_Id;
+ Check_Type : Entity_Id)
+ return Boolean
+ is
+ begin
+ if Target_Type = Check_Type then
+ return True;
+
+ else
+ declare
+ Tlo : constant Node_Id := Type_Low_Bound (Target_Type);
+ Thi : constant Node_Id := Type_High_Bound (Target_Type);
+ Clo : constant Node_Id := Type_Low_Bound (Check_Type);
+ Chi : constant Node_Id := Type_High_Bound (Check_Type);
+
+ begin
+ if (Tlo = Clo
+ or else (Compile_Time_Known_Value (Tlo)
+ and then
+ Compile_Time_Known_Value (Clo)
+ and then
+ Expr_Value (Clo) >= Expr_Value (Tlo)))
+ and then
+ (Thi = Chi
+ or else (Compile_Time_Known_Value (Thi)
+ and then
+ Compile_Time_Known_Value (Chi)
+ and then
+ Expr_Value (Chi) <= Expr_Value (Clo)))
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end;
+ end if;
+ end Within_Range_Of;
+
+ -- Start of processing for Find_Check
+
+ begin
+ -- Establish default, to avoid warnings from GCC.
+
+ Check_Num := 0;
+
+ -- Case of expression is simple entity reference
+
+ if Is_Entity_Name (Expr) then
+ Ent := Entity (Expr);
+ Ofs := Uint_0;
+
+ -- Case of expression is entity + known constant
+
+ elsif Nkind (Expr) = N_Op_Add
+ and then Compile_Time_Known_Value (Right_Opnd (Expr))
+ and then Is_Entity_Name (Left_Opnd (Expr))
+ then
+ Ent := Entity (Left_Opnd (Expr));
+ Ofs := Expr_Value (Right_Opnd (Expr));
+
+ -- Case of expression is entity - known constant
+
+ elsif Nkind (Expr) = N_Op_Subtract
+ and then Compile_Time_Known_Value (Right_Opnd (Expr))
+ and then Is_Entity_Name (Left_Opnd (Expr))
+ then
+ Ent := Entity (Left_Opnd (Expr));
+ Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr)));
+
+ -- Any other expression is not of the right form
+
+ else
+ Ent := Empty;
+ Ofs := Uint_0;
+ Entry_OK := False;
+ return;
+ end if;
+
+ -- Come here with expression of appropriate form, check if
+ -- entity is an appropriate one for our purposes.
+
+ if (Ekind (Ent) = E_Variable
+ or else
+ Ekind (Ent) = E_Constant
+ or else
+ Ekind (Ent) = E_Loop_Parameter
+ or else
+ Ekind (Ent) = E_In_Parameter)
+ and then not Is_Library_Level_Entity (Ent)
+ then
+ Entry_OK := True;
+ else
+ Entry_OK := False;
+ return;
+ end if;
+
+ -- See if there is matching check already
+
+ for J in reverse 1 .. Num_Saved_Checks loop
+ declare
+ SC : Saved_Check renames Saved_Checks (J);
+
+ begin
+ if SC.Killed = False
+ and then SC.Entity = Ent
+ and then SC.Offset = Ofs
+ and then SC.Check_Type = Check_Type
+ and then Within_Range_Of (Target_Type, SC.Target_Type)
+ then
+ Check_Num := J;
+ return;
+ end if;
+ end;
+ end loop;
+
+ -- If we fall through entry was not found
+
+ Check_Num := 0;
+ return;
+ end Find_Check;
+
+ ---------------------------------
+ -- Generate_Discriminant_Check --
+ ---------------------------------
+
+ -- Note: the code for this procedure is derived from the
+ -- emit_discriminant_check routine a-trans.c v1.659.
+
+ procedure Generate_Discriminant_Check (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Pref : constant Node_Id := Prefix (N);
+ Sel : constant Node_Id := Selector_Name (N);
+
+ Orig_Comp : constant Entity_Id :=
+ Original_Record_Component (Entity (Sel));
+ -- The original component to be checked
+
+ Discr_Fct : constant Entity_Id :=
+ Discriminant_Checking_Func (Orig_Comp);
+ -- The discriminant checking function
+
+ Discr : Entity_Id;
+ -- One discriminant to be checked in the type
+
+ Real_Discr : Entity_Id;
+ -- Actual discriminant in the call
+
+ Pref_Type : Entity_Id;
+ -- Type of relevant prefix (ignoring private/access stuff)
+
+ Args : List_Id;
+ -- List of arguments for function call
+
+ Formal : Entity_Id;
+ -- Keep track of the formal corresponding to the actual we build
+ -- for each discriminant, in order to be able to perform the
+ -- necessary type conversions.
+
+ Scomp : Node_Id;
+ -- Selected component reference for checking function argument
+
+ begin
+ Pref_Type := Etype (Pref);
+
+ -- Force evaluation of the prefix, so that it does not get evaluated
+ -- twice (once for the check, once for the actual reference). Such a
+ -- double evaluation is always a potential source of inefficiency,
+ -- and is functionally incorrect in the volatile case, or when the
+ -- prefix may have side-effects. An entity or a component of an
+ -- entity requires no evaluation.
+
+ if Is_Entity_Name (Pref) then
+ if Treat_As_Volatile (Entity (Pref)) then
+ Force_Evaluation (Pref, Name_Req => True);
+ end if;
+
+ elsif Treat_As_Volatile (Etype (Pref)) then
+ Force_Evaluation (Pref, Name_Req => True);
+
+ elsif Nkind (Pref) = N_Selected_Component
+ and then Is_Entity_Name (Prefix (Pref))
+ then
+ null;
+
+ else
+ Force_Evaluation (Pref, Name_Req => True);
+ end if;
+
+ -- For a tagged type, use the scope of the original component to
+ -- obtain the type, because ???
+
+ if Is_Tagged_Type (Scope (Orig_Comp)) then
+ Pref_Type := Scope (Orig_Comp);
+
+ -- For an untagged derived type, use the discriminants of the
+ -- parent which have been renamed in the derivation, possibly
+ -- by a one-to-many discriminant constraint.
+ -- For non-tagged type, initially get the Etype of the prefix
+
+ else
+ if Is_Derived_Type (Pref_Type)
+ and then Number_Discriminants (Pref_Type) /=
+ Number_Discriminants (Etype (Base_Type (Pref_Type)))
+ then
+ Pref_Type := Etype (Base_Type (Pref_Type));
+ end if;
+ end if;
+
+ -- We definitely should have a checking function, This routine should
+ -- not be called if no discriminant checking function is present.
+
+ pragma Assert (Present (Discr_Fct));
+
+ -- Create the list of the actual parameters for the call. This list
+ -- is the list of the discriminant fields of the record expression to
+ -- be discriminant checked.
+
+ Args := New_List;
+ Formal := First_Formal (Discr_Fct);
+ Discr := First_Discriminant (Pref_Type);
+ while Present (Discr) loop
+
+ -- If we have a corresponding discriminant field, and a parent
+ -- subtype is present, then we want to use the corresponding
+ -- discriminant since this is the one with the useful value.
+
+ if Present (Corresponding_Discriminant (Discr))
+ and then Ekind (Pref_Type) = E_Record_Type
+ and then Present (Parent_Subtype (Pref_Type))
+ then
+ Real_Discr := Corresponding_Discriminant (Discr);
+ else
+ Real_Discr := Discr;
+ end if;
+
+ -- Construct the reference to the discriminant
+
+ Scomp :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Pref_Type,
+ Duplicate_Subexpr (Pref)),
+ Selector_Name => New_Occurrence_Of (Real_Discr, Loc));
+
+ -- Manually analyze and resolve this selected component. We really
+ -- want it just as it appears above, and do not want the expander
+ -- playing discriminal games etc with this reference. Then we
+ -- append the argument to the list we are gathering.
+
+ Set_Etype (Scomp, Etype (Real_Discr));
+ Set_Analyzed (Scomp, True);
+ Append_To (Args, Convert_To (Etype (Formal), Scomp));
+
+ Next_Formal_With_Extras (Formal);
+ Next_Discriminant (Discr);
+ end loop;
+
+ -- Now build and insert the call
+
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Discr_Fct, Loc),
+ Parameter_Associations => Args),
+ Reason => CE_Discriminant_Check_Failed));
+ end Generate_Discriminant_Check;
+
+ ----------------------------
+ -- Generate_Index_Checks --
+ ----------------------------
+
+ procedure Generate_Index_Checks (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ A : constant Node_Id := Prefix (N);
+ Sub : Node_Id;
+ Ind : Nat;
+ Num : List_Id;
+
+ begin
+ Sub := First (Expressions (N));
+ Ind := 1;
+ while Present (Sub) loop
+ if Do_Range_Check (Sub) then
+ Set_Do_Range_Check (Sub, False);
+
+ -- Force evaluation except for the case of a simple name of
+ -- a non-volatile entity.
+
+ if not Is_Entity_Name (Sub)
+ or else Treat_As_Volatile (Entity (Sub))
+ then
+ Force_Evaluation (Sub);
+ end if;
+
+ -- Generate a raise of constraint error with the appropriate
+ -- reason and a condition of the form:
+
+ -- Base_Type(Sub) not in array'range (subscript)
+
+ -- Note that the reason we generate the conversion to the
+ -- base type here is that we definitely want the range check
+ -- to take place, even if it looks like the subtype is OK.
+ -- Optimization considerations that allow us to omit the
+ -- check have already been taken into account in the setting
+ -- of the Do_Range_Check flag earlier on.
+
+ if Ind = 1 then
+ Num := No_List;
+ else
+ Num := New_List (Make_Integer_Literal (Loc, Ind));
+ end if;
+
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Not_In (Loc,
+ Left_Opnd =>
+ Convert_To (Base_Type (Etype (Sub)),
+ Duplicate_Subexpr_Move_Checks (Sub)),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr_Move_Checks (A),
+ Attribute_Name => Name_Range,
+ Expressions => Num)),
+ Reason => CE_Index_Check_Failed));
+ end if;
+
+ Ind := Ind + 1;
+ Next (Sub);
+ end loop;
+ end Generate_Index_Checks;
+
+ --------------------------
+ -- Generate_Range_Check --
+ --------------------------
+
+ procedure Generate_Range_Check
+ (N : Node_Id;
+ Target_Type : Entity_Id;
+ Reason : RT_Exception_Code)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Source_Type : constant Entity_Id := Etype (N);
+ Source_Base_Type : constant Entity_Id := Base_Type (Source_Type);
+ Target_Base_Type : constant Entity_Id := Base_Type (Target_Type);
+
+ begin
+ -- First special case, if the source type is already within the
+ -- range of the target type, then no check is needed (probably we
+ -- should have stopped Do_Range_Check from being set in the first
+ -- place, but better late than later in preventing junk code!
+
+ -- We do NOT apply this if the source node is a literal, since in
+ -- this case the literal has already been labeled as having the
+ -- subtype of the target.
+
+ if In_Subrange_Of (Source_Type, Target_Type)
+ and then not
+ (Nkind (N) = N_Integer_Literal
+ or else
+ Nkind (N) = N_Real_Literal
+ or else
+ Nkind (N) = N_Character_Literal
+ or else
+ (Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_Enumeration_Literal))
+ then
+ return;
+ end if;
+
+ -- We need a check, so force evaluation of the node, so that it does
+ -- not get evaluated twice (once for the check, once for the actual
+ -- reference). Such a double evaluation is always a potential source
+ -- of inefficiency, and is functionally incorrect in the volatile case.
+
+ if not Is_Entity_Name (N)
+ or else Treat_As_Volatile (Entity (N))
+ then
+ Force_Evaluation (N);
+ end if;
+
+ -- The easiest case is when Source_Base_Type and Target_Base_Type
+ -- are the same since in this case we can simply do a direct
+ -- check of the value of N against the bounds of Target_Type.
+
+ -- [constraint_error when N not in Target_Type]
+
+ -- Note: this is by far the most common case, for example all cases of
+ -- checks on the RHS of assignments are in this category, but not all
+ -- cases are like this. Notably conversions can involve two types.
+
+ if Source_Base_Type = Target_Base_Type then
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Not_In (Loc,
+ Left_Opnd => Duplicate_Subexpr (N),
+ Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
+ Reason => Reason));
+
+ -- Next test for the case where the target type is within the bounds
+ -- of the base type of the source type, since in this case we can
+ -- simply convert these bounds to the base type of T to do the test.
+
+ -- [constraint_error when N not in
+ -- Source_Base_Type (Target_Type'First)
+ -- ..
+ -- Source_Base_Type(Target_Type'Last))]
+
+ -- The conversions will always work and need no check.
+
+ elsif In_Subrange_Of (Target_Type, Source_Base_Type) then
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Not_In (Loc,
+ Left_Opnd => Duplicate_Subexpr (N),
+
+ Right_Opnd =>
+ Make_Range (Loc,
+ Low_Bound =>
+ Convert_To (Source_Base_Type,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_First)),
+
+ High_Bound =>
+ Convert_To (Source_Base_Type,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_Last)))),
+ Reason => Reason));
+
+ -- Note that at this stage we now that the Target_Base_Type is
+ -- not in the range of the Source_Base_Type (since even the
+ -- Target_Type itself is not in this range). It could still be
+ -- the case that the Source_Type is in range of the target base
+ -- type, since we have not checked that case.
+
+ -- If that is the case, we can freely convert the source to the
+ -- target, and then test the target result against the bounds.
+
+ elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
+
+ -- We make a temporary to hold the value of the converted
+ -- value (converted to the base type), and then we will
+ -- do the test against this temporary.
+
+ -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
+ -- [constraint_error when Tnn not in Target_Type]
+
+ -- Then the conversion itself is replaced by an occurrence of Tnn
+
+ declare
+ Tnn : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
+
+ begin
+ Insert_Actions (N, New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Object_Definition =>
+ New_Occurrence_Of (Target_Base_Type, Loc),
+ Constant_Present => True,
+ Expression =>
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
+ Expression => Duplicate_Subexpr (N))),
+
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Not_In (Loc,
+ Left_Opnd => New_Occurrence_Of (Tnn, Loc),
+ Right_Opnd => New_Occurrence_Of (Target_Type, Loc)),
+
+ Reason => Reason)));
+
+ Rewrite (N, New_Occurrence_Of (Tnn, Loc));
+ end;
+
+ -- At this stage, we know that we have two scalar types, which are
+ -- directly convertible, and where neither scalar type has a base
+ -- range that is in the range of the other scalar type.
+
+ -- The only way this can happen is with a signed and unsigned type.
+ -- So test for these two cases:
+
+ else
+ -- Case of the source is unsigned and the target is signed
+
+ if Is_Unsigned_Type (Source_Base_Type)
+ and then not Is_Unsigned_Type (Target_Base_Type)
+ then
+ -- If the source is unsigned and the target is signed, then we
+ -- know that the source is not shorter than the target (otherwise
+ -- the source base type would be in the target base type range).
+
+ -- In other words, the unsigned type is either the same size
+ -- as the target, or it is larger. It cannot be smaller.
+
+ pragma Assert
+ (Esize (Source_Base_Type) >= Esize (Target_Base_Type));
+
+ -- We only need to check the low bound if the low bound of the
+ -- target type is non-negative. If the low bound of the target
+ -- type is negative, then we know that we will fit fine.
+
+ -- If the high bound of the target type is negative, then we
+ -- know we have a constraint error, since we can't possibly
+ -- have a negative source.
+
+ -- With these two checks out of the way, we can do the check
+ -- using the source type safely
+
+ -- This is definitely the most annoying case!
+
+ -- [constraint_error
+ -- when (Target_Type'First >= 0
+ -- and then
+ -- N < Source_Base_Type (Target_Type'First))
+ -- or else Target_Type'Last < 0
+ -- or else N > Source_Base_Type (Target_Type'Last)];
+
+ -- We turn off all checks since we know that the conversions
+ -- will work fine, given the guards for negative values.
+
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Or_Else (Loc,
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_And_Then (Loc,
+ Left_Opnd => Make_Op_Ge (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_First),
+ Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
+
+ Right_Opnd =>
+ Make_Op_Lt (Loc,
+ Left_Opnd => Duplicate_Subexpr (N),
+ Right_Opnd =>
+ Convert_To (Source_Base_Type,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_First)))),
+
+ Right_Opnd =>
+ Make_Op_Lt (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_Last),
+ Right_Opnd => Make_Integer_Literal (Loc, Uint_0))),
+
+ Right_Opnd =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Duplicate_Subexpr (N),
+ Right_Opnd =>
+ Convert_To (Source_Base_Type,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_Last)))),
+
+ Reason => Reason),
+ Suppress => All_Checks);
+
+ -- Only remaining possibility is that the source is signed and
+ -- the target is unsigned
+
+ else
+ pragma Assert (not Is_Unsigned_Type (Source_Base_Type)
+ and then Is_Unsigned_Type (Target_Base_Type));
+
+ -- If the source is signed and the target is unsigned, then
+ -- we know that the target is not shorter than the source
+ -- (otherwise the target base type would be in the source
+ -- base type range).
+
+ -- In other words, the unsigned type is either the same size
+ -- as the target, or it is larger. It cannot be smaller.
+
+ -- Clearly we have an error if the source value is negative
+ -- since no unsigned type can have negative values. If the
+ -- source type is non-negative, then the check can be done
+ -- using the target type.
+
+ -- Tnn : constant Target_Base_Type (N) := Target_Type;
+
+ -- [constraint_error
+ -- when N < 0 or else Tnn not in Target_Type];
+
+ -- We turn off all checks for the conversion of N to the
+ -- target base type, since we generate the explicit check
+ -- to ensure that the value is non-negative
+
+ declare
+ Tnn : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('T'));
+
+ begin
+ Insert_Actions (N, New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Object_Definition =>
+ New_Occurrence_Of (Target_Base_Type, Loc),
+ Constant_Present => True,
+ Expression =>
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Target_Base_Type, Loc),
+ Expression => Duplicate_Subexpr (N))),
+
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Lt (Loc,
+ Left_Opnd => Duplicate_Subexpr (N),
+ Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
+
+ Right_Opnd =>
+ Make_Not_In (Loc,
+ Left_Opnd => New_Occurrence_Of (Tnn, Loc),
+ Right_Opnd =>
+ New_Occurrence_Of (Target_Type, Loc))),
+
+ Reason => Reason)),
+ Suppress => All_Checks);
+
+ -- Set the Etype explicitly, because Insert_Actions may
+ -- have placed the declaration in the freeze list for an
+ -- enclosing construct, and thus it is not analyzed yet.
+
+ Set_Etype (Tnn, Target_Base_Type);
+ Rewrite (N, New_Occurrence_Of (Tnn, Loc));
+ end;
+ end if;
+ end if;
+ end Generate_Range_Check;
+
---------------------
-- Get_Discriminal --
---------------------
@@ -2704,7 +4020,7 @@ package body Checks is
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ne (Loc,
- Left_Opnd => Duplicate_Subexpr (Ck_Node),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Right_Opnd => Make_Null (Loc)),
Right_Opnd => Cond);
end if;
@@ -2716,8 +4032,11 @@ package body Checks is
function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Index_Checks
- or else (Present (E) and then Suppress_Index_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Index_Check);
+ else
+ return Scope_Suppress (Index_Check);
+ end if;
end Index_Checks_Suppressed;
----------------
@@ -2842,7 +4161,7 @@ package body Checks is
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
- Duplicate_Subexpr (Exp, Name_Req => True),
+ Duplicate_Subexpr_No_Checks (Exp, Name_Req => True),
Attribute_Name => Name_Valid)),
Reason => CE_Invalid_Data),
Suppress => All_Checks);
@@ -2867,14 +4186,59 @@ package body Checks is
Set_Is_Static_Expression (R_Cno, Stat);
end Install_Static_Check;
+ ---------------------
+ -- Kill_All_Checks --
+ ---------------------
+
+ procedure Kill_All_Checks is
+ begin
+ if Debug_Flag_CC then
+ w ("Kill_All_Checks");
+ end if;
+
+ -- We reset the number of saved checks to zero, and also modify
+ -- all stack entries for statement ranges to indicate that the
+ -- number of checks at each level is now zero.
+
+ Num_Saved_Checks := 0;
+
+ for J in 1 .. Saved_Checks_TOS loop
+ Saved_Checks_Stack (J) := 0;
+ end loop;
+ end Kill_All_Checks;
+
+ -----------------
+ -- Kill_Checks --
+ -----------------
+
+ procedure Kill_Checks (V : Entity_Id) is
+ begin
+ if Debug_Flag_CC then
+ w ("Kill_Checks for entity", Int (V));
+ end if;
+
+ for J in 1 .. Num_Saved_Checks loop
+ if Saved_Checks (J).Entity = V then
+ if Debug_Flag_CC then
+ w (" Checks killed for saved check ", J);
+ end if;
+
+ Saved_Checks (J).Killed := True;
+ end if;
+ end loop;
+ end Kill_Checks;
+
------------------------------
-- Length_Checks_Suppressed --
------------------------------
function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Length_Checks
- or else (Present (E) and then Suppress_Length_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Length_Check);
+ else
+ return Scope_Suppress (Length_Check);
+ end if;
end Length_Checks_Suppressed;
--------------------------------
@@ -2883,8 +4247,11 @@ package body Checks is
function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Overflow_Checks
- or else (Present (E) and then Suppress_Overflow_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Overflow_Check);
+ else
+ return Scope_Suppress (Overflow_Check);
+ end if;
end Overflow_Checks_Suppressed;
-----------------
@@ -2909,12 +4276,21 @@ package body Checks is
function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- -- Note: for now we always suppress range checks on Vax float types,
- -- since Gigi does not know how to generate these checks.
+ if Present (E) then
+
+ -- Note: for now we always suppress range checks on Vax float types,
+ -- since Gigi does not know how to generate these checks.
+
+ if Vax_Float (E) then
+ return True;
+ elsif Kill_Range_Checks (E) then
+ return True;
+ elsif Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Range_Check);
+ end if;
+ end if;
- return Scope_Suppress.Range_Checks
- or else (Present (E) and then Suppress_Range_Checks (E))
- or else Vax_Float (E);
+ return Scope_Suppress (Range_Check);
end Range_Checks_Suppressed;
-------------------
@@ -2923,6 +4299,7 @@ package body Checks is
procedure Remove_Checks (Expr : Node_Id) is
Discard : Traverse_Result;
+ pragma Warnings (Off, Discard);
function Process (N : Node_Id) return Traverse_Result;
-- Process a single node during the traversal
@@ -2948,18 +4325,11 @@ package body Checks is
return Skip;
when N_Attribute_Reference =>
- Set_Do_Access_Check (N, False);
Set_Do_Overflow_Check (N, False);
- when N_Explicit_Dereference =>
- Set_Do_Access_Check (N, False);
-
when N_Function_Call =>
Set_Do_Tag_Check (N, False);
- when N_Indexed_Component =>
- Set_Do_Access_Check (N, False);
-
when N_Op =>
Set_Do_Overflow_Check (N, False);
@@ -2991,16 +4361,12 @@ package body Checks is
return Skip;
when N_Selected_Component =>
- Set_Do_Access_Check (N, False);
Set_Do_Discriminant_Check (N, False);
- when N_Slice =>
- Set_Do_Access_Check (N, False);
-
when N_Type_Conversion =>
- Set_Do_Length_Check (N, False);
+ Set_Do_Length_Check (N, False);
+ Set_Do_Tag_Check (N, False);
Set_Do_Overflow_Check (N, False);
- Set_Do_Tag_Check (N, False);
when others =>
null;
@@ -3046,7 +4412,7 @@ package body Checks is
function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
-- True for equal literals and for nodes that denote the same constant
-- entity, even if its value is not a static constant. This includes the
- -- case of a discriminal reference within an init_proc. Removes some
+ -- case of a discriminal reference within an init proc. Removes some
-- obviously superfluous checks.
function Length_E_Cond
@@ -3090,9 +4456,9 @@ package body Checks is
------------------
function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
+ Pt : constant Entity_Id := Scope (Scope (E));
N : Node_Id;
E1 : Entity_Id := E;
- Pt : Entity_Id := Scope (Scope (E));
begin
if Ekind (Scope (E)) = E_Record_Type
@@ -3155,11 +4521,11 @@ package body Checks is
if Do_Expand then
if not Is_Entity_Name (Lo) then
- Lo := Duplicate_Subexpr (Lo);
+ Lo := Duplicate_Subexpr_No_Checks (Lo);
end if;
if not Is_Entity_Name (Hi) then
- Lo := Duplicate_Subexpr (Hi);
+ Lo := Duplicate_Subexpr_No_Checks (Hi);
end if;
N :=
@@ -3215,7 +4581,7 @@ package body Checks is
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Length,
Prefix =>
- Duplicate_Subexpr (N, Name_Req => True),
+ Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List (
Make_Integer_Literal (Loc, Indx)));
@@ -3354,7 +4720,9 @@ package body Checks is
-- T_Typ'Length = string-literal-length
- if Nkind (Expr_Actual) = N_String_Literal then
+ if Nkind (Expr_Actual) = N_String_Literal
+ and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype
+ then
Cond :=
Make_Op_Ne (Loc,
Left_Opnd => Get_E_Length (T_Typ, 1),
@@ -3374,19 +4742,35 @@ package body Checks is
elsif Is_Constrained (Exptyp) then
declare
- L_Index : Node_Id;
- R_Index : Node_Id;
- Ndims : Nat := Number_Dimensions (T_Typ);
-
- L_Low : Node_Id;
- L_High : Node_Id;
- R_Low : Node_Id;
- R_High : Node_Id;
-
+ Ndims : constant Nat := Number_Dimensions (T_Typ);
+
+ L_Index : Node_Id;
+ R_Index : Node_Id;
+ L_Low : Node_Id;
+ L_High : Node_Id;
+ R_Low : Node_Id;
+ R_High : Node_Id;
L_Length : Uint;
R_Length : Uint;
+ Ref_Node : Node_Id;
begin
+
+ -- At the library level, we need to ensure that the
+ -- type of the object is elaborated before the check
+ -- itself is emitted.
+
+ if Is_Itype (Exptyp)
+ and then
+ Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package
+ and then
+ not In_Package_Body (Cunit_Entity (Current_Sem_Unit))
+ then
+ Ref_Node := Make_Itype_Reference (Sloc (Ck_Node));
+ Set_Itype (Ref_Node, Exptyp);
+ Insert_Action (Ck_Node, Ref_Node);
+ end if;
+
L_Index := First_Index (T_Typ);
R_Index := First_Index (Exptyp);
@@ -3470,7 +4854,7 @@ package body Checks is
else
declare
- Ndims : Nat := Number_Dimensions (T_Typ);
+ Ndims : constant Nat := Number_Dimensions (T_Typ);
begin
-- Build the condition for the explicit dereference case
@@ -3554,7 +4938,7 @@ package body Checks is
function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id;
-- Returns expression to compute:
- -- N'First or N'Last using Duplicate_Subexpr
+ -- N'First or N'Last using Duplicate_Subexpr_No_Checks
function Range_E_Cond
(Exptyp : Entity_Id;
@@ -3615,7 +4999,8 @@ package body Checks is
Left_Opnd =>
Make_Op_Lt (Loc,
Left_Opnd =>
- Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)),
+ Convert_To (Base_Type (Typ),
+ Duplicate_Subexpr_No_Checks (Expr)),
Right_Opnd =>
Convert_To (Base_Type (Typ),
Get_E_First_Or_Last (Typ, 0, Name_First))),
@@ -3623,7 +5008,8 @@ package body Checks is
Right_Opnd =>
Make_Op_Gt (Loc,
Left_Opnd =>
- Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)),
+ Convert_To (Base_Type (Typ),
+ Duplicate_Subexpr_No_Checks (Expr)),
Right_Opnd =>
Convert_To
(Base_Type (Typ),
@@ -3660,7 +5046,7 @@ package body Checks is
Make_Op_Lt (Loc,
Left_Opnd =>
Convert_To
- (Base_Type (Typ), Duplicate_Subexpr (LB)),
+ (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)),
Right_Opnd =>
Convert_To
@@ -3694,7 +5080,7 @@ package body Checks is
Make_Op_Gt (Loc,
Left_Opnd =>
Convert_To
- (Base_Type (Typ), Duplicate_Subexpr (HB)),
+ (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)),
Right_Opnd =>
Convert_To
@@ -3753,7 +5139,50 @@ package body Checks is
if Nkind (Bound) = N_Identifier
and then Ekind (Entity (Bound)) = E_Discriminant
then
- return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
+ -- If this is a task discriminant, and we are the body, we must
+ -- retrieve the corresponding body discriminal. This is another
+ -- consequence of the early creation of discriminals, and the
+ -- need to generate constraint checks before their declarations
+ -- are made visible.
+
+ if Is_Concurrent_Record_Type (Scope (Entity (Bound))) then
+ declare
+ Tsk : constant Entity_Id :=
+ Corresponding_Concurrent_Type
+ (Scope (Entity (Bound)));
+ Disc : Entity_Id;
+
+ begin
+ if In_Open_Scopes (Tsk)
+ and then Has_Completion (Tsk)
+ then
+ -- Find discriminant of original task, and use its
+ -- current discriminal, which is the renaming within
+ -- the task body.
+
+ Disc := First_Discriminant (Tsk);
+ while Present (Disc) loop
+ if Chars (Disc) = Chars (Entity (Bound)) then
+ Set_Scope (Discriminal (Disc), Tsk);
+ return New_Occurrence_Of (Discriminal (Disc), Loc);
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ -- That loop should always succeed in finding a matching
+ -- entry and returning. Fatal error if not.
+
+ raise Program_Error;
+
+ else
+ return
+ New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
+ end if;
+ end;
+ else
+ return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
+ end if;
elsif Nkind (Bound) = N_Identifier
and then Ekind (Entity (Bound)) = E_In_Parameter
@@ -3765,7 +5194,7 @@ package body Checks is
return Make_Integer_Literal (Loc, Intval (Bound));
else
- return Duplicate_Subexpr (Bound);
+ return Duplicate_Subexpr_No_Checks (Bound);
end if;
end Get_E_First_Or_Last;
@@ -3779,7 +5208,7 @@ package body Checks is
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
Prefix =>
- Duplicate_Subexpr (N, Name_Req => True),
+ Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List (
Make_Integer_Literal (Loc, Indx)));
@@ -3795,7 +5224,7 @@ package body Checks is
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
Prefix =>
- Duplicate_Subexpr (N, Name_Req => True),
+ Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List (
Make_Integer_Literal (Loc, Indx)));
@@ -4030,7 +5459,7 @@ package body Checks is
-- the record declaration, it is a use of the discriminant
-- in a constraint of a component, and nothing can be
-- checked here. The check will be emitted within the
- -- init_proc. Before then, the discriminal has no real
+ -- init proc. Before then, the discriminal has no real
-- meaning.
if Nkind (LB) = N_Identifier
@@ -4062,8 +5491,8 @@ package body Checks is
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ge (Loc,
- Left_Opnd => Duplicate_Subexpr (HB),
- Right_Opnd => Duplicate_Subexpr (LB)),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (HB),
+ Right_Opnd => Duplicate_Subexpr_No_Checks (LB)),
Right_Opnd => Cond);
end;
@@ -4180,14 +5609,14 @@ package body Checks is
elsif Is_Constrained (Exptyp) then
declare
+ Ndims : constant Nat := Number_Dimensions (T_Typ);
+
L_Index : Node_Id;
R_Index : Node_Id;
- Ndims : Nat := Number_Dimensions (T_Typ);
-
- L_Low : Node_Id;
- L_High : Node_Id;
- R_Low : Node_Id;
- R_High : Node_Id;
+ L_Low : Node_Id;
+ L_High : Node_Id;
+ R_Low : Node_Id;
+ R_High : Node_Id;
begin
L_Index := First_Index (T_Typ);
@@ -4243,7 +5672,7 @@ package body Checks is
else
declare
- Ndims : Nat := Number_Dimensions (T_Typ);
+ Ndims : constant Nat := Number_Dimensions (T_Typ);
begin
-- Build the condition for the explicit dereference case
@@ -4282,6 +5711,17 @@ package body Checks is
then
null;
+ -- If null range, no check needed.
+ elsif
+ Compile_Time_Known_Value (High_Bound (Opnd_Index))
+ and then
+ Compile_Time_Known_Value (Low_Bound (Opnd_Index))
+ and then
+ Expr_Value (High_Bound (Opnd_Index)) <
+ Expr_Value (Low_Bound (Opnd_Index))
+ then
+ null;
+
elsif Is_Out_Of_Range
(Low_Bound (Opnd_Index), Etype (Targ_Index))
or else
@@ -4330,8 +5770,11 @@ package body Checks is
function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Storage_Checks
- or else (Present (E) and then Suppress_Storage_Checks (E));
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Storage_Check);
+ else
+ return Scope_Suppress (Storage_Check);
+ end if;
end Storage_Checks_Suppressed;
---------------------------
@@ -4340,8 +5783,15 @@ package body Checks is
function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- return Scope_Suppress.Tag_Checks
- or else (Present (E) and then Suppress_Tag_Checks (E));
+ if Present (E) then
+ if Kill_Tag_Checks (E) then
+ return True;
+ elsif Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Tag_Check);
+ end if;
+ end if;
+
+ return Scope_Suppress (Tag_Check);
end Tag_Checks_Suppressed;
end Checks;
diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads
index 8ccafdea7c0..d6ad2bde5a5 100644
--- a/gcc/ada/checks.ads
+++ b/gcc/ada/checks.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -71,9 +71,8 @@ package Checks is
-- operate anyway since they may generate useful compile time warnings.
procedure Apply_Access_Check (N : Node_Id);
- -- Determines whether an expression node should be flagged as needing
- -- a runtime access check. If the node requires such a check, the
- -- Do_Access_Check flag is turned on.
+ -- Determines whether an expression node requires a runtime access
+ -- check and if so inserts the appropriate run-time check.
procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id);
-- Given a name N denoting an access parameter, emits a run-time
@@ -171,6 +170,81 @@ package Checks is
-- Thus the significance of OK being False on return is that no
-- useful information is available on the range of the expression.
+ -------------------------------------------------------
+ -- Control and Optimization of Range/Overflow Checks --
+ -------------------------------------------------------
+
+ -- Range checks are controlled by the Do_Range_Check flag. The front end
+ -- is responsible for setting this flag in relevant nodes. Originally
+ -- the back end generated all corresponding range checks. But later on
+ -- we decided to generate all range checks in the front end. We are now
+ -- in the transitional phase where some of these checks are still done
+ -- by the back end, but many are done by the front end.
+
+ -- Overflow checks are similarly controlled by the Do_Overflow_Check
+ -- flag. The difference here is that if Backend_Overflow_Checks is
+ -- is (Backend_Overflow_Checks_On_Target set False), then the actual
+ -- overflow checks are generated by the front end, but if back end
+ -- overflow checks are active (Backend_Overflow_Checks_On_Target
+ -- set True), then the back end does generate the checks.
+
+ -- The following two routines are used to set these flags, they allow
+ -- for the possibility of eliminating checks. Checks can be eliminated
+ -- if an identical check has already been performed.
+
+ procedure Enable_Overflow_Check (N : Node_Id);
+ -- First this routine determines if an overflow check is needed by doing
+ -- an appropriate range check. If a check is not needed, then the call
+ -- has no effect. If a check is needed then this routine sets the flag
+ -- Set Do_Overflow_Check in node N to True, unless it can be determined
+ -- that the check is not needed. The only condition under which this is
+ -- the case is if there was an identical check earlier on.
+
+ procedure Enable_Range_Check (N : Node_Id);
+ -- Set Do_Range_Check flag in node N True, unless it can be determined
+ -- that the check is not needed. The only condition under which this is
+ -- the case is if there was an identical check earlier on. This routine
+ -- is not responsible for doing range analysis to determine whether or
+ -- not such a check is needed -- the caller is expected to do this. The
+ -- one other case in which the request to set the flag is ignored is
+ -- when Kill_Range_Check is set in an N_Unchecked_Conversion node.
+
+ -- The following routines are used to keep track of processing sequences
+ -- of statements (e.g. the THEN statements of an IF statement). A check
+ -- that appears within such a sequence can eliminate an identical check
+ -- within this sequence of statements. However, after the end of the
+ -- sequence of statements, such a check is no longer of interest, since
+ -- it may not have been executed.
+
+ procedure Conditional_Statements_Begin;
+ -- This call marks the start of processing of a sequence of statements.
+ -- Every call to this procedure must be followed by a matching call to
+ -- Conditional_Statements_End.
+
+ procedure Conditional_Statements_End;
+ -- This call removes from consideration all saved checks since the
+ -- corresponding call to Conditional_Statements_Begin. These two
+ -- procedures operate in a stack like manner.
+
+ -- The mechanism for optimizing checks works by remembering checks
+ -- that have already been made, but certain conditions, for example
+ -- an assignment to a variable involved in a check, may mean that the
+ -- remembered check is no longer valid, in the sense that if the same
+ -- expression appears again, another check is required because the
+ -- value may have changed.
+
+ -- The following routines are used to note conditions which may render
+ -- some or all of the stored and remembered checks to be invalidated.
+
+ procedure Kill_Checks (V : Entity_Id);
+ -- This procedure records an assignment or other condition that causes
+ -- the value of the variable to be changed, invalidating any stored
+ -- checks that reference the value. Note that all such checks must
+ -- be discarded, even if they are not in the current statement range.
+
+ procedure Kill_All_Checks;
+ -- This procedure kills all remembered checks.
+
-----------------------------
-- Length and Range Checks --
-----------------------------
@@ -293,12 +367,6 @@ package Checks is
-- flag. Checks_On is a boolean value that says if range and index checking
-- is on or not.
- procedure Enable_Range_Check (N : Node_Id);
- pragma Inline (Enable_Range_Check);
- -- Set Do_Range_Check flag in node N to True unless Kill_Range_Check flag
- -- is set in N (the purpose of the latter flag is precisely to prevent
- -- Do_Range_Check from being set).
-
procedure Insert_Range_Checks
(Checks : Check_Result;
Node : Node_Id;
@@ -331,12 +399,65 @@ package Checks is
-- in constructing the check.
-----------------------
+ -- Expander Routines --
+ -----------------------
+
+ -- Some of the earlier processing for checks results in temporarily
+ -- setting the Do_Range_Check flag rather than actually generating
+ -- checks. Now we are moving the generation of such checks into the
+ -- front end for reasons of efficiency and simplicity (there were
+ -- difficutlies in handling this in the back end when side effects
+ -- were present in the expressions being checked).
+
+ -- Probably we could eliminate the Do_Range_Check flag entirely and
+ -- generate the checks earlier, but this is a delicate area and it
+ -- seemed safer to implement the following routines, which are called
+ -- late on in the expansion process. They check the Do_Range_Check flag
+ -- and if it is set, generate the actual checks and reset the flag.
+
+ procedure Generate_Range_Check
+ (N : Node_Id;
+ Target_Type : Entity_Id;
+ Reason : RT_Exception_Code);
+ -- This procedure is called to actually generate and insert a range
+ -- check. A check is generated to ensure that the value of N lies
+ -- within the range of the target type. Note that the base type of
+ -- N may be different from the base type of the target type. This
+ -- happens in the conversion case. The Reason parameter is the
+ -- exception code to be used for the exception if raised.
+ --
+ -- Note on the relation of this routine to the Do_Range_Check flag.
+ -- Mostly for historical reasons, we often set the Do_Range_Check
+ -- flag and then later we call Generate_Range_Check if this flag is
+ -- set. Most probably we could eliminate this intermediate setting
+ -- of the flag (historically the back end dealt with range checks,
+ -- using this flag to indicate if a check was required, then we
+ -- moved checks into the front end).
+
+ procedure Generate_Index_Checks (N : Node_Id);
+ -- This procedure is called to generate index checks on the subscripts
+ -- for the indexed component node N. Each subscript expression is
+ -- examined, and if the Do_Range_Check flag is set, an appropriate
+ -- index check is generated and the flag is reset.
+
+ -- Similarly, we set the flag Do_Discriminant_Check in the semantic
+ -- analysis to indicate that a discriminant check is required for a
+ -- selected component of a discriminated type. The following routine
+ -- is called from the expander to actually generate the call.
+
+ procedure Generate_Discriminant_Check (N : Node_Id);
+ -- N is a selected component for which a discriminant check is required
+ -- to make sure that the discriminants have appropriate values for the
+ -- selection. This is done by calling the appropriate discriminant
+ -- checking routine for the selector.
+
+ -----------------------
-- Validity Checking --
-----------------------
-- In (RM 13.9.1(9-11)) we have the following rules on invalid values
- -- 9 If the representation of a scalar object does not represent a
+ -- If the representation of a scalar object does not represent a
-- value of the object's subtype (perhaps because the object was not
-- initialized), the object is said to have an invalid representation.
-- It is a bounded error to evaluate the value of such an object. If
@@ -518,18 +639,6 @@ private
-- For external clients, the required processing on this result is
-- achieved using the Insert_Range_Checks routine.
- pragma Inline (Access_Checks_Suppressed);
- pragma Inline (Accessibility_Checks_Suppressed);
- pragma Inline (Discriminant_Checks_Suppressed);
- pragma Inline (Division_Checks_Suppressed);
- pragma Inline (Elaboration_Checks_Suppressed);
- pragma Inline (Index_Checks_Suppressed);
- pragma Inline (Length_Checks_Suppressed);
- pragma Inline (Overflow_Checks_Suppressed);
- pragma Inline (Range_Checks_Suppressed);
- pragma Inline (Storage_Checks_Suppressed);
- pragma Inline (Tag_Checks_Suppressed);
-
pragma Inline (Apply_Length_Check);
pragma Inline (Apply_Range_Check);
pragma Inline (Apply_Static_Length_Check);
diff --git a/gcc/ada/cio.c b/gcc/ada/cio.c
index 50452bc1eff..1316455c86a 100644
--- a/gcc/ada/cio.c
+++ b/gcc/ada/cio.c
@@ -48,6 +48,7 @@
#undef getchar
#undef fputc
#undef stderr
+#undef stdout
#endif
int
@@ -73,7 +74,9 @@ void
put_int (x)
int x;
{
- printf ("%d", x);
+ /* Use fprintf rather than printf, since the latter is unbuffered
+ on vxworks */
+ fprintf (stdout, "%d", x);
}
void
diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb
new file mode 100644
index 00000000000..8f38eb39cb0
--- /dev/null
+++ b/gcc/ada/clean.adb
@@ -0,0 +1,1444 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- C L E A N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with ALI; use ALI;
+with Csets;
+with Gnatvsn;
+with Hostparm;
+with Namet; use Namet;
+with Opt; use Opt;
+with Osint; use Osint;
+with Osint.M; use Osint.M;
+with Prj; use Prj;
+with Prj.Com;
+with Prj.Env;
+with Prj.Ext;
+with Prj.Pars;
+with Prj.Util; use Prj.Util;
+with Snames;
+with System;
+with Table;
+with Types; use Types;
+
+with GNAT.Command_Line; use GNAT.Command_Line;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.IO; use GNAT.IO;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+
+package body Clean is
+
+ Initialized : Boolean := False;
+ -- Set to True by the first call to Initialize.
+ -- To avoid reinitialization of some packages.
+
+ -- Suffixes of various files
+
+ Assembly_Suffix : constant String := ".s";
+ ALI_Suffix : constant String := ".ali";
+ Tree_Suffix : constant String := ".adt";
+ Object_Suffix : constant String := Get_Object_Suffix.all;
+ Debug_Suffix : String := ".dg";
+ -- Changed to "_dg" for VMS in the body of the package
+
+ Repinfo_Suffix : String := ".rep";
+ -- Changed to "_rep" for VMS in the body of the package
+
+ B_Start : String := "b~";
+ -- Prefix of binder generated file.
+ -- Changed to "b$" for VMS in the body of the package.
+
+ Object_Directory_Path : String_Access := null;
+ -- The path name of the object directory, set with switch -D
+
+ Do_Nothing : Boolean := False;
+ -- Set to True when switch -n is specified.
+ -- When True, no file is deleted. gnatclean only lists the files that
+ -- would have been deleted if the switch -n had not been specified.
+
+ File_Deleted : Boolean := False;
+ -- Set to True if at least one file has been deleted
+
+ Copyright_Displayed : Boolean := False;
+ Usage_Displayed : Boolean := False;
+
+ Project_File_Name : String_Access := null;
+
+ Main_Project : Prj.Project_Id := Prj.No_Project;
+
+ All_Projects : Boolean := False;
+
+ -- Packages of project files where unknown attributes are errors.
+
+ Naming_String : aliased String := "naming";
+ Builder_String : aliased String := "builder";
+ Compiler_String : aliased String := "compiler";
+ Binder_String : aliased String := "binder";
+ Linker_String : aliased String := "linker";
+
+ Gnatmake_Packages : aliased String_List :=
+ (Naming_String 'Access,
+ Builder_String 'Access,
+ Compiler_String 'Access,
+ Binder_String 'Access,
+ Linker_String 'Access);
+
+ Packages_To_Check_By_Gnatmake : constant String_List_Access :=
+ Gnatmake_Packages'Access;
+
+ package Processed_Projects is new Table.Table
+ (Table_Component_Type => Project_Id,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 0,
+ Table_Initial => 10,
+ Table_Increment => 10,
+ Table_Name => "Clean.Processed_Projects");
+ -- Table to keep track of what project files have been processed, when
+ -- switch -r is specified.
+
+ package Sources is new Table.Table
+ (Table_Component_Type => File_Name_Type,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 0,
+ Table_Initial => 10,
+ Table_Increment => 10,
+ Table_Name => "Clean.Processed_Projects");
+ -- Table to store all the source files of a library unit: spec, body and
+ -- subunits, to detect .dg files and delete them.
+
+ ----------------------------
+ -- Queue (Q) manipulation --
+ ----------------------------
+
+ procedure Init_Q;
+ -- Must be called to initialize the Q
+
+ procedure Insert_Q
+ (Source_File : File_Name_Type);
+ -- If Source_File is not marked, inserts it at the end of Q and mark it
+
+ function Empty_Q return Boolean;
+ -- Returns True if Q is empty.
+
+ procedure Extract_From_Q
+ (Source_File : out File_Name_Type);
+ -- Extracts the first element from the Q.
+
+ Q_Front : Natural;
+ -- Points to the first valid element in the Q.
+
+ package Q is new Table.Table (
+ Table_Component_Type => File_Name_Type,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 0,
+ Table_Initial => 4000,
+ Table_Increment => 100,
+ Table_Name => "Clean.Q");
+ -- This is the actual queue
+
+ -----------------------------
+ -- Other local subprograms --
+ -----------------------------
+
+ procedure Add_Source_Dir (N : String);
+ -- Call Add_Src_Search_Dir.
+ -- Output one line when in verbose mode.
+
+ procedure Add_Source_Directories is
+ new Prj.Env.For_All_Source_Dirs (Action => Add_Source_Dir);
+
+ procedure Add_Object_Dir (N : String);
+ -- Call Add_Lib_Search_Dir.
+ -- Output one line when in verbose mode.
+
+ procedure Add_Object_Directories is
+ new Prj.Env.For_All_Object_Dirs (Action => Add_Object_Dir);
+
+ function ALI_File_Name (Source : Name_Id) return String;
+ -- Returns the name of the ALI file corresponding to Source
+
+ function Assembly_File_Name (Source : Name_Id) return String;
+ -- Returns the assembly file name corresponding to Source
+
+ procedure Clean_Directory (Dir : Name_Id);
+ -- Delete all regular files in a library directory or in a library
+ -- interface dir.
+
+ procedure Clean_Executables;
+ -- Do the cleaning work when no project file is specified
+
+ procedure Clean_Project (Project : Project_Id);
+ -- Do the cleaning work when a project file is specified.
+ -- This procedure calls itself recursively when there are several
+ -- project files in the tree rooted at the main project file and switch -r
+ -- has been specified.
+
+ function Debug_File_Name (Source : Name_Id) return String;
+ -- Name of the expanded source file corresponding to Source
+
+ procedure Delete (In_Directory : String; File : String);
+ -- Delete one file, or list the file name if switch -n is specified
+
+ procedure Delete_Binder_Generated_Files (Dir : String; Source : Name_Id);
+ -- Delete the binder generated file in directory Dir for Source, if they
+ -- exist: for Unix these are b~<source>.ads, b~<source>.adb,
+ -- b~<source>.ali and b~<source>.o.
+
+ procedure Display_Copyright;
+ -- Display the Copyright notice.
+ -- If called several times, display the Copyright notice only the first
+ -- time.
+
+ procedure Initialize;
+ -- Call the necessary package initializations
+
+ function Object_File_Name (Source : Name_Id) return String;
+ -- Returns the object file name corresponding to Source
+
+ procedure Parse_Cmd_Line;
+ -- Parse the command line
+
+ function Repinfo_File_Name (Source : Name_Id) return String;
+ -- Returns the repinfo file name corresponding to Source
+
+ function Tree_File_Name (Source : Name_Id) return String;
+ -- Returns the tree file name corresponding to Source
+
+ function In_Extension_Chain
+ (Of_Project : Project_Id;
+ Prj : Project_Id) return Boolean;
+ -- Returns True iff Prj is an extension of Of_Project or if Of_Project is
+ -- an extension of Prj.
+
+ procedure Usage;
+ -- Display the usage.
+ -- If called several times, the usage is displayed only the first time.
+
+ --------------------
+ -- Add_Object_Dir --
+ --------------------
+
+ procedure Add_Object_Dir (N : String) is
+ begin
+ Add_Lib_Search_Dir (N);
+
+ if Opt.Verbose_Mode then
+ Put ("Adding object directory """);
+ Put (N);
+ Put (""".");
+ New_Line;
+ end if;
+ end Add_Object_Dir;
+
+ --------------------
+ -- Add_Source_Dir --
+ --------------------
+
+ procedure Add_Source_Dir (N : String) is
+ begin
+ Add_Src_Search_Dir (N);
+
+ if Opt.Verbose_Mode then
+ Put ("Adding source directory """);
+ Put (N);
+ Put (""".");
+ New_Line;
+ end if;
+ end Add_Source_Dir;
+
+ -------------------
+ -- ALI_File_Name --
+ -------------------
+
+ function ALI_File_Name (Source : Name_Id) return String is
+ Src : constant String := Get_Name_String (Source);
+
+ begin
+ -- If the source name has an extension, then replace it with
+ -- the ALI suffix.
+
+ for Index in reverse Src'First + 1 .. Src'Last loop
+ if Src (Index) = '.' then
+ return Src (Src'First .. Index - 1) & ALI_Suffix;
+ end if;
+ end loop;
+
+ -- If there is no dot, or if it is the first character, just add the
+ -- ALI suffix.
+
+ return Src & ALI_Suffix;
+ end ALI_File_Name;
+
+ ------------------------
+ -- Assembly_File_Name --
+ ------------------------
+
+ function Assembly_File_Name (Source : Name_Id) return String is
+ Src : constant String := Get_Name_String (Source);
+
+ begin
+ -- If the source name has an extension, then replace it with
+ -- the assembly suffix.
+
+ for Index in reverse Src'First + 1 .. Src'Last loop
+ if Src (Index) = '.' then
+ return Src (Src'First .. Index - 1) & Assembly_Suffix;
+ end if;
+ end loop;
+
+ -- If there is no dot, or if it is the first character, just add the
+ -- assembly suffix.
+
+ return Src & Assembly_Suffix;
+ end Assembly_File_Name;
+
+ ---------------------
+ -- Clean_Directory --
+ ---------------------
+
+ procedure Clean_Directory (Dir : Name_Id) is
+ Directory : constant String := Get_Name_String (Dir);
+ Current : constant Dir_Name_Str := Get_Current_Dir;
+
+ Direc : Dir_Type;
+
+ Name : String (1 .. 200);
+ Last : Natural;
+
+ procedure Set_Writable (Name : System.Address);
+ pragma Import (C, Set_Writable, "__gnat_set_writable");
+
+ begin
+ Change_Dir (Directory);
+ Open (Direc, ".");
+
+ -- For each regular file in the directory, if switch -n has not been
+ -- specified, make it writable and delete the file.
+
+ loop
+ Read (Direc, Name, Last);
+ exit when Last = 0;
+
+ if Is_Regular_File (Name (1 .. Last)) then
+ if not Do_Nothing then
+ Name (Last + 1) := ASCII.NUL;
+ Set_Writable (Name (1)'Address);
+ end if;
+
+ Delete (Directory, Name (1 .. Last));
+ end if;
+ end loop;
+
+ Close (Direc);
+
+ -- Restore the initial working directory
+
+ Change_Dir (Current);
+ end Clean_Directory;
+
+ -----------------------
+ -- Clean_Executables --
+ -----------------------
+
+ procedure Clean_Executables is
+ Main_Source_File : File_Name_Type;
+ -- Current main source
+
+ Source_File : File_Name_Type;
+ -- Current source file
+
+ Full_Source_File : File_Name_Type;
+ -- Full name of the current source file
+
+ Lib_File : File_Name_Type;
+ -- Current library file
+
+ Full_Lib_File : File_Name_Type;
+ -- Full name of the current library file
+
+ Text : Text_Buffer_Ptr;
+ The_ALI : ALI_Id;
+
+ begin
+ Init_Q;
+
+ -- It does not really matter if there is or not an object file
+ -- corresponding to an ALI file: if there is one, it will be deleted.
+
+ Opt.Check_Object_Consistency := False;
+
+ -- Proceed each executable one by one. Each source is marked as it is
+ -- processed, so common sources between executables will not be
+ -- processed several times.
+
+ for N_File in 1 .. Osint.Number_Of_Files loop
+ Main_Source_File := Next_Main_Source;
+ Insert_Q (Main_Source_File);
+
+ while not Empty_Q loop
+ Sources.Set_Last (0);
+ Extract_From_Q (Source_File);
+ Full_Source_File := Osint.Full_Source_Name (Source_File);
+ Lib_File := Osint.Lib_File_Name (Source_File);
+ Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
+
+ -- If we have an existing ALI file that is not read-only,
+ -- process it.
+
+ if Full_Lib_File /= No_File
+ and then not Is_Readonly_Library (Full_Lib_File)
+ then
+ Text := Read_Library_Info (Lib_File);
+
+ if Text /= null then
+ The_ALI :=
+ Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
+ Free (Text);
+
+ -- If no error was produced while loading this ALI file,
+ -- insert into the queue all the unmarked withed sources.
+
+ if The_ALI /= No_ALI_Id then
+ for J in ALIs.Table (The_ALI).First_Unit ..
+ ALIs.Table (The_ALI).Last_Unit
+ loop
+ Sources.Increment_Last;
+ Sources.Table (Sources.Last) :=
+ ALI.Units.Table (J).Sfile;
+
+ for K in ALI.Units.Table (J).First_With ..
+ ALI.Units.Table (J).Last_With
+ loop
+ Insert_Q (Withs.Table (K).Sfile);
+ end loop;
+ end loop;
+
+ -- Look for subunits and put them in the Sources table
+
+ for J in ALIs.Table (The_ALI).First_Sdep ..
+ ALIs.Table (The_ALI).Last_Sdep
+ loop
+ if Sdep.Table (J).Subunit_Name /= No_Name then
+ Sources.Increment_Last;
+ Sources.Table (Sources.Last) :=
+ Sdep.Table (J).Sfile;
+ end if;
+ end loop;
+ end if;
+ end if;
+
+ -- Now, delete all the existing files corresponding to this
+ -- ALI file.
+
+ declare
+ Obj_Dir : constant String :=
+ Dir_Name (Get_Name_String (Full_Lib_File));
+ Obj : constant String := Object_File_Name (Lib_File);
+ Adt : constant String := Tree_File_Name (Lib_File);
+ Asm : constant String := Assembly_File_Name (Lib_File);
+
+ begin
+ Delete (Obj_Dir, Get_Name_String (Lib_File));
+
+ if Is_Regular_File (Obj_Dir & Dir_Separator & Obj) then
+ Delete (Obj_Dir, Obj);
+ end if;
+
+ if Is_Regular_File (Obj_Dir & Dir_Separator & Adt) then
+ Delete (Obj_Dir, Adt);
+ end if;
+
+ if Is_Regular_File (Obj_Dir & Dir_Separator & Asm) then
+ Delete (Obj_Dir, Asm);
+ end if;
+
+ -- Delete expanded source files (.dg) and/or repinfo files
+ -- (.rep) if any
+
+ for J in 1 .. Sources.Last loop
+ declare
+ Deb : constant String :=
+ Debug_File_Name (Sources.Table (J));
+ Rep : constant String :=
+ Repinfo_File_Name (Sources.Table (J));
+ begin
+ if Is_Regular_File (Obj_Dir & Dir_Separator & Deb) then
+ Delete (Obj_Dir, Deb);
+ end if;
+
+ if Is_Regular_File (Obj_Dir & Dir_Separator & Rep) then
+ Delete (Obj_Dir, Rep);
+ end if;
+ end;
+ end loop;
+ end;
+ end if;
+ end loop;
+
+ -- Delete the executable, if it exists, and the binder generated
+ -- files, if any.
+
+ if not Compile_Only then
+ declare
+ Source : constant Name_Id := Strip_Suffix (Main_Source_File);
+ Executable : constant String := Get_Name_String
+ (Executable_Name (Source));
+ begin
+ if Is_Regular_File (Executable) then
+ Delete ("", Executable);
+ end if;
+
+ Delete_Binder_Generated_Files (Get_Current_Dir, Source);
+ end;
+ end if;
+ end loop;
+ end Clean_Executables;
+
+ -------------------
+ -- Clean_Project --
+ -------------------
+
+ procedure Clean_Project (Project : Project_Id) is
+ Main_Source_File : File_Name_Type;
+ -- Name of the executable on the command line, without directory
+ -- information.
+
+ Executable : Name_Id;
+ -- Name of the executable file
+
+ Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
+ Data : constant Project_Data := Projects.Table (Project);
+ U_Data : Prj.Com.Unit_Data;
+ File_Name1 : Name_Id;
+ File_Name2 : Name_Id;
+
+ use Prj.Com;
+
+ begin
+ -- Check that we don't specify executable on the command line for
+ -- a main library project.
+
+ if Project = Main_Project
+ and then Osint.Number_Of_Files /= 0
+ and then Data.Library
+ then
+ Osint.Fail
+ ("Cannot specify executable(s) for a Library Project File");
+ end if;
+
+ if Verbose_Mode then
+ Put ("Cleaning project """);
+ Put (Get_Name_String (Data.Name));
+ Put_Line ("""");
+ end if;
+
+ -- Add project to the list of proceesed projects
+
+ Processed_Projects.Increment_Last;
+ Processed_Projects.Table (Processed_Projects.Last) := Project;
+
+ if Data.Object_Directory /= No_Name then
+ declare
+ Obj_Dir : constant String :=
+ Get_Name_String (Data.Object_Directory);
+
+ begin
+ Change_Dir (Obj_Dir);
+
+ -- Look through the units to find those that are either immediate
+ -- sources or inherited sources of the project.
+
+ for Unit in 1 .. Prj.Com.Units.Last loop
+ U_Data := Prj.Com.Units.Table (Unit);
+ File_Name1 := No_Name;
+ File_Name2 := No_Name;
+
+ -- If either the spec or the body is a source of the project,
+ -- check for the corresponding ALI file in the object
+ -- directory.
+
+ if In_Extension_Chain
+ (U_Data.File_Names (Body_Part).Project, Project)
+ or else
+ In_Extension_Chain
+ (U_Data.File_Names (Specification).Project, Project)
+ then
+ File_Name1 := U_Data.File_Names (Body_Part).Name;
+ File_Name2 := U_Data.File_Names (Specification).Name;
+
+ -- If there is no body file name, then there may be only a
+ -- spec.
+
+ if File_Name1 = No_Name then
+ File_Name1 := File_Name2;
+ File_Name2 := No_Name;
+ end if;
+ end if;
+
+ -- If there is either a spec or a body, look for files in the
+ -- object directory.
+
+ if File_Name1 /= No_Name then
+ declare
+ Asm : constant String := Assembly_File_Name (File_Name1);
+ ALI : constant String := ALI_File_Name (File_Name1);
+ Obj : constant String := Object_File_Name (File_Name1);
+ Adt : constant String := Tree_File_Name (File_Name1);
+ Deb : constant String := Debug_File_Name (File_Name1);
+ Rep : constant String := Repinfo_File_Name (File_Name1);
+ Del : Boolean := True;
+
+ begin
+ -- If the ALI file exists and is read-only, no file is
+ -- deleted.
+
+ if Is_Regular_File (ALI) then
+ if Is_Writable_File (ALI) then
+ Delete (Obj_Dir, ALI);
+
+ else
+ Del := False;
+
+ if Verbose_Mode then
+ Put ('"');
+ Put (Obj_Dir);
+
+ if Obj_Dir (Obj_Dir'Last) /= Dir_Separator then
+ Put (Dir_Separator);
+ end if;
+
+ Put (ALI);
+ Put_Line (""" is read-only");
+ end if;
+ end if;
+ end if;
+
+ if Del then
+
+ -- Object file
+
+ if Is_Regular_File (Obj) then
+ Delete (Obj_Dir, Obj);
+ end if;
+
+ -- Assembly file
+
+ if Is_Regular_File (Asm) then
+ Delete (Obj_Dir, Asm);
+ end if;
+
+ -- Tree file
+
+ if Is_Regular_File (Adt) then
+ Delete (Obj_Dir, Adt);
+ end if;
+
+ -- First expanded source file
+
+ if Is_Regular_File (Deb) then
+ Delete (Obj_Dir, Deb);
+ end if;
+
+ -- Repinfo file
+
+ if Is_Regular_File (Rep) then
+ Delete (Obj_Dir, Rep);
+ end if;
+
+ -- Second expanded source file
+
+ if File_Name2 /= No_Name then
+ declare
+ Deb : constant String :=
+ Debug_File_Name (File_Name2);
+ Rep : constant String :=
+ Repinfo_File_Name (File_Name2);
+ begin
+ if Is_Regular_File (Deb) then
+ Delete (Obj_Dir, Deb);
+ end if;
+
+ if Is_Regular_File (Rep) then
+ Delete (Obj_Dir, Rep);
+ end if;
+ end;
+ end if;
+ end if;
+ end;
+ end if;
+ end loop;
+
+ if Verbose_Mode then
+ New_Line;
+ end if;
+ end;
+ end if;
+
+ -- If switch -r is specified, call Clean_Project recursively for the
+ -- imported projects and the project being extended.
+
+ if All_Projects then
+ declare
+ Imported : Project_List := Data.Imported_Projects;
+ Element : Project_Element;
+ Process : Boolean;
+
+ begin
+ -- For each imported project, call Clean_Project if the project
+ -- has not been processed already.
+
+ while Imported /= Empty_Project_List loop
+ Element := Project_Lists.Table (Imported);
+ Imported := Element.Next;
+ Process := True;
+
+ for
+ J in Processed_Projects.First .. Processed_Projects.Last
+ loop
+ if Element.Project = Processed_Projects.Table (J) then
+ Process := False;
+ exit;
+ end if;
+ end loop;
+
+ if Process then
+ Clean_Project (Element.Project);
+ end if;
+ end loop;
+
+ -- If this project extends another project, call Clean_Project for
+ -- the project being extended. It is guaranteed that it has not
+ -- called before, because no other project may import or extend
+ -- this project.
+
+ if Data.Extends /= No_Project then
+ Clean_Project (Data.Extends);
+ end if;
+ end;
+ end if;
+
+ -- If this is a library project, clean the library directory, the
+ -- interface copy dir and, for a Stand-Alone Library, the binder
+ -- generated files of the library.
+
+ -- The directories are cleaned only if switch -c is not specified.
+
+ if Data.Library then
+ if not Compile_Only then
+ Clean_Directory (Data.Library_Dir);
+
+ if Data.Library_Src_Dir /= No_Name
+ and then Data.Library_Src_Dir /= Data.Library_Dir
+ then
+ Clean_Directory (Data.Library_Src_Dir);
+ end if;
+ end if;
+
+ if Data.Standalone_Library and then
+ Data.Object_Directory /= No_Name
+ then
+ Delete_Binder_Generated_Files
+ (Get_Name_String (Data.Object_Directory), Data.Library_Name);
+ end if;
+
+ -- Otherwise, for the main project, delete the executables and the
+ -- binder generated files.
+
+ -- The executables are deleted only if switch -c is not specified.
+
+ elsif Project = Main_Project and then Data.Exec_Directory /= No_Name then
+ declare
+ Exec_Dir : constant String :=
+ Get_Name_String (Data.Exec_Directory);
+ begin
+ Change_Dir (Exec_Dir);
+
+ for N_File in 1 .. Osint.Number_Of_Files loop
+ Main_Source_File := Next_Main_Source;
+
+ if not Compile_Only then
+ Executable := Executable_Of (Main_Project, Main_Source_File);
+
+ if Is_Regular_File (Get_Name_String (Executable)) then
+ Delete (Exec_Dir, Get_Name_String (Executable));
+ end if;
+ end if;
+
+ if Data.Object_Directory /= No_Name then
+ Delete_Binder_Generated_Files
+ (Get_Name_String
+ (Data.Object_Directory),
+ Strip_Suffix (Main_Source_File));
+ end if;
+ end loop;
+ end;
+ end if;
+
+ -- Change back to previous directory
+
+ Change_Dir (Current_Dir);
+ end Clean_Project;
+
+ ---------------------
+ -- Debug_File_Name --
+ ---------------------
+
+ function Debug_File_Name (Source : Name_Id) return String is
+ begin
+ return Get_Name_String (Source) & Debug_Suffix;
+ end Debug_File_Name;
+
+ ------------
+ -- Delete --
+ ------------
+
+ procedure Delete (In_Directory : String; File : String) is
+ Full_Name : String (1 .. In_Directory'Length + File'Length + 1);
+ Last : Natural := 0;
+ Success : Boolean;
+
+ begin
+ -- Indicate that at least one file is deleted or is to be deleted
+
+ File_Deleted := True;
+
+ -- Build the path name of the file to delete
+
+ Last := In_Directory'Length;
+ Full_Name (1 .. Last) := In_Directory;
+
+ if Last > 0 and then Full_Name (Last) /= Directory_Separator then
+ Last := Last + 1;
+ Full_Name (Last) := Directory_Separator;
+ end if;
+
+ Full_Name (Last + 1 .. Last + File'Length) := File;
+ Last := Last + File'Length;
+
+ -- If switch -n was used, simply output the path name
+
+ if Do_Nothing then
+ Put_Line (Full_Name (1 .. Last));
+
+ -- Otherwise, delete the file
+
+ else
+ Delete_File (Full_Name (1 .. Last), Success);
+
+ if not Success then
+ Put ("Warning: """);
+ Put (Full_Name (1 .. Last));
+ Put_Line (""" could not be deleted");
+
+ elsif Verbose_Mode or else not Quiet_Output then
+ Put ("""");
+ Put (Full_Name (1 .. Last));
+ Put_Line (""" has been deleted");
+ end if;
+ end if;
+ end Delete;
+
+ -----------------------------------
+ -- Delete_Binder_Generated_Files --
+ -----------------------------------
+
+ procedure Delete_Binder_Generated_Files (Dir : String; Source : Name_Id) is
+ Source_Name : constant String := Get_Name_String (Source);
+ Current : constant String := Get_Current_Dir;
+ Last : constant Positive := B_Start'Length + Source_Name'Length;
+ File_Name : String (1 .. Last + 4);
+
+ begin
+ Change_Dir (Dir);
+
+ -- Build the file name (before the extension)
+
+ File_Name (1 .. B_Start'Length) := B_Start;
+ File_Name (B_Start'Length + 1 .. Last) := Source_Name;
+
+ -- Spec
+
+ File_Name (Last + 1 .. Last + 4) := ".ads";
+
+ if Is_Regular_File (File_Name (1 .. Last + 4)) then
+ Delete (Dir, File_Name (1 .. Last + 4));
+ end if;
+
+ -- Body
+
+ File_Name (Last + 1 .. Last + 4) := ".adb";
+
+ if Is_Regular_File (File_Name (1 .. Last + 4)) then
+ Delete (Dir, File_Name (1 .. Last + 4));
+ end if;
+
+ -- ALI file
+
+ File_Name (Last + 1 .. Last + 4) := ".ali";
+
+ if Is_Regular_File (File_Name (1 .. Last + 4)) then
+ Delete (Dir, File_Name (1 .. Last + 4));
+ end if;
+
+ -- Object file
+
+ File_Name (Last + 1 .. Last + Object_Suffix'Length) := Object_Suffix;
+
+ if Is_Regular_File (File_Name (1 .. Last + Object_Suffix'Length)) then
+ Delete (Dir, File_Name (1 .. Last + Object_Suffix'Length));
+ end if;
+
+ -- Change back to previous directory
+
+ Change_Dir (Current);
+ end Delete_Binder_Generated_Files;
+
+ -----------------------
+ -- Display_Copyright --
+ -----------------------
+
+ procedure Display_Copyright is
+ begin
+ if not Copyright_Displayed then
+ Copyright_Displayed := True;
+ Put_Line ("GNATCLEAN " & Gnatvsn.Gnat_Version_String
+ & " Copyright 2003 Free Software Foundation, Inc.");
+ end if;
+ end Display_Copyright;
+
+ -------------
+ -- Empty_Q --
+ -------------
+
+ function Empty_Q return Boolean is
+ begin
+ return Q_Front >= Q.Last;
+ end Empty_Q;
+
+ --------------------
+ -- Extract_From_Q --
+ --------------------
+
+ procedure Extract_From_Q (Source_File : out File_Name_Type) is
+ File : constant File_Name_Type := Q.Table (Q_Front);
+
+ begin
+ Q_Front := Q_Front + 1;
+ Source_File := File;
+ end Extract_From_Q;
+
+ ---------------
+ -- Gnatclean --
+ ---------------
+
+ procedure Gnatclean is
+ begin
+ -- Do the necessary initializations
+
+ Initialize;
+
+ -- Parse the command line, getting the switches and the executable names
+
+ Parse_Cmd_Line;
+
+ if Verbose_Mode then
+ Display_Copyright;
+ end if;
+
+ if Project_File_Name /= null then
+
+ -- A project file was specified by a -P switch
+
+ if Opt.Verbose_Mode then
+ New_Line;
+ Put ("Parsing Project File """);
+ Put (Project_File_Name.all);
+ Put_Line (""".");
+ New_Line;
+ end if;
+
+ -- Set the project parsing verbosity to whatever was specified
+ -- by a possible -vP switch.
+
+ Prj.Pars.Set_Verbosity (To => Prj.Com.Current_Verbosity);
+
+ -- Parse the project file.
+ -- If there is an error, Main_Project will still be No_Project.
+
+ Prj.Pars.Parse
+ (Project => Main_Project,
+ Project_File_Name => Project_File_Name.all,
+ Packages_To_Check => Packages_To_Check_By_Gnatmake);
+
+ if Main_Project = No_Project then
+ Fail ("""" & Project_File_Name.all &
+ """ processing failed");
+ end if;
+
+ if Opt.Verbose_Mode then
+ New_Line;
+ Put ("Parsing of Project File """);
+ Put (Project_File_Name.all);
+ Put (""" is finished.");
+ New_Line;
+ end if;
+
+ -- We add the source directories and the object directories
+ -- to the search paths.
+
+ Add_Source_Directories (Main_Project);
+ Add_Object_Directories (Main_Project);
+
+ end if;
+
+ Osint.Add_Default_Search_Dirs;
+
+ -- If a project file was specified, but no executable name, put all
+ -- the mains of the project file (if any) as if there were on the
+ -- command line.
+
+ if Main_Project /= No_Project and then Osint.Number_Of_Files = 0 then
+ declare
+ Value : String_List_Id := Projects.Table (Main_Project).Mains;
+
+ begin
+ while Value /= Prj.Nil_String loop
+ Get_Name_String (String_Elements.Table (Value).Value);
+ Osint.Add_File (Name_Buffer (1 .. Name_Len));
+ Value := String_Elements.Table (Value).Next;
+ end loop;
+ end;
+ end if;
+
+ -- If neither a project file nor an executable were specified,
+ -- output the usage and exit.
+
+ if Main_Project = No_Project and then Osint.Number_Of_Files = 0 then
+ Usage;
+ return;
+ end if;
+
+ if Verbose_Mode then
+ New_Line;
+ end if;
+
+ if Main_Project /= No_Project then
+
+ -- If a project file has been specified, call Clean_Project with the
+ -- project id of this project file, after resetting the list of
+ -- processed projects.
+
+ Processed_Projects.Init;
+ Clean_Project (Main_Project);
+
+ else
+ -- If no project file has been specified, the work is done in
+ -- Clean_Executables.
+
+ Clean_Executables;
+ end if;
+
+ -- In verbose mode, if Delete has not been called, indicate that
+ -- no file needs to be deleted.
+
+ if Verbose_Mode and (not File_Deleted) then
+ New_Line;
+
+ if Do_Nothing then
+ Put_Line ("No file needs to be deleted");
+ else
+ Put_Line ("No file has been deleted");
+ end if;
+ end if;
+ end Gnatclean;
+
+ ------------------------
+ -- In_Extension_Chain --
+ ------------------------
+
+ function In_Extension_Chain
+ (Of_Project : Project_Id;
+ Prj : Project_Id) return Boolean
+ is
+ Data : Project_Data;
+
+ begin
+ if Of_Project = Prj then
+ return True;
+ end if;
+
+ Data := Projects.Table (Of_Project);
+
+ while Data.Extends /= No_Project loop
+ if Data.Extends = Prj then
+ return True;
+ end if;
+
+ Data := Projects.Table (Data.Extends);
+ end loop;
+
+ Data := Projects.Table (Prj);
+
+ while Data.Extends /= No_Project loop
+ if Data.Extends = Of_Project then
+ return True;
+ end if;
+
+ Data := Projects.Table (Data.Extends);
+ end loop;
+
+ return False;
+ end In_Extension_Chain;
+
+ ------------
+ -- Init_Q --
+ ------------
+
+ procedure Init_Q is
+ begin
+ Q_Front := Q.First;
+ Q.Set_Last (Q.First);
+ end Init_Q;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ if not Initialized then
+ Initialized := True;
+
+ -- Initialize some packages
+
+ Csets.Initialize;
+ Namet.Initialize;
+ Snames.Initialize;
+ Prj.Initialize;
+ end if;
+
+ -- Reset global variables
+
+ Free (Object_Directory_Path);
+ Do_Nothing := False;
+ File_Deleted := False;
+ Copyright_Displayed := False;
+ Usage_Displayed := False;
+ Free (Project_File_Name);
+ Main_Project := Prj.No_Project;
+ All_Projects := False;
+ end Initialize;
+
+ --------------
+ -- Insert_Q --
+ --------------
+
+ procedure Insert_Q
+ (Source_File : File_Name_Type)
+ is
+ begin
+ -- Do not insert an empty name or an already marked source
+
+ if Source_File /= No_Name
+ and then Get_Name_Table_Byte (Source_File) = 0
+ then
+ Q.Table (Q.Last) := Source_File;
+ Q.Increment_Last;
+
+ -- Mark the source that has been just added to the Q
+
+ Set_Name_Table_Byte (Source_File, 1);
+ end if;
+ end Insert_Q;
+
+ ----------------------
+ -- Object_File_Name --
+ ----------------------
+
+ function Object_File_Name (Source : Name_Id) return String is
+ Src : constant String := Get_Name_String (Source);
+ begin
+ -- If the source name has an extension, then replace it with
+ -- the Object suffix.
+
+ for Index in reverse Src'First + 1 .. Src'Last loop
+ if Src (Index) = '.' then
+ return Src (Src'First .. Index - 1) & Object_Suffix;
+ end if;
+ end loop;
+
+ -- If there is no dot, or if it is the first character, just add the
+ -- ALI suffix.
+
+ return Src & Object_Suffix;
+ end Object_File_Name;
+
+ --------------------
+ -- Parse_Cmd_Line --
+ --------------------
+
+ procedure Parse_Cmd_Line is
+ begin
+ loop
+ case
+ GNAT.Command_Line.Getopt
+ ("aO: c D: F h I: I- n P: q r v vP0 vP1 vP2 X:")
+ is
+ when ASCII.NUL =>
+ exit;
+
+ when 'a' =>
+ Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
+
+ when 'c' =>
+ Compile_Only := True;
+
+ when 'D' =>
+ declare
+ Dir : constant String := GNAT.Command_Line.Parameter;
+
+ begin
+ if Object_Directory_Path /= null then
+ Fail ("duplicate -D switch");
+
+ elsif Project_File_Name /= null then
+ Fail ("-P and -D cannot be used simultaneously");
+
+ elsif not Is_Directory (Dir) then
+ Fail (Dir, " is not a directory");
+
+ else
+ Add_Lib_Search_Dir (Dir);
+ end if;
+ end;
+
+ when 'F' =>
+ Full_Path_Name_For_Brief_Errors := True;
+
+ when 'h' =>
+ Usage;
+
+ when 'I' =>
+ if Full_Switch = "I-" then
+ Opt.Look_In_Primary_Dir := False;
+
+ else
+ Add_Lib_Search_Dir (GNAT.Command_Line.Parameter);
+ end if;
+
+ when 'n' =>
+ Do_Nothing := True;
+
+ when 'P' =>
+ if Project_File_Name /= null then
+ Fail ("multiple -P switches");
+
+ elsif Object_Directory_Path /= null then
+ Fail ("-D and -P cannot be used simultaneously");
+
+ else
+ declare
+ Prj : constant String := GNAT.Command_Line.Parameter;
+ begin
+ if Prj'Length > 1 and then Prj (Prj'First) = '=' then
+ Project_File_Name :=
+ new String'(Prj (Prj'First + 1 .. Prj'Last));
+
+ else
+ Project_File_Name := new String'(Prj);
+ end if;
+ end;
+ end if;
+
+ when 'q' =>
+ Quiet_Output := True;
+
+ when 'r' =>
+ All_Projects := True;
+
+ when 'v' =>
+ if Full_Switch = "v" then
+ Verbose_Mode := True;
+
+ elsif Full_Switch = "vP0" then
+ Prj.Com.Current_Verbosity := Prj.Default;
+
+ elsif Full_Switch = "vP1" then
+ Prj.Com.Current_Verbosity := Prj.Medium;
+
+ else
+ Prj.Com.Current_Verbosity := Prj.High;
+ end if;
+
+ when 'X' =>
+ declare
+ Ext_Asgn : constant String := GNAT.Command_Line.Parameter;
+ Start : Positive := Ext_Asgn'First;
+ Stop : Natural := Ext_Asgn'Last;
+ Equal_Pos : Natural;
+ OK : Boolean := True;
+
+ begin
+ if Ext_Asgn (Start) = '"' then
+ if Ext_Asgn (Stop) = '"' then
+ Start := Start + 1;
+ Stop := Stop - 1;
+
+ else
+ OK := False;
+ end if;
+ end if;
+
+ Equal_Pos := Start;
+
+ while Equal_Pos <= Stop and then
+ Ext_Asgn (Equal_Pos) /= '='
+ loop
+ Equal_Pos := Equal_Pos + 1;
+ end loop;
+
+ if Equal_Pos = Start or else Equal_Pos > Stop then
+ OK := False;
+ end if;
+
+ if OK then
+ Prj.Ext.Add
+ (External_Name => Ext_Asgn (Start .. Equal_Pos - 1),
+ Value => Ext_Asgn (Equal_Pos + 1 .. Stop));
+
+ else
+ Fail ("illegal external assignment '", Ext_Asgn, "'");
+ end if;
+ end;
+
+ when others =>
+ Fail ("INTERNAL ERROR, please report");
+ end case;
+ end loop;
+
+ -- Get the file names
+
+ loop
+ declare
+ S : constant String := GNAT.Command_Line.Get_Argument;
+
+ begin
+ exit when S'Length = 0;
+
+ Add_File (S);
+ end;
+ end loop;
+
+ exception
+ when GNAT.Command_Line.Invalid_Switch =>
+ Usage;
+ Fail ("invalid switch : "& GNAT.Command_Line.Full_Switch);
+
+ when GNAT.Command_Line.Invalid_Parameter =>
+ Usage;
+ Fail ("parameter missing for : " & GNAT.Command_Line.Full_Switch);
+ end Parse_Cmd_Line;
+
+ -----------------------
+ -- Repinfo_File_Name --
+ -----------------------
+
+ function Repinfo_File_Name (Source : Name_Id) return String is
+ begin
+ return Get_Name_String (Source) & Repinfo_Suffix;
+ end Repinfo_File_Name;
+
+ --------------------
+ -- Tree_File_Name --
+ --------------------
+
+ function Tree_File_Name (Source : Name_Id) return String is
+ Src : constant String := Get_Name_String (Source);
+
+ begin
+ -- If the source name has an extension, then replace it with
+ -- the tree suffix.
+
+ for Index in reverse Src'First + 1 .. Src'Last loop
+ if Src (Index) = '.' then
+ return Src (Src'First .. Index - 1) & Tree_Suffix;
+ end if;
+ end loop;
+
+ -- If there is no dot, or if it is the first character, just add the
+ -- tree suffix.
+
+ return Src & Tree_Suffix;
+ end Tree_File_Name;
+
+ -----------
+ -- Usage --
+ -----------
+
+ procedure Usage is
+ begin
+ if not Usage_Displayed then
+ Usage_Displayed := True;
+ Display_Copyright;
+ Put_Line ("Usage: gnatclean [switches] names");
+ New_Line;
+
+ Put_Line (" names is one or more file names from which " &
+ "the .adb or .ads suffix may be omitted");
+ Put_Line (" names may be omitted if -P<project> is specified");
+ New_Line;
+
+ Put_Line (" -c Only delete compiler generated files");
+ Put_Line (" -D dir Specify dir as the object library");
+ Put_Line (" -F Full project path name " &
+ "in brief error messages");
+ Put_Line (" -h Display this message");
+ Put_Line (" -n Nothing to do: only list files to delete");
+ Put_Line (" -Pproj Use GNAT Project File proj");
+ Put_Line (" -q Be quiet/terse");
+ Put_Line (" -r Clean all projects recursively");
+ Put_Line (" -v Verbose mode");
+ Put_Line (" -vPx Specify verbosity when parsing " &
+ "GNAT Project Files");
+ Put_Line (" -Xnm=val Specify an external reference " &
+ "for GNAT Project Files");
+ New_Line;
+
+ Put_Line (" -aOdir Specify ALI/object files search path");
+ Put_Line (" -Idir Like -aOdir");
+ Put_Line (" -I- Don't look for source/library files " &
+ "in the default directory");
+ New_Line;
+ end if;
+ end Usage;
+
+begin
+ if Hostparm.OpenVMS then
+ Debug_Suffix (Debug_Suffix'First) := '_';
+ Repinfo_Suffix (Repinfo_Suffix'First) := '_';
+ B_Start (B_Start'Last) := '$';
+ end if;
+end Clean;
diff --git a/gcc/ada/s-explfl.ads b/gcc/ada/clean.ads
index 5ff8bbfc8af..39cfa4251a1 100644
--- a/gcc/ada/s-explfl.ads
+++ b/gcc/ada/clean.ads
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . E X P _ L F L T --
+-- C L E A N --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- Copyright (C) 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- --
@@ -19,26 +19,17 @@
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
--- Long_Float exponentiation (checks on)
-
-with System.Exp_Gen;
+-- This package contains the implementation of gnatclean.
+-- See gnatclean.adb
-package System.Exp_LFlt is
-pragma Pure (Exp_LFlt);
+package Clean is
- function Exp_Long_Float is
- new System.Exp_Gen.Exp_Float_Type (Long_Float);
+ procedure Gnatclean;
+ -- The driver for gnatclean
-end System.Exp_LFlt;
+end Clean;
diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb
index 284ed47d9c9..ecc0f855294 100644
--- a/gcc/ada/comperr.adb
+++ b/gcc/ada/comperr.adb
@@ -77,7 +77,14 @@ package body Comperr is
-- The procedures below output a "bug box" with information about
-- the cause of the compiler abort and about the preferred method
-- of reporting bugs. The default is a bug box appropriate for
- -- the FSF version of GNAT.
+ -- the FSF version of GNAT, but there are specializations for
+ -- the GNATPRO and Public releases by Ada Core Technologies.
+
+ Public_Version : constant Boolean := Gnat_Version_Type = "PUBLIC ";
+ -- Set True for the public version of GNAT
+
+ GNATPRO_Version : constant Boolean := Gnat_Version_Type = "GNATPRO";
+ -- Set True for the GNATPRO version of GNAT
procedure End_Line;
-- Add blanks up to column 76, and then a final vertical bar
@@ -257,10 +264,30 @@ package body Comperr is
-- Otherwise we use the standard fixed text
else
- Write_Str
- ("| Please submit a bug report; see" &
- " http://gcc.gnu.org/bugs.html.");
- End_Line;
+ if Public_Version or GNATPRO_Version then
+ Write_Str
+ ("| Please submit bug report by email " &
+ "to report@gnat.com.");
+ End_Line;
+
+ Write_Str
+ ("| Use a subject line meaningful to you" &
+ " and us to track the bug.");
+ End_Line;
+
+ else
+ Write_Str
+ ("| Please submit a bug report; see" &
+ " http://gcc.gnu.org/bugs.html.");
+ End_Line;
+ end if;
+
+ if GNATPRO_Version then
+ Write_Str
+ ("| (include your customer number #nnn " &
+ "in the subject line).");
+ End_Line;
+ end if;
Write_Str
("| Include the entire contents of this bug " &
@@ -280,6 +307,27 @@ package body Comperr is
("| (concatenated together with no headers between files).");
End_Line;
+ if Public_Version then
+ Write_Str
+ ("| (use plain ASCII or MIME attachment).");
+ End_Line;
+
+ Write_Str
+ ("| See gnatinfo.txt for full info on procedure " &
+ "for submitting bugs.");
+ End_Line;
+
+ elsif GNATPRO_Version then
+ Write_Str
+ ("| (use plain ASCII or MIME attachment, or FTP "
+ & "to your customer directory).");
+ End_Line;
+
+ Write_Str
+ ("| See README.GNATPRO for full info on procedure " &
+ "for submitting bugs.");
+ End_Line;
+ end if;
end if;
end;
diff --git a/gcc/ada/comperr.ads b/gcc/ada/comperr.ads
index ea4703ac42e..7db5927d888 100644
--- a/gcc/ada/comperr.ads
+++ b/gcc/ada/comperr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -54,24 +54,20 @@ package Comperr is
-- When comperr generates the "bug box". The first two lines contain
-- information on the version number, type of abort, and source location.
- -- Normally the remaining text is of the following form:
+ -- Normally the remaining text is one of three possible forms
+ -- depending on Gnatvsn.Gnat_Version_Type (FSF, Public, GNATPRO).
+ -- See body of this package for the exact text used.
- -- Please submit a bug report; see http://gcc.gnu.org/bugs.html.
- -- Include the entire contents of this bug box in the report.
- -- Include the exact gcc or gnatmake command that you entered.
- -- Also include sources listed below in gnatchop format
- -- concatenated together with no headers between files.
-
- -- However, an alternative mechanism exists for easily substituting
+ -- In addition, an alternative mechanism exists for easily substituting
-- different text for this message. Compiler_Abort checks for the
-- existence of the file "gnat_bug.box" in the current source path.
-- Most typically this file, if present, will be in the directory
-- containing the run-time sources.
-- If this file is present, then it is a plain ASCII file, whose
- -- contents replace the above quoted paragraphs. The lines in this
- -- file should be 72 characters or less to avoid misformatting the
- -- right boundary of the box. Note that the file does not contain
- -- the vertical bar characters or any leading spaces in lines.
+ -- contents replace the remaining text. The lines in this file should be
+ -- 72 characters or less to avoid misformatting the right boundary of the
+ -- box. Note that the file does not contain the vertical bar characters or
+ -- any leading spaces in lines.
end Comperr;
diff --git a/gcc/ada/csets.adb b/gcc/ada/csets.adb
index 4bd2ef733d4..319989b5b3b 100644
--- a/gcc/ada/csets.adb
+++ b/gcc/ada/csets.adb
@@ -170,7 +170,7 @@ package body Csets is
-- Definitions for Latin-1 (ISO 8859-1) --
------------------------------------------
- Fold_Latin_1 : Translate_Table := Translate_Table'(
+ Fold_Latin_1 : constant Translate_Table := Translate_Table'(
'a' => 'A', X_E0 => X_C0, X_F0 => X_D0,
'b' => 'B', X_E1 => X_C1, X_F1 => X_D1,
@@ -245,7 +245,7 @@ package body Csets is
-- Definitions for Latin-2 (ISO 8859-2) --
------------------------------------------
- Fold_Latin_2 : Translate_Table := Translate_Table'(
+ Fold_Latin_2 : constant Translate_Table := Translate_Table'(
'a' => 'A', X_E0 => X_C0, X_F0 => X_D0,
'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, X_B1 => X_A1,
@@ -320,7 +320,7 @@ package body Csets is
-- Definitions for Latin-3 (ISO 8859-3) --
------------------------------------------
- Fold_Latin_3 : Translate_Table := Translate_Table'(
+ Fold_Latin_3 : constant Translate_Table := Translate_Table'(
'a' => 'A', X_E0 => X_C0,
'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, X_B1 => X_A1,
@@ -395,7 +395,7 @@ package body Csets is
-- Definitions for Latin-4 (ISO 8859-4) --
------------------------------------------
- Fold_Latin_4 : Translate_Table := Translate_Table'(
+ Fold_Latin_4 : constant Translate_Table := Translate_Table'(
'a' => 'A', X_E0 => X_C0, X_F0 => X_D0,
'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, X_B1 => X_A1,
@@ -470,7 +470,7 @@ package body Csets is
-- Definitions for Latin-5 (Cyrillic ISO-8859-5) --
---------------------------------------------------
- Fold_Latin_5 : Translate_Table := Translate_Table'(
+ Fold_Latin_5 : constant Translate_Table := Translate_Table'(
'a' => 'A', X_D0 => X_B0, X_E0 => X_C0,
'b' => 'B', X_D1 => X_B1, X_E1 => X_C1, X_F1 => X_A1,
@@ -545,7 +545,7 @@ package body Csets is
-- Definitions for Latin-9 (ISO 8859-9) --
------------------------------------------
- Fold_Latin_9 : Translate_Table := Translate_Table'(
+ Fold_Latin_9 : constant Translate_Table := Translate_Table'(
'a' => 'A', X_E0 => X_C0, X_F0 => X_D0,
'b' => 'B', X_E1 => X_C1, X_F1 => X_D1,
@@ -624,7 +624,7 @@ package body Csets is
-- for PC's in the US, it corresponds to the original PC character set.
-- See also the definitions for code page 850.
- Fold_IBM_PC_437 : Translate_Table := Translate_Table'(
+ Fold_IBM_PC_437 : constant Translate_Table := Translate_Table'(
'a' => 'A',
'b' => 'B',
@@ -759,7 +759,7 @@ package body Csets is
-- set to include the additional characters defined in ISO Latin-1.
-- See also the definitions for code page 437.
- Fold_IBM_PC_850 : Translate_Table := Translate_Table'(
+ Fold_IBM_PC_850 : constant Translate_Table := Translate_Table'(
'a' => 'A',
'b' => 'B',
@@ -907,7 +907,7 @@ package body Csets is
-- The full upper half set allows all upper half characters as letters,
-- and does not recognize any upper/lower case equivalences in this half.
- Fold_Full_Upper_Half : Translate_Table := Translate_Table'(
+ Fold_Full_Upper_Half : constant Translate_Table := Translate_Table'(
'a' => 'A',
'b' => 'B',
@@ -1020,7 +1020,7 @@ package body Csets is
-- thus there are no upper/lower case equivalences in this half. This set
-- corresponds to the Ada 83 rules.
- Fold_No_Upper_Half : Translate_Table := Translate_Table'(
+ Fold_No_Upper_Half : constant Translate_Table := Translate_Table'(
'a' => 'A',
'b' => 'B',
diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb
index a3a5a327c8c..93b84a86f27 100644
--- a/gcc/ada/cstand.adb
+++ b/gcc/ada/cstand.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- --
@@ -33,6 +33,7 @@ with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Ttypef; use Ttypef;
@@ -667,13 +668,13 @@ package body CStand is
Set_Constant_Present (Decl, True);
declare
- A_Char : Entity_Id := Standard_Entity (S);
+ A_Char : constant Entity_Id := Standard_Entity (S);
Expr_Decl : Node_Id;
begin
Set_Sloc (A_Char, Staloc);
Set_Ekind (A_Char, E_Constant);
- Set_Not_Source_Assigned (A_Char, True);
+ Set_Never_Set_In_Source (A_Char, True);
Set_Is_True_Constant (A_Char, True);
Set_Etype (A_Char, Standard_Character);
Set_Scope (A_Char, Standard_Entity (S_ASCII));
@@ -716,7 +717,6 @@ package body CStand is
Standard_Void_Type := New_Standard_Entity;
Set_Ekind (Standard_Void_Type, E_Void);
Set_Etype (Standard_Void_Type, Standard_Void_Type);
- Init_Size_Align (Standard_Void_Type);
Set_Scope (Standard_Void_Type, Standard_Standard);
Make_Name (Standard_Void_Type, "_void_type");
@@ -900,14 +900,12 @@ package body CStand is
declare
Index : Node_Id;
- Indexes : List_Id;
begin
Index :=
Make_Range (Stloc,
Low_Bound => Make_Integer (Uint_0),
High_Bound => Make_Integer (Uint_2 ** Standard_Integer_Size));
- Indexes := New_List (Index);
Set_Etype (Index, Standard_Integer);
Set_First_Index (Any_String, Index);
end;
@@ -952,14 +950,15 @@ package body CStand is
Set_Prim_Alignment (Standard_Unsigned);
Set_Modulus (Standard_Unsigned,
Uint_2 ** Standard_Integer_Size);
-
Set_Is_Unsigned_Type (Standard_Unsigned);
+ Set_Size_Known_At_Compile_Time
+ (Standard_Unsigned);
R_Node := New_Node (N_Range, Stloc);
- Set_Low_Bound (R_Node,
- Make_Integer_Literal (Stloc, 0));
- Set_High_Bound (R_Node,
- Make_Integer_Literal (Stloc, Modulus (Standard_Unsigned)));
+ Set_Low_Bound (R_Node, Make_Integer (Uint_0));
+ Set_High_Bound (R_Node, Make_Integer (Modulus (Standard_Unsigned) - 1));
+ Set_Etype (Low_Bound (R_Node), Standard_Unsigned);
+ Set_Etype (High_Bound (R_Node), Standard_Unsigned);
Set_Scalar_Range (Standard_Unsigned, R_Node);
-- Note: universal integer and universal real are constructed as fully
@@ -1002,26 +1001,24 @@ package body CStand is
(Universal_Fixed);
-- Create type declaration for Duration, using a 64-bit size. The
- -- delta value depends on the mode we are running in:
-
- -- Normal mode or No_Run_Time mode when word size is 64 bits:
- -- 10**(-9) seconds, size is 64 bits
-
- -- No_Run_Time mode when word size is 32 bits:
- -- 10**(-4) seconds, oize is 32 bits
+ -- delta and size values depend on the mode set in system.ads.
Build_Duration : declare
Dlo : Uint;
Dhi : Uint;
Delta_Val : Ureal;
- Use_32_Bits : constant Boolean :=
- No_Run_Time and then System_Word_Size = 32;
begin
- if Use_32_Bits then
+ -- In 32 bit mode, the size is 32 bits, and the delta and
+ -- small values are set to 20 milliseconds (20.0**(10.0**(-3)).
+
+ if Duration_32_Bits_On_Target then
Dlo := Intval (Type_Low_Bound (Standard_Integer_32));
Dhi := Intval (Type_High_Bound (Standard_Integer_32));
- Delta_Val := UR_From_Components (Uint_1, Uint_4, 10);
+ Delta_Val := UR_From_Components (UI_From_Int (20), Uint_3, 10);
+
+ -- In standard 64-bit mode, the size is 64-bits and the delta and
+ -- amll values are set to nanoseconds (1.0**(10.0**(-9))
else
Dlo := Intval (Type_Low_Bound (Standard_Integer_64));
@@ -1045,7 +1042,7 @@ package body CStand is
Set_Ekind (Standard_Duration, E_Ordinary_Fixed_Point_Type);
Set_Etype (Standard_Duration, Standard_Duration);
- if Use_32_Bits then
+ if Duration_32_Bits_On_Target then
Init_Size (Standard_Duration, 32);
else
Init_Size (Standard_Duration, 64);
@@ -1087,7 +1084,7 @@ package body CStand is
Set_Ekind (Standard_Exception_Type, E_Record_Type);
Set_Etype (Standard_Exception_Type, Standard_Exception_Type);
Set_Scope (Standard_Exception_Type, Standard_Standard);
- Set_Girder_Constraint
+ Set_Stored_Constraint
(Standard_Exception_Type, No_Elist);
Init_Size_Align (Standard_Exception_Type);
Set_Size_Known_At_Compile_Time
@@ -1105,7 +1102,8 @@ package body CStand is
"HTable_Ptr");
Make_Component (Standard_Exception_Type, Standard_Integer,
"Import_Code");
-
+ Make_Component (Standard_Exception_Type, Standard_A_Char,
+ "Raise_Hook");
-- Build tree for record declaration, for use by the back-end.
declare
@@ -1138,6 +1136,8 @@ package body CStand is
Append (Decl, Decl_S);
+ Layout_Type (Standard_Exception_Type);
+
-- Create declarations of standard exceptions
Build_Exception (S_Constraint_Error);
@@ -1256,9 +1256,10 @@ package body CStand is
New_Ent : constant Entity_Id := New_Copy (E);
begin
- Set_Ekind (E, K);
- Set_Is_Constrained (E, True);
- Set_Etype (E, New_Ent);
+ Set_Ekind (E, K);
+ Set_Is_Constrained (E, True);
+ Set_Is_First_Subtype (E, True);
+ Set_Etype (E, New_Ent);
Append_Entity (New_Ent, Standard_Standard);
Set_Is_Constrained (New_Ent, False);
@@ -1294,7 +1295,7 @@ package body CStand is
Typ : Entity_Id;
Nam : String)
is
- Id : Entity_Id := New_Standard_Entity;
+ Id : constant Entity_Id := New_Standard_Entity;
begin
Set_Ekind (Id, E_Component);
diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c
index 281ad739a1f..0e85c09dba5 100644
--- a/gcc/ada/cstreams.c
+++ b/gcc/ada/cstreams.c
@@ -6,8 +6,7 @@
* *
* Auxiliary C functions for Interfaces.C.Streams *
* *
- * *
- * Copyright (C) 1992-2001 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- *
@@ -65,14 +64,16 @@
#ifdef stdout
# undef stdout
#endif
+
#endif
-/* The _IONBF value in CYGNUS or MINGW32 stdio.h is wrong. */
+/* The _IONBF value in MINGW32 stdio.h is wrong. */
#if defined (WINNT) || defined (_WINNT)
+#if OLD_MINGW
#undef _IONBF
#define _IONBF 0004
#endif
-
+#endif
int
__gnat_feof (stream)
@@ -189,19 +190,20 @@ __gnat_full_name (nam, buffer)
realpath (nam, buffer);
#elif defined (VMS)
- strcpy (buffer, __gnat_to_canonical_file_spec (nam));
+ strncpy (buffer, __gnat_to_canonical_file_spec (nam), __gnat_max_path_len);
- if (buffer[0] == '/')
- strcpy (buffer, __gnat_to_host_file_spec (buffer));
+ if (buffer[0] == '/' || strchr (buffer, '!')) /* '!' means decnet node */
+ strncpy (buffer, __gnat_to_host_file_spec (buffer), __gnat_max_path_len);
else
{
char *nambuffer = alloca (__gnat_max_path_len);
- strcpy (nambuffer, buffer);
- strcpy (buffer, getcwd (buffer, __gnat_max_path_len, 0));
- strcat (buffer, "/");
- strcat (buffer, nambuffer);
- strcpy (buffer, __gnat_to_host_file_spec (buffer));
+ strncpy (nambuffer, buffer, __gnat_max_path_len);
+ strncpy
+ (buffer, getcwd (buffer, __gnat_max_path_len, 0), __gnat_max_path_len);
+ strncat (buffer, "/", __gnat_max_path_len);
+ strncat (buffer, nambuffer, __gnat_max_path_len);
+ strncpy (buffer, __gnat_to_host_file_spec (buffer), __gnat_max_path_len);
}
return buffer;
diff --git a/gcc/ada/ctrl_c.c b/gcc/ada/ctrl_c.c
new file mode 100644
index 00000000000..7d7eef043e4
--- /dev/null
+++ b/gcc/ada/ctrl_c.c
@@ -0,0 +1,158 @@
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * C T R L _ C *
+ * *
+ * C Implementation File *
+ * *
+ * Copyright (C) 2002-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- *
+ * ware Foundation; either version 2, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * As a special exception, if you link this file with other files to *
+ * produce an executable, this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not however invalidate any other reasons why the executable *
+ * file might be covered by the GNU Public License. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * Extensive contributions were provided by Ada Core Technologies Inc. *
+ * *
+ ****************************************************************************/
+
+#ifdef IN_RTS
+#include "tconfig.h"
+#include "tsystem.h"
+#include <sys/stat.h>
+#else
+#include "config.h"
+#include "system.h"
+#endif
+
+/* Services to intercept Ctrl-C */
+
+/* __gnat_install_int_handler will install the specified handler.
+ If called for the first time, it will also save the original handler */
+void __gnat_install_int_handler (void (*) (void));
+
+/* __gnat_uninstall_int_handler will reinstall the original handler */
+void __gnat_uninstall_int_handler (void);
+
+static void __gnat_int_handler (int);
+
+/* POSIX implementation */
+
+#if (defined (_AIX) || defined (unix)) && !defined (__vxworks)
+
+#include <signal.h>
+
+void (*sigint_intercepted) (void) = 0;
+
+struct sigaction original_act;
+
+static void
+__gnat_int_handler (int sig __attribute__ ((unused)))
+{
+ if (sigint_intercepted != 0)
+ sigint_intercepted ();
+}
+
+/* Install handler and save original handler. */
+
+void
+__gnat_install_int_handler (void (*proc) (void))
+{
+ struct sigaction act;
+
+ if (sigint_intercepted == 0)
+ {
+ act.sa_handler = __gnat_int_handler;
+ act.sa_flags = SA_RESTART;
+ sigemptyset (&act.sa_mask);
+ sigaction (SIGINT, &act, &original_act);
+ }
+
+ sigint_intercepted = proc;
+}
+
+/* Restore original handler */
+
+void
+__gnat_uninstall_int_handler (void)
+{
+ if (sigint_intercepted != 0)
+ {
+ sigaction (SIGINT, &original_act, 0);
+ sigint_intercepted = 0;
+ }
+}
+
+/* Windows implementation */
+
+#elif defined (__MINGW32__)
+
+#include "mingw32.h"
+#include <windows.h>
+
+void (*sigint_intercepted) () = NULL;
+
+static BOOL WINAPI
+__gnat_int_handler (DWORD dwCtrlType)
+{
+ switch (dwCtrlType)
+ {
+ case CTRL_C_EVENT:
+ case CTRL_BREAK_EVENT:
+ if (sigint_intercepted != 0)
+ sigint_intercepted ();
+ break;
+
+ case CTRL_CLOSE_EVENT:
+ case CTRL_LOGOFF_EVENT:
+ case CTRL_SHUTDOWN_EVENT:
+ break;
+ }
+}
+
+void
+__gnat_install_int_handler (void (*proc) (void))
+{
+ if (sigint_intercepted == NULL)
+ SetConsoleCtrlHandler (__gnat_int_handler, TRUE);
+
+ sigint_intercepted = proc;
+}
+
+void
+__gnat_uninstall_int_handler ()
+{
+ if (sigint_intercepted != NULL)
+ SetConsoleCtrlHandler (__gnat_int_handler, FALSE);
+
+ sigint_intercepted = NULL;
+}
+
+/* Default implementation: do nothing */
+
+#else
+
+void
+__gnat_install_int_handler (void (*proc) (void) __attribute__ ((unused)))
+{
+}
+
+void
+__gnat_uninstall_int_handler ()
+{
+}
+#endif
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index e2040d2e4f1..09ec0dccd49 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.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- --
@@ -37,7 +37,7 @@ package body Debug is
-- Summary of Debug Flag Usage --
---------------------------------
- -- Debug flags for compiler (GNAT1 and GNATF)
+ -- Debug flags for compiler (GNAT1)
-- da Generate messages tracking semantic analyzer progress
-- db Show encoding of type names for debug output
@@ -68,18 +68,18 @@ package body Debug is
-- dA All entities included in representation information output
-- dB Output debug encoding of type names and variants
- -- dC
+ -- dC Output debugging information on check suppression
-- dD Delete elaboration checks in inner level routines
-- dE Apply elaboration checks to predefined units
-- dF Front end data layout enabled.
- -- dG
+ -- dG Generate all warnings including those normally suppressed
-- dH Hold (kill) call to gigi
-- dI Inhibit internal name numbering in gnatG listing
-- dJ Output debugging trace info for JGNAT (Java VM version of GNAT)
-- dK Kill all error messages
-- dL Output trace information on elaboration checking
- -- dM
- -- dN Do not generate file/line exception messages
+ -- dM Asssume all variables are modified (no current values)
+ -- dN No file name information in exception messages
-- dO Output immediate error messages
-- dP Do not check for controlled objects in preelaborable packages
-- dQ
@@ -88,11 +88,40 @@ package body Debug is
-- dT Convert to machine numbers only for constant declarations
-- dU Enable garbage collection of unreachable entities
-- dV Enable viewing of all symbols in debugger
- -- dW
+ -- dW Disable warnings on calls for IN OUT parameters
-- dX Enable Frontend ZCX even when it is not supported
- -- dY
+ -- dY Enable configurable run-time mode
-- dZ
+ -- d.a
+ -- d.b
+ -- d.c
+ -- d.d
+ -- d.e
+ -- d.f
+ -- d.g
+ -- d.h
+ -- d.i
+ -- d.j
+ -- d.k
+ -- d.l
+ -- d.m
+ -- d.n
+ -- d.o
+ -- d.p
+ -- d.q
+ -- d.r
+ -- d.s
+ -- d.t
+ -- d.u
+ -- d.v
+ -- d.w
+ -- d.x No exception handlers
+ -- d.y
+ -- d.z
+
+
+
-- d1 Error msgs have node numbers where possible
-- d2 Eliminate error flags in verbose form error messages
-- d3 Dump bad node in Comperr on an abort
@@ -128,7 +157,7 @@ package body Debug is
-- du List units as they are acquired
-- dv
-- dw
- -- dx
+ -- dx Force binder to read xref information from ali files
-- dy
-- dz
@@ -157,13 +186,13 @@ package body Debug is
-- dk
-- dl
-- dm
- -- dn
+ -- dn Do not delete temp files created by gnatmake
-- do
-- dp Prints the contents of the Q used by Make.Compile_Sources
-- dq Prints source files as they are enqueued and dequeued
-- dr
-- ds
- -- dt
+ -- dt Display time stamps when there is a mismatch
-- du List units as their ali files are acquired
-- dv
-- dw Prints the list of units withed by the unit currently explored
@@ -190,10 +219,6 @@ package body Debug is
-- resolved, or evaluated. This option is useful for finding out
-- exactly where a bomb during semantic analysis is occurring.
- -- dA Normally the output from -gnatR excludes private types and all
- -- internal entities. This debug flag causes representation info
- -- for these entities to be output as well.
-
-- db In Exp_Dbug, certain type names are encoded to include debugging
-- information. This debug switch causes lines to be output showing
-- the encodings used.
@@ -205,21 +230,6 @@ package body Debug is
-- dd Dynamic allocation of tables messages generated. Each time a
-- table is reallocated, a line is output indicating the expansion.
- -- dD Delete new elaboration checks. This flag causes GNAT to return
- -- to the 3.13a elaboration semantics, and to suppress the fixing
- -- of two bugs. The first is in the context of inner routines in
- -- dynamic elaboration mode, when the subprogram we are in was
- -- called at elaboration time by a unit that was also compiled with
- -- dynamic elaboration checks. In this case, if A calls B calls C,
- -- and all are in different units, we need an elaboration check at
- -- each call. These nested checks were only put in recently (see
- -- version 1.80 of Sem_Elab) and we provide this debug flag to
- -- revert to the previous behavior in case of regressions. The
- -- other behavior reverted by this flag is the treatment of the
- -- Elaborate_Body pragma in static elaboration mode. This used to
- -- be treated as not needing elaboration checking, but in fact in
- -- general Elaborate_All is still required because of nested calls.
-
-- de List the entity table
-- df Full tree/source print (includes withed units). Normally the tree
@@ -229,10 +239,6 @@ package body Debug is
-- be effective, this swich must be used in combination with one or
-- more of dt, dg, do or ds.
- -- dF Front end data layout enabled. Normally front end data layout
- -- is only enabled if the target parameter Backend_Layout is False.
- -- This debugging switch enables it unconditionally.
-
-- dg Print the source recreated from the generated tree. In the case
-- where the tree has been rewritten this output includes only the
-- generated code, not the original code (see also df,do,ds,dz).
@@ -245,10 +251,6 @@ package body Debug is
-- in ensuring that the hashing algorithm (in Namet.Hash) is working
-- effectively with typical sets of program identifiers.
- -- dH Inhibit call to gigi. This is useful for testing front end data
- -- layout, and may be useful in other debugging situations where
- -- you do not want gigi to intefere with the testing.
-
-- di Generate messages for visibility linking/delinking
-- dj Suppress "junk null check" for access parameters. This flag permits
@@ -257,20 +259,11 @@ package body Debug is
-- Neither of these is valid Ada, but both were allowed in versions of
-- GNAT before 3.10, so this switch can ease the transition process.
- -- dJ Generate debugging trace output for the JGNAT back end. This
- -- consists of symbolic Java Byte Code sequences for all generated
- -- classes plus additional information to indicate local variables
- -- and methods.
-
-- dk Immediate kill on abort. Normally on an abort (i.e. a call to
-- Comperr.Compiler_Abort), the GNATBUG message is not given if
-- there is a previous error. This debug switch bypasses this test
-- and gives the message unconditionally (useful for debugging).
- -- dK Kill all error messages. This debug flag suppresses the output
- -- of all error messages. It is used in regression tests where the
- -- error messages are target dependent and irrelevant.
-
-- dl Generate unit load trace messages. A line of traceback output is
-- generated each time a request is made to the library manager to
-- load a new unit.
@@ -289,10 +282,6 @@ package body Debug is
-- generated. This option is useful in seeing where the parser is
-- blowing up.;
- -- dN Do not generate file/line exception messages. Normally we do the
- -- explicit generation of these messages, but since these can only
- -- be disabled using pragma Discard_Names, this switch may be useful.
-
-- do Print the source recreated from the generated tree. In the case
-- where the tree has been rewritten, this output includes only the
-- original code, not the generated code (see also df,dg,ds,dz).
@@ -327,6 +316,10 @@ package body Debug is
-- for adding temporary debugging code to units that have pragmas
-- that are inconsistent with the debugging code added.
+ -- dv Output trace of overload resolution. Outputs messages for
+ -- overload attempts that involve cascaded errors, or where
+ -- an interepretation is incompatible with the context.
+
-- dw Write semantic scope stack messages. Each time a scope is created
-- or removed, a message is output (see the Sem_Ch8.New_Scope and
-- Sem_Ch8.Pop_Scope subprograms).
@@ -349,26 +342,75 @@ package body Debug is
-- dA Forces output of representation information, including full
-- information for all internal type and object entities, as well
- -- as all user defined type and object entities.
+ -- as all user defined type and object entities including private
+ -- and incomplete types.
-- dB Output debug encodings for types and variants. See Exp_Dbug for
-- exact form of the generated output.
+ -- dC Output trace information showing the decisions made during
+ -- check suppression activity in unit Checks.
+
+ -- dD Delete new elaboration checks. This flag causes GNAT to return
+ -- to the 3.13a elaboration semantics, and to suppress the fixing
+ -- of two bugs. The first is in the context of inner routines in
+ -- dynamic elaboration mode, when the subprogram we are in was
+ -- called at elaboration time by a unit that was also compiled with
+ -- dynamic elaboration checks. In this case, if A calls B calls C,
+ -- and all are in different units, we need an elaboration check at
+ -- each call. These nested checks were only put in recently (see
+ -- version 1.80 of Sem_Elab) and we provide this debug flag to
+ -- revert to the previous behavior in case of regressions. The
+ -- other behavior reverted by this flag is the treatment of the
+ -- Elaborate_Body pragma in static elaboration mode. This used to
+ -- be treated as not needing elaboration checking, but in fact in
+ -- general Elaborate_All is still required because of nested calls.
+
-- dE Apply compile time elaboration checking for with relations between
-- predefined units. Normally no checks are made (it seems that at
-- least on the SGI, such checks run into trouble).
+ -- dF Front end data layout enabled. Normally front end data layout
+ -- is only enabled if the target parameter Backend_Layout is False.
+ -- This debugging switch enables it unconditionally.
+
+ -- dG Generate all warnings. Normally Errout suppresses warnings on
+ -- units that are not part of the main extended source, and also
+ -- suppresses warnings on instantiations in the main extended
+ -- source that duplicate warnings already posted on the template.
+ -- This switch stops both kinds of deletion and causes Errout to
+ -- post all warnings sent to it.
+
+ -- dH Inhibit call to gigi. This is useful for testing front end data
+ -- layout, and may be useful in other debugging situations where
+ -- you do not want gigi to intefere with the testing.
+
-- dI Inhibit internal name numbering in gnatDG listing. For internal
-- names of the form <uppercase-letters><digits><suffix>, the output
-- will be modified to <uppercase-letters>...<suffix>. This is used
-- in the fixed bugs run to minimize system and version dependency
-- in filed -gnatDG output.
+ -- dJ Generate debugging trace output for the JGNAT back end. This
+ -- consists of symbolic Java Byte Code sequences for all generated
+ -- classes plus additional information to indicate local variables
+ -- and methods.
+
+ -- dK Kill all error messages. This debug flag suppresses the output
+ -- of all error messages. It is used in regression tests where the
+ -- error messages are target dependent and irrelevant.
+
-- dL Output trace information on elaboration checking. This debug
-- switch causes output to be generated showing each call or
-- instantiation as it is checked, and the progress of the recursive
-- trace through calls at elaboration time.
+ -- dM Assume all variables have been modified, and ignore current value
+ -- indications. This debug flag disconnects the tracking of constant
+ -- values (see Exp_Ch2.Expand_Current_Value).
+
+ -- dN Do not generate file name information in exception messages.
+
-- dO Output immediate error messages. This causes error messages to
-- be output as soon as they are generated (disconnecting several
-- circuits for improvement of messages, deletion of duplicate
@@ -403,7 +445,16 @@ package body Debug is
-- be enabled without generating modified source files. Note that the
-- use of -gnatdV ensures in the dwarf/elf case that all symbols that
-- are present in the elf tables are also in the dwarf tables (which
- -- seems to be required by some tools).
+ -- seems to be required by some tools). Another effect of dV is to
+ -- generate full qualified names, including internal names generated
+ -- for blocks and loops.
+
+ -- dW Disable warnings when a possibly uninitialized scalar value is
+ -- passed to an IN OUT parameter of a procedure. This usage is a
+ -- quite improper bounded error [erroneous in Ada 83] situation,
+ -- and would normally generate a warning. However, to ease the
+ -- task of transitioning incorrect legacy code, we provide this
+ -- undocumented feature for suppressing these warnings.
-- dX Enable frontend ZCX even when it is not supported. Equivalent to
-- -gnatZ but without verifying that System.Front_End_ZCX_Support
@@ -412,7 +463,17 @@ package body Debug is
-- is used for testing the front end for correct ZCX operation, and
-- in particular is useful for multi-target testing.
- -- d1 Error msgs have node numbers where possible. Normally error
+ -- dY Enable configurable run-time mode, just as though the System file
+ -- had Configurable_Run_Time_Mode set to True. This is useful in
+ -- testing high integrity mode.
+
+ -- d.x No exception handlers in generated code. This causes exception
+ -- handles to be eliminated from the generated code. They are still
+ -- fully compiled and analyzed, they just get eliminated from the
+ -- code generation step.
+
+
+ -- d1 Error messages have node numbers where possible. Normally error
-- messages have only source locations. This option is useful when
-- debugging errors caused by expanded code, where the source location
-- does not give enough information.
@@ -421,7 +482,10 @@ package body Debug is
-- messages. The messages are still interspersed in the listing, but
-- without any error flags or extra blank lines. Also causes an extra
-- <<< to be output at the right margin. This is intended to be the
- -- easiest format for checking conformance of ACVC B tests.
+ -- easiest format for checking conformance of ACATS B tests. This
+ -- flag also suppresses the additional messages explaining why a
+ -- non-static expression is non-static (see Sem_Eval.Why_Not_Static).
+ -- This avoids having to worry about these messages in ACATS testing.
-- d3 Causes Comperr to dump the contents of the node for which an abort
-- was detected (normally only the Node_Id of the node is output).
@@ -432,6 +496,9 @@ package body Debug is
-- of the prefixes Ada, System, and Interfaces. Setting this debug
-- switch disables this special treatment.
+ -- d5 Causes the tree read/write circuit to output detailed information
+ -- tracking the data that is read and written element by element.
+
-- d6 Normally access-to-unconstrained-array types are represented
-- using fat (double) pointers. Using this debug flag causes them
-- to default to thin. This can be used to test the performance
@@ -465,6 +532,9 @@ package body Debug is
-- du List unit name and file name for each unit as it is read in
+ -- dx Force the binder to read (and then ignore) the xref information
+ -- in ali files (used to check that read circuit is working OK).
+
------------------------------------------------------------
-- Documentation for the Debug Flags used in package Make --
------------------------------------------------------------
@@ -472,6 +542,10 @@ package body Debug is
-- Please note that such flags apply to all of Make clients,
-- such as gnatmake.
+ -- dn Do not delete temporary files creates by Make at the end
+ -- of execution, such as temporary config pragma files, mapping
+ -- files or project path files.
+
-- dp Prints the Q used by routine Make.Compile_Sources every time
-- we go around the main compile loop of Make.Compile_Sources
@@ -479,6 +553,12 @@ package body Debug is
-- used by routine Make.Compile_Sources. Useful to figure out the
-- order in which sources are recompiled.
+ -- dt When a time stamp mismatch has been found for an ALI file,
+ -- display the source file name, the time stamp expected and
+ -- the time stamp found.
+
+ -- du List unit name and file name for each unit as it is read in
+
-- dw Prints the list of units withed by the unit currently explored
-- during the main loop of Make.Compile_Sources.
@@ -576,4 +656,89 @@ package body Debug is
end if;
end Set_Debug_Flag;
+ ---------------------------
+ -- Set_Dotted_Debug_Flag --
+ ---------------------------
+
+ procedure Set_Dotted_Debug_Flag (C : Character; Val : Boolean := True) is
+ subtype Dig is Character range '1' .. '9';
+ subtype LLet is Character range 'a' .. 'z';
+ subtype ULet is Character range 'A' .. 'Z';
+
+ begin
+ if C in Dig then
+ case Dig (C) is
+ when '1' => Debug_Flag_Dot_1 := Val;
+ when '2' => Debug_Flag_Dot_2 := Val;
+ when '3' => Debug_Flag_Dot_3 := Val;
+ when '4' => Debug_Flag_Dot_4 := Val;
+ when '5' => Debug_Flag_Dot_5 := Val;
+ when '6' => Debug_Flag_Dot_6 := Val;
+ when '7' => Debug_Flag_Dot_7 := Val;
+ when '8' => Debug_Flag_Dot_8 := Val;
+ when '9' => Debug_Flag_Dot_9 := Val;
+ end case;
+
+ elsif C in ULet then
+ case ULet (C) is
+ when 'A' => Debug_Flag_Dot_AA := Val;
+ when 'B' => Debug_Flag_Dot_BB := Val;
+ when 'C' => Debug_Flag_Dot_CC := Val;
+ when 'D' => Debug_Flag_Dot_DD := Val;
+ when 'E' => Debug_Flag_Dot_EE := Val;
+ when 'F' => Debug_Flag_Dot_FF := Val;
+ when 'G' => Debug_Flag_Dot_GG := Val;
+ when 'H' => Debug_Flag_Dot_HH := Val;
+ when 'I' => Debug_Flag_Dot_II := Val;
+ when 'J' => Debug_Flag_Dot_JJ := Val;
+ when 'K' => Debug_Flag_Dot_KK := Val;
+ when 'L' => Debug_Flag_Dot_LL := Val;
+ when 'M' => Debug_Flag_Dot_MM := Val;
+ when 'N' => Debug_Flag_Dot_NN := Val;
+ when 'O' => Debug_Flag_Dot_OO := Val;
+ when 'P' => Debug_Flag_Dot_PP := Val;
+ when 'Q' => Debug_Flag_Dot_QQ := Val;
+ when 'R' => Debug_Flag_Dot_RR := Val;
+ when 'S' => Debug_Flag_Dot_SS := Val;
+ when 'T' => Debug_Flag_Dot_TT := Val;
+ when 'U' => Debug_Flag_Dot_UU := Val;
+ when 'V' => Debug_Flag_Dot_VV := Val;
+ when 'W' => Debug_Flag_Dot_WW := Val;
+ when 'X' => Debug_Flag_Dot_XX := Val;
+ when 'Y' => Debug_Flag_Dot_YY := Val;
+ when 'Z' => Debug_Flag_Dot_ZZ := Val;
+ end case;
+
+ else
+ case LLet (C) is
+ when 'a' => Debug_Flag_Dot_A := Val;
+ when 'b' => Debug_Flag_Dot_B := Val;
+ when 'c' => Debug_Flag_Dot_C := Val;
+ when 'd' => Debug_Flag_Dot_D := Val;
+ when 'e' => Debug_Flag_Dot_E := Val;
+ when 'f' => Debug_Flag_Dot_F := Val;
+ when 'g' => Debug_Flag_Dot_G := Val;
+ when 'h' => Debug_Flag_Dot_H := Val;
+ when 'i' => Debug_Flag_Dot_I := Val;
+ when 'j' => Debug_Flag_Dot_J := Val;
+ when 'k' => Debug_Flag_Dot_K := Val;
+ when 'l' => Debug_Flag_Dot_L := Val;
+ when 'm' => Debug_Flag_Dot_M := Val;
+ when 'n' => Debug_Flag_Dot_N := Val;
+ when 'o' => Debug_Flag_Dot_O := Val;
+ when 'p' => Debug_Flag_Dot_P := Val;
+ when 'q' => Debug_Flag_Dot_Q := Val;
+ when 'r' => Debug_Flag_Dot_R := Val;
+ when 's' => Debug_Flag_Dot_S := Val;
+ when 't' => Debug_Flag_Dot_T := Val;
+ when 'u' => Debug_Flag_Dot_U := Val;
+ when 'v' => Debug_Flag_Dot_V := Val;
+ when 'w' => Debug_Flag_Dot_W := Val;
+ when 'x' => Debug_Flag_Dot_X := Val;
+ when 'y' => Debug_Flag_Dot_Y := Val;
+ when 'z' => Debug_Flag_Dot_Z := Val;
+ end case;
+ end if;
+ end Set_Dotted_Debug_Flag;
+
end Debug;
diff --git a/gcc/ada/debug.ads b/gcc/ada/debug.ads
index feb5d5a19d0..4019a1774d2 100644
--- a/gcc/ada/debug.ads
+++ b/gcc/ada/debug.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -115,6 +115,70 @@ pragma Preelaborate (Debug);
Debug_Flag_8 : Boolean := False;
Debug_Flag_9 : Boolean := False;
+ Debug_Flag_Dot_A : Boolean := False;
+ Debug_Flag_Dot_B : Boolean := False;
+ Debug_Flag_Dot_C : Boolean := False;
+ Debug_Flag_Dot_D : Boolean := False;
+ Debug_Flag_Dot_E : Boolean := False;
+ Debug_Flag_Dot_F : Boolean := False;
+ Debug_Flag_Dot_G : Boolean := False;
+ Debug_Flag_Dot_H : Boolean := False;
+ Debug_Flag_Dot_I : Boolean := False;
+ Debug_Flag_Dot_J : Boolean := False;
+ Debug_Flag_Dot_K : Boolean := False;
+ Debug_Flag_Dot_L : Boolean := False;
+ Debug_Flag_Dot_M : Boolean := False;
+ Debug_Flag_Dot_N : Boolean := False;
+ Debug_Flag_Dot_O : Boolean := False;
+ Debug_Flag_Dot_P : Boolean := False;
+ Debug_Flag_Dot_Q : Boolean := False;
+ Debug_Flag_Dot_R : Boolean := False;
+ Debug_Flag_Dot_S : Boolean := False;
+ Debug_Flag_Dot_T : Boolean := False;
+ Debug_Flag_Dot_U : Boolean := False;
+ Debug_Flag_Dot_V : Boolean := False;
+ Debug_Flag_Dot_W : Boolean := False;
+ Debug_Flag_Dot_X : Boolean := False;
+ Debug_Flag_Dot_Y : Boolean := False;
+ Debug_Flag_Dot_Z : Boolean := False;
+
+ Debug_Flag_Dot_AA : Boolean := False;
+ Debug_Flag_Dot_BB : Boolean := False;
+ Debug_Flag_Dot_CC : Boolean := False;
+ Debug_Flag_Dot_DD : Boolean := False;
+ Debug_Flag_Dot_EE : Boolean := False;
+ Debug_Flag_Dot_FF : Boolean := False;
+ Debug_Flag_Dot_GG : Boolean := False;
+ Debug_Flag_Dot_HH : Boolean := False;
+ Debug_Flag_Dot_II : Boolean := False;
+ Debug_Flag_Dot_JJ : Boolean := False;
+ Debug_Flag_Dot_KK : Boolean := False;
+ Debug_Flag_Dot_LL : Boolean := False;
+ Debug_Flag_Dot_MM : Boolean := False;
+ Debug_Flag_Dot_NN : Boolean := False;
+ Debug_Flag_Dot_OO : Boolean := False;
+ Debug_Flag_Dot_PP : Boolean := False;
+ Debug_Flag_Dot_QQ : Boolean := False;
+ Debug_Flag_Dot_RR : Boolean := False;
+ Debug_Flag_Dot_SS : Boolean := False;
+ Debug_Flag_Dot_TT : Boolean := False;
+ Debug_Flag_Dot_UU : Boolean := False;
+ Debug_Flag_Dot_VV : Boolean := False;
+ Debug_Flag_Dot_WW : Boolean := False;
+ Debug_Flag_Dot_XX : Boolean := False;
+ Debug_Flag_Dot_YY : Boolean := False;
+ Debug_Flag_Dot_ZZ : Boolean := False;
+
+ Debug_Flag_Dot_1 : Boolean := False;
+ Debug_Flag_Dot_2 : Boolean := False;
+ Debug_Flag_Dot_3 : Boolean := False;
+ Debug_Flag_Dot_4 : Boolean := False;
+ Debug_Flag_Dot_5 : Boolean := False;
+ Debug_Flag_Dot_6 : Boolean := False;
+ Debug_Flag_Dot_7 : Boolean := False;
+ Debug_Flag_Dot_8 : Boolean := False;
+ Debug_Flag_Dot_9 : Boolean := False;
+
function Get_Debug_Flag_K return Boolean;
-- This function is called from C code to get the setting of the K flag
-- (it does not work to try to access a constant object directly).
@@ -124,4 +188,8 @@ pragma Preelaborate (Debug);
-- the given value. In the checks off version of debug, the call to
-- Set_Debug_Flag is always a null operation.
+ procedure Set_Dotted_Debug_Flag (C : Character; Val : Boolean := True);
+ -- Where C is 0-9, A-Z, or a-z, sets the corresponding dotted debug
+ -- flag (e.g. call with C = 'a' for the .a flag).
+
end Debug;
diff --git a/gcc/ada/debug_a.adb b/gcc/ada/debug_a.adb
index c066314b04d..0d1a8cffbf2 100644
--- a/gcc/ada/debug_a.adb
+++ b/gcc/ada/debug_a.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -60,6 +60,8 @@ package body Debug_A is
procedure Debug_A_Entry (S : String; N : Node_Id) is
begin
+ -- Output debugging information if -gnatda flag set
+
if Debug_Flag_A then
Debug_Output_Astring;
Write_Str (S);
@@ -72,12 +74,21 @@ package body Debug_A is
Write_Eol;
end if;
+ -- Now push the new element
+
Debug_A_Depth := Debug_A_Depth + 1;
- Current_Error_Node := N;
if Debug_A_Depth <= Max_Node_Ids then
Node_Ids (Debug_A_Depth) := N;
end if;
+
+ -- Set Current_Error_Node only if the new node has a decent Sloc
+ -- value, since it is for the Sloc value that we set this anyway.
+ -- If we don't have a decent Sloc value, we leave it unchanged.
+
+ if Sloc (N) > No_Location then
+ Current_Error_Node := N;
+ end if;
end Debug_A_Entry;
------------------
@@ -88,9 +99,17 @@ package body Debug_A is
begin
Debug_A_Depth := Debug_A_Depth - 1;
- if Debug_A_Depth in 1 .. Max_Node_Ids then
- Current_Error_Node := Node_Ids (Debug_A_Depth);
- end if;
+ -- We look down the stack to find something with a decent Sloc. (If
+ -- we find nothing, just leave it unchanged which is not so terrible)
+
+ for J in reverse 1 .. Integer'Min (Max_Node_Ids, Debug_A_Depth) loop
+ if Sloc (Node_Ids (J)) > No_Location then
+ Current_Error_Node := Node_Ids (J);
+ exit;
+ end if;
+ end loop;
+
+ -- Output debugging information if -gnatda flag set
if Debug_Flag_A then
Debug_Output_Astring;
@@ -107,7 +126,7 @@ package body Debug_A is
--------------------------
procedure Debug_Output_Astring is
- Vbars : String := "|||||||||||||||||||||||||";
+ Vbars : constant String := "|||||||||||||||||||||||||";
-- Should be constant, removed because of GNAT 1.78 bug ???
begin
diff --git a/gcc/ada/debug_a.ads b/gcc/ada/debug_a.ads
index c0fa7e51ce6..c805a438259 100644
--- a/gcc/ada/debug_a.ads
+++ b/gcc/ada/debug_a.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -36,7 +36,7 @@ package Debug_A is
-- an exit call matching each entry call. This means that they can keep
-- track of the current node being worked on, with the entry call setting
-- a new value, by pushing the Node_Id value on a stack, and the exit call
- -- popping this value off. Comperr.Current_Error_Node is set by both the
+ -- popping this value off. Atree.Current_Error_Node is set by both the
-- entry and exit routines to point to the current node so that an abort
-- message indicates the node involved as accurately as possible.
@@ -48,7 +48,7 @@ package Debug_A is
-- (analyzing, expanding etc), followed by the node number and its kind.
-- This output is generated only if the debug A flag is set. If the debug
-- A flag is not set, then no output is generated. This call also sets the
- -- Node_Id value in Comperr.Current_Error_Node in case a bomb occurs. This
+ -- Node_Id value in Atree.Current_Error_Node in case a bomb occurs. This
-- is done unconditionally, whether or not the debug A flag is set.
procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String);
@@ -58,7 +58,7 @@ package Debug_A is
-- a trailing comment (e.g. " (already evaluated)"). This output is
-- generated only if the debug A flag is set. If the debug A flag is not
-- set, then no output is generated. This call also resets the value in
- -- Comperr.Current_Error_Node to what it was before the corresponding call
+ -- Atree.Current_Error_Node to what it was before the corresponding call
-- to Debug_A_Entry.
end Debug_A;
diff --git a/gcc/ada/decl.c b/gcc/ada/decl.c
index 1225ba169a5..dd4b427c2e0 100644
--- a/gcc/ada/decl.c
+++ b/gcc/ada/decl.c
@@ -6,8 +6,7 @@
* *
* C Implementation File *
* *
- * *
- * 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- *
@@ -89,6 +88,7 @@ static int allocatable_size_p PARAMS ((tree, int));
static struct attrib *build_attr_list PARAMS ((Entity_Id));
static tree elaborate_expression PARAMS ((Node_Id, Entity_Id, tree,
int, int, int));
+static int is_variable_size PARAMS ((tree));
static tree elaborate_expression_1 PARAMS ((Node_Id, Entity_Id, tree,
tree, int, int));
static tree make_packable_type PARAMS ((tree));
@@ -335,10 +335,15 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
/* If we have an external constant that we are not defining,
get the expression that is was defined to represent. We
may throw that expression away later if it is not a
- constant. */
+ constant.
+ Do not retrieve the expression if it is an aggregate, because
+ in complex instantiation contexts it may not be expanded */
+
if (! definition
&& Present (Expression (Declaration_Node (gnat_entity)))
- && ! No_Initialization (Declaration_Node (gnat_entity)))
+ && ! No_Initialization (Declaration_Node (gnat_entity))
+ && Nkind (Expression (Declaration_Node (gnat_entity)))
+ != N_Aggregate)
gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
/* Ignore deferred constant definitions; they are processed fully in the
@@ -407,11 +412,12 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
extended record types), just return the inherited entity, which
must be a FIELD_DECL. Likewise for discriminants.
For discriminants of untagged records which have explicit
- girder discriminants, return the entity for the corresponding
- girder discriminant. Also use Original_Record_Component
+ stored discriminants, return the entity for the corresponding
+ stored discriminant. Also use Original_Record_Component
if the record has a private extension. */
if ((Base_Type (gnat_record) == gnat_record
+ || Ekind (Scope (gnat_entity)) == E_Private_Subtype
|| Ekind (Scope (gnat_entity)) == E_Record_Subtype_With_Private
|| Ekind (Scope (gnat_entity)) == E_Record_Type_With_Private)
&& Present (Original_Record_Component (gnat_entity))
@@ -424,20 +430,20 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
break;
}
- /* If the enclosing record has explicit girder discriminants,
+ /* If the enclosing record has explicit stored discriminants,
then it is an untagged record. If the Corresponding_Discriminant
is not empty then this must be a renamed discriminant and its
Original_Record_Component must point to the corresponding explicit
- girder discriminant (i.e., we should have taken the previous
+ stored discriminant (i.e., we should have taken the previous
branch). */
else if (Present (Corresponding_Discriminant (gnat_entity))
&& Is_Tagged_Type (gnat_record))
{
- /* A tagged record has no explicit girder discriminants. */
+ /* A tagged record has no explicit stored discriminants. */
if (First_Discriminant (gnat_record)
- != First_Girder_Discriminant (gnat_record))
+ != First_Stored_Discriminant (gnat_record))
gigi_abort (119);
gnu_decl
@@ -447,16 +453,16 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
break;
}
- /* If the enclosing record has explicit girder discriminants,
+ /* If the enclosing record has explicit stored discriminants,
then it is an untagged record. If the Corresponding_Discriminant
is not empty then this must be a renamed discriminant and its
Original_Record_Component must point to the corresponding explicit
- girder discriminant (i.e., we should have taken the first
+ stored discriminant (i.e., we should have taken the first
branch). */
else if (Present (Corresponding_Discriminant (gnat_entity))
&& (First_Discriminant (gnat_record)
- != First_Girder_Discriminant (gnat_record)))
+ != First_Stored_Discriminant (gnat_record)))
gigi_abort (120);
/* Otherwise, if we are not defining this and we have no GCC type
@@ -468,9 +474,14 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
type and we have an Original_Record_Component, use it.
This is a workaround for major problems in protected type
handling. */
- if (Is_Protected_Type (Scope (Scope (gnat_entity)))
+
+ Entity_Id Scop = Scope (Scope (gnat_entity));
+ if ((Is_Protected_Type (Scop)
+ || (Is_Private_Type (Scop)
+ && Present (Full_View (Scop))
+ && Is_Protected_Type (Full_View (Scop))))
&& Present (Original_Record_Component (gnat_entity)))
- {
+ {
gnu_decl
= gnat_to_gnu_entity (Original_Record_Component
(gnat_entity),
@@ -572,21 +583,14 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
this may end up with an indirect allocation. */
if (No (Renamed_Object (gnat_entity))
- && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
- && contains_placeholder_p (TYPE_SIZE (gnu_type)))
+ && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
{
if (gnu_expr != 0 && kind == E_Constant)
{
gnu_size = TYPE_SIZE (TREE_TYPE (gnu_expr));
- if (TREE_CODE (gnu_size) != INTEGER_CST
- && contains_placeholder_p (gnu_size))
- {
- gnu_size = TYPE_SIZE (TREE_TYPE (gnu_expr));
- if (TREE_CODE (gnu_size) != INTEGER_CST
- && contains_placeholder_p (gnu_size))
- gnu_size = build (WITH_RECORD_EXPR, bitsizetype,
- gnu_size, gnu_expr);
- }
+ if (CONTAINS_PLACEHOLDER_P (gnu_size))
+ gnu_size = build (WITH_RECORD_EXPR, bitsizetype,
+ gnu_size, gnu_expr);
}
/* We may have no GNU_EXPR because No_Initialization is
@@ -603,14 +607,20 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
gnu_size = max_size (TYPE_SIZE (gnu_type), 1);
}
- /* If the size is zero bytes, make it one byte since some linkers
- have trouble with zero-sized objects. But if this will have a
- template, that will make it nonzero. */
+ /* If the size is zero bytes, make it one byte since some linkers have
+ trouble with zero-sized objects. If the object will have a
+ template, that will make it nonzero so don't bother. Also avoid
+ doing that for an object renaming or an object with an address
+ clause, as we would lose useful information on the view size
+ (e.g. for null array slices) and we are not allocating the object
+ here anyway. */
if (((gnu_size != 0 && integer_zerop (gnu_size))
|| (TYPE_SIZE (gnu_type) != 0
&& integer_zerop (TYPE_SIZE (gnu_type))))
&& (! Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
- || ! Is_Array_Type (Etype (gnat_entity))))
+ || ! Is_Array_Type (Etype (gnat_entity)))
+ && ! Present (Renamed_Object (gnat_entity))
+ && ! Present (Address_Clause (gnat_entity)))
gnu_size = bitsize_unit_node;
/* If an alignment is specified, use it if valid. Note that
@@ -644,25 +654,6 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
+ 1));
}
-#ifdef MINIMUM_ATOMIC_ALIGNMENT
- /* If the size is a constant and no alignment is specified, force
- the alignment to be the minimum valid atomic alignment. The
- restriction on constant size avoids problems with variable-size
- temporaries; if the size is variable, there's no issue with
- atomic access. Also don't do this for a constant, since it isn't
- necessary and can interfere with constant replacement. Finally,
- do not do it for Out parameters since that creates an
- size inconsistency with In parameters. */
- if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
- && ! FLOAT_TYPE_P (gnu_type)
- && ! const_flag && No (Renamed_Object (gnat_entity))
- && ! imported_p && No (Address_Clause (gnat_entity))
- && kind != E_Out_Parameter
- && (gnu_size != 0 ? TREE_CODE (gnu_size) == INTEGER_CST
- : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
- align = MINIMUM_ATOMIC_ALIGNMENT;
-#endif
-
/* If the object is set to have atomic components, find the component
type and validate it.
@@ -691,22 +682,6 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
if (Is_Atomic (gnat_entity))
check_ok_for_atomic (gnu_type, gnat_entity, 0);
- /* Make a new type with the desired size and alignment, if needed. */
- gnu_type = maybe_pad_type (gnu_type, gnu_size, align,
- gnat_entity, "PAD", 0, definition, 1);
-
- /* Make a volatile version of this object's type if we are to
- make the object volatile. Note that 13.3(19) says that we
- should treat other types of objects as volatile as well. */
- if ((Is_Volatile (gnat_entity)
- || Is_Exported (gnat_entity)
- || Is_Imported (gnat_entity)
- || Present (Address_Clause (gnat_entity)))
- && ! TYPE_VOLATILE (gnu_type))
- gnu_type = build_qualified_type (gnu_type,
- (TYPE_QUALS (gnu_type)
- | TYPE_QUAL_VOLATILE));
-
/* If this is an aliased object with an unconstrained nominal subtype,
make a type that includes the template. */
if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
@@ -724,6 +699,41 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
"UNC"));
}
+#ifdef MINIMUM_ATOMIC_ALIGNMENT
+ /* If the size is a constant and no alignment is specified, force
+ the alignment to be the minimum valid atomic alignment. The
+ restriction on constant size avoids problems with variable-size
+ temporaries; if the size is variable, there's no issue with
+ atomic access. Also don't do this for a constant, since it isn't
+ necessary and can interfere with constant replacement. Finally,
+ do not do it for Out parameters since that creates an
+ size inconsistency with In parameters. */
+ if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
+ && ! FLOAT_TYPE_P (gnu_type)
+ && ! const_flag && No (Renamed_Object (gnat_entity))
+ && ! imported_p && No (Address_Clause (gnat_entity))
+ && kind != E_Out_Parameter
+ && (gnu_size != 0 ? TREE_CODE (gnu_size) == INTEGER_CST
+ : TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
+ align = MINIMUM_ATOMIC_ALIGNMENT;
+#endif
+
+ /* Make a new type with the desired size and alignment, if needed. */
+ gnu_type = maybe_pad_type (gnu_type, gnu_size, align,
+ gnat_entity, "PAD", 0, definition, 1);
+
+ /* Make a volatile version of this object's type if we are to
+ make the object volatile. Note that 13.3(19) says that we
+ should treat other types of objects as volatile as well. */
+ if ((Treat_As_Volatile (gnat_entity)
+ || Is_Exported (gnat_entity)
+ || Is_Imported (gnat_entity)
+ || Present (Address_Clause (gnat_entity)))
+ && ! TYPE_VOLATILE (gnu_type))
+ gnu_type = build_qualified_type (gnu_type,
+ (TYPE_QUALS (gnu_type)
+ | TYPE_QUAL_VOLATILE));
+
/* Convert the expression to the type of the object except in the
case where the object's type is unconstrained or the object's type
is a padded record whose field is of self-referential size. In
@@ -732,11 +742,10 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
want to only copy the actual data. */
if (gnu_expr != 0
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
- && ! (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
- && contains_placeholder_p (TYPE_SIZE (gnu_type)))
+ && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
&& ! (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (gnu_type)
- && (contains_placeholder_p
+ && (CONTAINS_PLACEHOLDER_P
(TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
gnu_expr = convert (gnu_type, gnu_expr);
@@ -809,23 +818,38 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
been converted to the right type, but we need to create the
template if there is no initializer. */
else if (definition && TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_type)
+ && (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
+ /* Beware that padding might have been introduced
+ via maybe_pad_type above. */
+ || (TYPE_IS_PADDING_P (gnu_type)
+ && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
+ == RECORD_TYPE
+ && TYPE_CONTAINS_TEMPLATE_P
+ (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
&& gnu_expr == 0)
- gnu_expr
- = gnat_build_constructor
+ {
+ tree template_field
+ = TYPE_IS_PADDING_P (gnu_type)
+ ? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
+ : TYPE_FIELDS (gnu_type);
+
+ gnu_expr
+ = gnat_build_constructor
(gnu_type,
tree_cons
- (TYPE_FIELDS (gnu_type),
- build_template
- (TREE_TYPE (TYPE_FIELDS (gnu_type)),
- TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))),
- NULL_TREE),
+ (template_field,
+ build_template (TREE_TYPE (template_field),
+ TREE_TYPE (TREE_CHAIN (template_field)),
+ NULL_TREE),
NULL_TREE));
+ }
/* If this is a pointer and it does not have an initializing
- expression, initialize it to NULL. */
+ expression, initialize it to NULL, unless the obect is
+ imported. */
if (definition
&& (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type))
+ && !Is_Imported (gnat_entity)
&& gnu_expr == 0)
gnu_expr = integer_zero_node;
@@ -932,7 +956,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
gnat_entity);
gnu_expr = build_allocator (gnu_alloc_type, gnu_expr,
- gnu_type, 0, 0);
+ gnu_type, 0, 0, gnat_entity);
}
else
{
@@ -955,17 +979,20 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
TYPE_SIZE_UNIT (gnu_type));
tree gnu_new_var;
- if (gnu_expr != 0)
- gnu_expr
- = gnat_build_constructor (gnu_new_type,
- tree_cons (TYPE_FIELDS (gnu_new_type),
- gnu_expr, NULL_TREE));
set_lineno (gnat_entity, 1);
gnu_new_var
= create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
NULL_TREE, gnu_new_type, gnu_expr,
0, 0, 0, 0, 0);
+ if (gnu_expr != 0)
+ expand_expr_stmt
+ (build_binary_op
+ (MODIFY_EXPR, NULL_TREE,
+ build_component_ref (gnu_new_var, NULL_TREE,
+ TYPE_FIELDS (gnu_new_type)),
+ gnu_expr));
+
gnu_type = build_reference_type (gnu_type);
gnu_expr
= build_unary_op
@@ -986,11 +1013,10 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
want to only copy the actual data. */
if (gnu_expr != 0
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
- && ! (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
- && contains_placeholder_p (TYPE_SIZE (gnu_type)))
+ && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
&& ! (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (gnu_type)
- && (contains_placeholder_p
+ && (CONTAINS_PLACEHOLDER_P
(TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
gnu_expr = convert (gnu_type, gnu_expr);
@@ -1046,7 +1072,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
|| Address_Taken (gnat_entity)
|| Is_Aliased (gnat_entity)
|| Is_Aliased (Etype (gnat_entity))))
- SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl,
+ SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl,
create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_expr, 0, Is_Public (gnat_entity), 0,
static_p, 0));
@@ -1250,7 +1276,6 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
gnu_type = make_node (INTEGER_TYPE);
if (Is_Packed_Array_Type (gnat_entity))
{
-
esize = UI_To_Int (RM_Size (gnat_entity));
TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
}
@@ -1322,7 +1347,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
{
gnu_type = make_signed_type (esize);
TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
- SET_TYPE_DIGITS_VALUE (gnu_type,
+ SET_TYPE_DIGITS_VALUE (gnu_type,
UI_To_Int (Digits_Value (gnat_entity)));
break;
}
@@ -1561,8 +1586,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
/* If the component type is a RECORD_TYPE that has a self-referential
size, use the maxium size. */
if (gnu_comp_size == 0 && TREE_CODE (tem) == RECORD_TYPE
- && TREE_CODE (TYPE_SIZE (tem)) != INTEGER_CST
- && contains_placeholder_p (TYPE_SIZE (tem)))
+ && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem)))
gnu_comp_size = max_size (TYPE_SIZE (tem), 1);
if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0)
@@ -1594,8 +1618,14 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
{
tem = build_array_type (tem, gnu_index_types[index]);
TYPE_MULTI_ARRAY_P (tem) = (index > 0);
+
+ /* ??? For now, we say that any component of aggregate type is
+ addressable because the front end may take 'Reference of it.
+ But we have to make it addressable if it must be passed by
+ reference or it that is the default. */
TYPE_NONALIASED_COMPONENT (tem)
- = ! Has_Aliased_Components (gnat_entity);
+ = (! Has_Aliased_Components (gnat_entity)
+ && ! AGGREGATE_TYPE_P (TREE_TYPE (tem)));
}
/* If an alignment is specified, use it if valid. But ignore it for
@@ -1805,15 +1835,13 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
if ((TREE_CODE (gnu_min) == INTEGER_CST
&& ! TREE_OVERFLOW (gnu_min)
&& ! operand_equal_p (gnu_min, gnu_base_base_min, 0))
- || (TREE_CODE (gnu_min) != INTEGER_CST
- && ! contains_placeholder_p (gnu_min)))
+ || ! CONTAINS_PLACEHOLDER_P (gnu_min))
gnu_base_min = gnu_min;
if ((TREE_CODE (gnu_max) == INTEGER_CST
&& ! TREE_OVERFLOW (gnu_max)
&& ! operand_equal_p (gnu_max, gnu_base_base_max, 0))
- || (TREE_CODE (gnu_max) != INTEGER_CST
- && ! contains_placeholder_p (gnu_max)))
+ || ! CONTAINS_PLACEHOLDER_P (gnu_max))
gnu_base_max = gnu_max;
if ((TREE_CODE (gnu_base_min) == INTEGER_CST
@@ -1879,8 +1907,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
/* If the component type is a RECORD_TYPE that has a self-referential
size, use the maxium size. */
if (gnu_comp_size == 0 && TREE_CODE (gnu_type) == RECORD_TYPE
- && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
- && contains_placeholder_p (TYPE_SIZE (gnu_type)))
+ && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
gnu_comp_size = max_size (TYPE_SIZE (gnu_type), 1);
if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0)
@@ -1911,8 +1938,13 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
{
gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
+ /* ??? For now, we say that any component of aggregate type is
+ addressable because the front end may take 'Reference.
+ But we have to make it addressable if it must be passed by
+ reference or it that is the default. */
TYPE_NONALIASED_COMPONENT (gnu_type)
- = ! Has_Aliased_Components (gnat_entity);
+ = (! Has_Aliased_Components (gnat_entity)
+ && ! AGGREGATE_TYPE_P (TREE_TYPE (gnu_type)));
}
/* If we are at file level and this is a multi-dimensional array, we
@@ -1975,8 +2007,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
/* If our size depends on a placeholder and the maximum size doesn't
overflow, use it. */
- if (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
- && contains_placeholder_p (TYPE_SIZE (gnu_type))
+ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
&& ! (TREE_CODE (gnu_max_size) == INTEGER_CST
&& TREE_OVERFLOW (gnu_max_size))
&& ! (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
@@ -2009,7 +2040,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
gnu_type = build_qualified_type (gnu_type,
(TYPE_QUALS (gnu_type)
| (TYPE_QUAL_VOLATILE
- * Is_Volatile (gnat_entity))));
+ * Treat_As_Volatile (gnat_entity))));
set_lineno (gnat_entity, 0);
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
@@ -2104,7 +2135,8 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
tree gnu_string_array_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
tree gnu_string_index_type
- = TREE_TYPE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_string_array_type)));
+ = get_base_type (TREE_TYPE (TYPE_INDEX_TYPE
+ (TYPE_DOMAIN (gnu_string_array_type))));
tree gnu_lower_bound
= convert (gnu_string_index_type,
gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
@@ -2167,7 +2199,6 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
(Type_Definition
(Declaration_Node (gnat_entity)))))))));
-
break;
}
@@ -2212,10 +2243,23 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
/* Make a node for the record. If we are not defining the record,
suppress expanding incomplete types and save the node as the type
- for GNAT_ENTITY. We use the same RECORD_TYPE as was made
- for a dummy type and then show it's no longer a dummy. */
+ for GNAT_ENTITY. We use the same RECORD_TYPE as for a dummy type
+ and reset TYPE_DUMMY_P to show it's no longer a dummy.
+
+ It is very tempting to delay resetting this bit until we are done
+ with completing the type, e.g. to let possible intermediate
+ elaboration of access types designating the record know it is not
+ complete and arrange for update_pointer_to to fix things up later.
+
+ It would be wrong, however, because dummy types are expected only
+ to be created for Ada incomplete or private types, which is not
+ what we have here. Doing so would make other parts of gigi think
+ we are dealing with a really incomplete or private type, and have
+ nasty side effects, typically on the generation of the associated
+ debugging information. */
gnu_type = make_dummy_type (gnat_entity);
TYPE_DUMMY_P (gnu_type) = 0;
+
if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL && debug_info_p)
DECL_IGNORED_P (TYPE_NAME (gnu_type)) = 0;
@@ -2242,13 +2286,15 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
/* Always set the alignment here so that it can be used to
set the mode, if it is making the alignment stricter. If
it is invalid, it will be checked again below. If this is to
- be Atomic, choose a default alignment of a word. */
-
+ be Atomic, choose a default alignment of a word unless we know
+ the size and it's smaller. */
if (Known_Alignment (gnat_entity))
TYPE_ALIGN (gnu_type)
= validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
else if (Is_Atomic (gnat_entity))
- TYPE_ALIGN (gnu_type) = BITS_PER_WORD;
+ TYPE_ALIGN (gnu_type)
+ = (esize >= BITS_PER_WORD ? BITS_PER_WORD
+ : 1 << ((floor_log2 (esize) - 1) + 1));
/* If we have a Parent_Subtype, make a field for the parent. If
this record has rep clauses, force the position to zero. */
@@ -2270,9 +2316,9 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
NULL_TREE));
if (Has_Discriminants (gnat_entity))
- for (gnat_field = First_Girder_Discriminant (gnat_entity);
+ for (gnat_field = First_Stored_Discriminant (gnat_entity);
Present (gnat_field);
- gnat_field = Next_Girder_Discriminant (gnat_field))
+ gnat_field = Next_Stored_Discriminant (gnat_field))
if (Present (Corresponding_Discriminant (gnat_field)))
save_gnu_tree
(gnat_field,
@@ -2301,9 +2347,9 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
/* Add the fields for the discriminants into the record. */
if (! Is_Unchecked_Union (gnat_entity)
&& Has_Discriminants (gnat_entity))
- for (gnat_field = First_Girder_Discriminant (gnat_entity);
+ for (gnat_field = First_Stored_Discriminant (gnat_entity);
Present (gnat_field);
- gnat_field = Next_Girder_Discriminant (gnat_field))
+ gnat_field = Next_Stored_Discriminant (gnat_field))
{
/* If this is a record extension and this discriminant
is the renaming of another discriminant, we've already
@@ -2340,8 +2386,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
gnu_field_list, packed, definition, 0,
0, all_rep);
- TYPE_DUMMY_P (gnu_type) = 0;
- TYPE_VOLATILE (gnu_type) = Is_Volatile (gnat_entity);
+ TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity);
/* If this is an extension type, reset the tree for any
@@ -2349,9 +2394,9 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
for non-inherited discriminants. */
if (! Is_Unchecked_Union (gnat_entity)
&& Has_Discriminants (gnat_entity))
- for (gnat_field = First_Girder_Discriminant (gnat_entity);
+ for (gnat_field = First_Stored_Discriminant (gnat_entity);
Present (gnat_field);
- gnat_field = Next_Girder_Discriminant (gnat_field))
+ gnat_field = Next_Stored_Discriminant (gnat_field))
{
if (Present (Parent_Subtype (gnat_entity))
&& Present (Corresponding_Discriminant (gnat_field)))
@@ -2367,10 +2412,21 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
/* If it is a tagged record force the type to BLKmode to insure
that these objects will always be placed in memory. Do the
same thing for limited record types. */
-
if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
TYPE_MODE (gnu_type) = BLKmode;
+ /* If this is a derived type, we must make the alias set of this type
+ the same as that of the type we are derived from. We assume here
+ that the other type is already frozen. */
+ if (Etype (gnat_entity) != gnat_entity
+ && ! (Is_Private_Type (Etype (gnat_entity))
+ && Full_View (Etype (gnat_entity)) == gnat_entity))
+ {
+ TYPE_ALIAS_SET (gnu_type)
+ = get_alias_set (gnat_to_gnu_type (Etype (gnat_entity)));
+ record_component_aliases (gnu_type);
+ }
+
/* Fill in locations of fields. */
annotate_rep (gnat_entity, gnu_type);
@@ -2394,7 +2450,8 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
if (Present (Equivalent_Type (gnat_entity)))
{
- gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
+ gnu_decl = gnat_to_gnu_entity (Equivalent_Type (gnat_entity),
+ NULL_TREE, 0);
maybe_present = 1;
break;
}
@@ -2460,7 +2517,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
&& ! Is_For_Access_Subtype (gnat_entity)
&& ! Is_Unchecked_Union (gnat_base_type)
&& Is_Constrained (gnat_entity)
- && Girder_Constraint (gnat_entity) != No_Elist
+ && Stored_Constraint (gnat_entity) != No_Elist
&& Present (Discriminant_Constraint (gnat_entity)))
{
Entity_Id gnat_field;
@@ -2543,8 +2600,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
gnu_field_type = make_packable_type (gnu_field_type);
}
- if (TREE_CODE (gnu_pos) != INTEGER_CST
- && contains_placeholder_p (gnu_pos))
+ if (CONTAINS_PLACEHOLDER_P (gnu_pos))
for (gnu_temp = gnu_subst_list;
gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
gnu_pos = substitute_in_expr (gnu_pos,
@@ -2581,7 +2637,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
= DECL_INTERNAL_P (gnu_old_field);
SET_DECL_ORIGINAL_FIELD (gnu_field,
(DECL_ORIGINAL_FIELD (gnu_old_field) != 0
- ? DECL_ORIGINAL_FIELD (gnu_old_field)
+ ? DECL_ORIGINAL_FIELD (gnu_old_field)
: gnu_old_field));
DECL_DISCRIMINANT_NUMBER (gnu_field)
= DECL_DISCRIMINANT_NUMBER (gnu_old_field);
@@ -2597,14 +2653,14 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
/* Now set the size, alignment and alias set of the new type to
match that of the old one, doing any substitutions, as
above. */
- TYPE_ALIAS_SET (gnu_type) = get_alias_set (gnu_base_type);
TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
+ TYPE_ALIAS_SET (gnu_type) = get_alias_set (gnu_base_type);
+ record_component_aliases (gnu_type);
- if (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
- && contains_placeholder_p (TYPE_SIZE (gnu_type)))
+ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
for (gnu_temp = gnu_subst_list;
gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
TYPE_SIZE (gnu_type)
@@ -2612,8 +2668,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
TREE_PURPOSE (gnu_temp),
TREE_VALUE (gnu_temp));
- if (TREE_CODE (TYPE_SIZE_UNIT (gnu_type)) != INTEGER_CST
- && contains_placeholder_p (TYPE_SIZE_UNIT (gnu_type)))
+ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
for (gnu_temp = gnu_subst_list;
gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
TYPE_SIZE_UNIT (gnu_type)
@@ -2622,8 +2677,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
TREE_VALUE (gnu_temp));
if (TYPE_ADA_SIZE (gnu_type) != 0
- && TREE_CODE (TYPE_ADA_SIZE (gnu_type)) != INTEGER_CST
- && contains_placeholder_p (TYPE_ADA_SIZE (gnu_type)))
+ && CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
for (gnu_temp = gnu_subst_list;
gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
SET_TYPE_ADA_SIZE (gnu_type,
@@ -2663,7 +2717,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
0, 0);
}
- TYPE_VOLATILE (gnu_type) = Is_Volatile (gnat_entity);
+ TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
TYPE_NAME (gnu_type) = gnu_entity_id;
TYPE_STUB_DECL (gnu_type)
= pushdecl (build_decl (TYPE_DECL, TYPE_NAME (gnu_type),
@@ -2897,17 +2951,43 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
break;
}
- /* If we have a GCC type for the designated type, possibly
- modify it if we are pointing only to constant objects and then
- make a pointer to it. Don't do this for unconstrained arrays. */
+ /* If we have a GCC type for the designated type, possibly modify it
+ if we are pointing only to constant objects and then make a pointer
+ to it. Don't do this for unconstrained arrays. */
if (gnu_type == 0 && gnu_desig_type != 0)
{
if (Is_Access_Constant (gnat_entity)
&& TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
- gnu_desig_type
- = build_qualified_type (gnu_desig_type,
- (TYPE_QUALS (gnu_desig_type)
- | TYPE_QUAL_CONST));
+ {
+ gnu_desig_type
+ = build_qualified_type
+ (gnu_desig_type,
+ TYPE_QUALS (gnu_desig_type) | TYPE_QUAL_CONST);
+
+ /* Some extra processing is required if we are building a
+ pointer to an incomplete type (in the GCC sense). We might
+ have such a type if we just made a dummy, or directly out
+ of the call to gnat_to_gnu_type above if we are processing
+ an access type for a record component designating the
+ record type itself. */
+ if (! COMPLETE_TYPE_P (gnu_desig_type))
+ {
+ /* We must ensure that the pointer to variant we make will
+ be processed by update_pointer_to when the initial type
+ is completed. Pretend we made a dummy and let further
+ processing act as usual. */
+ made_dummy = 1;
+
+ /* We must ensure that update_pointer_to will not retrieve
+ the dummy variant when building a properly qualified
+ version of the complete type. We take advantage of the
+ fact that get_qualified_type is requiring TYPE_NAMEs to
+ match to influence build_qualified_type and then also
+ update_pointer_to here. */
+ TYPE_NAME (gnu_desig_type)
+ = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
+ }
+ }
gnu_type = build_pointer_type (gnu_desig_type);
}
@@ -2938,8 +3018,22 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
this_made_decl = saved = 1;
if (defer_incomplete_level == 0)
- update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
- gnat_to_gnu_type (gnat_desig_type));
+ {
+ update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
+ gnat_to_gnu_type (gnat_desig_type));
+ /* Note that the call to gnat_to_gnu_type here might have
+ updated gnu_old_type directly, in which case it is not a
+ dummy type any more when we get into update_pointer_to.
+
+ This may happen for instance when the designated type is a
+ record type, because their elaboration starts with an
+ initial node from make_dummy_type, which may yield the same
+ node as the one we got.
+
+ Besides, variants of this non-dummy type might have been
+ created along the way. update_pointer_to is expected to
+ properly take care of those situations. */
+ }
else
{
struct incomplete *p
@@ -3006,6 +3100,10 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
p->next = defer_incomplete_list;
defer_incomplete_list = p;
}
+ else if
+ (IN (Ekind (Base_Type (Directly_Designated_Type (gnat_entity))),
+ Incomplete_Or_Private_Kind))
+ { ;}
else
gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
NULL_TREE, 0);
@@ -3091,7 +3189,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
int volatile_flag = No_Return (gnat_entity);
int returns_by_ref = 0;
int returns_unconstrained = 0;
- tree gnu_ext_name = NULL_TREE;
+ tree gnu_ext_name = create_concat_name (gnat_entity, 0);
int has_copy_in_out = 0;
int parmnum;
@@ -3130,10 +3228,19 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
if (Returns_By_Ref (gnat_entity))
{
returns_by_ref = 1;
-
gnu_return_type = build_pointer_type (gnu_return_type);
}
+ /* If the Mechanism is By_Reference, ensure the return type uses
+ the machine's by-reference mechanism, which may not the same
+ as above (e.g., it might be by passing a fake parameter). */
+ else if (kind == E_Function
+ && Mechanism (gnat_entity) == By_Reference)
+ {
+ gnu_return_type = copy_type (gnu_return_type);
+ TREE_ADDRESSABLE (gnu_return_type) = 1;
+ }
+
/* If we are supposed to return an unconstrained array,
actually return a fat pointer and make a note of that. Return
a pointer to an unconstrained record of variable size. */
@@ -3143,9 +3250,9 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
returns_unconstrained = 1;
}
- /* If the type requires a transient scope, the result is allocated
- on the secondary stack, so the result type of the function is
- just a pointer. */
+ /* If the type requires a transient scope, the result is allocated
+ on the secondary stack, so the result type of the function is
+ just a pointer. */
else if (Requires_Transient_Scope (Etype (gnat_entity)))
{
gnu_return_type = build_pointer_type (gnu_return_type);
@@ -3223,8 +3330,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
if (Ekind (gnat_param) == E_In_Parameter
&& TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
&& ! (TYPE_SIZE (gnu_param_type) != 0
- && TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
- && contains_placeholder_p (TYPE_SIZE (gnu_param_type))))
+ && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type))))
gnu_param_type
= build_qualified_type (gnu_param_type,
(TYPE_QUALS (gnu_param_type)
@@ -3283,7 +3389,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
or aggregates by reference. For COBOL and Fortran, pass
all integer and FP types that way too. For Convention Ada,
use the standard Ada default. */
- else if (must_pass_by_ref (gnu_param_type) || req_by_ref
+ else if (must_pass_by_ref (gnu_param_type) || req_by_ref
|| (! req_by_copy
&& ((Has_Foreign_Convention (gnat_entity)
&& (Ekind (gnat_param) != E_In_Parameter
@@ -3303,7 +3409,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
by_ref_p = 1;
}
- else if (Ekind (gnat_param) != E_In_Parameter)
+ else if (Ekind (gnat_param) != E_In_Parameter)
copy_in_copy_out_flag = 1;
if (req_by_copy && (by_ref_p || by_component_ptr_p))
@@ -3313,12 +3419,30 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
and isn't a pointer or aggregate, we don't make a PARM_DECL
for it. Instead, it will be a VAR_DECL created when we process
the procedure. For the special parameter of Valued_Procedure,
- never pass it in. */
+ never pass it in.
+
+ An exception is made to cover the RM-6.4.1 rule requiring "by
+ copy" out parameters with discriminants or implicit initial
+ values to be handled like in out parameters. These type are
+ normally built as aggregates, and hence passed by reference,
+ except for some packed arrays which end up encoded in special
+ integer types.
+
+ The exception we need to make is then for packed arrays of
+ records with discriminants or implicit initial values. We have
+ no light/easy way to check for the latter case, so we merely
+ check for packed arrays of records. This may lead to useless
+ copy-in operations, but in very rare cases only, as these would
+ be exceptions in a set of already exceptional situations. */
if (Ekind (gnat_param) == E_Out_Parameter && ! by_ref_p
&& ((Is_Valued_Procedure (gnat_entity) && parmnum == 0)
|| (! by_descr_p
&& ! POINTER_TYPE_P (gnu_param_type)
- && ! AGGREGATE_TYPE_P (gnu_param_type))))
+ && ! AGGREGATE_TYPE_P (gnu_param_type)))
+ && ! (Is_Array_Type (Etype (gnat_param))
+ && Is_Packed (Etype (gnat_param))
+ && Is_Composite_Type (Component_Type
+ (Etype (gnat_param)))))
gnu_param = 0;
else
{
@@ -3348,7 +3472,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
pure_flag = 0;
}
- if (copy_in_copy_out_flag)
+ if (copy_in_copy_out_flag)
{
if (! has_copy_in_out)
{
@@ -3370,8 +3494,8 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
}
}
- /* Do not compute record for out parameters if subprogram is
- stubbed since structures are incomplete for the back-end. */
+ /* Do not compute record for out parameters if subprogram is
+ stubbed since structures are incomplete for the back-end. */
if (gnu_field_list != 0
&& Convention (gnat_entity) != Convention_Stubbed)
finish_record_type (gnu_return_type, nreverse (gnu_field_list),
@@ -3383,6 +3507,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
if (list_length (gnu_return_list) == 1)
gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
+#ifdef _WIN32
if (Convention (gnat_entity) == Convention_Stdcall)
{
struct attrib *attr
@@ -3395,6 +3520,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
attr->error_point = gnat_entity;
attr_list = attr;
}
+#endif
/* Both lists ware built in reverse. */
gnu_param_list = nreverse (gnu_param_list);
@@ -3416,33 +3542,14 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
| (TYPE_QUAL_CONST * pure_flag)
| (TYPE_QUAL_VOLATILE * volatile_flag)));
- /* Top-level or external functions need to have an assembler name.
- This is passed to create_subprog_decl through the ext_name argument.
- For Pragma Interface subprograms with no Pragma Interface_Name, the
- simple name already in entity_name is correct, and this is what is
- gotten when ext_name is NULL. If Interface_Name is specified, then
- the name is extracted from the N_String_Literal node containing the
- string specified in the Pragma. If there is no Pragma Interface,
- then the Ada fully qualified name is created. */
-
- if (Present (Interface_Name (gnat_entity))
- || ! (Is_Imported (gnat_entity) || Is_Exported (gnat_entity)))
- {
- gnu_ext_name = create_concat_name (gnat_entity, 0);
-
- /* If there wasn't a specified Interface_Name, use this for the
- main name of the entity. This will cause GCC to allow
- qualification of a nested subprogram with a unique ID. We
- need this in case there is an overloaded subprogram somewhere
- up the scope chain.
-
- ??? This may be a kludge. */
- if (No (Interface_Name (gnat_entity)))
- gnu_entity_id = gnu_ext_name;
- }
-
set_lineno (gnat_entity, 0);
+ /* If there was no specified Interface_Name and the external and
+ internal names of the subprogram are the same, only use the
+ internal name to allow disambiguation of nested subprograms. */
+ if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id)
+ gnu_ext_name = 0;
+
/* If we are defining the subprogram and it has an Address clause
we must get the address expression from the saved GCC tree for the
subprogram if it has a Freeze_Node. Otherwise, we elaborate
@@ -3473,11 +3580,11 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
DECL_BY_REF_P (gnu_decl) = 1;
}
- else if (kind == E_Subprogram_Type)
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
+ else if (kind == E_Subprogram_Type)
+ gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
- else
+ else
{
gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name,
gnu_type, gnu_param_list,
@@ -3601,7 +3708,8 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
if ((gnu_decl == 0 || this_made_decl) && IN (kind, Type_Kind))
{
- if (Is_Tagged_Type (gnat_entity))
+ if (Is_Tagged_Type (gnat_entity)
+ || Is_Class_Wide_Equivalent_Type (gnat_entity))
TYPE_ALIGN_OK (gnu_type) = 1;
if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
@@ -3667,8 +3775,8 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
Handle both the RM size and the actual size. */
if (global_bindings_p ()
&& TYPE_SIZE (gnu_type) != 0
- && TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
- && ! contains_placeholder_p (TYPE_SIZE (gnu_type)))
+ && ! TREE_CONSTANT (TYPE_SIZE (gnu_type))
+ && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
{
if (TREE_CODE (gnu_type) == RECORD_TYPE
&& operand_equal_p (TYPE_ADA_SIZE (gnu_type),
@@ -3726,16 +3834,15 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
/* ??? Unfortunately, GCC needs to be able to prove the
alignment of this offset and if it's a variable, it can't.
- In GCC 3.2, we'll use DECL_OFFSET_ALIGN in some way, but
+ In GCC 3.4, we'll use DECL_OFFSET_ALIGN in some way, but
right now, we have to put in an explicit multiply and
divide by that value. */
- if (TREE_CODE (DECL_FIELD_OFFSET (gnu_field)) != INTEGER_CST
- && ! contains_placeholder_p (DECL_FIELD_OFFSET (gnu_field)))
+ if (! CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
DECL_FIELD_OFFSET (gnu_field)
= build_binary_op
(MULT_EXPR, sizetype,
elaborate_expression_1
- (gnat_temp, gnat_temp,
+ (gnat_temp, gnat_temp,
build_binary_op (EXACT_DIV_EXPR, sizetype,
DECL_FIELD_OFFSET (gnu_field),
size_int (DECL_OFFSET_ALIGN (gnu_field)
@@ -3748,7 +3855,7 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
gnu_type = build_qualified_type (gnu_type,
(TYPE_QUALS (gnu_type)
| (TYPE_QUAL_VOLATILE
- * Is_Volatile (gnat_entity))));
+ * Treat_As_Volatile (gnat_entity))));
if (Is_Atomic (gnat_entity))
check_ok_for_atomic (gnu_type, gnat_entity, 0);
@@ -3783,10 +3890,36 @@ gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
value of that size. */
tree gnu_size = TYPE_SIZE (gnu_type);
- if (contains_placeholder_p (gnu_size))
+ if (CONTAINS_PLACEHOLDER_P (gnu_size))
gnu_size = max_size (gnu_size, 1);
Set_Esize (gnat_entity, annotate_value (gnu_size));
+
+ if (type_annotate_only && Is_Tagged_Type (gnat_entity))
+ {
+ /* In this mode the tag and the parent components are not
+ generated by the front-end, so the sizes must be adjusted
+ explicitly now. */
+
+ int size_offset;
+ int new_size;
+
+ if (Is_Derived_Type (gnat_entity))
+ {
+ size_offset
+ = UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
+ Set_Alignment (gnat_entity,
+ Alignment (Etype (Base_Type (gnat_entity))));
+ }
+ else
+ size_offset = POINTER_SIZE;
+
+ new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
+ Set_Esize (gnat_entity,
+ UI_From_Int (((new_size + (POINTER_SIZE - 1))
+ / POINTER_SIZE) * POINTER_SIZE));
+ Set_RM_Size (gnat_entity, Esize (gnat_entity));
+ }
}
if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type) != 0)
@@ -4026,10 +4159,10 @@ substitution_list (gnat_subtype, gnat_type, gnu_list, definition)
gnat_type = Implementation_Base_Type (gnat_subtype);
if (Has_Discriminants (gnat_type))
- for (gnat_discrim = First_Girder_Discriminant (gnat_type),
- gnat_value = First_Elmt (Girder_Constraint (gnat_subtype));
+ for (gnat_discrim = First_Stored_Discriminant (gnat_type),
+ gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
Present (gnat_discrim);
- gnat_discrim = Next_Girder_Discriminant (gnat_discrim),
+ gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
gnat_value = Next_Elmt (gnat_value))
/* Ignore access discriminants. */
if (! Is_Access_Type (Etype (Node (gnat_value))))
@@ -4117,6 +4250,8 @@ allocatable_size_p (gnu_size, static_p)
tree gnu_size;
int static_p;
{
+ HOST_WIDE_INT our_size;
+
/* If this is not a static allocation, the only case we want to forbid
is an overflowing size. That will be converted into a raise a
Storage_Error. */
@@ -4125,8 +4260,13 @@ allocatable_size_p (gnu_size, static_p)
&& TREE_CONSTANT_OVERFLOW (gnu_size));
/* Otherwise, we need to deal with both variable sizes and constant
- sizes that won't fit in a host int. */
- return host_integerp (gnu_size, 1);
+ sizes that won't fit in a host int. We use int instead of HOST_WIDE_INT
+ since assemblers may not like very large sizes. */
+ if (!host_integerp (gnu_size, 1))
+ return 0;
+
+ our_size = tree_low_cst (gnu_size, 1);
+ return (int) our_size == our_size;
}
/* Return a list of attributes for GNAT_ENTITY, if any. */
@@ -4230,8 +4370,7 @@ maybe_variable (gnu_operand, gnat_node)
/* If we will be generating code, make sure we are at the proper
line number. */
- if (! global_bindings_p () && ! TREE_CONSTANT (gnu_operand)
- && ! contains_placeholder_p (gnu_operand))
+ if (! global_bindings_p () && ! CONTAINS_PLACEHOLDER_P (gnu_operand))
set_lineno (gnat_node, 1);
if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
@@ -4284,7 +4423,7 @@ elaborate_expression (gnat_expr, gnat_entity, gnu_name, definition,
Since this is not a DECL, don't check it. If this is a constant,
don't save it since GNAT_EXPR might be used more than once. Also,
don't save if it's a discriminant. */
- if (! TREE_CONSTANT (gnu_expr) && ! contains_placeholder_p (gnu_expr))
+ if (! CONTAINS_PLACEHOLDER_P (gnu_expr))
save_gnu_tree (gnat_expr, gnu_expr, 1);
return need_value ? gnu_expr : error_mark_node;
@@ -4333,14 +4472,14 @@ elaborate_expression_1 (gnat_expr, gnat_entity, gnu_expr, gnu_name, definition,
expr_variable = (TREE_CODE_CLASS (TREE_CODE (gnu_expr)) != 'c'
&& ! (TREE_CODE (gnu_inner_expr) == VAR_DECL
&& TREE_READONLY (gnu_inner_expr))
- && ! contains_placeholder_p (gnu_expr));
+ && ! CONTAINS_PLACEHOLDER_P (gnu_expr));
/* If this is a static expression or contains a discriminant, we don't
need the variable for debugging (and can't elaborate anyway if a
discriminant). */
if (need_debug
&& (Is_OK_Static_Expression (gnat_expr)
- || contains_placeholder_p (gnu_expr)))
+ || CONTAINS_PLACEHOLDER_P (gnu_expr)))
need_debug = 0;
/* Now create the variable if we need it. */
@@ -4392,7 +4531,7 @@ make_aligning_type (type, align, size)
pos = size_binop (MULT_EXPR,
convert (bitsizetype,
- size_binop (BIT_AND_EXPR,
+ size_binop (BIT_AND_EXPR,
size_diffop (size_zero_node,
size_addr_place),
ssize_int ((align / BITS_PER_UNIT)
@@ -4412,29 +4551,36 @@ make_aligning_type (type, align, size)
bitsize_int (align));
TYPE_SIZE_UNIT (record_type)
= size_binop (PLUS_EXPR, size, size_int (align / BITS_PER_UNIT));
-
+ TYPE_ALIAS_SET (record_type) = get_alias_set (type);
return record_type;
}
-/* TYPE is a RECORD_TYPE with BLKmode that's being used as the field
- type of a packed record. See if we can rewrite it as a record that has
- a non-BLKmode type, which we can pack tighter. If so, return the
- new type. If not, return the original type. */
+/* TYPE is a RECORD_TYPE, UNION_TYPE, or QUAL_UNION_TYPE, with BLKmode that's
+ being used as the field type of a packed record. See if we can rewrite it
+ as a record that has a non-BLKmode type, which we can pack tighter. If so,
+ return the new type. If not, return the original type. */
static tree
make_packable_type (type)
tree type;
{
- tree new_type = make_node (RECORD_TYPE);
+ tree new_type = make_node (TREE_CODE (type));
tree field_list = NULL_TREE;
tree old_field;
/* Copy the name and flags from the old type to that of the new and set
- the alignment to try for an integral type. */
+ the alignment to try for an integral type. For QUAL_UNION_TYPE,
+ also copy the size. */
TYPE_NAME (new_type) = TYPE_NAME (type);
TYPE_LEFT_JUSTIFIED_MODULAR_P (new_type)
= TYPE_LEFT_JUSTIFIED_MODULAR_P (type);
TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
+ TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
+ if (TREE_CODE (type) == QUAL_UNION_TYPE)
+ {
+ TYPE_SIZE (new_type) = TYPE_SIZE (type);
+ TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
+ }
TYPE_ALIGN (new_type)
= ((HOST_WIDE_INT) 1
@@ -4444,22 +4590,36 @@ make_packable_type (type)
for (old_field = TYPE_FIELDS (type); old_field != 0;
old_field = TREE_CHAIN (old_field))
{
- tree new_field
- = create_field_decl (DECL_NAME (old_field), TREE_TYPE (old_field),
- new_type, TYPE_PACKED (type),
- DECL_SIZE (old_field),
- bit_position (old_field),
- ! DECL_NONADDRESSABLE_P (old_field));
+ tree new_field_type = TREE_TYPE (old_field);
+ tree new_field;
+
+ if (TYPE_MODE (new_field_type) == BLKmode
+ && (TREE_CODE (new_field_type) == RECORD_TYPE
+ || TREE_CODE (new_field_type) == UNION_TYPE
+ || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
+ && host_integerp (TYPE_SIZE (new_field_type), 1))
+ new_field_type = make_packable_type (new_field_type);
+
+ new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
+ new_type, TYPE_PACKED (type),
+ DECL_SIZE (old_field),
+ bit_position (old_field),
+ ! DECL_NONADDRESSABLE_P (old_field));
DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
SET_DECL_ORIGINAL_FIELD (new_field,
(DECL_ORIGINAL_FIELD (old_field) != 0
? DECL_ORIGINAL_FIELD (old_field) : old_field));
+
+ if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
+ DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
+
TREE_CHAIN (new_field) = field_list;
field_list = new_field;
}
finish_record_type (new_type, nreverse (field_list), 1, 1);
+ TYPE_ALIAS_SET (new_type) = get_alias_set (type);
return TYPE_MODE (new_type) == BLKmode ? type : new_type;
}
@@ -4583,7 +4743,7 @@ maybe_pad_type (type, size, align, gnat_entity, name_trailer,
TYPE_ALIGN (record) = align;
TYPE_IS_PADDING_P (record) = 1;
TYPE_VOLATILE (record)
- = Present (gnat_entity) && Is_Volatile (gnat_entity);
+ = Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
finish_record_type (record, field, 1, 0);
/* Keep the RM_Size of the padded record as that of the old record
@@ -4620,8 +4780,7 @@ maybe_pad_type (type, size, align, gnat_entity, name_trailer,
type = record;
- if (TREE_CODE (orig_size) != INTEGER_CST
- && contains_placeholder_p (orig_size))
+ if (CONTAINS_PLACEHOLDER_P (orig_size))
orig_size = max_size (orig_size, 1);
/* If the size was widened explicitly, maybe give a warning. */
@@ -4772,10 +4931,11 @@ gnat_to_gnu_field (gnat_field, gnu_record_type, packed, definition)
tree gnu_field;
int needs_strict_alignment
= (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
- || Is_Volatile (gnat_field));
+ || Treat_As_Volatile (gnat_field));
- /* If this field requires strict alignment pretend it isn't packed. */
- if (needs_strict_alignment)
+ /* If this field requires strict alignment or contains an item of
+ variable sized, pretend it isn't packed. */
+ if (needs_strict_alignment || is_variable_size (gnu_field_type))
packed = 0;
/* For packed records, this is one of the few occasions on which we use
@@ -4818,6 +4978,11 @@ gnat_to_gnu_field (gnat_field, gnu_record_type, packed, definition)
gnu_size = rm_size (gnu_field_type);
}
+ /* If we are packing the record and the field is BLKmode, round the
+ size up to a byte boundary. */
+ if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size != 0)
+ gnu_size = round_up (gnu_size, BITS_PER_UNIT);
+
if (Present (Component_Clause (gnat_field)))
{
gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
@@ -4877,7 +5042,7 @@ gnat_to_gnu_field (gnat_field, gnu_record_type, packed, definition)
gnu_size = 0;
}
- if (! integer_zerop (size_binop
+ if (! integer_zerop (size_binop
(TRUNC_MOD_EXPR, gnu_pos,
bitsize_int (TYPE_ALIGN (gnu_field_type)))))
{
@@ -4887,7 +5052,7 @@ gnat_to_gnu_field (gnat_field, gnu_record_type, packed, definition)
First_Bit (Component_Clause (gnat_field)), gnat_field,
TYPE_ALIGN (gnu_field_type));
- else if (Is_Volatile (gnat_field))
+ else if (Treat_As_Volatile (gnat_field))
post_error_ne_num
("position of volatile field& must be multiple of ^ bits",
First_Bit (Component_Clause (gnat_field)), gnat_field,
@@ -4913,22 +5078,15 @@ gnat_to_gnu_field (gnat_field, gnu_record_type, packed, definition)
if (Is_Atomic (gnat_field))
check_ok_for_atomic (gnu_field_type, gnat_field, 0);
- if (gnu_pos !=0 && TYPE_MODE (gnu_field_type) == BLKmode
+ if (gnu_pos != 0 && TYPE_MODE (gnu_field_type) == BLKmode
&& (! integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_pos,
- bitsize_unit_node))))
+ bitsize_unit_node)))
+ && TYPE_MODE (gnu_field_type) == BLKmode)
{
- /* Try to see if we can make this a packable type. If we
- can, it's OK. */
- if (TREE_CODE (gnu_field_type) == RECORD_TYPE)
- gnu_field_type = make_packable_type (gnu_field_type);
-
- if (TYPE_MODE (gnu_field_type) == BLKmode)
- {
- post_error_ne ("fields of& must start at storage unit boundary",
- First_Bit (Component_Clause (gnat_field)),
- Etype (gnat_field));
- gnu_pos = 0;
- }
+ post_error_ne ("fields of& must start at storage unit boundary",
+ First_Bit (Component_Clause (gnat_field)),
+ Etype (gnat_field));
+ gnu_pos = 0;
}
}
@@ -4941,13 +5099,23 @@ gnat_to_gnu_field (gnat_field, gnu_record_type, packed, definition)
gnu_size = TYPE_SIZE (gnu_field_type);
}
+ /* If a size is specified and this is a BLKmode field, it must be an
+ integral number of bytes. */
+ if (gnu_size != 0 && TYPE_MODE (gnu_field_type) == BLKmode
+ && ! integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_size,
+ bitsize_unit_node)))
+ {
+ post_error_ne ("size of fields of& must be multiple of a storage unit",
+ gnat_field, Etype (gnat_field));
+ gnu_pos = gnu_size = 0;
+ }
+
/* We need to make the size the maximum for the type if it is
self-referential and an unconstrained type. In that case, we can't
pack the field since we can't make a copy to align it. */
if (TREE_CODE (gnu_field_type) == RECORD_TYPE
&& gnu_size == 0
- && ! TREE_CONSTANT (TYPE_SIZE (gnu_field_type))
- && contains_placeholder_p (TYPE_SIZE (gnu_field_type))
+ && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
&& ! Is_Constrained (Underlying_Type (Etype (gnat_field))))
{
gnu_size = max_size (TYPE_SIZE (gnu_field_type), 1);
@@ -4979,12 +5147,13 @@ gnat_to_gnu_field (gnat_field, gnu_record_type, packed, definition)
&& TYPE_CONTAINS_TEMPLATE_P (gnu_field_type))
gigi_abort (118);
+ /* Now create the decl for the field. */
set_lineno (gnat_field, 0);
gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
packed, gnu_size, gnu_pos,
Is_Aliased (gnat_field));
- TREE_THIS_VOLATILE (gnu_field) = Is_Volatile (gnat_field);
+ TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
if (Ekind (gnat_field) == E_Discriminant)
DECL_DISCRIMINANT_NUMBER (gnu_field)
@@ -4993,6 +5162,36 @@ gnat_to_gnu_field (gnat_field, gnu_record_type, packed, definition)
return gnu_field;
}
+/* Return 1 if TYPE is a type with variable size, a padding type with a field
+ of variable size or is a record that has a field such a field. */
+
+static int
+is_variable_size (type)
+ tree type;
+{
+ tree field;
+
+ /* We need not be concerned about this at all if we don't have
+ strict alignment. */
+ if (! STRICT_ALIGNMENT)
+ return 0;
+ else if (! TREE_CONSTANT (TYPE_SIZE (type)))
+ return 1;
+ else if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)
+ && ! TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
+ return 1;
+ else if (TREE_CODE (type) != RECORD_TYPE
+ && TREE_CODE (type) != UNION_TYPE
+ && TREE_CODE (type) != QUAL_UNION_TYPE)
+ return 0;
+
+ for (field = TYPE_FIELDS (type); field != 0; field = TREE_CHAIN (field))
+ if (is_variable_size (TREE_TYPE (field)))
+ return 1;
+
+ return 0;
+}
+
/* Return a GCC tree for a record type given a GNAT Component_List and a chain
of GCC trees for fields that are in the record and have already been
processed. When called from gnat_to_gnu_entity during the processing of a
@@ -5041,6 +5240,7 @@ components_to_record (gnu_record_type, component_list, gnu_field_list, packed,
tree gnu_our_rep_list = NULL_TREE;
tree gnu_field, gnu_last;
int layout_with_rep = 0;
+ int all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type) != 0;
/* For each variable within each component declaration create a GCC field
and add it to the list, skipping any pragmas in the list. */
@@ -5060,7 +5260,8 @@ components_to_record (gnu_record_type, component_list, gnu_field_list, packed,
packed, definition);
/* If this is the _Tag field, put it before any discriminants,
- instead of after them as is the case for all other fields. */
+ instead of after them as is the case for all other fields.
+ Ignore field of void type if only annotating. */
if (Chars (gnat_field) == Name_uTag)
gnu_field_list = chainon (gnu_field_list, gnu_field);
else
@@ -5137,16 +5338,33 @@ components_to_record (gnu_record_type, component_list, gnu_field_list, packed,
so the record actually gets only the alignment required. */
TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
+
+ /* Similarly, if the outer record has a size specified and all fields
+ have record rep clauses, we can propagate the size into the
+ variant part. */
+ if (all_rep_and_size)
+ {
+ TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
+ TYPE_SIZE_UNIT (gnu_variant_type)
+ = TYPE_SIZE_UNIT (gnu_record_type);
+ }
+
components_to_record (gnu_variant_type, Component_List (variant),
NULL_TREE, packed, definition,
- &gnu_our_rep_list, 1, all_rep);
+ &gnu_our_rep_list, !all_rep_and_size, all_rep);
gnu_qual = choices_to_gnu (gnu_discriminant,
Discrete_Choices (variant));
Set_Present_Expr (variant, annotate_value (gnu_qual));
gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
- gnu_union_type, 0, 0, 0, 1);
+ gnu_union_type, 0,
+ (all_rep_and_size
+ ? TYPE_SIZE (gnu_record_type) : 0),
+ (all_rep_and_size
+ ? bitsize_zero_node : 0),
+ 1);
+
DECL_INTERNAL_P (gnu_field) = 1;
DECL_QUALIFIER (gnu_field) = gnu_qual;
TREE_CHAIN (gnu_field) = gnu_variant_list;
@@ -5162,8 +5380,15 @@ components_to_record (gnu_record_type, component_list, gnu_field_list, packed,
/* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
if (gnu_variant_list != 0)
{
+ if (all_rep_and_size)
+ {
+ TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
+ TYPE_SIZE_UNIT (gnu_union_type)
+ = TYPE_SIZE_UNIT (gnu_record_type);
+ }
+
finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
- 0, 0);
+ all_rep_and_size, 0);
gnu_union_field
= create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
@@ -5297,10 +5522,19 @@ annotate_value (gnu_size)
{
int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
TCode tcode;
- Node_Ref_Or_Val ops[3];
+ Node_Ref_Or_Val ops[3], ret;
int i;
int size;
+ /* If back annotation is suppressed by the front end, return No_Uint */
+ if (!Back_Annotate_Rep_Info)
+ return No_Uint;
+
+ /* See if we've already saved the value for this node. */
+ if (IS_EXPR_CODE_CLASS (TREE_CODE_CLASS (TREE_CODE (gnu_size)))
+ && TREE_COMPLEXITY (gnu_size) != 0)
+ return (Node_Ref_Or_Val) TREE_COMPLEXITY (gnu_size);
+
/* If we do not return inside this switch, TCODE will be set to the
code to use for a Create_Node operand and LEN (set above) will be
the number of recursive calls for us to make. */
@@ -5412,7 +5646,9 @@ annotate_value (gnu_size)
return No_Uint;
}
- return Create_Node (tcode, ops[0], ops[1], ops[2]);
+ ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
+ TREE_COMPLEXITY (gnu_size) = ret;
+ return ret;
}
/* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
@@ -5439,20 +5675,55 @@ annotate_rep (gnat_entity, gnu_type)
gnat_field = Next_Entity (gnat_field))
if ((Ekind (gnat_field) == E_Component
|| (Ekind (gnat_field) == E_Discriminant
- && ! Is_Unchecked_Union (Scope (gnat_field))))
- && 0 != (gnu_entry = purpose_member (gnat_to_gnu_entity (gnat_field,
- NULL_TREE, 0),
- gnu_list)))
+ && ! Is_Unchecked_Union (Scope (gnat_field)))))
{
- Set_Component_Bit_Offset
- (gnat_field,
- annotate_value (bit_from_pos
- (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
- TREE_VALUE (TREE_VALUE
- (TREE_VALUE (gnu_entry))))));
-
- Set_Esize (gnat_field,
- annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
+ tree parent_offset = bitsize_zero_node;
+
+ gnu_entry
+ = purpose_member (gnat_to_gnu_entity (gnat_field, NULL_TREE, 0),
+ gnu_list);
+
+ if (gnu_entry)
+ {
+ if (type_annotate_only && Is_Tagged_Type (gnat_entity))
+ {
+ /* In this mode the tag and parent components have not been
+ generated, so we add the appropriate offset to each
+ component. For a component appearing in the current
+ extension, the offset is the size of the parent. */
+ if (Is_Derived_Type (gnat_entity)
+ && Original_Record_Component (gnat_field) == gnat_field)
+ parent_offset
+ = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
+ bitsizetype);
+ else
+ parent_offset = bitsize_int (POINTER_SIZE);
+ }
+
+ Set_Component_Bit_Offset
+ (gnat_field,
+ annotate_value
+ (size_binop (PLUS_EXPR,
+ bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
+ TREE_VALUE (TREE_VALUE
+ (TREE_VALUE (gnu_entry)))),
+ parent_offset)));
+
+ Set_Esize (gnat_field,
+ annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
+ }
+ else if (type_annotate_only
+ && Is_Tagged_Type (gnat_entity)
+ && Is_Derived_Type (gnat_entity))
+ {
+ /* If there is no gnu_entry, this is an inherited component whose
+ position is the same as in the parent type. */
+ Set_Component_Bit_Offset
+ (gnat_field,
+ Component_Bit_Offset (Original_Record_Component (gnat_field)));
+ Set_Esize (gnat_field,
+ Esize (Original_Record_Component (gnat_field)));
+ }
}
}
@@ -5527,13 +5798,7 @@ validate_size (uint_size, gnu_type, gnat_object, kind, component_p, zero_ok)
= kind == VAR_DECL ? TYPE_SIZE (gnu_type) : rm_size (gnu_type);
tree size;
- if (type_size != 0 && TREE_CODE (type_size) != INTEGER_CST
- && contains_placeholder_p (type_size))
- type_size = max_size (type_size, 1);
-
- if (TYPE_FAT_POINTER_P (gnu_type))
- type_size = bitsize_int (POINTER_SIZE);
-
+ /* Find the node to use for errors. */
if ((Ekind (gnat_object) == E_Component
|| Ekind (gnat_object) == E_Discriminant)
&& Present (Component_Clause (gnat_object)))
@@ -5548,30 +5813,25 @@ validate_size (uint_size, gnu_type, gnat_object, kind, component_p, zero_ok)
if (Is_Packed_Array_Type (gnat_object))
gnat_error_node = Empty;
- /* Get the size as a tree. Return 0 if none was specified, either because
- Esize was not Present or if the specified size was zero. Give an error
- if a size was specified, but cannot be represented as in sizetype. If
- the size is negative, it was a back-annotation of a variable size and
- should be treated as not specified. */
+ /* Return 0 if no size was specified, either because Esize was not Present or
+ the specified size was zero. */
if (No (uint_size) || uint_size == No_Uint)
return 0;
+ /* Get the size as a tree. Give an error if a size was specified, but cannot
+ be represented as in sizetype. */
size = UI_To_gnu (uint_size, bitsizetype);
if (TREE_OVERFLOW (size))
{
- if (component_p)
- post_error_ne ("component size of & is too large",
- gnat_error_node, gnat_object);
- else
- post_error_ne ("size of & is too large", gnat_error_node, gnat_object);
-
+ post_error_ne (component_p ? "component size of & is too large"
+ : "size of & is too large",
+ gnat_error_node, gnat_object);
return 0;
}
-
/* Ignore a negative size since that corresponds to our back-annotation.
Also ignore a zero size unless a size clause exists. */
else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && ! zero_ok))
- return 0;
+ return 0;
/* The size of objects is always a multiple of a byte. */
if (kind == VAR_DECL
@@ -5601,6 +5861,13 @@ validate_size (uint_size, gnu_type, gnat_object, kind, component_p, zero_ok)
&& TYPE_CONTAINS_TEMPLATE_P (gnu_type))
size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
+ /* Modify the size of the type to be that of the maximum size if it has a
+ discriminant or the size of a thin pointer if this is a fat pointer. */
+ if (type_size != 0 && CONTAINS_PLACEHOLDER_P (type_size))
+ type_size = max_size (type_size, 1);
+ else if (TYPE_FAT_POINTER_P (gnu_type))
+ type_size = bitsize_int (POINTER_SIZE);
+
/* If the size of the object is a constant, the new size must not be
smaller. */
if (TREE_CODE (type_size) != INTEGER_CST
@@ -5677,8 +5944,7 @@ set_rm_size (uint_size, gnu_type, gnat_entity)
return;
/* If the old size is self-referential, get the maximum size. */
- if (TREE_CODE (old_size) != INTEGER_CST
- && contains_placeholder_p (old_size))
+ if (CONTAINS_PLACEHOLDER_P (old_size))
old_size = max_size (old_size, 1);
/* If the size of the object is a constant, the new size must not be
@@ -5882,7 +6148,7 @@ check_ok_for_atomic (object, gnat_entity, comp_p)
/* For the moment, also allow anything that has an alignment equal
to its size and which is smaller than a word. */
- if (TREE_CODE (size) == INTEGER_CST
+ if (size != 0 && TREE_CODE (size) == INTEGER_CST
&& compare_tree_int (size, align) == 0
&& align <= BITS_PER_WORD)
return;
@@ -5927,10 +6193,8 @@ gnat_substitute_in_type (t, f, r)
case ENUMERAL_TYPE:
case BOOLEAN_TYPE:
case CHAR_TYPE:
- if ((TREE_CODE (TYPE_MIN_VALUE (t)) != INTEGER_CST
- && contains_placeholder_p (TYPE_MIN_VALUE (t)))
- || (TREE_CODE (TYPE_MAX_VALUE (t)) != INTEGER_CST
- && contains_placeholder_p (TYPE_MAX_VALUE (t))))
+ if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
+ || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
{
tree low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r);
tree high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r);
@@ -5940,7 +6204,7 @@ gnat_substitute_in_type (t, f, r)
new = build_range_type (TREE_TYPE (t), low, high);
if (TYPE_INDEX_TYPE (t))
- SET_TYPE_INDEX_TYPE (new,
+ SET_TYPE_INDEX_TYPE (new,
gnat_substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
return new;
}
@@ -5949,11 +6213,9 @@ gnat_substitute_in_type (t, f, r)
case REAL_TYPE:
if ((TYPE_MIN_VALUE (t) != 0
- && TREE_CODE (TYPE_MIN_VALUE (t)) != REAL_CST
- && contains_placeholder_p (TYPE_MIN_VALUE (t)))
+ && CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t)))
|| (TYPE_MAX_VALUE (t) != 0
- && TREE_CODE (TYPE_MAX_VALUE (t)) != REAL_CST
- && contains_placeholder_p (TYPE_MAX_VALUE (t))))
+ && CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t))))
{
tree low = 0, high = 0;
@@ -6181,6 +6443,28 @@ create_concat_name (gnat_entity, suffix)
Get_External_Name_With_Suffix (gnat_entity, fp);
+#ifdef _WIN32
+ /* A variable using the Stdcall convention (meaning we are running
+ on a Windows box) live in a DLL. Here we adjust its name to use
+ the jump-table, the _imp__NAME contains the address for the NAME
+ variable. */
+
+ {
+ Entity_Kind kind = Ekind (gnat_entity);
+ char *prefix = "_imp__";
+ int plen = strlen (prefix);
+
+ if ((kind == E_Variable || kind == E_Constant)
+ && Convention (gnat_entity) == Convention_Stdcall)
+ {
+ int k;
+ for (k = 0; k <= Name_Len; k++)
+ Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
+ strncpy (Name_Buffer, prefix, plen);
+ }
+ }
+#endif
+
return get_identifier (Name_Buffer);
}
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 11a14fbc1ad..6eac0d78359 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -6,14 +6,14 @@
-- --
-- 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- or FITNESS FOR A CPARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
@@ -80,10 +80,10 @@ package body Einfo is
-- Hiding_Loop_Variable Node8
-- Mechanism Uint8 (but returns Mechanism_Type)
-- Normalized_First_Bit Uint8
+ -- Non_Limited_Views Elist8
-- Class_Wide_Type Node9
- -- Normalized_Position Uint9
- -- Size_Check_Code Node9
+ -- Current_Value Node9
-- Renaming_Map Uint9
-- Discriminal_Link Node10
@@ -95,6 +95,7 @@ package body Einfo is
-- Full_View Node11
-- Entry_Component Node11
-- Enumeration_Pos Uint11
+ -- Generic_Homonym Node11
-- Protected_Body_Subprogram Node11
-- Block_Node Node11
@@ -112,6 +113,7 @@ package body Einfo is
-- Alignment Uint14
-- First_Optional_Parameter Node14
+ -- Normalized_Position Uint14
-- Shadow_Entities List14
-- Discriminant_Number Uint15
@@ -145,6 +147,7 @@ package body Einfo is
-- First_Literal Node17
-- Master_Id Node17
-- Modulus Uint17
+ -- Non_Limited_View Node17
-- Object_Ref Node17
-- Prival Node17
@@ -163,6 +166,7 @@ package body Einfo is
-- Finalization_Chain_Entity Node19
-- Parent_Subtype Node19
-- Related_Array_Object Node19
+ -- Size_Check_Code Node19
-- Spec_Entity Node19
-- Underlying_Full_View Node19
@@ -195,13 +199,14 @@ package body Einfo is
-- Associated_Final_Chain Node23
-- CR_Discriminant Node23
- -- Girder_Constraint Elist23
+ -- Stored_Constraint Elist23
-- Entry_Cancel_Parameter Node23
-- Extra_Constrained Node23
-- Generic_Renamings Elist23
-- Inner_Instances Elist23
-- Enum_Pos_To_Rep Node23
-- Packed_Array_Type Node23
+ -- Limited_Views Elist23
-- Privals_Chain Elist23
-- Protected_Operation Node23
@@ -225,6 +230,7 @@ package body Einfo is
-- In_Use Flag8
-- Is_Potentially_Use_Visible Flag9
-- Is_Public Flag10
+
-- Is_Inlined Flag11
-- Is_Constrained Flag12
-- Is_Generic_Type Flag13
@@ -235,6 +241,7 @@ package body Einfo is
-- Has_Delayed_Freeze Flag18
-- Is_Abstract Flag19
-- Is_Concurrent_Record_Type Flag20
+
-- Has_Master_Entity Flag21
-- Needs_No_Actuals Flag22
-- Has_Storage_Size_Clause Flag23
@@ -245,17 +252,19 @@ package body Einfo is
-- Is_Statically_Allocated Flag28
-- Has_Size_Clause Flag29
-- Has_Task Flag30
- -- Suppress_Access_Checks Flag31
- -- Suppress_Accessibility_Checks Flag32
- -- Suppress_Discriminant_Checks Flag33
- -- Suppress_Division_Checks Flag34
- -- Suppress_Elaboration_Checks Flag35
- -- Suppress_Index_Checks Flag36
- -- Suppress_Length_Checks Flag37
- -- Suppress_Overflow_Checks Flag38
- -- Suppress_Range_Checks Flag39
- -- Suppress_Storage_Checks Flag40
- -- Suppress_Tag_Checks Flag41
+
+ -- Checks_May_Be_Suppressed Flag31
+ -- Kill_Elaboration_Checks Flag32
+ -- Kill_Range_Checks Flag33
+ -- Kill_Tag_Checks Flag34
+ -- Is_Class_Wide_Equivalent_Type Flag35
+ -- Referenced_As_LHS Flag36
+ -- Is_Known_Non_Null Flag37
+ -- Can_Never_Be_Null Flag38
+ -- Is_Overriding_Operation Flag39
+ -- Body_Needed_For_SAL Flag40
+
+ -- Treat_As_Volatile Flag41
-- Is_Controlled Flag42
-- Has_Controlled_Component Flag43
-- Is_Pure Flag44
@@ -265,6 +274,7 @@ package body Einfo is
-- In_Package_Body Flag48
-- Reachable Flag49
-- Delay_Subprogram_Descriptors Flag50
+
-- Is_Packed Flag51
-- Is_Entry_Formal Flag52
-- Is_Private_Descendant Flag53
@@ -275,6 +285,7 @@ package body Einfo is
-- Non_Binary_Modulus Flag58
-- Is_Preelaborated Flag59
-- Is_Shared_Passive Flag60
+
-- Is_Remote_Types Flag61
-- Is_Remote_Call_Interface Flag62
-- Is_Character_Type Flag63
@@ -285,16 +296,17 @@ package body Einfo is
-- Has_Component_Size_Clause Flag68
-- Is_Access_Constant Flag69
-- Is_First_Subtype Flag70
+
-- Has_Completion_In_Body Flag71
-- Has_Unknown_Discriminants Flag72
-- Is_Child_Unit Flag73
-- Is_CPP_Class Flag74
-- Has_Non_Standard_Rep Flag75
-- Is_Constructor Flag76
- -- Is_Destructor Flag77
-- Is_Tag Flag78
-- Has_All_Calls_Remote Flag79
-- Is_Constr_Subt_For_U_Nominal Flag80
+
-- Is_Asynchronous Flag81
-- Has_Gigi_Rep_Item Flag82
-- Has_Machine_Radix_Clause Flag83
@@ -305,6 +317,7 @@ package body Einfo is
-- Discard_Names Flag88
-- Is_Interrupt_Handler Flag89
-- Returns_By_Ref Flag90
+
-- Is_Itype Flag91
-- Size_Known_At_Compile_Time Flag92
-- Has_Subprogram_Descriptor Flag93
@@ -315,6 +328,7 @@ package body Einfo is
-- Has_Controlling_Result Flag98
-- Is_Exported Flag99
-- Has_Specified_Layout Flag100
+
-- Has_Nested_Block_With_Handler Flag101
-- Is_Called Flag102
-- Is_Completely_Hidden Flag103
@@ -325,16 +339,18 @@ package body Einfo is
-- Default_Expressions_Processed Flag108
-- Is_Non_Static_Subtype Flag109
-- Has_External_Tag_Rep_Clause Flag110
+
-- Is_Formal_Subprogram Flag111
-- Is_Renaming_Of_Object Flag112
-- No_Return Flag113
-- Delay_Cleanups Flag114
- -- Not_Source_Assigned Flag115
+ -- Never_Set_In_Source Flag115
-- Is_Visible_Child_Unit Flag116
-- Is_Unchecked_Union Flag117
-- Is_For_Access_Subtype Flag118
-- Has_Convention_Pragma Flag119
-- Has_Primitive_Operations Flag120
+
-- Has_Pragma_Pack Flag121
-- Is_Bit_Packed_Array Flag122
-- Has_Unchecked_Union Flag123
@@ -345,6 +361,7 @@ package body Einfo is
-- (used for Component_Alignment) Flag128
-- (used for Component_Alignment) Flag129
-- Is_Generic_Instance Flag130
+
-- No_Pool_Assigned Flag131
-- Is_AST_Entry Flag132
-- Is_VMS_Exception Flag133
@@ -354,6 +371,7 @@ package body Einfo is
-- Is_Packed_Array_Type Flag138
-- Has_Biased_Representation Flag139
-- Has_Complex_Representation Flag140
+
-- Is_Constr_Subt_For_UN_Aliased Flag141
-- Has_Missing_Return Flag142
-- Has_Recursive_Call Flag143
@@ -364,6 +382,7 @@ package body Einfo is
-- Suppress_Elaboration_Warnings Flag148
-- Is_Compilation_Unit Flag149
-- Has_Pragma_Elaborate_Body Flag150
+
-- Vax_Float Flag151
-- Entry_Accepted Flag152
-- Is_Psected Flag153
@@ -374,6 +393,7 @@ package body Einfo is
-- Finalize_Storage_Only Flag158
-- From_With_Type Flag159
-- Is_Package_Body_Entity Flag160
+
-- Has_Qualified_Name Flag161
-- Nonzero_Is_True Flag162
-- Is_True_Constant Flag163
@@ -384,6 +404,7 @@ package body Einfo is
-- Materialize_Entity Flag168
-- Function_Returns_With_DSP Flag169
-- Is_Known_Valid Flag170
+
-- Is_Hidden_Open_Scope Flag171
-- Has_Object_Size_Clause Flag172
-- Has_Fully_Qualified_Name Flag173
@@ -395,8 +416,13 @@ package body Einfo is
-- Has_Pragma_Pure_Function Flag179
-- Has_Pragma_Unreferenced Flag180
- -- (unused) Flag181
- -- (unused) Flag182
+ -- Has_Contiguous_Rep Flag181
+ -- Has_Xref_Entry Flag182
+
+ -- Remaining flags are currently unused and available
+
+ -- (unused) Flag77
+ -- (unused) Flag136
-- (unused) Flag183
--------------------------------
@@ -438,6 +464,12 @@ package body Einfo is
function Alignment (Id : E) return U is
begin
+ pragma Assert (Is_Type (Id)
+ or else Is_Formal (Id)
+ or else Ekind (Id) = E_Loop_Parameter
+ or else Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_Exception
+ or else Ekind (Id) = E_Variable);
return Uint14 (Id);
end Alignment;
@@ -483,12 +515,31 @@ package body Einfo is
return Node19 (Id);
end Body_Entity;
+ function Body_Needed_For_SAL (Id : E) return B is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Package
+ or else Is_Subprogram (Id)
+ or else Is_Generic_Unit (Id));
+ return Flag40 (Id);
+ end Body_Needed_For_SAL;
+
function C_Pass_By_Copy (Id : E) return B is
begin
pragma Assert (Is_Record_Type (Id));
return Flag125 (Implementation_Base_Type (Id));
end C_Pass_By_Copy;
+ function Can_Never_Be_Null (Id : E) return B is
+ begin
+ return Flag38 (Id);
+ end Can_Never_Be_Null;
+
+ function Checks_May_Be_Suppressed (Id : E) return B is
+ begin
+ return Flag31 (Id);
+ end Checks_May_Be_Suppressed;
+
function Class_Wide_Type (Id : E) return E is
begin
pragma Assert (Is_Type (Id));
@@ -560,6 +611,12 @@ package body Einfo is
return Node22 (Id);
end Corresponding_Remote_Type;
+ function Current_Value (Id : E) return N is
+ begin
+ pragma Assert (Ekind (Id) in Object_Kind);
+ return Node9 (Id);
+ end Current_Value;
+
function CR_Discriminant (Id : E) return E is
begin
return Node23 (Id);
@@ -892,17 +949,16 @@ package body Einfo is
return Flag169 (Id);
end Function_Returns_With_DSP;
- function Generic_Renamings (Id : E) return L is
+ function Generic_Homonym (Id : E) return E is
begin
- return Elist23 (Id);
- end Generic_Renamings;
+ pragma Assert (Ekind (Id) = E_Generic_Package);
+ return Node11 (Id);
+ end Generic_Homonym;
- function Girder_Constraint (Id : E) return L is
+ function Generic_Renamings (Id : E) return L is
begin
- pragma Assert
- (Is_Composite_Type (Id) and then not Is_Array_Type (Id));
return Elist23 (Id);
- end Girder_Constraint;
+ end Generic_Renamings;
function Handler_Records (Id : E) return S is
begin
@@ -962,6 +1018,11 @@ package body Einfo is
return Flag43 (Base_Type (Id));
end Has_Controlled_Component;
+ function Has_Contiguous_Rep (Id : E) return B is
+ begin
+ return Flag181 (Id);
+ end Has_Contiguous_Rep;
+
function Has_Controlling_Result (Id : E) return B is
begin
return Flag98 (Id);
@@ -1169,6 +1230,11 @@ package body Einfo is
return Flag87 (Implementation_Base_Type (Id));
end Has_Volatile_Components;
+ function Has_Xref_Entry (Id : E) return B is
+ begin
+ return Flag182 (Implementation_Base_Type (Id));
+ end Has_Xref_Entry;
+
function Hiding_Loop_Variable (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Variable);
@@ -1263,6 +1329,11 @@ package body Einfo is
return Flag73 (Id);
end Is_Child_Unit;
+ function Is_Class_Wide_Equivalent_Type (Id : E) return B is
+ begin
+ return Flag35 (Id);
+ end Is_Class_Wide_Equivalent_Type;
+
function Is_Compilation_Unit (Id : E) return B is
begin
return Flag149 (Id);
@@ -1311,11 +1382,6 @@ package body Einfo is
return Flag74 (Id);
end Is_CPP_Class;
- function Is_Destructor (Id : E) return B is
- begin
- return Flag77 (Id);
- end Is_Destructor;
-
function Is_Discrim_SO_Function (Id : E) return B is
begin
return Flag176 (Id);
@@ -1436,6 +1502,11 @@ package body Einfo is
return Flag91 (Id);
end Is_Itype;
+ function Is_Known_Non_Null (Id : E) return B is
+ begin
+ return Flag37 (Id);
+ end Is_Known_Non_Null;
+
function Is_Known_Valid (Id : E) return B is
begin
return Flag170 (Id);
@@ -1475,6 +1546,12 @@ package body Einfo is
return Flag134 (Id);
end Is_Optional_Parameter;
+ function Is_Overriding_Operation (Id : E) return B is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ return Flag39 (Id);
+ end Is_Overriding_Operation;
+
function Is_Package_Body_Entity (Id : E) return B is
begin
return Flag160 (Id);
@@ -1600,14 +1677,39 @@ package body Einfo is
function Is_Volatile (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
- return Flag16 (Id);
+ if Is_Type (Id) then
+ return Flag16 (Base_Type (Id));
+ else
+ return Flag16 (Id);
+ end if;
end Is_Volatile;
+ function Kill_Elaboration_Checks (Id : E) return B is
+ begin
+ return Flag32 (Id);
+ end Kill_Elaboration_Checks;
+
+ function Kill_Range_Checks (Id : E) return B is
+ begin
+ return Flag33 (Id);
+ end Kill_Range_Checks;
+
+ function Kill_Tag_Checks (Id : E) return B is
+ begin
+ return Flag34 (Id);
+ end Kill_Tag_Checks;
+
function Last_Entity (Id : E) return E is
begin
return Node20 (Id);
end Last_Entity;
+ function Limited_Views (Id : E) return L is
+ begin
+ pragma Assert (Ekind (Id) = E_Package);
+ return Elist23 (Id);
+ end Limited_Views;
+
function Lit_Indexes (Id : E) return E is
begin
pragma Assert (Is_Enumeration_Type (Id));
@@ -1662,6 +1764,11 @@ package body Einfo is
return Flag22 (Id);
end Needs_No_Actuals;
+ function Never_Set_In_Source (Id : E) return B is
+ begin
+ return Flag115 (Id);
+ end Never_Set_In_Source;
+
function Next_Inlined_Subprogram (Id : E) return E is
begin
return Node12 (Id);
@@ -1676,7 +1783,9 @@ package body Einfo is
function No_Return (Id : E) return B is
begin
pragma Assert
- (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Generic_Procedure);
+ (Id = Any_Id
+ or else Ekind (Id) = E_Procedure
+ or else Ekind (Id) = E_Generic_Procedure);
return Flag113 (Id);
end No_Return;
@@ -1686,6 +1795,20 @@ package body Einfo is
return Flag58 (Base_Type (Id));
end Non_Binary_Modulus;
+ function Non_Limited_View (Id : E) return E is
+ begin
+ pragma Assert (False
+ or else Ekind (Id) = E_Incomplete_Type
+ or else Ekind (Id) = E_Package);
+ return Node17 (Id);
+ end Non_Limited_View;
+
+ function Non_Limited_Views (Id : E) return L is
+ begin
+ pragma Assert (Ekind (Id) = E_Package);
+ return Elist8 (Id);
+ end Non_Limited_Views;
+
function Nonzero_Is_True (Id : E) return B is
begin
pragma Assert (Root_Type (Id) = Standard_Boolean);
@@ -1703,7 +1826,7 @@ package body Einfo is
begin
pragma Assert
(Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
- return Uint9 (Id);
+ return Uint14 (Id);
end Normalized_Position;
function Normalized_Position_Max (Id : E) return U is
@@ -1713,11 +1836,6 @@ package body Einfo is
return Uint10 (Id);
end Normalized_Position_Max;
- function Not_Source_Assigned (Id : E) return B is
- begin
- return Flag115 (Id);
- end Not_Source_Assigned;
-
function Object_Ref (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Protected_Body);
@@ -1732,6 +1850,10 @@ package body Einfo is
function Original_Record_Component (Id : E) return E is
begin
+ pragma Assert
+ (Ekind (Id) = E_Void
+ or else Ekind (Id) = E_Component
+ or else Ekind (Id) = E_Discriminant);
return Node22 (Id);
end Original_Record_Component;
@@ -1806,6 +1928,11 @@ package body Einfo is
return Flag156 (Id);
end Referenced;
+ function Referenced_As_LHS (Id : E) return B is
+ begin
+ return Flag36 (Id);
+ end Referenced_As_LHS;
+
function Referenced_Object (Id : E) return N is
begin
pragma Assert (Is_Type (Id));
@@ -1826,7 +1953,8 @@ package body Einfo is
function Related_Instance (Id : E) return E is
begin
- pragma Assert (Ekind (Id) = E_Package);
+ pragma Assert
+ (Ekind (Id) = E_Package or else Ekind (Id) = E_Package_Body);
return Node15 (Id);
end Related_Instance;
@@ -1909,7 +2037,7 @@ package body Einfo is
function Size_Check_Code (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable);
- return Node9 (Id);
+ return Node19 (Id);
end Size_Check_Code;
function Size_Depends_On_Discriminant (Id : E) return B is
@@ -1941,6 +2069,13 @@ package body Einfo is
return Node15 (Implementation_Base_Type (Id));
end Storage_Size_Variable;
+ function Stored_Constraint (Id : E) return L is
+ begin
+ pragma Assert
+ (Is_Composite_Type (Id) and then not Is_Array_Type (Id));
+ return Elist23 (Id);
+ end Stored_Constraint;
+
function Strict_Alignment (Id : E) return B is
begin
return Flag145 (Implementation_Base_Type (Id));
@@ -1956,75 +2091,25 @@ package body Einfo is
return Node15 (Id);
end String_Literal_Low_Bound;
- function Suppress_Access_Checks (Id : E) return B is
- begin
- return Flag31 (Id);
- end Suppress_Access_Checks;
-
- function Suppress_Accessibility_Checks (Id : E) return B is
- begin
- return Flag32 (Id);
- end Suppress_Accessibility_Checks;
-
- function Suppress_Discriminant_Checks (Id : E) return B is
- begin
- return Flag33 (Id);
- end Suppress_Discriminant_Checks;
-
- function Suppress_Division_Checks (Id : E) return B is
- begin
- return Flag34 (Id);
- end Suppress_Division_Checks;
-
- function Suppress_Elaboration_Checks (Id : E) return B is
- begin
- return Flag35 (Id);
- end Suppress_Elaboration_Checks;
-
function Suppress_Elaboration_Warnings (Id : E) return B is
begin
return Flag148 (Id);
end Suppress_Elaboration_Warnings;
- function Suppress_Index_Checks (Id : E) return B is
- begin
- return Flag36 (Id);
- end Suppress_Index_Checks;
-
function Suppress_Init_Proc (Id : E) return B is
begin
return Flag105 (Base_Type (Id));
end Suppress_Init_Proc;
- function Suppress_Length_Checks (Id : E) return B is
- begin
- return Flag37 (Id);
- end Suppress_Length_Checks;
-
- function Suppress_Overflow_Checks (Id : E) return B is
- begin
- return Flag38 (Id);
- end Suppress_Overflow_Checks;
-
- function Suppress_Range_Checks (Id : E) return B is
- begin
- return Flag39 (Id);
- end Suppress_Range_Checks;
-
- function Suppress_Storage_Checks (Id : E) return B is
- begin
- return Flag40 (Id);
- end Suppress_Storage_Checks;
-
function Suppress_Style_Checks (Id : E) return B is
begin
return Flag165 (Id);
end Suppress_Style_Checks;
- function Suppress_Tag_Checks (Id : E) return B is
+ function Treat_As_Volatile (Id : E) return B is
begin
return Flag41 (Id);
- end Suppress_Tag_Checks;
+ end Treat_As_Volatile;
function Underlying_Full_View (Id : E) return E is
begin
@@ -2145,6 +2230,11 @@ package body Einfo is
return Ekind (Id) in Formal_Kind;
end Is_Formal;
+ function Is_Generic_Subprogram (Id : E) return B is
+ begin
+ return Ekind (Id) in Generic_Subprogram_Kind;
+ end Is_Generic_Subprogram;
+
function Is_Generic_Unit (Id : E) return B is
begin
return Ekind (Id) in Generic_Unit_Kind;
@@ -2300,6 +2390,12 @@ package body Einfo is
procedure Set_Alignment (Id : E; V : U) is
begin
+ pragma Assert (Is_Type (Id)
+ or else Is_Formal (Id)
+ or else Ekind (Id) = E_Loop_Parameter
+ or else Ekind (Id) = E_Constant
+ or else Ekind (Id) = E_Exception
+ or else Ekind (Id) = E_Variable);
Set_Uint14 (Id, V);
end Set_Alignment;
@@ -2322,12 +2418,31 @@ package body Einfo is
Set_Node19 (Id, V);
end Set_Body_Entity;
+ procedure Set_Body_Needed_For_SAL (Id : E; V : B := True) is
+ begin
+ pragma Assert
+ (Ekind (Id) = E_Package
+ or else Is_Subprogram (Id)
+ or else Is_Generic_Unit (Id));
+ Set_Flag40 (Id, V);
+ end Set_Body_Needed_For_SAL;
+
procedure Set_C_Pass_By_Copy (Id : E; V : B := True) is
begin
pragma Assert (Is_Record_Type (Id) and then Id = Base_Type (Id));
Set_Flag125 (Id, V);
end Set_C_Pass_By_Copy;
+ procedure Set_Can_Never_Be_Null (Id : E; V : B := True) is
+ begin
+ Set_Flag38 (Id, V);
+ end Set_Can_Never_Be_Null;
+
+ procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True) is
+ begin
+ Set_Flag31 (Id, V);
+ end Set_Checks_May_Be_Suppressed;
+
procedure Set_Class_Wide_Type (Id : E; V : E) is
begin
pragma Assert (Is_Type (Id));
@@ -2401,6 +2516,12 @@ package body Einfo is
Set_Node22 (Id, V);
end Set_Corresponding_Remote_Type;
+ procedure Set_Current_Value (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind (Id) in Object_Kind or else Ekind (Id) = E_Void);
+ Set_Node9 (Id, V);
+ end Set_Current_Value;
+
procedure Set_CR_Discriminant (Id : E; V : E) is
begin
Set_Node23 (Id, V);
@@ -2500,8 +2621,7 @@ package body Einfo is
procedure Set_Discriminant_Checking_Func (Id : E; V : E) is
begin
- pragma Assert
- (Ekind (Id) = E_Component and Ekind (Scope (Id)) in Record_Kind);
+ pragma Assert (Ekind (Id) = E_Component);
Set_Node20 (Id, V);
end Set_Discriminant_Checking_Func;
@@ -2742,16 +2862,15 @@ package body Einfo is
Set_Flag169 (Id, V);
end Set_Function_Returns_With_DSP;
- procedure Set_Generic_Renamings (Id : E; V : L) is
+ procedure Set_Generic_Homonym (Id : E; V : E) is
begin
- Set_Elist23 (Id, V);
- end Set_Generic_Renamings;
+ Set_Node11 (Id, V);
+ end Set_Generic_Homonym;
- procedure Set_Girder_Constraint (Id : E; V : L) is
+ procedure Set_Generic_Renamings (Id : E; V : L) is
begin
- pragma Assert (Nkind (Id) in N_Entity);
Set_Elist23 (Id, V);
- end Set_Girder_Constraint;
+ end Set_Generic_Renamings;
procedure Set_Handler_Records (Id : E; V : S) is
begin
@@ -2810,6 +2929,11 @@ package body Einfo is
Set_Flag68 (Id, V);
end Set_Has_Component_Size_Clause;
+ procedure Set_Has_Contiguous_Rep (Id : E; V : B := True) is
+ begin
+ Set_Flag181 (Id, V);
+ end Set_Has_Contiguous_Rep;
+
procedure Set_Has_Controlled_Component (Id : E; V : B := True) is
begin
pragma Assert (Base_Type (Id) = Id);
@@ -3029,6 +3153,11 @@ package body Einfo is
Set_Flag87 (Id, V);
end Set_Has_Volatile_Components;
+ procedure Set_Has_Xref_Entry (Id : E; V : B := True) is
+ begin
+ Set_Flag182 (Id, V);
+ end Set_Has_Xref_Entry;
+
procedure Set_Hiding_Loop_Variable (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Variable);
@@ -3040,6 +3169,7 @@ package body Einfo is
pragma Assert (Id /= V);
Set_Node4 (Id, V);
end Set_Homonym;
+
procedure Set_In_Package_Body (Id : E; V : B := True) is
begin
Set_Flag48 (Id, V);
@@ -3126,6 +3256,11 @@ package body Einfo is
Set_Flag73 (Id, V);
end Set_Is_Child_Unit;
+ procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True) is
+ begin
+ Set_Flag35 (Id, V);
+ end Set_Is_Class_Wide_Equivalent_Type;
+
procedure Set_Is_Compilation_Unit (Id : E; V : B := True) is
begin
Set_Flag149 (Id, V);
@@ -3180,11 +3315,6 @@ package body Einfo is
Set_Flag74 (Id, V);
end Set_Is_CPP_Class;
- procedure Set_Is_Destructor (Id : E; V : B := True) is
- begin
- Set_Flag77 (Id, V);
- end Set_Is_Destructor;
-
procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True) is
begin
Set_Flag176 (Id, V);
@@ -3312,6 +3442,11 @@ package body Einfo is
Set_Flag91 (Id, V);
end Set_Is_Itype;
+ procedure Set_Is_Known_Non_Null (Id : E; V : B := True) is
+ begin
+ Set_Flag37 (Id, V);
+ end Set_Is_Known_Non_Null;
+
procedure Set_Is_Known_Valid (Id : E; V : B := True) is
begin
Set_Flag170 (Id, V);
@@ -3352,6 +3487,12 @@ package body Einfo is
Set_Flag134 (Id, V);
end Set_Is_Optional_Parameter;
+ procedure Set_Is_Overriding_Operation (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Subprogram (Id));
+ Set_Flag39 (Id, V);
+ end Set_Is_Overriding_Operation;
+
procedure Set_Is_Package_Body_Entity (Id : E; V : B := True) is
begin
Set_Flag160 (Id, V);
@@ -3489,11 +3630,32 @@ package body Einfo is
Set_Flag16 (Id, V);
end Set_Is_Volatile;
+ procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True) is
+ begin
+ Set_Flag32 (Id, V);
+ end Set_Kill_Elaboration_Checks;
+
+ procedure Set_Kill_Range_Checks (Id : E; V : B := True) is
+ begin
+ Set_Flag33 (Id, V);
+ end Set_Kill_Range_Checks;
+
+ procedure Set_Kill_Tag_Checks (Id : E; V : B := True) is
+ begin
+ Set_Flag34 (Id, V);
+ end Set_Kill_Tag_Checks;
+
procedure Set_Last_Entity (Id : E; V : E) is
begin
Set_Node20 (Id, V);
end Set_Last_Entity;
+ procedure Set_Limited_Views (Id : E; V : L) is
+ begin
+ pragma Assert (Ekind (Id) = E_Package);
+ Set_Elist23 (Id, V);
+ end Set_Limited_Views;
+
procedure Set_Lit_Indexes (Id : E; V : E) is
begin
pragma Assert (Is_Enumeration_Type (Id) and then Root_Type (Id) = Id);
@@ -3548,6 +3710,11 @@ package body Einfo is
Set_Flag22 (Id, V);
end Set_Needs_No_Actuals;
+ procedure Set_Never_Set_In_Source (Id : E; V : B := True) is
+ begin
+ Set_Flag115 (Id, V);
+ end Set_Never_Set_In_Source;
+
procedure Set_Next_Inlined_Subprogram (Id : E; V : E) is
begin
Set_Node12 (Id, V);
@@ -3572,6 +3739,20 @@ package body Einfo is
Set_Flag58 (Id, V);
end Set_Non_Binary_Modulus;
+ procedure Set_Non_Limited_View (Id : E; V : E) is
+ pragma Assert (False
+ or else Ekind (Id) = E_Incomplete_Type
+ or else Ekind (Id) = E_Package);
+ begin
+ Set_Node17 (Id, V);
+ end Set_Non_Limited_View;
+
+ procedure Set_Non_Limited_Views (Id : E; V : L) is
+ begin
+ pragma Assert (Ekind (Id) = E_Package);
+ Set_Elist8 (Id, V);
+ end Set_Non_Limited_Views;
+
procedure Set_Nonzero_Is_True (Id : E; V : B := True) is
begin
pragma Assert
@@ -3591,7 +3772,7 @@ package body Einfo is
begin
pragma Assert
(Ekind (Id) = E_Component or else Ekind (Id) = E_Discriminant);
- Set_Uint9 (Id, V);
+ Set_Uint14 (Id, V);
end Set_Normalized_Position;
procedure Set_Normalized_Position_Max (Id : E; V : U) is
@@ -3601,11 +3782,6 @@ package body Einfo is
Set_Uint10 (Id, V);
end Set_Normalized_Position_Max;
- procedure Set_Not_Source_Assigned (Id : E; V : B := True) is
- begin
- Set_Flag115 (Id, V);
- end Set_Not_Source_Assigned;
-
procedure Set_Object_Ref (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Protected_Body);
@@ -3620,6 +3796,10 @@ package body Einfo is
procedure Set_Original_Record_Component (Id : E; V : E) is
begin
+ pragma Assert
+ (Ekind (Id) = E_Void
+ or else Ekind (Id) = E_Component
+ or else Ekind (Id) = E_Discriminant);
Set_Node22 (Id, V);
end Set_Original_Record_Component;
@@ -3694,6 +3874,11 @@ package body Einfo is
Set_Flag156 (Id, V);
end Set_Referenced;
+ procedure Set_Referenced_As_LHS (Id : E; V : B := True) is
+ begin
+ Set_Flag36 (Id, V);
+ end Set_Referenced_As_LHS;
+
procedure Set_Referenced_Object (Id : E; V : N) is
begin
pragma Assert (Is_Type (Id));
@@ -3714,7 +3899,8 @@ package body Einfo is
procedure Set_Related_Instance (Id : E; V : E) is
begin
- pragma Assert (Ekind (Id) = E_Package);
+ pragma Assert
+ (Ekind (Id) = E_Package or else Ekind (Id) = E_Package_Body);
Set_Node15 (Id, V);
end Set_Related_Instance;
@@ -3799,7 +3985,7 @@ package body Einfo is
procedure Set_Size_Check_Code (Id : E; V : N) is
begin
pragma Assert (Ekind (Id) = E_Constant or else Ekind (Id) = E_Variable);
- Set_Node9 (Id, V);
+ Set_Node19 (Id, V);
end Set_Size_Check_Code;
procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True) is
@@ -3831,6 +4017,12 @@ package body Einfo is
Set_Node15 (Id, V);
end Set_Storage_Size_Variable;
+ procedure Set_Stored_Constraint (Id : E; V : L) is
+ begin
+ pragma Assert (Nkind (Id) in N_Entity);
+ Set_Elist23 (Id, V);
+ end Set_Stored_Constraint;
+
procedure Set_Strict_Alignment (Id : E; V : B := True) is
begin
pragma Assert (Base_Type (Id) = Id);
@@ -3849,76 +4041,26 @@ package body Einfo is
Set_Node15 (Id, V);
end Set_String_Literal_Low_Bound;
- procedure Set_Suppress_Access_Checks (Id : E; V : B := True) is
- begin
- Set_Flag31 (Id, V);
- end Set_Suppress_Access_Checks;
-
- procedure Set_Suppress_Accessibility_Checks (Id : E; V : B := True) is
- begin
- Set_Flag32 (Id, V);
- end Set_Suppress_Accessibility_Checks;
-
- procedure Set_Suppress_Discriminant_Checks (Id : E; V : B := True) is
- begin
- Set_Flag33 (Id, V);
- end Set_Suppress_Discriminant_Checks;
-
- procedure Set_Suppress_Division_Checks (Id : E; V : B := True) is
- begin
- Set_Flag34 (Id, V);
- end Set_Suppress_Division_Checks;
-
- procedure Set_Suppress_Elaboration_Checks (Id : E; V : B := True) is
- begin
- Set_Flag35 (Id, V);
- end Set_Suppress_Elaboration_Checks;
-
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is
begin
Set_Flag148 (Id, V);
end Set_Suppress_Elaboration_Warnings;
- procedure Set_Suppress_Index_Checks (Id : E; V : B := True) is
- begin
- Set_Flag36 (Id, V);
- end Set_Suppress_Index_Checks;
-
procedure Set_Suppress_Init_Proc (Id : E; V : B := True) is
begin
pragma Assert (Id = Base_Type (Id));
Set_Flag105 (Id, V);
end Set_Suppress_Init_Proc;
- procedure Set_Suppress_Length_Checks (Id : E; V : B := True) is
- begin
- Set_Flag37 (Id, V);
- end Set_Suppress_Length_Checks;
-
- procedure Set_Suppress_Overflow_Checks (Id : E; V : B := True) is
- begin
- Set_Flag38 (Id, V);
- end Set_Suppress_Overflow_Checks;
-
- procedure Set_Suppress_Range_Checks (Id : E; V : B := True) is
- begin
- Set_Flag39 (Id, V);
- end Set_Suppress_Range_Checks;
-
- procedure Set_Suppress_Storage_Checks (Id : E; V : B := True) is
- begin
- Set_Flag40 (Id, V);
- end Set_Suppress_Storage_Checks;
-
procedure Set_Suppress_Style_Checks (Id : E; V : B := True) is
begin
Set_Flag165 (Id, V);
end Set_Suppress_Style_Checks;
- procedure Set_Suppress_Tag_Checks (Id : E; V : B := True) is
+ procedure Set_Treat_As_Volatile (Id : E; V : B := True) is
begin
Set_Flag41 (Id, V);
- end Set_Suppress_Tag_Checks;
+ end Set_Treat_As_Volatile;
procedure Set_Underlying_Full_View (Id : E; V : E) is
begin
@@ -4013,12 +4155,12 @@ package body Einfo is
procedure Init_Normalized_Position (Id : E) is
begin
- Set_Uint9 (Id, No_Uint);
+ Set_Uint14 (Id, No_Uint);
end Init_Normalized_Position;
procedure Init_Normalized_Position (Id : E; V : Int) is
begin
- Set_Uint9 (Id, UI_From_Int (V));
+ Set_Uint14 (Id, UI_From_Int (V));
end Init_Normalized_Position;
procedure Init_Normalized_Position_Max (Id : E) is
@@ -4048,10 +4190,10 @@ package body Einfo is
procedure Init_Component_Location (Id : E) is
begin
Set_Uint8 (Id, No_Uint); -- Normalized_First_Bit
- Set_Uint9 (Id, No_Uint); -- Normalized_Position
+ Set_Uint10 (Id, No_Uint); -- Normalized_Position_Max
Set_Uint11 (Id, No_Uint); -- Component_First_Bit
Set_Uint12 (Id, Uint_0); -- Esize
- Set_Uint10 (Id, No_Uint); -- Normalized_Position_Max
+ Set_Uint14 (Id, No_Uint); -- Normalized_Position
end Init_Component_Location;
---------------
@@ -4109,7 +4251,7 @@ package body Einfo is
function Known_Normalized_Position (E : Entity_Id) return B is
begin
- return Uint9 (E) /= No_Uint;
+ return Uint14 (E) /= No_Uint;
end Known_Normalized_Position;
function Known_Normalized_Position_Max (E : Entity_Id) return B is
@@ -4121,7 +4263,8 @@ package body Einfo is
begin
return Uint13 (E) /= No_Uint
and then (Uint13 (E) /= Uint_0
- or else Is_Discrete_Type (E));
+ or else Is_Discrete_Type (E)
+ or else Is_Fixed_Point_Type (E));
end Known_RM_Size;
function Known_Static_Component_Bit_Offset (E : Entity_Id) return B is
@@ -4148,8 +4291,8 @@ package body Einfo is
function Known_Static_Normalized_Position (E : Entity_Id) return B is
begin
- return Uint9 (E) /= No_Uint
- and then Uint9 (E) >= Uint_0;
+ return Uint14 (E) /= No_Uint
+ and then Uint14 (E) >= Uint_0;
end Known_Static_Normalized_Position;
function Known_Static_Normalized_Position_Max (E : Entity_Id) return B is
@@ -4161,7 +4304,8 @@ package body Einfo is
function Known_Static_RM_Size (E : Entity_Id) return B is
begin
return Uint13 (E) > Uint_0
- or else Is_Discrete_Type (E);
+ or else Is_Discrete_Type (E)
+ or else Is_Fixed_Point_Type (E);
end Known_Static_RM_Size;
function Unknown_Alignment (E : Entity_Id) return B is
@@ -4196,7 +4340,7 @@ package body Einfo is
function Unknown_Normalized_Position (E : Entity_Id) return B is
begin
- return Uint9 (E) = No_Uint;
+ return Uint14 (E) = No_Uint;
end Unknown_Normalized_Position;
function Unknown_Normalized_Position_Max (E : Entity_Id) return B is
@@ -4207,7 +4351,8 @@ package body Einfo is
function Unknown_RM_Size (E : Entity_Id) return B is
begin
return (Uint13 (E) = Uint_0
- and then not Is_Discrete_Type (E))
+ and then not Is_Discrete_Type (E)
+ and then not Is_Fixed_Point_Type (E))
or else Uint13 (E) = No_Uint;
end Unknown_RM_Size;
@@ -4316,6 +4461,7 @@ package body Einfo is
begin
case Ekind (Id) is
when E_Enumeration_Subtype |
+ E_Incomplete_Type |
E_Signed_Integer_Subtype |
E_Modular_Integer_Subtype |
E_Floating_Point_Subtype |
@@ -4334,13 +4480,6 @@ package body Einfo is
E_Class_Wide_Subtype =>
return Etype (Id);
- when E_Incomplete_Type =>
- if Present (Etype (Id)) then
- return Etype (Id);
- else
- return Id;
- end if;
-
when others =>
return Id;
end case;
@@ -4363,7 +4502,7 @@ package body Einfo is
-- True True Calign_Storage_Unit
function Component_Alignment (Id : E) return C is
- BT : Node_Id := Base_Type (Id);
+ BT : constant Node_Id := Base_Type (Id);
begin
pragma Assert (Is_Array_Type (Id) or else Is_Record_Type (Id));
@@ -4412,23 +4551,30 @@ package body Einfo is
elsif Nkind (D) = N_Component_Declaration then
return Empty;
- else
- if Present (Expression (D)) then
- return (Expression (D));
+ -- If there is an expression, return it
- elsif Present (Full_View (Id)) then
- Full_D := Parent (Full_View (Id));
+ elsif Present (Expression (D)) then
+ return (Expression (D));
- -- The full view may have been rewritten as an object renaming.
+ -- For a constant, see if we have a full view
- if Nkind (Full_D) = N_Object_Renaming_Declaration then
- return Name (Full_D);
- else
- return Expression (Full_D);
- end if;
+ elsif Ekind (Id) = E_Constant
+ and then Present (Full_View (Id))
+ then
+ Full_D := Parent (Full_View (Id));
+
+ -- The full view may have been rewritten as an object renaming.
+
+ if Nkind (Full_D) = N_Object_Renaming_Declaration then
+ return Name (Full_D);
else
- return Empty;
+ return Expression (Full_D);
end if;
+
+ -- Otherwise we have no expression to return
+
+ else
+ return Empty;
end if;
end Constant_Value;
@@ -4473,8 +4619,8 @@ package body Einfo is
begin
Desig_Type := Directly_Designated_Type (Id);
- if (Ekind (Desig_Type) = E_Incomplete_Type
- and then Present (Full_View (Desig_Type)))
+ if Ekind (Desig_Type) = E_Incomplete_Type
+ and then Present (Full_View (Desig_Type))
then
return Full_View (Desig_Type);
@@ -4565,7 +4711,7 @@ package body Einfo is
Ent := Next_Entity (Ent);
end if;
- -- Skip all hidden girder discriminants if any.
+ -- Skip all hidden stored discriminants if any.
while Present (Ent) loop
exit when Ekind (Ent) = E_Discriminant
@@ -4608,15 +4754,15 @@ package body Einfo is
end First_Formal;
-------------------------------
- -- First_Girder_Discriminant --
+ -- First_Stored_Discriminant --
-------------------------------
- function First_Girder_Discriminant (Id : E) return E is
+ function First_Stored_Discriminant (Id : E) return E is
Ent : Entity_Id;
function Has_Completely_Hidden_Discriminant (Id : E) return Boolean;
-- Scans the Discriminants to see whether any are Completely_Hidden
- -- (the mechanism for describing non-specified girder discriminants)
+ -- (the mechanism for describing non-specified stored discriminants)
function Has_Completely_Hidden_Discriminant (Id : E) return Boolean is
Ent : Entity_Id := Id;
@@ -4636,7 +4782,7 @@ package body Einfo is
return False;
end Has_Completely_Hidden_Discriminant;
- -- Start of processing for First_Girder_Discriminant
+ -- Start of processing for First_Stored_Discriminant
begin
pragma Assert
@@ -4665,7 +4811,7 @@ package body Einfo is
pragma Assert (Ekind (Ent) = E_Discriminant);
return Ent;
- end First_Girder_Discriminant;
+ end First_Stored_Discriminant;
-------------------
-- First_Subtype --
@@ -5010,7 +5156,6 @@ package body Einfo is
return True;
elsif Is_Record_Type (Btype) then
-
if Is_Limited_Record (Btype)
or else Is_Tagged_Type (Btype)
or else Is_Volatile (Btype)
@@ -5229,7 +5374,6 @@ package body Einfo is
--------------------------
function Is_Protected_Private (Id : E) return B is
-
begin
pragma Assert (Ekind (Id) = E_Component);
return Is_Protected_Type (Scope (Id));
@@ -5309,8 +5453,8 @@ package body Einfo is
begin
return Ekind (Id) in String_Kind
or else (Is_Array_Type (Id)
- and then Number_Dimensions (Id) = 1
- and then Is_Character_Type (Component_Type (Id)));
+ and then Number_Dimensions (Id) = 1
+ and then Is_Character_Type (Component_Type (Id)));
end Is_String_Type;
-------------------------
@@ -5357,19 +5501,20 @@ package body Einfo is
-----------------------
-- This function actually implements both Next_Discriminant and
- -- Next_Girder_Discriminant by making sure that the Discriminant
+ -- Next_Stored_Discriminant by making sure that the Discriminant
-- returned is of the same variety as Id.
function Next_Discriminant (Id : E) return E is
-- Derived Tagged types with private extensions look like this...
- --
+
-- E_Discriminant d1
-- E_Discriminant d2
-- E_Component _tag
-- E_Discriminant d1
-- E_Discriminant d2
-- ...
+
-- so it is critical not to go past the leading discriminants.
D : E := Id;
@@ -5427,23 +5572,11 @@ package body Einfo is
begin
if Present (Extra_Formal (Id)) then
return Extra_Formal (Id);
-
else
return Next_Formal (Id);
end if;
end Next_Formal_With_Extras;
- ------------------------------
- -- Next_Girder_Discriminant --
- ------------------------------
-
- function Next_Girder_Discriminant (Id : E) return E is
- begin
- -- See comment in Next_Discriminant
-
- return Next_Discriminant (Id);
- end Next_Girder_Discriminant;
-
----------------
-- Next_Index --
----------------
@@ -5463,6 +5596,17 @@ package body Einfo is
return Next (Id);
end Next_Literal;
+ ------------------------------
+ -- Next_Stored_Discriminant --
+ ------------------------------
+
+ function Next_Stored_Discriminant (Id : E) return E is
+ begin
+ -- See comment in Next_Discriminant
+
+ return Next_Discriminant (Id);
+ end Next_Stored_Discriminant;
+
-----------------------
-- Number_Dimensions --
-----------------------
@@ -5585,6 +5729,12 @@ package body Einfo is
if T = Etyp then
return T;
+ -- Following test catches some error cases resulting from
+ -- previous errors.
+
+ elsif No (Etyp) then
+ return T;
+
elsif Is_Private_Type (T) and then Etyp = Full_View (T) then
return T;
@@ -5593,6 +5743,14 @@ package body Einfo is
end if;
T := Etyp;
+
+ -- Return if there is a circularity in the inheritance chain.
+ -- This happens in some error situations and we do not want
+ -- to get stuck in this loop.
+
+ if T = Base_Type (Id) then
+ return T;
+ end if;
end loop;
end if;
@@ -5825,7 +5983,6 @@ package body Einfo is
function Underlying_Type (Id : E) return E is
begin
-
-- For record_with_private the underlying type is always the direct
-- full view. Never try to take the full view of the parent it
-- doesn't make sense.
@@ -5839,7 +5996,15 @@ package body Einfo is
-- then we return the Underlying_Type of this full view
if Present (Full_View (Id)) then
- return Underlying_Type (Full_View (Id));
+ if Id = Full_View (Id) then
+
+ -- Previous error in declaration
+
+ return Empty;
+
+ else
+ return Underlying_Type (Full_View (Id));
+ end if;
-- Otherwise check for the case where we have a derived type or
-- subtype, and if so get the Underlying_Type of the parent type.
@@ -5911,7 +6076,10 @@ package body Einfo is
end if;
W ("Address_Taken", Flag104 (Id));
+ W ("Body_Needed_For_SAL", Flag40 (Id));
W ("C_Pass_By_Copy", Flag125 (Id));
+ W ("Can_Never_Be_Null", Flag38 (Id));
+ W ("Checks_May_Be_Suppressed", Flag31 (Id));
W ("Debug_Info_Off", Flag166 (Id));
W ("Default_Expressions_Processed", Flag108 (Id));
W ("Delay_Cleanups", Flag114 (Id));
@@ -5933,6 +6101,7 @@ package body Einfo is
W ("Has_Completion_In_Body", Flag71 (Id));
W ("Has_Complex_Representation", Flag140 (Id));
W ("Has_Component_Size_Clause", Flag68 (Id));
+ W ("Has_Contiguous_Rep", Flag181 (Id));
W ("Has_Controlled_Component", Flag43 (Id));
W ("Has_Controlling_Result", Flag98 (Id));
W ("Has_Convention_Pragma", Flag119 (Id));
@@ -5972,6 +6141,7 @@ package body Einfo is
W ("Has_Unchecked_Union", Flag123 (Id));
W ("Has_Unknown_Discriminants", Flag72 (Id));
W ("Has_Volatile_Components", Flag87 (Id));
+ W ("Has_Xref_Entry", Flag182 (Id));
W ("In_Package_Body", Flag48 (Id));
W ("In_Private_Part", Flag45 (Id));
W ("In_Use", Flag8 (Id));
@@ -5986,6 +6156,7 @@ package body Einfo is
W ("Is_Called", Flag102 (Id));
W ("Is_Character_Type", Flag63 (Id));
W ("Is_Child_Unit", Flag73 (Id));
+ W ("Is_Class_Wide_Equivalent_Type", Flag35 (Id));
W ("Is_Compilation_Unit", Flag149 (Id));
W ("Is_Completely_Hidden", Flag103 (Id));
W ("Is_Concurrent_Record_Type", Flag20 (Id));
@@ -5995,7 +6166,6 @@ package body Einfo is
W ("Is_Constructor", Flag76 (Id));
W ("Is_Controlled", Flag42 (Id));
W ("Is_Controlling_Formal", Flag97 (Id));
- W ("Is_Destructor", Flag77 (Id));
W ("Is_Discrim_SO_Function", Flag176 (Id));
W ("Is_Dispatching_Operation", Flag6 (Id));
W ("Is_Eliminated", Flag124 (Id));
@@ -6018,12 +6188,15 @@ package body Einfo is
W ("Is_Interrupt_Handler", Flag89 (Id));
W ("Is_Intrinsic_Subprogram", Flag64 (Id));
W ("Is_Itype", Flag91 (Id));
+ W ("Is_Known_Valid", Flag37 (Id));
W ("Is_Known_Valid", Flag170 (Id));
W ("Is_Limited_Composite", Flag106 (Id));
W ("Is_Limited_Record", Flag25 (Id));
+ W ("Is_Machine_Code_Subprogram", Flag137 (Id));
W ("Is_Non_Static_Subtype", Flag109 (Id));
W ("Is_Null_Init_Proc", Flag178 (Id));
W ("Is_Optional_Parameter", Flag134 (Id));
+ W ("Is_Overriding_Operation", Flag39 (Id));
W ("Is_Package_Body_Entity", Flag160 (Id));
W ("Is_Packed", Flag51 (Id));
W ("Is_Packed_Array_Type", Flag138 (Id));
@@ -6048,17 +6221,21 @@ package body Einfo is
W ("Is_Valued_Procedure", Flag127 (Id));
W ("Is_Visible_Child_Unit", Flag116 (Id));
W ("Is_Volatile", Flag16 (Id));
+ W ("Kill_Elaboration_Checks", Flag32 (Id));
+ W ("Kill_Range_Checks", Flag33 (Id));
+ W ("Kill_Tag_Checks", Flag34 (Id));
W ("Machine_Radix_10", Flag84 (Id));
W ("Materialize_Entity", Flag168 (Id));
W ("Needs_Debug_Info", Flag147 (Id));
W ("Needs_No_Actuals", Flag22 (Id));
+ W ("Never_Set_In_Source", Flag115 (Id));
W ("No_Pool_Assigned", Flag131 (Id));
W ("No_Return", Flag113 (Id));
W ("Non_Binary_Modulus", Flag58 (Id));
W ("Nonzero_Is_True", Flag162 (Id));
- W ("Not_Source_Assigned", Flag115 (Id));
W ("Reachable", Flag49 (Id));
W ("Referenced", Flag156 (Id));
+ W ("Referenced_As_LHS", Flag36 (Id));
W ("Return_Present", Flag54 (Id));
W ("Returns_By_Ref", Flag90 (Id));
W ("Reverse_Bit_Order", Flag164 (Id));
@@ -6066,24 +6243,13 @@ package body Einfo is
W ("Size_Depends_On_Discriminant", Flag177 (Id));
W ("Size_Known_At_Compile_Time", Flag92 (Id));
W ("Strict_Alignment", Flag145 (Id));
- W ("Suppress_Access_Checks", Flag31 (Id));
- W ("Suppress_Accessibility_Checks", Flag32 (Id));
- W ("Suppress_Discriminant_Checks", Flag33 (Id));
- W ("Suppress_Division_Checks", Flag34 (Id));
- W ("Suppress_Elaboration_Checks", Flag35 (Id));
W ("Suppress_Elaboration_Warnings", Flag148 (Id));
- W ("Suppress_Index_Checks", Flag36 (Id));
W ("Suppress_Init_Proc", Flag105 (Id));
- W ("Suppress_Length_Checks", Flag37 (Id));
- W ("Suppress_Overflow_Checks", Flag38 (Id));
- W ("Suppress_Range_Checks", Flag39 (Id));
- W ("Suppress_Storage_Checks", Flag40 (Id));
W ("Suppress_Style_Checks", Flag165 (Id));
- W ("Suppress_Tag_Checks", Flag41 (Id));
+ W ("Treat_As_Volatile", Flag41 (Id));
W ("Uses_Sec_Stack", Flag95 (Id));
W ("Vax_Float", Flag151 (Id));
W ("Warnings_Off", Flag96 (Id));
-
end Write_Entity_Flags;
-----------------------
@@ -6269,9 +6435,6 @@ package body Einfo is
when Type_Kind =>
Write_Str ("Class_Wide_Type");
- when E_Constant | E_Variable =>
- Write_Str ("Size_Check_Code");
-
when E_Function |
E_Generic_Function |
E_Generic_Package |
@@ -6280,9 +6443,8 @@ package body Einfo is
E_Procedure =>
Write_Str ("Renaming_Map");
- when E_Component |
- E_Discriminant =>
- Write_Str ("Normalized_Position");
+ when Object_Kind =>
+ Write_Str ("Current_Value");
when others =>
Write_Str ("Field9??");
@@ -6347,6 +6509,9 @@ package body Einfo is
E_Entry_Family =>
Write_Str ("Protected_Body_Subprogram");
+ when E_Generic_Package =>
+ Write_Str ("Generic_Homonym");
+
when Type_Kind =>
Write_Str ("Full_View");
@@ -6444,9 +6609,16 @@ package body Einfo is
begin
case Ekind (Id) is
when Type_Kind |
- Object_Kind =>
+ Formal_Kind |
+ E_Constant |
+ E_Variable |
+ E_Loop_Parameter =>
Write_Str ("Alignment");
+ when E_Component |
+ E_Discriminant =>
+ Write_Str ("Normalized_Position");
+
when E_Function |
E_Procedure =>
Write_Str ("First_Optional_Parameter");
@@ -6499,7 +6671,8 @@ package body Einfo is
when Enumeration_Kind =>
Write_Str ("Lit_Indexes");
- when E_Package =>
+ when E_Package |
+ E_Package_Body =>
Write_Str ("Related_Instance");
when E_Protected_Type =>
@@ -6616,6 +6789,9 @@ package body Einfo is
E_Variable =>
Write_Str ("Actual_Subtype");
+ when E_Incomplete_Type =>
+ Write_Str ("Non-limited view");
+
when others =>
Write_Str ("Field17??");
end case;
@@ -6694,6 +6870,9 @@ package body Einfo is
Entry_Kind =>
Write_Str ("Finalization_Chain_Entity");
+ when E_Constant | E_Variable =>
+ Write_Str ("Size_Check_Code");
+
when E_Discriminant =>
Write_Str ("Corresponding_Discriminant");
@@ -6913,13 +7092,19 @@ package body Einfo is
Class_Wide_Kind |
E_Record_Type |
E_Record_Subtype =>
- Write_Str ("Girder_Constraint");
+ Write_Str ("Stored_Constraint");
when E_Function |
- E_Package |
E_Procedure =>
Write_Str ("Generic_Renamings");
+ when E_Package =>
+ if Is_Generic_Instance (Id) then
+ Write_Str ("Generic_Renamings");
+ else
+ Write_Str ("Limited Views");
+ end if;
+
-- What about Privals_Chain for protected operations ???
when Entry_Kind =>
@@ -6954,11 +7139,6 @@ package body Einfo is
N := Next_Formal_With_Extras (N);
end Proc_Next_Formal_With_Extras;
- procedure Proc_Next_Girder_Discriminant (N : in out Node_Id) is
- begin
- N := Next_Girder_Discriminant (N);
- end Proc_Next_Girder_Discriminant;
-
procedure Proc_Next_Index (N : in out Node_Id) is
begin
N := Next_Index (N);
@@ -6974,4 +7154,9 @@ package body Einfo is
N := Next_Literal (N);
end Proc_Next_Literal;
+ procedure Proc_Next_Stored_Discriminant (N : in out Node_Id) is
+ begin
+ N := Next_Stored_Discriminant (N);
+ end Proc_Next_Stored_Discriminant;
+
end Einfo;
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index fce8aee1fc7..3f8b227fd6d 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -335,11 +335,15 @@ package Einfo is
-- Always empty for entries.
-- Alignment (Uint14)
--- Present in all entities for types and objects. This indicates the
--- desired alignment for a type, or the actual alignment for an object.
--- A value of zero (Uint_0) indicates that the alignment is not yet set.
+-- Present in entities for types and also in constants, variables,
+-- loop parameters, and formal parameters. This indicates the desired
+-- alignment for a type, or the actual alignment for an object. A value
+-- of zero (Uint_0) indicates that the alignment has not been set yet.
-- The alignment can be set by an explicit alignment clause, or set by
--- the front-end in package Layout, or set by the back-end.
+-- the front-end in package Layout, or set by the back-end as part of
+-- the back end back-annotation process. The alignment field is also
+-- present in E_Exception entities, but there it is used only by the
+-- back-end for back annotation.
-- Alignment_Clause (synthesized)
-- Appllies to all entities for types and objects. If an alignment
@@ -410,6 +414,11 @@ package Einfo is
-- Present in package and generic package entities, points to the
-- corresponding package body entity if one is present.
+-- Body_Needed_For_SAL (Flag40)
+-- Present in package and subprogram entities that are compilation
+-- units. Indicates that the source for the body must be included
+-- when the unit is part of a standalone library.
+
-- C_Pass_By_Copy (Flag125) [implementation base type only]
-- Present in record types. Set if a pragma Convention for the record
-- type specifies convention C_Pass_By_Copy. This convention name is
@@ -420,6 +429,13 @@ package Einfo is
-- set to By_Copy (unless specifically overridden by an Import or
-- Export pragma).
+-- Can_Never_Be_Null (Flag38)
+-- This flag is present in all entities, but can only be set in an
+-- object which can never have a null value. This is used to avoid
+-- unncessary resetting of the Is_Known_Non_Null flag for such
+-- entities. The cases where this is set True are constant access
+-- values initialized to a non-null value, and access parameters.
+
-- Chars (Name1)
-- Present in all entities. This field contains an entry into the names
-- table that has the character string of the identifier, character
@@ -431,6 +447,13 @@ package Einfo is
-- (including post gigi steps such as cross-reference generation), the
-- entities will contain the encoded qualified names.
+-- Checks_May_Be_Suppressed (Flag31)
+-- Present in all entities. Set if a pragma Suppress or Unsuppress
+-- mentions the entity specifically in the second argument. If this
+-- flag is set the the Global_Entity_Suppress and Local_Entity_Suppress
+-- tables must be consulted to determine if the is actually an active
+-- Suppress or Unsuppress pragma that applies to the entity.
+
-- Class_Wide_Type (Node9)
-- Present in all type entities. For a tagged type or subtype, returns
-- the corresponding implicitly declared class-wide type. Set to Empty
@@ -516,11 +539,12 @@ package Einfo is
-- Present in array types and string types. References component type.
-- Constant_Value (synthesized)
--- Applies to constants, named integers, and named reals. Obtains
--- the initialization expression for the entity. Will return Empty for
--- for a deferred constant whose full view is not available or in some
--- other cases of internal entities, which cannot be treated as
--- constants from the point of view of constant folding.
+-- Applies to variables, constants, named integers, and named reals.
+-- Obtains the initialization expression for the entity. Will return
+-- Empty for for a deferred constant whose full view is not available
+-- or in some other cases of internal entities, which cannot be treated
+-- as constants from the point of view of constant folding. Empty is
+-- also returned for variables with no initialization expression.
-- Corresponding_Concurrent_Type (Node18)
-- Present in record types that are constructed by the expander to
@@ -555,10 +579,35 @@ package Einfo is
-- created at the same time as the discriminal, and used to replace
-- occurrences of the discriminant within the type declaration.
+-- Current_Value (Node9)
+-- Present in E_Variable, E_Out_Parameter and E_In_Out_Parameter
+-- entities. Set non-Empty if the (constant) current value of the
+-- variable is known. This value is valid only for references from
+-- the same sequential scope as the entity. The sequential scope
+-- of an entity includes the immediate scope and any contained
+-- scopes that are package specs, package bodies, or blocks (at
+-- any nesting level). For convenience in coding, this field is
+-- also present in other object entities (E_Loop_Parameter and
+-- E_In_Parameter and E_Constant), but is not used to hold a
+-- constant value, since value tracking is not needed in this case.
+--
+-- Another related use of this field is to record information
+-- about the value obtained from an IF statement condition.
+-- If the IF/ELSIF condition has the form "[NOT] OBJ RELOP VAL",
+-- where OBJ is a reference to an entity with a Current_Value field,
+-- RELOP is one of the six relational operators, and VAL is a compile-
+-- time known valoue, then the Current_Value field if OBJ is set to
+-- point to the N_If_Statement or N_Elsif_Part node of the relevant
+-- construct. For more details on this usage, see the procedure
+-- Exp_Util.Get_Current_Value_Condition.
+
-- Debug_Info_Off (Flag166)
-- Present in all entities. Set if a pragma Suppress_Debug_Info applies
-- to the entity, or if internal processing in the compiler determines
--- that suppression of debug information is desirable.
+-- that suppression of debug information is desirable. Note that this
+-- flag is only for use by the front end as part of the processing for
+-- determining if Needs_Debug_Info should be set. The back end should
+-- always test Needs_Debug_Info, it should never test Debug_Info_Off.
-- Debug_Renaming_Link (Node13)
-- Used to link the enumeration literal of a debug renaming declaration
@@ -658,12 +707,14 @@ package Einfo is
-- package specs for which a Discard_Names pragma with zero arguments
-- has been encountered. The purpose of setting this flag is to be able
-- to set the Discard_Names attribute on enumeration types declared
--- after the pragma within the same declarative region.
+-- after the pragma within the same declarative region. This flag is
+-- set to False if a Keep_Names pragma appears for an enumeration type.
-- Discriminal (Node17)
-- Present in discriminants (Discriminant formal: GNAT's first
-- coinage). The entity used as a formal parameter that corresponds
--- to a discriminant. See section "Use of Discriminants" for details.
+-- to a discriminant. See section "Handling of Discriminants" for
+-- full details of the use of discriminals.
-- Discriminal_Link (Node10)
-- Present in discriminals (which have an Ekind of E_In_Parameter,
@@ -680,7 +731,7 @@ package Einfo is
-- types, subtypes, record types and subtypes, private types and
-- subtypes, limited private types and subtypes and incomplete types).
-- It is an error to reference the Discriminant_Constraint field if
--- Has_Disciminants is False.
+-- Has_Discriminants is False.
--
-- If the Is_Constrained flag is set, Discriminant_Constraint points
-- to an element list containing the discriminant constraints in the
@@ -897,7 +948,10 @@ package Einfo is
-- Present in all entities. Represents the type of the entity, which
-- is itself another entity. For a type entity, points to the parent
-- type for a derived type, or if the type is not derived, points to
--- itself. For a subtype entity, Etype points to the base type.
+-- itself. For a subtype entity, Etype points to the base type. For
+-- a class wide type, points to the parent type. For a subprogram or
+-- subprogram type, Etype has the return type of a function or is set
+-- to Standard_Void_Type to represent a procedure.
-- Exception_Code (Uint22)
-- Present in exception entitites. Set to zero unless either an
@@ -981,23 +1035,6 @@ package Einfo is
-- tag itself is prepended to the front of the entity chain, so the
-- First_Discriminant function steps past the tag if it is present.
--- First_Girder_Discriminant (synthesized)
--- Applies to types with discriminants. For tagged types, and untagged
--- types which are root types or derived types but which do not rename
--- discriminants in their root type, this is the same as
--- First_Discriminant.
---
--- For derived non-tagged types that rename discriminants in the root
--- type this is the first of the discriminants that occurr in the
--- root type. To be precise, in this case girder discriminants are
--- entities attached to the entity chain of the derived type which
--- are a copy of the discriminants of the root type. Furthermore their
--- Is_Completely_Hidden flag is set.
---
--- For derived untagged types, girder discriminants are the real
--- discriminants from Gigi's standpoint, ie those that will be stored in
--- actual objects of the type.
-
-- First_Entity (Node17)
-- Present in all entities which act as scopes to which a list of
-- associated entities is attached (blocks, class subtypes and types,
@@ -1030,6 +1067,8 @@ package Einfo is
-- the enumeration type definition node. A special case occurs with
-- standard character and wide character types, where this field is
-- Empty, since there are no enumeration literal lists in these cases.
+-- Note that this field is set in enumeration subtypes, but it still
+-- points to the first literal of the base type in this case.
-- First_Optional_Parameter (Node14)
-- Present in (non-generic) function and procedure entities. Set to a
@@ -1077,6 +1116,31 @@ package Einfo is
-- Note in particular that size clauses are present only for this
-- purpose, and should only be accessed if Has_Size_Clause is set.
+-- First_Stored_Discriminant (synthesized)
+-- Applies to types with discriminants. Gives the first discriminant
+-- stored in the object. In many cases, these are the same as the
+-- normal visible discriminants for the type, but in the case of
+-- renamed discriminants, this is not always the case.
+--
+-- For tagged types, and untagged types which are root types or
+-- derived types but which do not rename discriminants in their
+-- root type, the stored discriminants are the same as the actual
+-- discriminants of the type, and hence this function is the same
+-- as First_Discriminant.
+--
+-- For derived non-tagged types that rename discriminants in the root
+-- type this is the first of the discriminants that occurr in the
+-- root type. To be precise, in this case stored discriminants are
+-- entities attached to the entity chain of the derived type which
+-- are a copy of the discriminants of the root type. Furthermore their
+-- Is_Completely_Hidden flag is set since although they are actually
+-- stored in the object, they are not in the set of discriminants that
+-- is visble in the type.
+--
+-- For derived untagged types, stored discriminants are the real
+-- discriminants from Gigi's standpoint, i.e. those that will be
+-- stored in actual objects of the type.
+
-- First_Subtype (synthesized)
-- Applies to all types and subtypes. For types, yields the first
-- subtype of the type. For subtypes, yields the first subtype of
@@ -1114,18 +1178,17 @@ package Einfo is
-- the function returns a value of a type whose size is not known
-- at compile time.
+-- Generic_Homonym (Node11)
+-- Present in generic packages. The generic homonym is the entity of
+-- a renaming declaration inserted in every generic unit. It is used
+-- to resolve the name of a local entity that is given by a qualified
+-- name, when the generic entity itself is hidden by a local name.
+
-- Generic_Renamings (Elist23)
-- Present in package and subprogram instances. Holds mapping that
-- associates generic parameters with the corresponding instances, in
-- those cases where the instance is an entity.
--- Girder_Constraint (Elist23)
--- Present in entities that can have discriminants (concurrent types
--- subtypes, record types and subtypes, private types and subtypes,
--- limited private types and subtypes and incomplete types). Points
--- to an element list containing the expressions for each of the
--- girder discriminants for the record (sub)type.
-
-- Handler_Records (List10)
-- Present in subprogram and package entities. Points to a list of
-- identifiers referencing the handler record entities for the
@@ -1200,6 +1263,10 @@ package Einfo is
-- present for the given type. Note that this flag can be False even
-- if Component_Size is non-zero (happens in the case of derived types).
+-- Has_Contiguous_Rep (Flag181)
+-- Present in enumeration types. True if the type as a representation
+-- clause whose entries are successive integers.
+
-- Has_Controlling_Result (Flag98)
-- Present in E_Function entities. True if The function is a primitive
-- function of a tagged type which can dispatch on result
@@ -1285,7 +1352,7 @@ package Einfo is
-- scope. Used by Gigi to generate unique names for such entities.
-- Has_Interrupt_Handler (synthesized)
--- Applies to all protected types entities. Set if the protected type
+-- Applies to all protected type entities. Set if the protected type
-- definition contains at least one procedure to which a pragma
-- Interrupt_Handler applies.
@@ -1343,10 +1410,10 @@ package Einfo is
-- Has_Pragma_Inline (Flag157)
-- Present in all entities. Set for functions and procedures for which
-- a pragma Inline or Inline_Always applies to the subprogram. Note
--- subprogram. Note that this flag can be set even if Is_Inlined is
--- not set. This happens for pragma Inline (if Inline_Active is False)
--- In other words, the flag Has_Pragma_Inline represents the formal
--- semantic status, and is used for checking semantic correctness.
+-- that this flag can be set even if Is_Inlined is not set. This
+-- happens for pragma Inline (if Inline_Active is False). In other
+-- words, the flag Has_Pragma_Inline represents the formal semantic
+-- status, and is used for checking semantic correctness.
-- The flag Is_Inlined indicates whether inlining is actually active
-- for the entity.
@@ -1475,11 +1542,20 @@ package Einfo is
-- that in the case of a type the pragma will be chained to the rep
-- item chain of the first subtype in the usual manner.
+-- Has_Xref_Entry (Flag182)
+-- This flag is set if an entity has an entry in the Xref information
+-- generated in ali files. This is true for all source entities in the
+-- extended main source file. It is also true of entities in other
+-- packages that are referenced directly or indirectly from the main
+-- source file (indirect reference occurs when the main source file
+-- references an entity with a type reference. See package Lib.Xref
+-- for further details).
+
-- Hiding_Loop_Variable (Node8)
-- Present in variables. Set only if a variable of a discrete type is
-- hidden by a loop variable in the same local scope, in which case
-- the Hiding_Loop_Variable field of the hidden variable points to
--- the E_Loop_Variable entity doing the hiding. Used in processing
+-- the E_Loop_Parameter entity doing the hiding. Used in processing
-- warning messages if the hidden variable turns out to be unused
-- or is referenced without being set.
@@ -1618,6 +1694,11 @@ package Einfo is
-- Is_Class_Wide_Type (synthesized)
-- Applies to all entities, true for class wide types and subtypes
+-- Is_Class_Wide_Equivalent_Type (Flag35)
+-- Present in record types and subtypes. Set to True, if the type acts
+-- as a class-wide equivalent type, i.e. the Equivalent_Type field of
+-- some class-wide subtype entity references this record type.
+
-- Is_Compilation_Unit (Flag149)
-- Present in all entities. Set if the entity is a package or subprogram
-- entity for a compilation unit other than a subunit (since we treat
@@ -1631,7 +1712,7 @@ package Einfo is
-- directly visible in the derived type because the derived type or
-- one of its ancestors have renamed the discriminants in the root
-- type. Note that there are girder discriminants which are not
--- Completely_Hidden (eg the discriminants of a root type).
+-- Completely_Hidden (e.g. the discriminants of a root type).
-- Is_Composite_Type (synthesized)
-- Applies to all entities, true for all composite types and
@@ -1692,10 +1773,6 @@ package Einfo is
-- Applies to all type entities. Determine if given entity is a
-- derived type
--- Is_Destructor (Flag77)
--- Present in function and procedure entities. Set if a pragma
--- CPP_Destructor applies to the subprogram.
-
-- Is_Discrete_Type (synthesized)
-- Applies to all entities, true for all discrete types and subtypes
@@ -1784,10 +1861,14 @@ package Einfo is
-- Present in all entities. Set to indicate that the entity is an
-- instance of a generic unit.
+-- Is_Generic_Subprogram (synthesized)
+-- Applies to all entities. Yields True for a generic subprogram
+-- (generic function, generic subprogram), False for all other entities.
+
-- Is_Generic_Type (Flag13)
--- Present in types which are generic formal types. Such types have an
--- Ekind that corresponds to their classification, so the Ekind cannot
--- be used to identify generic types.
+-- Present in all types and subtypes. Set for types which are generic
+-- formal types. Such types have an Ekind that corresponds to their
+-- classification, so the Ekind cannot be used to identify generic types.
-- Is_Generic_Unit (synthesized)
-- Applies to all entities. Yields True for a generic unit (generic
@@ -1851,8 +1932,9 @@ package Einfo is
-- on this one! ???
-- Is_Interrupt_Handler (Flag89)
--- Present in protected procedures. Set if a pragma Interrupt_Handler
--- applies to the procedure (which must be parameterless).
+-- Present in procedures. Set if a pragma Interrupt_Handler applies
+-- to the procedure. The procedure must be parameterless, and on all
+-- targets except AAMP it must be a protected procedure.
-- Is_Intrinsic_Subprogram (Flag64)
-- Present in functions and procedures. It is set if a valid pragma
@@ -1874,6 +1956,27 @@ package Einfo is
-- is that the first use of such a type (the one that causes it to be
-- defined) must be in the same scope as the type.
+-- Is_Known_Non_Null (Flag37)
+-- Present in all entities. Relevant (and can be set True) only for
+-- objects of an access type. It is set if the object is currently
+-- known to have a non-null value (meaning that no access checks
+-- are needed). The indication can for eample3 come from assignment
+-- of an access parameter or an allocator.
+--
+-- Note: this flag is set according to the sequential flow of the
+-- program, watching the current value of the variable. However,
+-- this processing can cases of changing the value of an aliased
+-- or constant object, so even if this flag is set, it should not
+-- be believed if the variable is aliased or volatile. It would
+-- be a little neater to avoid the flag being set in the first
+-- place in such cases, but that's trickier, and there is only
+-- one place that tests the value anyway.
+--
+-- The flag is dynamically set and reset as semantic analysis and
+-- expansion proceeds. Its value is meaningless once the tree is
+-- fully constructed, since it simply indicates the last state.
+-- Thus this flag has no meaning to the back end.
+
-- Is_Known_Valid (Flag170)
-- Present in all entities. Relevant for types (and subtype) and
-- for objects (and enumeration literals) of a discrete type.
@@ -1902,6 +2005,11 @@ package Einfo is
-- For non-discrete objects, the setting of the Is_Known_Valid flag is
-- not defined, and is not relevant, since the considerations of the
-- requirement in (RM 13.9.1(9-11)) do not apply.
+--
+-- The flag is dynamically set and reset as semantic analysis and
+-- expansion proceeds. Its value is meaningless once the tree is
+-- fully constructed, since it simply indicates the last state.
+-- Thus this flag has no meaning to the back end.
-- Is_Limited_Composite (Flag106)
-- Present in all entities. True for composite types that have a
@@ -1924,7 +2032,10 @@ package Einfo is
-- Present in subprogram entities. Set to indicate that the subprogram
-- is a machine code subprogram (i.e. its body includes at least one
-- code statement). Also indicates that all necessary semantic checks
--- as required by RM 13.8 have been performed.
+-- as required by RM 13.8(3) have been performed.
+
+-- Is_Modular_Integer_Type (synthesized)
+-- Applies to all entities. True if entity is a modular integer type
-- Is_Non_Static_Subtype (Flag109)
-- This flag is present in all type and subtype entities. It is set in
@@ -1943,7 +2054,7 @@ package Einfo is
-- and the tests for static subtypes greatly simplified.
-- Is_Null_Init_Proc (Flag178)
--- Present in procedure entities. Set for generated init_proc procedures
+-- Present in procedure entities. Set for generated init proc procedures
-- (used to initialize composite types), if the code for the procedure
-- is null (i.e. is a return and nothing else). Such null initialization
-- procedures are generated in case some client is compiled using the
@@ -1968,6 +2079,10 @@ package Einfo is
-- Applies to all entities, true for ordinary fixed point types
-- and subtypes
+-- Is_Overriding_Operation (Flag39)
+-- Present in subprograms. Set if the subprogram is a primitive
+-- operation of a derived type, that overrides an inherited operation.
+
-- Is_Package (synthesized)
-- Applies to all entities. True for packages and generic packages.
-- False for all other entities.
@@ -2169,6 +2284,16 @@ package Einfo is
-- code generator. For a constant, it means that the constant was not
-- modified by generated code (e.g. to set a discriminant in an init
-- proc). Assignments by user or generated code will reset this flag.
+--
+-- Note: there is one situation in which the back end does not permit
+-- this flag to be set, even if no assignments are generated. This is
+-- the case of an object of a record or array type which is initialized
+-- with an aggregate, and is itself used as the expression initializing
+-- an atomic object, or the right hand side of an assignment to an atomic
+-- object. In this case the object must not have Is_True_Constant set,
+-- even though no assignments are generated (the reason for this is that
+-- the back end must not optimize the object away, because that would
+-- violate the restriction on aggregates in these positions).
-- Is_Type (synthesized)
-- Applies to all entities, true for a type entity
@@ -2210,12 +2335,40 @@ package Einfo is
-- variables. Set if a pragma Volatile applies to the entity. Also set
-- if pragma Shared or pragma Atomic applies to entity. In the case of
-- private or incomplete types, this flag is set in both the private
--- and full view.
+-- and full view. The flag is not set reliably on private subtypes,
+-- and is always retrieved from the base type (but this is not a base-
+-- type-only attribute because it applies to other entities). Note that
+-- the back end should use Treat_As_Volatile, rather than Is_Volatile
+-- to indicate code generation requirements for volatile variables.
+-- Similarly, any front end test which is concerned with suppressing
+-- optimizations on volatile objects should test Treat_As_Volatile
+-- rather than testing this flag.
-- Is_Wrapper_Package (synthesized)
-- Present in package entities. Indicates that the package has been
-- created as a wrapper for a subprogram instantiation.
+-- Kill_Elaboration_Checks (Flag32)
+-- Present in all entities. Set by the expander to kill elaboration
+-- checks which are known not to be needed. Equivalent in effect to
+-- the use of pragma Supress (Elaboration_Checks) for that entity
+-- except that the effect is permanent and cannot be undone by a
+-- subsequent pragma Unsuppress.
+
+-- Kill_Range_Checks (Flag33)
+-- Present in all entities. Set by the expander to kill elaboration
+-- checks which are known not to be needed. Equivalent in effect to
+-- the use of pragma Supress (Range_Checks) for that entity except
+-- that the result is permanent and cannot be undone by a subsequent
+-- pragma Unsuppress.
+
+-- Kill_Tag_Checks (Flag34)
+-- Present in all entities. Set by the expander to kill elaboration
+-- checks which are known not to be needed. Equivalent in effect to
+-- the use of pragma Supress (Tag_Checks) for that entity except
+-- that the result is permanent and cannot be undone by a subsequent
+-- pragma Unsuppress.
+
-- Last_Entity (Node20)
-- Present in all entities which act as scopes to which a list of
-- associated entities is attached (blocks, class subtypes and types,
@@ -2224,6 +2377,13 @@ package Einfo is
-- Points to a the last entry in the list of associated entities chained
-- through the Next_Entity field. Empty if no entities are chained.
+-- Limited_Views (Elist23)
+-- Present in non-generic package entities that are not instances.
+-- The elements of this list are the shadow entities created for the
+-- types and local packages that are declared in a package that appears
+-- in a limited_with clause. This list and Non_Limited_Views are built
+-- at the same time, and their elements are in one-one correspondence.
+
-- Lit_Indexes (Node15)
-- Present in enumeration types and subtypes. Non-empty only for the
-- case of an enumeration root type, where it contains the entity for
@@ -2275,6 +2435,8 @@ package Einfo is
-- have Comes_From_Source set, and also transitively for entities
-- associated with such components (e.g. their types). It is true
-- for all entities in Debug_Generated_Code mode (-gnatD switch).
+-- This is the flag that the back end should check to determine
+-- whether or not to generate debugging information for an entity.
-- Needs_No_Actuals (Flag22)
-- Present in callable entities (subprograms, entries, access to
@@ -2285,20 +2447,24 @@ package Einfo is
-- interpreted as an indexing of the result of the call. It is also
-- used to resolve various cases of entry calls.
--- Not_Source_Assigned (Flag115)
+-- Never_Set_In_Source (Flag115)
-- Present in all entities, but relevant only for variables and
--- parameters. This flag is set if the object is never assigned a
--- value in user code and was not fully initialized at declaration
--- time. Note however, that an access variable is not considered
--- fully initialized in this sense.
---
+-- parameters. This flag is set if the object is never assigned
+-- a value in user source code, either by assignment or by the
+-- use of an initial value, or by some other means.
+
-- This flag is only for the purposes of issuing warnings, it must not
-- be used by the code generator to indicate that the variable is in
-- fact a constant, since some assignments in generated code do not
--- count (for example, the call to an init_proc to assign some but
--- not all of the fields in a patially initialized record). The code
+-- count (for example, the call to an init proc to assign some but
+-- not all of the fields in a partially initialized record). The code
-- generator should instead use the flag Is_True_Constant.
--
+-- For the purposes of this warning, the default assignment of
+-- access variables to null is not considered the assignment of
+-- of a value (so the warning can be given for code that relies
+-- on this initial null value, when no other value is ever set).
+--
-- In variables and out parameters, if this flag is set after full
-- processing of the corresponding declarative unit, it indicates that
-- the variable or parameter was never set, and a warning message can
@@ -2307,8 +2473,8 @@ package Einfo is
-- Note: this flag is initially set, and then cleared on encountering
-- any construct that might conceivably legitimately set the value.
-- Thus during the analysis of a declarative region and its associated
--- statement sequence, the meaning of the flag is "not assigned yet",
--- and once this analysis is complete the flag means "never assigned".
+-- statement sequence, the meaning of the flag is "not set yet", and
+-- once this analysis is complete the flag means "never assigned".
-- Note: for variables appearing in package declarations, this flag
-- is never set. That is because there is no way to tell if some
@@ -2318,7 +2484,7 @@ package Einfo is
-- Note: in the case of renamed objects, the flag must be set in the
-- ultimate renamed object. Clients noting a possible modification
-- should use the Note_Possible_Modification procedure in Sem_Util
--- rather than Set_Not_Source_Assigned precisely to deal properly with
+-- rather than Set_Never_Set_In_Source precisely to deal properly with
-- the renaming possibility.
-- Next_Component (synthesized)
@@ -2384,6 +2550,16 @@ package Einfo is
-- Present in modular integer types. Set if the modulus for the type
-- is other than a power of 2.
+-- Non_Limited_View (Node17)
+-- Present in incomplete types, and local packages that are the
+-- shadow entities created when analyzing a limited_with_clause.
+-- Points to the definining entity in the original declaration.
+
+-- Non_Limited_Views (Elist8)
+-- Present in non-generic packages that are not instances. The elements
+-- of this list are defining identifiers for types and local packages
+-- declared within a package that appears in a limited_with clause.
+
-- Nonzero_Is_True (Flag162) [base type only]
-- Present in enumeration types. True if any non-zero value is to be
-- interpreted as true. Currently this is set true for derived Boolean
@@ -2392,8 +2568,8 @@ package Einfo is
-- No_Pool_Assigned (Flag131) [root type only]
-- Present in access types. Set if a storage size clause applies to
-- the variable with a compile time known value of zero. This flag is
--- used to generate warnings if any attempt is made to allocate an
--- instance of such an access type. This is set only in the root
+-- used to generate warnings if any attempt is made to allocate or free
+-- an instance of such an access type. This is set only in the root
-- type, since derived types must have the same pool.
-- No_Return (Flag113)
@@ -2405,7 +2581,7 @@ package Einfo is
-- value of First_Bit for the component, i.e. the offset within the
-- lowest addressed storage unit containing part or all of the field.
--- Normalized_Position (Uint9)
+-- Normalized_Position (Uint14)
-- Present in components and discriminants. Indicates the normalized
-- value of Position for the component, i.e. the offset in storage
-- units from the start of the record to the lowest addressed storage
@@ -2489,8 +2665,7 @@ package Einfo is
-- Parent_Subtype (Node19)
-- Present in E_Record_Type. Points to the subtype to use for a
--- field that references the parent record. This is used by Gigi to
--- construct such a field.
+-- field that references the parent record.
-- Primitive_Operations (Elist15)
-- Present in tagged record types and subtypes and in tagged private
@@ -2570,7 +2745,16 @@ package Einfo is
-- which a goto to that label is legal.
-- Referenced (Flag156)
--- Present in all entities, set if the entity is referenced.
+-- Present in all entities, set if the entity is referenced, except
+-- for the case of an appearence of a simple variable that is not a
+-- renaming, as the left side of an assignment in which case the flag
+-- Referenced_As_LHS is set instead.
+
+-- Referenced_As_LHS (Flag36): This flag is set instead of
+-- Referenced if a simple variable that is not a renaming appears as
+-- the left side of an assignment. The reason we distinguish this kind
+-- of reference is that we have a separate warning for variables that
+-- are only assigned and never read.
-- Referenced_Object (Node10)
-- Present in all type entities. Set non-Empty only for type entities
@@ -2606,13 +2790,15 @@ package Einfo is
-- Renamed_Object (Node18)
-- Present in all objects (constants, variables, components, formal
--- parameters, generic formal parameters, and loop parameters. Set
+-- parameters, generic formal parameters, and loop parameters). Set
-- non-Empty if the object was declared by a renaming declaration, in
-- which case it references the tree node for the name of the renamed
-- object. This is only possible for the variable and constant cases.
-- For formal parameters, this field is used in the course of inline
-- expansion, to map the formals of a subprogram into the corresponding
--- actuals. The field is Empty otherwise.
+-- actuals. For formals of a task entry, it denotes the local renaming
+-- that replaces the actual within the accept statement.
+-- The field is Empty otherwise.
-- Renaming_Map (Uint9)
-- Present in generic subprograms, generic packages, and their
@@ -2729,9 +2915,9 @@ package Einfo is
-- set, in which case this is the entity for the shared memory read
-- routine. See Exp_Smem for full details.
--- Size_Check_Code (Node9)
+-- Size_Check_Code (Node19)
-- Present in constants and variables. Normally Empty. Set if code is
--- generated to check the size of the variable. This field is used to
+-- generated to check the size of the object. This field is used to
-- suppress this code if a subsequent address clause is encountered.
-- Size_Clause (synthesized)
@@ -2779,6 +2965,13 @@ package Einfo is
-- this field is present only in the root type (since derived types
-- share the same storage pool).
+-- Stored_Constraint (Elist23)
+-- Present in entities that can have discriminants (concurrent types
+-- subtypes, record types and subtypes, private types and subtypes,
+-- limited private types and subtypes and incomplete types). Points
+-- to an element list containing the expressions for each of the
+-- stored discriminants for the record (sub)type.
+
-- Strict_Alignment (Flag145) [implementation base type only]
-- Present in all type entities. Indicates that some containing part
-- is either aliased or tagged. This prohibits packing the object
@@ -2796,81 +2989,42 @@ package Einfo is
-- the low bound of the applicable index constraint if there is one,
-- or a copy of the low bound of the index base type if not.
--- Suppress_Access_Checks (Flag31)
--- Present in all entities. Set if access checks associated with this
--- entity are to be suppressed (see separate section on "Handling of
--- Check Suppression")
-
--- Suppress_Accessibility_Checks (Flag32)
--- Present in all entities. Set if accessibility checks associated with
--- this entity are to be suppressed (see separate section on "Handling
--- of Check Suppression")
-
--- Suppress_Discriminant_Checks (Flag33)
--- Present in all entities. Set if discriminant checks associated with
--- this entity are to be suppressed (see separate section on "Handling
--- of Check Suppression")
-
--- Suppress_Division_Checks (Flag34)
--- Present in all entities. Set if division checks associated with
--- this entity are to be suppressed (see separate section on "Handling
--- of Check Suppression")
-
--- Suppress_Elaboration_Checks (Flag35)
--- Present in all entities. Set if elaboration checks associated with
--- this entity are to be suppressed (see separate section on "Handling
--- of Check Suppression")
-
-- Suppress_Elaboration_Warnings (Flag148)
--- Present in all entities. Set if a pragma Suppress Elaboration_Checks
--- is applied specifically to the entity. If set on a subprogram, all
--- elaboration warnings for calls to the subprogram are suppressed. If
--- set on a package, then all elaboration warnings for calls to any
--- subprograms in the package are suppressed.
-
--- Suppress_Index_Checks (Flag36)
--- Present in all entities. Set if index checks associated with this
--- entity are to be suppressed (see separate section on "Handling of
--- Check Suppression")
+-- Present in all entities, relevant only for subprogram entities. If
+-- this flag is set then Sem_Elab will not generate elaboration warnings
+-- for the subprogram. Suppression of such warnings is automatic for
+-- subprograms for which elaboration checks are suppressed (without the
+-- need to set this flag), but the flag is also set for various internal
+-- entities (such as init procs) which are known not to generate any
+-- possible access before elaboration. (we need a clear description of
+-- how this flag differs in effect from Elaboration_Checks_Suppressed???)
-- Suppress_Init_Proc (Flag105) [base type only]
-- Present in all type entities. Set to suppress the generation of
-- initialization procedures where they are known to be not needed.
-- For example, the enumeration image table entity uses this flag.
--- Suppress_Length_Checks (Flag37)
--- Present in all entities. Set if length checks associated with this
--- entity are to be suppressed (see separate section on "Handling of
--- Check Suppression")
-
--- Suppress_Overflow_Checks (Flag38)
--- Present in all entities. Set if overflow checks associated with
--- this entity are to be suppressed (see separate section on "Handling
--- of Check Suppression")
-
--- Suppress_Range_Checks (Flag39)
--- Present in all entities. Set if range checks associated with this
--- entity are to be suppressed (see separate section on "Handling of
--- Check Suppression")
-
--- Suppress_Storage_Checks (Flag40)
--- Present in all entities. Set if storage checks associated with
--- this entity are to be suppressed (see separate section on "Handling
--- of Check Suppression")
-
-- Suppress_Style_Checks (Flag165)
-- Present in all entities. Suppresses any style checks specifically
-- associated with the given entity if set.
--- Suppress_Tag_Checks (Flag41)
--- Present in all entities. Set if tag checks associated with this
--- entity are to be suppressed (see separate section on "Handling of
--- Check Suppression")
-
-- Tag_Component (synthesized)
-- Applies to tagged record types, returns the entity for the _Tag
-- field in this record, which must be present.
+-- Treat_As_Volatile (Flag41)
+-- Present in all type entities, and also in constants, components and
+-- variables. Set if this entity is to be treated as volatile for code
+-- generation purposes. Always set if Is_Volatile is set, but can also
+-- be set as a result of situations (such as address overlays) where
+-- the front end wishes to force volatile handling to inhibit aliasing
+-- optimization which might be legally ok, but is undesirable. Note
+-- that the back end always tests this flag rather than Is_Volatile.
+-- The front end tests Is_Volatile if it is concerned with legality
+-- checks associated with declared volatile variables, but if the test
+-- is for the purposes of suppressing optimizations, then the front
+-- end should test Treat_As_Volatile rather than Is_Volatile.
+
-- Type_High_Bound (synthesized)
-- Applies to scalar types. Returns the tree node (Node_Id) that
-- contains the high bound of a scalar type. The returned value is a
@@ -3302,14 +3456,14 @@ package Einfo is
-- A generic function. This is the entity for a generic function
-- created by a generic subprogram declaration.
- E_Generic_Package,
- -- A generic package, this is the entity for a generic package created
- -- by a generic package declaration.
-
E_Generic_Procedure,
-- A generic function. This is the entity for a generic procedure
-- created by a generic subprogram declaration.
+ E_Generic_Package,
+ -- A generic package, this is the entity for a generic package created
+ -- by a generic package declaration.
+
E_Label,
-- The defining entity for a label. Note that this is created by the
-- implicit label declaration, not the occurrence of the label itself,
@@ -3355,7 +3509,7 @@ package Einfo is
--------------------------
-- The above entities are arranged so that they can be conveniently
- -- grouped into subtype ranges. Note that for each of the xxx_KInd
+ -- grouped into subtype ranges. Note that for each of the xxx_Kind
-- ranges defined below, there is a corresponding Is_xxx.. predicate
-- which is to be used in preference to direct range tests using the
-- subtype name. However, the subtype names are available for direct
@@ -3489,11 +3643,15 @@ package Einfo is
-- E_Out_Parameter
E_In_Out_Parameter;
- subtype Generic_Unit_Kind is Entity_Kind range
+ subtype Generic_Subprogram_Kind is Entity_Kind range
E_Generic_Function ..
- -- E_Generic_Package,
E_Generic_Procedure;
+ subtype Generic_Unit_Kind is Entity_Kind range
+ E_Generic_Function ..
+ -- E_Generic_Procedure
+ E_Generic_Package;
+
subtype Incomplete_Or_Private_Kind is Entity_Kind range
E_Record_Type_With_Private ..
-- E_Record_Subtype_With_Private
@@ -3679,6 +3837,8 @@ package Einfo is
-- Freeze_Node (Node7)
-- Address_Taken (Flag104)
+ -- Can_Never_Be_Null (Flag38)
+ -- Checks_May_Be_Suppressed (Flag31)
-- Debug_Info_Off (Flag166)
-- Has_Convention_Pragma (Flag119)
-- Has_Delayed_Freeze (Flag18)
@@ -3691,6 +3851,7 @@ package Einfo is
-- Has_Private_Declaration (Flag155)
-- Has_Qualified_Name (Flag161)
-- Has_Unknown_Discriminants (Flag72)
+ -- Has_Xref_Entry (Flag182)
-- Is_Bit_Packed_Array (Flag122) (base type only)
-- Is_Child_Unit (Flag73)
-- Is_Compilation_Unit (Flag149)
@@ -3708,6 +3869,7 @@ package Einfo is
-- Is_Inlined (Flag11)
-- Is_Internal (Flag17)
-- Is_Itype (Flag91)
+ -- Is_Known_Non_Null (Flag37)
-- Is_Known_Valid (Flag170)
-- Is_Limited_Composite (Flag106)
-- Is_Limited_Record (Flag25)
@@ -3723,28 +3885,20 @@ package Einfo is
-- Is_Statically_Allocated (Flag28)
-- Is_Unchecked_Union (Flag117)
-- Is_VMS_Exception (Flag133)
+ -- Kill_Elaboration_Checks (Flag32)
+ -- Kill_Range_Checks (Flag33)
+ -- Kill_Tag_Checks (Flag34)
-- Materialize_Entity (Flag168)
-- Needs_Debug_Info (Flag147)
-- Referenced (Flag156)
- -- Suppress_Access_Checks (Flag31)
- -- Suppress_Accessibility_Checks (Flag32)
- -- Suppress_Discriminant_Checks (Flag33)
- -- Suppress_Division_Checks (Flag34)
- -- Suppress_Elaboration_Checks (Flag35)
+ -- Referenced_As_LHS (Flag36)
-- Suppress_Elaboration_Warnings (Flag148)
- -- Suppress_Index_Checks (Flag36)
- -- Suppress_Length_Checks (Flag37)
- -- Suppress_Overflow_Checks (Flag38)
- -- Suppress_Range_Checks (Flag39)
- -- Suppress_Storage_Checks (Flag40)
-- Suppress_Style_Checks (Flag165)
- -- Suppress_Tag_Checks (Flag41)
-- Declaration_Node (synth)
-- Enclosing_Dynamic_Scope (synth)
-- Has_Foreign_Convention (synth)
-- Is_Dynamic_Scope (synth)
- -- Is_Generic_Unit (synth)
-- Is_Limited_Type (synth)
-- Underlying_Type (synth)
-- all classification attributes (synth)
@@ -3800,6 +3954,7 @@ package Einfo is
-- Size_Known_At_Compile_Time (Flag92)
-- Strict_Alignment (Flag145) (base type only)
-- Suppress_Init_Proc (Flag105) (base type only)
+ -- Treat_As_Volatile (Flag41)
-- Alignment_Clause (synth)
-- Ancestor_Subtype (synth)
@@ -3881,12 +4036,12 @@ package Einfo is
-- Discard_Names (Flag88)
-- Finalization_Chain_Entity (Node19)
-- Scope_Depth_Value (Uint22)
- -- Scope_Depth (synth)
-- Entry_Cancel_Parameter (Node23)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
-- Sec_Stack_Needed_For_Return (Flag167)
-- Uses_Sec_Stack (Flag95)
+ -- Scope_Depth (synth)
-- E_Class_Wide_Type
-- E_Class_Wide_Subtype
@@ -3900,11 +4055,12 @@ package Einfo is
-- E_Component
-- Normalized_First_Bit (Uint8)
- -- Normalized_Position (Uint9)
+ -- Current_Value (Node9) (always Empty)
-- Normalized_Position_Max (Uint10)
-- Component_Bit_Offset (Uint11)
-- Esize (Uint12)
-- Component_Clause (Node13)
+ -- Normalized_Position (Uint14)
-- DT_Entry_Count (Uint15)
-- Entry_Formal (Node16)
-- Prival (Node17)
@@ -3918,18 +4074,20 @@ package Einfo is
-- Is_Atomic (Flag85)
-- Is_Tag (Flag78)
-- Is_Volatile (Flag16)
- -- Next_Component (synth)
+ -- Treat_As_Volatile (Flag41)
-- Is_Protected_Private (synth)
+ -- Next_Component (synth)
-- E_Constant
-- E_Loop_Parameter
- -- Size_Check_Code (Node9)
+ -- Current_Value (Node9) (always Empty)
-- Discriminal_Link (Node10) (discriminals only)
-- Full_View (Node11)
-- Esize (Uint12)
-- Alignment (Uint14)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
+ -- Size_Check_Code (Node19) (constants only)
-- Interface_Name (Node21)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
@@ -3941,7 +4099,8 @@ package Einfo is
-- Is_Psected (Flag153)
-- Is_True_Constant (Flag163)
-- Is_Volatile (Flag16)
- -- Not_Source_Assigned (Flag115)
+ -- Never_Set_In_Source (Flag115)
+ -- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
-- Constant_Value (synth)
@@ -3962,11 +4121,12 @@ package Einfo is
-- E_Discriminant
-- Normalized_First_Bit (Uint8)
- -- Normalized_Position (Uint9)
+ -- Current_Value (Node9) (always Empty)
-- Normalized_Position_Max (Uint10)
-- Component_Bit_Offset (Uint11)
-- Esize (Uint12)
-- Component_Clause (Node13)
+ -- Normalized_Position (Uint14)
-- Discriminant_Number (Uint15)
-- Discriminal (Node17)
-- Renamed_Object (Node18) (always Empty)
@@ -3976,7 +4136,7 @@ package Einfo is
-- Original_Record_Component (Node22)
-- CR_Discriminant (Node23)
-- Next_Discriminant (synth)
- -- Next_Girder_Discriminant (synth)
+ -- Next_Stored_Discriminant (synth)
-- E_Entry
-- E_Entry_Family
@@ -3989,7 +4149,6 @@ package Einfo is
-- Last_Entity (Node20)
-- Accept_Address (Elist21)
-- Scope_Depth_Value (Uint22)
- -- Scope_Depth (synth)
-- Privals_Chain (Elist23) (for a protected entry)
-- Default_Expressions_Processed (Flag108)
-- Entry_Accepted (Flag152)
@@ -4001,6 +4160,7 @@ package Einfo is
-- First_Formal (synth)
-- Entry_Index_Type (synth)
-- Number_Formals (synth)
+ -- Scope_Depth (synth)
-- E_Entry_Index_Parameter
-- Entry_Index_Constant (Node18)
@@ -4021,6 +4181,7 @@ package Einfo is
-- Scalar_Range (Node20)
-- Enum_Pos_To_Rep (Node23) (type only, not subtype)
-- Has_Biased_Representation (Flag139)
+ -- Has_Contiguous_Rep (Flag181)
-- Has_Enumeration_Rep_Clause (Flag66)
-- Nonzero_Is_True (Flag162) (base type only)
-- Type_Low_Bound (synth)
@@ -4028,6 +4189,7 @@ package Einfo is
-- (plus type attributes)
-- E_Exception
+ -- Alignment (Uint14)
-- Renamed_Entity (Node18)
-- Register_Exception_Call (Node20)
-- Interface_Name (Node21)
@@ -4042,8 +4204,8 @@ package Einfo is
-- E_Floating_Point_Type
-- E_Floating_Point_Subtype
-- Digits_Value (Uint17)
- -- Type_Low_Bound (synth)
-- Scalar_Range (Node20)
+ -- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
-- (plus type attributes)
@@ -4066,10 +4228,10 @@ package Einfo is
-- Last_Entity (Node20)
-- Interface_Name (Node21)
-- Scope_Depth_Value (Uint22)
- -- Scope_Depth (synth)
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (for a generic function)
-- Privals_Chain (Elist23) (for a protected function)
+ -- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Function_Returns_With_DSP (Flag169)
-- Default_Expressions_Processed (Flag108)
@@ -4088,12 +4250,12 @@ package Einfo is
-- Is_Abstract (Flag19)
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
- -- Is_Destructor (Flag77)
-- Is_Discrim_SO_Function (Flag176)
-- Is_Eliminated (Flag124)
-- Is_Instantiated (Flag126) (generic case only)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
+ -- Is_Overriding_Operation (Flag39) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Pure (Flag44)
-- Is_Visible_Child_Unit (Flag116)
@@ -4105,6 +4267,7 @@ package Einfo is
-- Address_Clause (synth)
-- First_Formal (synth)
-- Number_Formals (synth)
+ -- Scope_Depth (synth)
-- E_General_Access_Type
-- Storage_Size_Variable (Node15) (base type only)
@@ -4116,6 +4279,7 @@ package Einfo is
-- E_Generic_In_Parameter
-- E_Generic_In_Out_Parameter
+ -- Current_Value (Node9) (always Empty)
-- Entry_Component (Node11)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18) (always Empty)
@@ -4126,17 +4290,19 @@ package Einfo is
-- Parameter_Mode (synth)
-- E_Incomplete_Type
+ -- Non_Limited_View (Node17)
-- Private_Dependents (Elist18)
-- Discriminant_Constraint (Elist21)
- -- Girder_Constraint (Elist23)
+ -- Stored_Constraint (Elist23)
-- First_Discriminant (synth)
- -- First_Girder_Discriminant (synth)
+ -- First_Stored_Discriminant (synth)
-- (plus type attributes)
-- E_In_Parameter
-- E_In_Out_Parameter
-- E_Out_Parameter
-- Mechanism (Uint8) (returns Mechanism_Type)
+ -- Current_Value (Node9) (always Empty for IN case)
-- Discriminal_Link (Node10) (discriminals only)
-- Entry_Component (Node11)
-- Esize (Uint12)
@@ -4154,7 +4320,7 @@ package Einfo is
-- Is_Controlling_Formal (Flag97)
-- Is_Entry_Formal (Flag52)
-- Is_Optional_Parameter (Flag134)
- -- Not_Source_Assigned (Flag115)
+ -- Never_Set_In_Source (Flag115)
-- Parameter_Mode (synth)
-- E_Label
@@ -4169,11 +4335,11 @@ package Einfo is
-- Last_Entity (Node20)
-- Discriminant_Constraint (Elist21)
-- Private_View (Node22)
- -- Girder_Constraint (Elist23)
+ -- Stored_Constraint (Elist23)
-- Has_Completion (Flag26)
-- Has_Completion_In_Body (Flag71)
-- First_Discriminant (synth)
- -- First_Girder_Discriminant (synth)
+ -- First_Stored_Discriminant (synth)
-- (plus type attributes)
-- E_Loop
@@ -4205,6 +4371,7 @@ package Einfo is
-- Is_Machine_Code_Subprogram (Flag137)
-- Is_Pure (Flag44)
-- Is_Intrinsic_Subprogram (Flag64)
+ -- Is_Overriding_Operation (Flag39)
-- Default_Expressions_Processed (Flag108)
-- Has_Pragma_Pure_Function (Flag179)
@@ -4221,8 +4388,10 @@ package Einfo is
-- E_Package
-- E_Generic_Package
-- Dependent_Instances (Elist8) (for an instance)
+ -- Non_Limited_Views (Elist8) (non-generic, not instance)
-- Renaming_Map (Uint9)
-- Handler_Records (List10) (non-generic case only)
+ -- Generic_Homonym (Node11) (generic case only)
-- Associated_Formal_Package (Node12)
-- Elaboration_Entity (Node13)
-- Shadow_Entities (List14)
@@ -4234,10 +4403,11 @@ package Einfo is
-- Last_Entity (Node20)
-- Interface_Name (Node21)
-- Scope_Depth_Value (Uint22)
- -- Scope_Depth (synth)
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (generic case only)
+ -- Limited_Views (Elist23) (non-generic, not instance)
-- Delay_Subprogram_Descriptors (Flag50)
+ -- Body_Needed_For_SAL (Flag40)
-- Discard_Names (Flag88)
-- Elaborate_All_Desirable (Flag146)
-- Elaboration_Entity_Required (Flag174)
@@ -4254,9 +4424,11 @@ package Einfo is
-- Is_Private_Descendant (Flag53)
-- Is_Visible_Child_Unit (Flag116)
-- Is_Wrapper_Package (synth) (non-generic case only)
+ -- Scope_Depth (synth)
-- E_Package_Body
-- Handler_Records (List10) (non-generic case only)
+ -- Related_Instance (Node15) (non-generic case only)
-- First_Entity (Node17)
-- Spec_Entity (Node19)
-- Last_Entity (Node20)
@@ -4274,13 +4446,13 @@ package Einfo is
-- Last_Entity (Node20)
-- Discriminant_Constraint (Elist21)
-- Private_View (Node22)
- -- Girder_Constraint (Elist23)
+ -- Stored_Constraint (Elist23)
-- Has_Completion (Flag26)
-- Has_Completion_In_Body (Flag71)
-- Is_Controlled (Flag42) (base type only)
-- Is_For_Access_Subtype (Flag118) (subtype only)
-- First_Discriminant (synth)
- -- First_Girder_Discriminant (synth)
+ -- First_Stored_Discriminant (synth)
-- (plus type attributes)
-- E_Procedure
@@ -4304,6 +4476,7 @@ package Einfo is
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (for a generic procedure)
-- Privals_Chain (Elist23) (for a protected procedure)
+ -- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Function_Returns_With_DSP (Flag169) (always False for procedure)
-- Default_Expressions_Processed (Flag108)
@@ -4321,13 +4494,13 @@ package Einfo is
-- Is_Asynchronous (Flag81)
-- Is_Called (Flag102) (non-generic subprogram)
-- Is_Constructor (Flag76)
- -- Is_Destructor (Flag77)
-- Is_Eliminated (Flag124)
-- Is_Instantiated (Flag126) (generic case only)
-- Is_Interrupt_Handler (Flag89)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Null_Init_Proc (Flag178)
+ -- Is_Overriding_Operation (Flag39) (non-generic case only)
-- Is_Private_Descendant (Flag53)
-- Is_Pure (Flag44)
-- Is_Valued_Procedure (Flag127)
@@ -4356,7 +4529,7 @@ package Einfo is
-- Discriminant_Constraint (Elist21)
-- Scope_Depth_Value (Uint22)
-- Scope_Depth (synth)
- -- Girder_Constraint (Elist23)
+ -- Stored_Constraint (Elist23)
-- Has_Controlled_Component (Flag43) (base type only)
-- Has_Interrupt_Handler (synth)
-- Sec_Stack_Needed_For_Return (Flag167) ???
@@ -4375,19 +4548,20 @@ package Einfo is
-- Last_Entity (Node20)
-- Discriminant_Constraint (Elist21)
-- Corresponding_Remote_Type (Node22)
- -- Girder_Constraint (Elist23)
+ -- Stored_Constraint (Elist23)
-- Component_Alignment (special) (base type only)
-- C_Pass_By_Copy (Flag125) (base type only)
-- Has_Controlled_Component (Flag43) (base type only)
-- Has_External_Tag_Rep_Clause (Flag110)
-- Has_Record_Rep_Clause (Flag65) (base type only)
+ -- Is_Class_Wide_Equivalent_Type (Flag35)
-- Is_Concurrent_Record_Type (Flag20)
-- Is_Constrained (Flag12)
-- Is_Controlled (Flag42) (base type only)
-- Reverse_Bit_Order (Flag164) (base type only)
-- First_Component (synth)
-- First_Discriminant (synth)
- -- First_Girder_Discriminant (synth)
+ -- First_Stored_Discriminant (synth)
-- Tag_Component (synth)
-- (plus type attributes)
@@ -4401,7 +4575,7 @@ package Einfo is
-- Last_Entity (Node20)
-- Discriminant_Constraint (Elist21)
-- Private_View (Node22)
- -- Girder_Constraint (Elist23)
+ -- Stored_Constraint (Elist23)
-- Has_Completion (Flag26)
-- Has_Completion_In_Body (Flag71)
-- Has_Controlled_Component (Flag43) (base type only)
@@ -4413,7 +4587,7 @@ package Einfo is
-- Reverse_Bit_Order (Flag164) (base type only)
-- First_Component (synth)
-- First_Discriminant (synth)
- -- First_Girder_Discriminant (synth)
+ -- First_Stored_Discriminant (synth)
-- Tag_Component (synth)
-- (plus type attributes)
@@ -4469,7 +4643,7 @@ package Einfo is
-- Discriminant_Constraint (Elist21)
-- Scope_Depth_Value (Uint22)
-- Scope_Depth (synth)
- -- Girder_Constraint (Elist23)
+ -- Stored_Constraint (Elist23)
-- Delay_Cleanups (Flag114)
-- Has_Master_Entity (Flag21)
-- Has_Storage_Size_Clause (Flag23) (base type only)
@@ -4481,7 +4655,7 @@ package Einfo is
-- E_Variable
-- Hiding_Loop_Variable (Node8)
- -- Size_Check_Code (Node9)
+ -- Current_Value (Node9)
-- Esize (Uint12)
-- Extra_Accessibility (Node13)
-- Alignment (Uint14)
@@ -4489,6 +4663,7 @@ package Einfo is
-- Unset_Reference (Node16)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
+ -- Size_Check_Code (Node19)
-- Interface_Name (Node21)
-- Shared_Var_Assign_Proc (Node22)
-- Extra_Constrained (Node23)
@@ -4503,9 +4678,11 @@ package Einfo is
-- Is_Shared_Passive (Flag60)
-- Is_True_Constant (Flag163)
-- Is_Volatile (Flag16)
- -- Not_Source_Assigned (Flag115)
+ -- Never_Set_In_Source (Flag115)
+ -- Treat_As_Volatile (Flag41)
-- Address_Clause (synth)
-- Alignment_Clause (synth)
+ -- Constant_Value (synth)
-- Size_Clause (synth)
-- E_Void
@@ -4574,22 +4751,12 @@ package Einfo is
-- There are three ways that checks can be suppressed:
- -- 1. At the command line level. Package Opt contains global Boolean
- -- flags with names Suppress_Options.xxx_Checks, where xxx is the
- -- name of one of the checks that can be suppressed (excluding
- -- All_Checks, which is simply reflected by setting all the
- -- individual flags)
-
- -- 2. At the scope level. The body of Sem contains flags with names
- -- Suppress.xxx_Checks which are set to indicate that the given
- -- check is suppressed for the current scope. These flags are
- -- saved in the scope stack on entry to a scope and restored on
- -- exit from the scope.
+ -- 1. At the command line level
+ -- 2. At the scope level.
+ -- 3. At the entity level.
- -- 3. At the entity level. Each entity contains a set of flags named
- -- Suppress_xxx_Checks which suppress the given check for that
- -- particularly entity (of course not all flags are meaningful for
- -- all entities).
+ -- See spec of Sem in sem.ads for details of the data structures used
+ -- to keep track of these various methods for suppressing checks.
-------------------------------
-- Handling of Discriminants --
@@ -4760,8 +4927,11 @@ package Einfo is
function Barrier_Function (Id : E) return N;
function Block_Node (Id : E) return N;
function Body_Entity (Id : E) return E;
+ function Body_Needed_For_SAL (Id : E) return B;
function CR_Discriminant (Id : E) return E;
function C_Pass_By_Copy (Id : E) return B;
+ function Can_Never_Be_Null (Id : E) return B;
+ function Checks_May_Be_Suppressed (Id : E) return B;
function Class_Wide_Type (Id : E) return E;
function Cloned_Subtype (Id : E) return E;
function Component_Alignment (Id : E) return C;
@@ -4774,6 +4944,7 @@ package Einfo is
function Corresponding_Equality (Id : E) return E;
function Corresponding_Record_Type (Id : E) return E;
function Corresponding_Remote_Type (Id : E) return E;
+ function Current_Value (Id : E) return N;
function Debug_Info_Off (Id : E) return B;
function Debug_Renaming_Link (Id : E) return E;
function DTC_Entity (Id : E) return E;
@@ -4830,8 +5001,8 @@ package Einfo is
function From_With_Type (Id : E) return B;
function Full_View (Id : E) return E;
function Function_Returns_With_DSP (Id : E) return B;
+ function Generic_Homonym (Id : E) return E;
function Generic_Renamings (Id : E) return L;
- function Girder_Constraint (Id : E) return L;
function Handler_Records (Id : E) return S;
function Has_Aliased_Components (Id : E) return B;
function Has_Alignment_Clause (Id : E) return B;
@@ -4842,6 +5013,7 @@ package Einfo is
function Has_Completion_In_Body (Id : E) return B;
function Has_Complex_Representation (Id : E) return B;
function Has_Component_Size_Clause (Id : E) return B;
+ function Has_Contiguous_Rep (Id : E) return B;
function Has_Controlled_Component (Id : E) return B;
function Has_Controlling_Result (Id : E) return B;
function Has_Convention_Pragma (Id : E) return B;
@@ -4881,8 +5053,9 @@ package Einfo is
function Has_Unchecked_Union (Id : E) return B;
function Has_Unknown_Discriminants (Id : E) return B;
function Has_Volatile_Components (Id : E) return B;
- function Homonym (Id : E) return E;
+ function Has_Xref_Entry (Id : E) return B;
function Hiding_Loop_Variable (Id : E) return E;
+ function Homonym (Id : E) return E;
function In_Package_Body (Id : E) return B;
function In_Private_Part (Id : E) return B;
function In_Use (Id : E) return B;
@@ -4899,6 +5072,7 @@ package Einfo is
function Is_Called (Id : E) return B;
function Is_Character_Type (Id : E) return B;
function Is_Child_Unit (Id : E) return B;
+ function Is_Class_Wide_Equivalent_Type (Id : E) return B;
function Is_Compilation_Unit (Id : E) return B;
function Is_Completely_Hidden (Id : E) return B;
function Is_Constr_Subt_For_UN_Aliased (Id : E) return B;
@@ -4907,7 +5081,6 @@ package Einfo is
function Is_Constructor (Id : E) return B;
function Is_Controlled (Id : E) return B;
function Is_Controlling_Formal (Id : E) return B;
- function Is_Destructor (Id : E) return B;
function Is_Discrim_SO_Function (Id : E) return B;
function Is_Dispatching_Operation (Id : E) return B;
function Is_Eliminated (Id : E) return B;
@@ -4927,6 +5100,7 @@ package Einfo is
function Is_Interrupt_Handler (Id : E) return B;
function Is_Intrinsic_Subprogram (Id : E) return B;
function Is_Itype (Id : E) return B;
+ function Is_Known_Non_Null (Id : E) return B;
function Is_Known_Valid (Id : E) return B;
function Is_Limited_Composite (Id : E) return B;
function Is_Machine_Code_Subprogram (Id : E) return B;
@@ -4958,7 +5132,11 @@ package Einfo is
function Is_Visible_Child_Unit (Id : E) return B;
function Is_Volatile (Id : E) return B;
function Is_Wrapper_Package (Id : E) return B;
+ function Kill_Elaboration_Checks (Id : E) return B;
+ function Kill_Range_Checks (Id : E) return B;
+ function Kill_Tag_Checks (Id : E) return B;
function Last_Entity (Id : E) return E;
+ function Limited_Views (Id : E) return L;
function Lit_Indexes (Id : E) return E;
function Lit_Strings (Id : E) return E;
function Machine_Radix_10 (Id : E) return B;
@@ -4968,15 +5146,17 @@ package Einfo is
function Modulus (Id : E) return U;
function Needs_Debug_Info (Id : E) return B;
function Needs_No_Actuals (Id : E) return B;
+ function Never_Set_In_Source (Id : E) return B;
function Next_Inlined_Subprogram (Id : E) return E;
function No_Pool_Assigned (Id : E) return B;
function No_Return (Id : E) return B;
function Non_Binary_Modulus (Id : E) return B;
+ function Non_Limited_View (Id : E) return E;
+ function Non_Limited_Views (Id : E) return L;
function Nonzero_Is_True (Id : E) return B;
function Normalized_First_Bit (Id : E) return U;
function Normalized_Position (Id : E) return U;
function Normalized_Position_Max (Id : E) return U;
- function Not_Source_Assigned (Id : E) return B;
function Object_Ref (Id : E) return E;
function Original_Array_Type (Id : E) return E;
function Original_Record_Component (Id : E) return E;
@@ -4993,6 +5173,7 @@ package Einfo is
function RM_Size (Id : E) return U;
function Reachable (Id : E) return B;
function Referenced (Id : E) return B;
+ function Referenced_As_LHS (Id : E) return B;
function Referenced_Object (Id : E) return N;
function Register_Exception_Call (Id : E) return N;
function Related_Array_Object (Id : E) return E;
@@ -5016,23 +5197,14 @@ package Einfo is
function Small_Value (Id : E) return R;
function Spec_Entity (Id : E) return E;
function Storage_Size_Variable (Id : E) return E;
+ function Stored_Constraint (Id : E) return L;
function Strict_Alignment (Id : E) return B;
function String_Literal_Length (Id : E) return U;
function String_Literal_Low_Bound (Id : E) return N;
- function Suppress_Access_Checks (Id : E) return B;
- function Suppress_Accessibility_Checks (Id : E) return B;
- function Suppress_Discriminant_Checks (Id : E) return B;
- function Suppress_Division_Checks (Id : E) return B;
- function Suppress_Elaboration_Checks (Id : E) return B;
function Suppress_Elaboration_Warnings (Id : E) return B;
- function Suppress_Index_Checks (Id : E) return B;
function Suppress_Init_Proc (Id : E) return B;
- function Suppress_Length_Checks (Id : E) return B;
- function Suppress_Overflow_Checks (Id : E) return B;
- function Suppress_Range_Checks (Id : E) return B;
- function Suppress_Storage_Checks (Id : E) return B;
function Suppress_Style_Checks (Id : E) return B;
- function Suppress_Tag_Checks (Id : E) return B;
+ function Treat_As_Volatile (Id : E) return B;
function Underlying_Full_View (Id : E) return E;
function Unset_Reference (Id : E) return N;
function Uses_Sec_Stack (Id : E) return B;
@@ -5068,8 +5240,9 @@ package Einfo is
function Is_Formal (Id : E) return B;
function Is_Formal_Subprogram (Id : E) return B;
function Is_Generic_Actual_Type (Id : E) return B;
- function Is_Generic_Type (Id : E) return B;
function Is_Generic_Unit (Id : E) return B;
+ function Is_Generic_Type (Id : E) return B;
+ function Is_Generic_Subprogram (Id : E) return B;
function Is_Incomplete_Or_Private_Type (Id : E) return B;
function Is_Integer_Type (Id : E) return B;
function Is_Limited_Record (Id : E) return B;
@@ -5079,6 +5252,7 @@ package Einfo is
function Is_Object (Id : E) return B;
function Is_Ordinary_Fixed_Point_Type (Id : E) return B;
function Is_Overloadable (Id : E) return B;
+ function Is_Overriding_Operation (Id : E) return B;
function Is_Private_Type (Id : E) return B;
function Is_Protected_Type (Id : E) return B;
function Is_Real_Type (Id : E) return B;
@@ -5107,7 +5281,7 @@ package Einfo is
function First_Component (Id : E) return E;
function First_Discriminant (Id : E) return E;
function First_Formal (Id : E) return E;
- function First_Girder_Discriminant (Id : E) return E;
+ function First_Stored_Discriminant (Id : E) return E;
function First_Subtype (Id : E) return E;
function Has_Attach_Handler (Id : E) return B;
function Has_Entries (Id : E) return B;
@@ -5133,8 +5307,8 @@ package Einfo is
function Next_Discriminant (Id : E) return E;
function Next_Formal (Id : E) return E;
function Next_Formal_With_Extras (Id : E) return E;
- function Next_Girder_Discriminant (Id : E) return E;
function Next_Literal (Id : E) return E;
+ function Next_Stored_Discriminant (Id : E) return E;
function Number_Dimensions (Id : E) return Pos;
function Number_Discriminants (Id : E) return Pos;
function Number_Entries (Id : E) return Nat;
@@ -5221,8 +5395,11 @@ package Einfo is
procedure Set_Barrier_Function (Id : E; V : N);
procedure Set_Block_Node (Id : E; V : N);
procedure Set_Body_Entity (Id : E; V : E);
+ procedure Set_Body_Needed_For_SAL (Id : E; V : B := True);
procedure Set_CR_Discriminant (Id : E; V : E);
procedure Set_C_Pass_By_Copy (Id : E; V : B := True);
+ procedure Set_Can_Never_Be_Null (Id : E; V : B := True);
+ procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True);
procedure Set_Class_Wide_Type (Id : E; V : E);
procedure Set_Cloned_Subtype (Id : E; V : E);
procedure Set_Component_Alignment (Id : E; V : C);
@@ -5235,6 +5412,7 @@ package Einfo is
procedure Set_Corresponding_Equality (Id : E; V : E);
procedure Set_Corresponding_Record_Type (Id : E; V : E);
procedure Set_Corresponding_Remote_Type (Id : E; V : E);
+ procedure Set_Current_Value (Id : E; V : N);
procedure Set_Debug_Info_Off (Id : E; V : B := True);
procedure Set_Debug_Renaming_Link (Id : E; V : E);
procedure Set_DTC_Entity (Id : E; V : E);
@@ -5290,8 +5468,8 @@ package Einfo is
procedure Set_From_With_Type (Id : E; V : B := True);
procedure Set_Full_View (Id : E; V : E);
procedure Set_Function_Returns_With_DSP (Id : E; V : B := True);
+ procedure Set_Generic_Homonym (Id : E; V : E);
procedure Set_Generic_Renamings (Id : E; V : L);
- procedure Set_Girder_Constraint (Id : E; V : L);
procedure Set_Handler_Records (Id : E; V : S);
procedure Set_Has_Aliased_Components (Id : E; V : B := True);
procedure Set_Has_Alignment_Clause (Id : E; V : B := True);
@@ -5302,6 +5480,7 @@ package Einfo is
procedure Set_Has_Completion_In_Body (Id : E; V : B := True);
procedure Set_Has_Complex_Representation (Id : E; V : B := True);
procedure Set_Has_Component_Size_Clause (Id : E; V : B := True);
+ procedure Set_Has_Contiguous_Rep (Id : E; V : B := True);
procedure Set_Has_Controlled_Component (Id : E; V : B := True);
procedure Set_Has_Controlling_Result (Id : E; V : B := True);
procedure Set_Has_Convention_Pragma (Id : E; V : B := True);
@@ -5341,6 +5520,7 @@ package Einfo is
procedure Set_Has_Unchecked_Union (Id : E; V : B := True);
procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True);
procedure Set_Has_Volatile_Components (Id : E; V : B := True);
+ procedure Set_Has_Xref_Entry (Id : E; V : B := True);
procedure Set_Hiding_Loop_Variable (Id : E; V : E);
procedure Set_Homonym (Id : E; V : E);
procedure Set_In_Package_Body (Id : E; V : B := True);
@@ -5359,6 +5539,7 @@ package Einfo is
procedure Set_Is_Called (Id : E; V : B := True);
procedure Set_Is_Character_Type (Id : E; V : B := True);
procedure Set_Is_Child_Unit (Id : E; V : B := True);
+ procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True);
procedure Set_Is_Compilation_Unit (Id : E; V : B := True);
procedure Set_Is_Completely_Hidden (Id : E; V : B := True);
procedure Set_Is_Concurrent_Record_Type (Id : E; V : B := True);
@@ -5368,7 +5549,6 @@ package Einfo is
procedure Set_Is_Constructor (Id : E; V : B := True);
procedure Set_Is_Controlled (Id : E; V : B := True);
procedure Set_Is_Controlling_Formal (Id : E; V : B := True);
- procedure Set_Is_Destructor (Id : E; V : B := True);
procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True);
procedure Set_Is_Dispatching_Operation (Id : E; V : B := True);
procedure Set_Is_Eliminated (Id : E; V : B := True);
@@ -5391,6 +5571,7 @@ package Einfo is
procedure Set_Is_Interrupt_Handler (Id : E; V : B := True);
procedure Set_Is_Intrinsic_Subprogram (Id : E; V : B := True);
procedure Set_Is_Itype (Id : E; V : B := True);
+ procedure Set_Is_Known_Non_Null (Id : E; V : B := True);
procedure Set_Is_Known_Valid (Id : E; V : B := True);
procedure Set_Is_Limited_Composite (Id : E; V : B := True);
procedure Set_Is_Limited_Record (Id : E; V : B := True);
@@ -5398,6 +5579,7 @@ package Einfo is
procedure Set_Is_Non_Static_Subtype (Id : E; V : B := True);
procedure Set_Is_Null_Init_Proc (Id : E; V : B := True);
procedure Set_Is_Optional_Parameter (Id : E; V : B := True);
+ procedure Set_Is_Overriding_Operation (Id : E; V : B := True);
procedure Set_Is_Package_Body_Entity (Id : E; V : B := True);
procedure Set_Is_Packed (Id : E; V : B := True);
procedure Set_Is_Packed_Array_Type (Id : E; V : B := True);
@@ -5422,7 +5604,11 @@ package Einfo is
procedure Set_Is_Valued_Procedure (Id : E; V : B := True);
procedure Set_Is_Visible_Child_Unit (Id : E; V : B := True);
procedure Set_Is_Volatile (Id : E; V : B := True);
+ procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True);
+ procedure Set_Kill_Range_Checks (Id : E; V : B := True);
+ procedure Set_Kill_Tag_Checks (Id : E; V : B := True);
procedure Set_Last_Entity (Id : E; V : E);
+ procedure Set_Limited_Views (Id : E; V : L);
procedure Set_Lit_Indexes (Id : E; V : E);
procedure Set_Lit_Strings (Id : E; V : E);
procedure Set_Machine_Radix_10 (Id : E; V : B := True);
@@ -5432,15 +5618,17 @@ package Einfo is
procedure Set_Modulus (Id : E; V : U);
procedure Set_Needs_Debug_Info (Id : E; V : B := True);
procedure Set_Needs_No_Actuals (Id : E; V : B := True);
+ procedure Set_Never_Set_In_Source (Id : E; V : B := True);
procedure Set_Next_Inlined_Subprogram (Id : E; V : E);
procedure Set_No_Pool_Assigned (Id : E; V : B := True);
procedure Set_No_Return (Id : E; V : B := True);
procedure Set_Non_Binary_Modulus (Id : E; V : B := True);
+ procedure Set_Non_Limited_View (Id : E; V : E);
+ procedure Set_Non_Limited_Views (Id : E; V : L);
procedure Set_Nonzero_Is_True (Id : E; V : B := True);
procedure Set_Normalized_First_Bit (Id : E; V : U);
procedure Set_Normalized_Position (Id : E; V : U);
procedure Set_Normalized_Position_Max (Id : E; V : U);
- procedure Set_Not_Source_Assigned (Id : E; V : B := True);
procedure Set_Object_Ref (Id : E; V : E);
procedure Set_Original_Array_Type (Id : E; V : E);
procedure Set_Original_Record_Component (Id : E; V : E);
@@ -5457,6 +5645,7 @@ package Einfo is
procedure Set_RM_Size (Id : E; V : U);
procedure Set_Reachable (Id : E; V : B := True);
procedure Set_Referenced (Id : E; V : B := True);
+ procedure Set_Referenced_As_LHS (Id : E; V : B := True);
procedure Set_Referenced_Object (Id : E; V : N);
procedure Set_Register_Exception_Call (Id : E; V : N);
procedure Set_Related_Array_Object (Id : E; V : E);
@@ -5480,23 +5669,14 @@ package Einfo is
procedure Set_Small_Value (Id : E; V : R);
procedure Set_Spec_Entity (Id : E; V : E);
procedure Set_Storage_Size_Variable (Id : E; V : E);
+ procedure Set_Stored_Constraint (Id : E; V : L);
procedure Set_Strict_Alignment (Id : E; V : B := True);
procedure Set_String_Literal_Length (Id : E; V : U);
procedure Set_String_Literal_Low_Bound (Id : E; V : N);
- procedure Set_Suppress_Access_Checks (Id : E; V : B := True);
- procedure Set_Suppress_Accessibility_Checks (Id : E; V : B := True);
- procedure Set_Suppress_Discriminant_Checks (Id : E; V : B := True);
- procedure Set_Suppress_Division_Checks (Id : E; V : B := True);
- procedure Set_Suppress_Elaboration_Checks (Id : E; V : B := True);
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True);
- procedure Set_Suppress_Index_Checks (Id : E; V : B := True);
procedure Set_Suppress_Init_Proc (Id : E; V : B := True);
- procedure Set_Suppress_Length_Checks (Id : E; V : B := True);
- procedure Set_Suppress_Overflow_Checks (Id : E; V : B := True);
- procedure Set_Suppress_Range_Checks (Id : E; V : B := True);
- procedure Set_Suppress_Storage_Checks (Id : E; V : B := True);
procedure Set_Suppress_Style_Checks (Id : E; V : B := True);
- procedure Set_Suppress_Tag_Checks (Id : E; V : B := True);
+ procedure Set_Treat_As_Volatile (Id : E; V : B := True);
procedure Set_Underlying_Full_View (Id : E; V : E);
procedure Set_Unset_Reference (Id : E; V : N);
procedure Set_Uses_Sec_Stack (Id : E; V : B := True);
@@ -5572,19 +5752,19 @@ package Einfo is
procedure Proc_Next_Discriminant (N : in out Node_Id);
procedure Proc_Next_Formal (N : in out Node_Id);
procedure Proc_Next_Formal_With_Extras (N : in out Node_Id);
- procedure Proc_Next_Girder_Discriminant (N : in out Node_Id);
procedure Proc_Next_Index (N : in out Node_Id);
procedure Proc_Next_Inlined_Subprogram (N : in out Node_Id);
procedure Proc_Next_Literal (N : in out Node_Id);
+ procedure Proc_Next_Stored_Discriminant (N : in out Node_Id);
pragma Inline (Proc_Next_Component);
pragma Inline (Proc_Next_Discriminant);
pragma Inline (Proc_Next_Formal);
pragma Inline (Proc_Next_Formal_With_Extras);
- pragma Inline (Proc_Next_Girder_Discriminant);
pragma Inline (Proc_Next_Index);
pragma Inline (Proc_Next_Inlined_Subprogram);
pragma Inline (Proc_Next_Literal);
+ pragma Inline (Proc_Next_Stored_Discriminant);
procedure Next_Component (N : in out Node_Id)
renames Proc_Next_Component;
@@ -5598,9 +5778,6 @@ package Einfo is
procedure Next_Formal_With_Extras (N : in out Node_Id)
renames Proc_Next_Formal_With_Extras;
- procedure Next_Girder_Discriminant (N : in out Node_Id)
- renames Proc_Next_Girder_Discriminant;
-
procedure Next_Index (N : in out Node_Id)
renames Proc_Next_Index;
@@ -5610,6 +5787,9 @@ package Einfo is
procedure Next_Literal (N : in out Node_Id)
renames Proc_Next_Literal;
+ procedure Next_Stored_Discriminant (N : in out Node_Id)
+ renames Proc_Next_Stored_Discriminant;
+
-------------------------------
-- Miscellaneous Subprograms --
-------------------------------
@@ -5706,8 +5886,11 @@ package Einfo is
pragma Inline (Barrier_Function);
pragma Inline (Block_Node);
pragma Inline (Body_Entity);
+ pragma Inline (Body_Needed_For_SAL);
pragma Inline (CR_Discriminant);
pragma Inline (C_Pass_By_Copy);
+ pragma Inline (Can_Never_Be_Null);
+ pragma Inline (Checks_May_Be_Suppressed);
pragma Inline (Class_Wide_Type);
pragma Inline (Cloned_Subtype);
pragma Inline (Component_Bit_Offset);
@@ -5719,6 +5902,7 @@ package Einfo is
pragma Inline (Corresponding_Equality);
pragma Inline (Corresponding_Record_Type);
pragma Inline (Corresponding_Remote_Type);
+ pragma Inline (Current_Value);
pragma Inline (Debug_Info_Off);
pragma Inline (Debug_Renaming_Link);
pragma Inline (DTC_Entity);
@@ -5774,8 +5958,8 @@ package Einfo is
pragma Inline (From_With_Type);
pragma Inline (Full_View);
pragma Inline (Function_Returns_With_DSP);
+ pragma Inline (Generic_Homonym);
pragma Inline (Generic_Renamings);
- pragma Inline (Girder_Constraint);
pragma Inline (Handler_Records);
pragma Inline (Has_Aliased_Components);
pragma Inline (Has_Alignment_Clause);
@@ -5786,6 +5970,7 @@ package Einfo is
pragma Inline (Has_Completion_In_Body);
pragma Inline (Has_Complex_Representation);
pragma Inline (Has_Component_Size_Clause);
+ pragma Inline (Has_Contiguous_Rep);
pragma Inline (Has_Controlled_Component);
pragma Inline (Has_Controlling_Result);
pragma Inline (Has_Convention_Pragma);
@@ -5825,6 +6010,7 @@ package Einfo is
pragma Inline (Has_Unchecked_Union);
pragma Inline (Has_Unknown_Discriminants);
pragma Inline (Has_Volatile_Components);
+ pragma Inline (Has_Xref_Entry);
pragma Inline (Hiding_Loop_Variable);
pragma Inline (Homonym);
pragma Inline (In_Package_Body);
@@ -5845,6 +6031,7 @@ package Einfo is
pragma Inline (Is_Called);
pragma Inline (Is_Character_Type);
pragma Inline (Is_Child_Unit);
+ pragma Inline (Is_Class_Wide_Equivalent_Type);
pragma Inline (Is_Class_Wide_Type);
pragma Inline (Is_Compilation_Unit);
pragma Inline (Is_Completely_Hidden);
@@ -5859,7 +6046,6 @@ package Einfo is
pragma Inline (Is_Controlled);
pragma Inline (Is_Controlling_Formal);
pragma Inline (Is_Decimal_Fixed_Point_Type);
- pragma Inline (Is_Destructor);
pragma Inline (Is_Discrim_SO_Function);
pragma Inline (Is_Digits_Type);
pragma Inline (Is_Discrete_Or_Fixed_Point_Type);
@@ -5880,6 +6066,7 @@ package Einfo is
pragma Inline (Is_Frozen);
pragma Inline (Is_Generic_Actual_Type);
pragma Inline (Is_Generic_Instance);
+ pragma Inline (Is_Generic_Subprogram);
pragma Inline (Is_Generic_Type);
pragma Inline (Is_Generic_Unit);
pragma Inline (Is_Hidden);
@@ -5894,6 +6081,7 @@ package Einfo is
pragma Inline (Is_Interrupt_Handler);
pragma Inline (Is_Intrinsic_Subprogram);
pragma Inline (Is_Itype);
+ pragma Inline (Is_Known_Non_Null);
pragma Inline (Is_Known_Valid);
pragma Inline (Is_Limited_Composite);
pragma Inline (Is_Limited_Record);
@@ -5908,6 +6096,7 @@ package Einfo is
pragma Inline (Is_Package_Body_Entity);
pragma Inline (Is_Ordinary_Fixed_Point_Type);
pragma Inline (Is_Overloadable);
+ pragma Inline (Is_Overriding_Operation);
pragma Inline (Is_Packed);
pragma Inline (Is_Packed_Array_Type);
pragma Inline (Is_Potentially_Use_Visible);
@@ -5939,8 +6128,11 @@ package Einfo is
pragma Inline (Is_VMS_Exception);
pragma Inline (Is_Valued_Procedure);
pragma Inline (Is_Visible_Child_Unit);
- pragma Inline (Is_Volatile);
+ pragma Inline (Kill_Elaboration_Checks);
+ pragma Inline (Kill_Range_Checks);
+ pragma Inline (Kill_Tag_Checks);
pragma Inline (Last_Entity);
+ pragma Inline (Limited_Views);
pragma Inline (Lit_Indexes);
pragma Inline (Lit_Strings);
pragma Inline (Machine_Radix_10);
@@ -5950,17 +6142,19 @@ package Einfo is
pragma Inline (Modulus);
pragma Inline (Needs_Debug_Info);
pragma Inline (Needs_No_Actuals);
+ pragma Inline (Never_Set_In_Source);
pragma Inline (Next_Index);
pragma Inline (Next_Inlined_Subprogram);
pragma Inline (Next_Literal);
pragma Inline (No_Pool_Assigned);
pragma Inline (No_Return);
pragma Inline (Non_Binary_Modulus);
+ pragma Inline (Non_Limited_View);
+ pragma Inline (Non_Limited_Views);
pragma Inline (Nonzero_Is_True);
pragma Inline (Normalized_First_Bit);
pragma Inline (Normalized_Position);
pragma Inline (Normalized_Position_Max);
- pragma Inline (Not_Source_Assigned);
pragma Inline (Object_Ref);
pragma Inline (Original_Array_Type);
pragma Inline (Original_Record_Component);
@@ -5978,6 +6172,7 @@ package Einfo is
pragma Inline (RM_Size);
pragma Inline (Reachable);
pragma Inline (Referenced);
+ pragma Inline (Referenced_As_LHS);
pragma Inline (Referenced_Object);
pragma Inline (Register_Exception_Call);
pragma Inline (Related_Array_Object);
@@ -6001,23 +6196,14 @@ package Einfo is
pragma Inline (Small_Value);
pragma Inline (Spec_Entity);
pragma Inline (Storage_Size_Variable);
+ pragma Inline (Stored_Constraint);
pragma Inline (Strict_Alignment);
pragma Inline (String_Literal_Length);
pragma Inline (String_Literal_Low_Bound);
- pragma Inline (Suppress_Access_Checks);
- pragma Inline (Suppress_Accessibility_Checks);
- pragma Inline (Suppress_Discriminant_Checks);
- pragma Inline (Suppress_Division_Checks);
- pragma Inline (Suppress_Elaboration_Checks);
pragma Inline (Suppress_Elaboration_Warnings);
- pragma Inline (Suppress_Index_Checks);
pragma Inline (Suppress_Init_Proc);
- pragma Inline (Suppress_Length_Checks);
- pragma Inline (Suppress_Overflow_Checks);
- pragma Inline (Suppress_Range_Checks);
- pragma Inline (Suppress_Storage_Checks);
pragma Inline (Suppress_Style_Checks);
- pragma Inline (Suppress_Tag_Checks);
+ pragma Inline (Treat_As_Volatile);
pragma Inline (Underlying_Full_View);
pragma Inline (Unset_Reference);
pragma Inline (Uses_Sec_Stack);
@@ -6044,8 +6230,11 @@ package Einfo is
pragma Inline (Set_Barrier_Function);
pragma Inline (Set_Block_Node);
pragma Inline (Set_Body_Entity);
+ pragma Inline (Set_Body_Needed_For_SAL);
pragma Inline (Set_CR_Discriminant);
pragma Inline (Set_C_Pass_By_Copy);
+ pragma Inline (Set_Can_Never_Be_Null);
+ pragma Inline (Set_Checks_May_Be_Suppressed);
pragma Inline (Set_Class_Wide_Type);
pragma Inline (Set_Cloned_Subtype);
pragma Inline (Set_Component_Bit_Offset);
@@ -6057,6 +6246,7 @@ package Einfo is
pragma Inline (Set_Corresponding_Equality);
pragma Inline (Set_Corresponding_Record_Type);
pragma Inline (Set_Corresponding_Remote_Type);
+ pragma Inline (Set_Current_Value);
pragma Inline (Set_Debug_Info_Off);
pragma Inline (Set_Debug_Renaming_Link);
pragma Inline (Set_DTC_Entity);
@@ -6109,8 +6299,8 @@ package Einfo is
pragma Inline (Set_From_With_Type);
pragma Inline (Set_Full_View);
pragma Inline (Set_Function_Returns_With_DSP);
+ pragma Inline (Set_Generic_Homonym);
pragma Inline (Set_Generic_Renamings);
- pragma Inline (Set_Girder_Constraint);
pragma Inline (Set_Handler_Records);
pragma Inline (Set_Has_Aliased_Components);
pragma Inline (Set_Has_Alignment_Clause);
@@ -6121,6 +6311,7 @@ package Einfo is
pragma Inline (Set_Has_Completion_In_Body);
pragma Inline (Set_Has_Complex_Representation);
pragma Inline (Set_Has_Component_Size_Clause);
+ pragma Inline (Set_Has_Contiguous_Rep);
pragma Inline (Set_Has_Controlled_Component);
pragma Inline (Set_Has_Controlling_Result);
pragma Inline (Set_Has_Convention_Pragma);
@@ -6160,6 +6351,7 @@ package Einfo is
pragma Inline (Set_Has_Unchecked_Union);
pragma Inline (Set_Has_Unknown_Discriminants);
pragma Inline (Set_Has_Volatile_Components);
+ pragma Inline (Set_Has_Xref_Entry);
pragma Inline (Set_Hiding_Loop_Variable);
pragma Inline (Set_Homonym);
pragma Inline (Set_In_Package_Body);
@@ -6178,6 +6370,7 @@ package Einfo is
pragma Inline (Set_Is_Called);
pragma Inline (Set_Is_Character_Type);
pragma Inline (Set_Is_Child_Unit);
+ pragma Inline (Set_Is_Class_Wide_Equivalent_Type);
pragma Inline (Set_Is_Compilation_Unit);
pragma Inline (Set_Is_Completely_Hidden);
pragma Inline (Set_Is_Concurrent_Record_Type);
@@ -6187,7 +6380,6 @@ package Einfo is
pragma Inline (Set_Is_Constructor);
pragma Inline (Set_Is_Controlled);
pragma Inline (Set_Is_Controlling_Formal);
- pragma Inline (Set_Is_Destructor);
pragma Inline (Set_Is_Discrim_SO_Function);
pragma Inline (Set_Is_Dispatching_Operation);
pragma Inline (Set_Is_Eliminated);
@@ -6210,6 +6402,7 @@ package Einfo is
pragma Inline (Set_Is_Interrupt_Handler);
pragma Inline (Set_Is_Intrinsic_Subprogram);
pragma Inline (Set_Is_Itype);
+ pragma Inline (Set_Is_Known_Non_Null);
pragma Inline (Set_Is_Known_Valid);
pragma Inline (Set_Is_Limited_Composite);
pragma Inline (Set_Is_Limited_Record);
@@ -6217,6 +6410,7 @@ package Einfo is
pragma Inline (Set_Is_Non_Static_Subtype);
pragma Inline (Set_Is_Null_Init_Proc);
pragma Inline (Set_Is_Optional_Parameter);
+ pragma Inline (Set_Is_Overriding_Operation);
pragma Inline (Set_Is_Package_Body_Entity);
pragma Inline (Set_Is_Packed);
pragma Inline (Set_Is_Packed_Array_Type);
@@ -6241,7 +6435,11 @@ package Einfo is
pragma Inline (Set_Is_Valued_Procedure);
pragma Inline (Set_Is_Visible_Child_Unit);
pragma Inline (Set_Is_Volatile);
+ pragma Inline (Set_Kill_Elaboration_Checks);
+ pragma Inline (Set_Kill_Range_Checks);
+ pragma Inline (Set_Kill_Tag_Checks);
pragma Inline (Set_Last_Entity);
+ pragma Inline (Set_Limited_Views);
pragma Inline (Set_Lit_Indexes);
pragma Inline (Set_Lit_Strings);
pragma Inline (Set_Machine_Radix_10);
@@ -6251,15 +6449,17 @@ package Einfo is
pragma Inline (Set_Modulus);
pragma Inline (Set_Needs_Debug_Info);
pragma Inline (Set_Needs_No_Actuals);
+ pragma Inline (Set_Never_Set_In_Source);
pragma Inline (Set_Next_Inlined_Subprogram);
pragma Inline (Set_No_Pool_Assigned);
pragma Inline (Set_No_Return);
pragma Inline (Set_Non_Binary_Modulus);
+ pragma Inline (Set_Non_Limited_View);
+ pragma Inline (Set_Non_Limited_Views);
pragma Inline (Set_Nonzero_Is_True);
pragma Inline (Set_Normalized_First_Bit);
pragma Inline (Set_Normalized_Position);
pragma Inline (Set_Normalized_Position_Max);
- pragma Inline (Set_Not_Source_Assigned);
pragma Inline (Set_Object_Ref);
pragma Inline (Set_Original_Array_Type);
pragma Inline (Set_Original_Record_Component);
@@ -6276,6 +6476,7 @@ package Einfo is
pragma Inline (Set_RM_Size);
pragma Inline (Set_Reachable);
pragma Inline (Set_Referenced);
+ pragma Inline (Set_Referenced_As_LHS);
pragma Inline (Set_Referenced_Object);
pragma Inline (Set_Register_Exception_Call);
pragma Inline (Set_Related_Array_Object);
@@ -6299,23 +6500,14 @@ package Einfo is
pragma Inline (Set_Small_Value);
pragma Inline (Set_Spec_Entity);
pragma Inline (Set_Storage_Size_Variable);
+ pragma Inline (Set_Stored_Constraint);
pragma Inline (Set_Strict_Alignment);
pragma Inline (Set_String_Literal_Length);
pragma Inline (Set_String_Literal_Low_Bound);
- pragma Inline (Set_Suppress_Access_Checks);
- pragma Inline (Set_Suppress_Accessibility_Checks);
- pragma Inline (Set_Suppress_Discriminant_Checks);
- pragma Inline (Set_Suppress_Division_Checks);
- pragma Inline (Set_Suppress_Elaboration_Checks);
pragma Inline (Set_Suppress_Elaboration_Warnings);
- pragma Inline (Set_Suppress_Index_Checks);
pragma Inline (Set_Suppress_Init_Proc);
- pragma Inline (Set_Suppress_Length_Checks);
- pragma Inline (Set_Suppress_Overflow_Checks);
- pragma Inline (Set_Suppress_Range_Checks);
- pragma Inline (Set_Suppress_Storage_Checks);
pragma Inline (Set_Suppress_Style_Checks);
- pragma Inline (Set_Suppress_Tag_Checks);
+ pragma Inline (Set_Treat_As_Volatile);
pragma Inline (Set_Underlying_Full_View);
pragma Inline (Set_Unset_Reference);
pragma Inline (Set_Uses_Sec_Stack);
diff --git a/gcc/ada/einfo.h b/gcc/ada/einfo.h
index a25fd3a7f06..f9b0a8a41fa 100644
--- a/gcc/ada/einfo.h
+++ b/gcc/ada/einfo.h
@@ -6,11 +6,7 @@
/* */
/* C Header File */
/* */
-/* Generated by xeinfo revision 1.3 using */
-/* einfo.ads revision 1.654 */
-/* einfo.adb revision 1.642 */
-/* */
-/* 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- */
@@ -100,8 +96,8 @@
#define E_Entry_Index_Parameter 62
#define E_Exception 63
#define E_Generic_Function 64
- #define E_Generic_Package 65
- #define E_Generic_Procedure 66
+ #define E_Generic_Procedure 65
+ #define E_Generic_Package 66
#define E_Label 67
#define E_Loop 68
#define E_Package 69
@@ -159,9 +155,12 @@
SUBTYPE (Formal_Kind, Entity_Kind,
E_In_Parameter, E_In_Out_Parameter)
- SUBTYPE (Generic_Unit_Kind, Entity_Kind,
+ SUBTYPE (Generic_Subprogram_Kind, Entity_Kind,
E_Generic_Function, E_Generic_Procedure)
+ SUBTYPE (Generic_Unit_Kind, Entity_Kind,
+ E_Generic_Function, E_Generic_Package)
+
SUBTYPE (Incomplete_Or_Private_Kind, Entity_Kind,
E_Record_Type_With_Private, E_Incomplete_Type)
@@ -245,8 +244,11 @@
INLINE N Barrier_Function (E Id);
INLINE N Block_Node (E Id);
INLINE E Body_Entity (E Id);
+ INLINE B Body_Needed_For_SAL (E Id);
INLINE E CR_Discriminant (E Id);
INLINE B C_Pass_By_Copy (E Id);
+ INLINE B Can_Never_Be_Null (E Id);
+ INLINE B Checks_May_Be_Suppressed (E Id);
INLINE E Class_Wide_Type (E Id);
INLINE E Cloned_Subtype (E Id);
@@ -262,6 +264,7 @@
INLINE E Corresponding_Equality (E Id);
INLINE E Corresponding_Record_Type (E Id);
INLINE E Corresponding_Remote_Type (E Id);
+ INLINE N Current_Value (E Id);
INLINE B Debug_Info_Off (E Id);
INLINE E Debug_Renaming_Link (E Id);
INLINE E DTC_Entity (E Id);
@@ -321,8 +324,8 @@
INLINE B From_With_Type (E Id);
INLINE E Full_View (E Id);
INLINE B Function_Returns_With_DSP (E Id);
+ INLINE E Generic_Homonym (E Id);
INLINE L Generic_Renamings (E Id);
- INLINE L Girder_Constraint (E Id);
INLINE S Handler_Records (E Id);
INLINE B Has_Aliased_Components (E Id);
INLINE B Has_Alignment_Clause (E Id);
@@ -333,6 +336,7 @@
INLINE B Has_Completion_In_Body (E Id);
INLINE B Has_Complex_Representation (E Id);
INLINE B Has_Component_Size_Clause (E Id);
+ INLINE B Has_Contiguous_Rep (E Id);
INLINE B Has_Controlled_Component (E Id);
INLINE B Has_Controlling_Result (E Id);
INLINE B Has_Convention_Pragma (E Id);
@@ -375,8 +379,9 @@
INLINE B Has_Unchecked_Union (E Id);
INLINE B Has_Unknown_Discriminants (E Id);
INLINE B Has_Volatile_Components (E Id);
- INLINE E Homonym (E Id);
+ INLINE B Has_Xref_Entry (E Id);
INLINE E Hiding_Loop_Variable (E Id);
+ INLINE E Homonym (E Id);
INLINE B In_Package_Body (E Id);
INLINE B In_Private_Part (E Id);
INLINE B In_Use (E Id);
@@ -393,6 +398,7 @@
INLINE B Is_Called (E Id);
INLINE B Is_Character_Type (E Id);
INLINE B Is_Child_Unit (E Id);
+ INLINE B Is_Class_Wide_Equivalent_Type (E Id);
INLINE B Is_Compilation_Unit (E Id);
INLINE B Is_Completely_Hidden (E Id);
INLINE B Is_Constr_Subt_For_UN_Aliased (E Id);
@@ -401,7 +407,6 @@
INLINE B Is_Constructor (E Id);
INLINE B Is_Controlled (E Id);
INLINE B Is_Controlling_Formal (E Id);
- INLINE B Is_Destructor (E Id);
INLINE B Is_Discrim_SO_Function (E Id);
INLINE B Is_Dispatching_Operation (E Id);
INLINE B Is_Eliminated (E Id);
@@ -421,6 +426,7 @@
INLINE B Is_Interrupt_Handler (E Id);
INLINE B Is_Intrinsic_Subprogram (E Id);
INLINE B Is_Itype (E Id);
+ INLINE B Is_Known_Non_Null (E Id);
INLINE B Is_Known_Valid (E Id);
INLINE B Is_Limited_Composite (E Id);
INLINE B Is_Machine_Code_Subprogram (E Id);
@@ -450,12 +456,18 @@
INLINE B Is_VMS_Exception (E Id);
INLINE B Is_Valued_Procedure (E Id);
INLINE B Is_Visible_Child_Unit (E Id);
- INLINE B Is_Volatile (E Id);
+
+ #define Is_Volatile einfo__is_volatile
+ B Is_Volatile (E Id);
#define Is_Wrapper_Package einfo__is_wrapper_package
B Is_Wrapper_Package (E Id);
+ INLINE B Kill_Elaboration_Checks (E Id);
+ INLINE B Kill_Range_Checks (E Id);
+ INLINE B Kill_Tag_Checks (E Id);
INLINE E Last_Entity (E Id);
+ INLINE L Limited_Views (E Id);
INLINE E Lit_Indexes (E Id);
INLINE E Lit_Strings (E Id);
INLINE B Machine_Radix_10 (E Id);
@@ -465,15 +477,17 @@
INLINE U Modulus (E Id);
INLINE B Needs_Debug_Info (E Id);
INLINE B Needs_No_Actuals (E Id);
+ INLINE B Never_Set_In_Source (E Id);
INLINE E Next_Inlined_Subprogram (E Id);
INLINE B No_Pool_Assigned (E Id);
INLINE B No_Return (E Id);
INLINE B Non_Binary_Modulus (E Id);
+ INLINE E Non_Limited_View (E Id);
+ INLINE L Non_Limited_Views (E Id);
INLINE B Nonzero_Is_True (E Id);
INLINE U Normalized_First_Bit (E Id);
INLINE U Normalized_Position (E Id);
INLINE U Normalized_Position_Max (E Id);
- INLINE B Not_Source_Assigned (E Id);
INLINE E Object_Ref (E Id);
INLINE E Original_Array_Type (E Id);
INLINE E Original_Record_Component (E Id);
@@ -490,6 +504,7 @@
INLINE U RM_Size (E Id);
INLINE B Reachable (E Id);
INLINE B Referenced (E Id);
+ INLINE B Referenced_As_LHS (E Id);
INLINE N Referenced_Object (E Id);
INLINE N Register_Exception_Call (E Id);
INLINE E Related_Array_Object (E Id);
@@ -513,23 +528,14 @@
INLINE R Small_Value (E Id);
INLINE E Spec_Entity (E Id);
INLINE E Storage_Size_Variable (E Id);
+ INLINE L Stored_Constraint (E Id);
INLINE B Strict_Alignment (E Id);
INLINE U String_Literal_Length (E Id);
INLINE N String_Literal_Low_Bound (E Id);
- INLINE B Suppress_Access_Checks (E Id);
- INLINE B Suppress_Accessibility_Checks (E Id);
- INLINE B Suppress_Discriminant_Checks (E Id);
- INLINE B Suppress_Division_Checks (E Id);
- INLINE B Suppress_Elaboration_Checks (E Id);
INLINE B Suppress_Elaboration_Warnings (E Id);
- INLINE B Suppress_Index_Checks (E Id);
INLINE B Suppress_Init_Proc (E Id);
- INLINE B Suppress_Length_Checks (E Id);
- INLINE B Suppress_Overflow_Checks (E Id);
- INLINE B Suppress_Range_Checks (E Id);
- INLINE B Suppress_Storage_Checks (E Id);
INLINE B Suppress_Style_Checks (E Id);
- INLINE B Suppress_Tag_Checks (E Id);
+ INLINE B Treat_As_Volatile (E Id);
INLINE E Underlying_Full_View (E Id);
INLINE N Unset_Reference (E Id);
INLINE B Uses_Sec_Stack (E Id);
@@ -554,8 +560,9 @@
INLINE B Is_Formal (E Id);
INLINE B Is_Formal_Subprogram (E Id);
INLINE B Is_Generic_Actual_Type (E Id);
- INLINE B Is_Generic_Type (E Id);
INLINE B Is_Generic_Unit (E Id);
+ INLINE B Is_Generic_Type (E Id);
+ INLINE B Is_Generic_Subprogram (E Id);
INLINE B Is_Incomplete_Or_Private_Type (E Id);
INLINE B Is_Integer_Type (E Id);
INLINE B Is_Limited_Record (E Id);
@@ -565,6 +572,7 @@
INLINE B Is_Object (E Id);
INLINE B Is_Ordinary_Fixed_Point_Type (E Id);
INLINE B Is_Overloadable (E Id);
+ INLINE B Is_Overriding_Operation (E Id);
INLINE B Is_Private_Type (E Id);
INLINE B Is_Protected_Type (E Id);
INLINE B Is_Real_Type (E Id);
@@ -608,8 +616,8 @@
#define First_Formal einfo__first_formal
E First_Formal (E Id);
- #define First_Girder_Discriminant einfo__first_girder_discriminant
- E First_Girder_Discriminant (E Id);
+ #define First_Stored_Discriminant einfo__first_stored_discriminant
+ E First_Stored_Discriminant (E Id);
#define First_Subtype einfo__first_subtype
E First_Subtype (E Id);
@@ -685,11 +693,11 @@
#define Next_Formal_With_Extras einfo__next_formal_with_extras
E Next_Formal_With_Extras (E Id);
- #define Next_Girder_Discriminant einfo__next_girder_discriminant
- E Next_Girder_Discriminant (E Id);
-
INLINE E Next_Literal (E Id);
+ #define Next_Stored_Discriminant einfo__next_stored_discriminant
+ E Next_Stored_Discriminant (E Id);
+
#define Number_Dimensions einfo__number_dimensions
Pos Number_Dimensions (E Id);
@@ -834,9 +842,18 @@
INLINE E Body_Entity (E Id)
{ return Node19 (Id); }
+ INLINE B Body_Needed_For_SAL (E Id)
+ { return Flag40 (Id); }
+
INLINE B C_Pass_By_Copy (E Id)
{ return Flag125 (Implementation_Base_Type (Id)); }
+ INLINE B Can_Never_Be_Null (E Id)
+ { return Flag38 (Id); }
+
+ INLINE B Checks_May_Be_Suppressed (E Id)
+ { return Flag31 (Id); }
+
INLINE E Class_Wide_Type (E Id)
{ return Node9 (Id); }
@@ -870,6 +887,9 @@
INLINE E Corresponding_Remote_Type (E Id)
{ return Node22 (Id); }
+ INLINE N Current_Value (E Id)
+ { return Node9 (Id); }
+
INLINE E CR_Discriminant (E Id)
{ return Node23 (Id); }
@@ -1035,10 +1055,10 @@
INLINE B Function_Returns_With_DSP (E Id)
{ return Flag169 (Id); }
- INLINE L Generic_Renamings (E Id)
- { return Elist23 (Id); }
+ INLINE E Generic_Homonym (E Id)
+ { return Node11 (Id); }
- INLINE L Girder_Constraint (E Id)
+ INLINE L Generic_Renamings (E Id)
{ return Elist23 (Id); }
INLINE S Handler_Records (E Id)
@@ -1074,6 +1094,9 @@
INLINE B Has_Controlled_Component (E Id)
{ return Flag43 (Base_Type (Id)); }
+ INLINE B Has_Contiguous_Rep (E Id)
+ { return Flag181 (Id); }
+
INLINE B Has_Controlling_Result (E Id)
{ return Flag98 (Id); }
@@ -1188,6 +1211,9 @@
INLINE B Has_Volatile_Components (E Id)
{ return Flag87 (Implementation_Base_Type (Id)); }
+ INLINE B Has_Xref_Entry (E Id)
+ { return Flag182 (Implementation_Base_Type (Id)); }
+
INLINE E Hiding_Loop_Variable (E Id)
{ return Node8 (Id); }
@@ -1239,6 +1265,9 @@
INLINE B Is_Child_Unit (E Id)
{ return Flag73 (Id); }
+ INLINE B Is_Class_Wide_Equivalent_Type (E Id)
+ { return Flag35 (Id); }
+
INLINE B Is_Compilation_Unit (E Id)
{ return Flag149 (Id); }
@@ -1266,9 +1295,6 @@
INLINE B Is_CPP_Class (E Id)
{ return Flag74 (Id); }
- INLINE B Is_Destructor (E Id)
- { return Flag77 (Id); }
-
INLINE B Is_Discrim_SO_Function (E Id)
{ return Flag176 (Id); }
@@ -1335,6 +1361,9 @@
INLINE B Is_Itype (E Id)
{ return Flag91 (Id); }
+ INLINE B Is_Known_Non_Null (E Id)
+ { return Flag37 (Id); }
+
INLINE B Is_Known_Valid (E Id)
{ return Flag170 (Id); }
@@ -1356,6 +1385,9 @@
INLINE B Is_Optional_Parameter (E Id)
{ return Flag134 (Id); }
+ INLINE B Is_Overriding_Operation (E Id)
+ { return Flag39 (Id); }
+
INLINE B Is_Package_Body_Entity (E Id)
{ return Flag160 (Id); }
@@ -1425,12 +1457,21 @@
INLINE B Is_VMS_Exception (E Id)
{ return Flag133 (Id); }
- INLINE B Is_Volatile (E Id)
- { return Flag16 (Id); }
+ INLINE B Kill_Elaboration_Checks (E Id)
+ { return Flag32 (Id); }
+
+ INLINE B Kill_Range_Checks (E Id)
+ { return Flag33 (Id); }
+
+ INLINE B Kill_Tag_Checks (E Id)
+ { return Flag34 (Id); }
INLINE E Last_Entity (E Id)
{ return Node20 (Id); }
+ INLINE L Limited_Views (E Id)
+ { return Elist23 (Id); }
+
INLINE E Lit_Indexes (E Id)
{ return Node15 (Id); }
@@ -1458,6 +1499,9 @@
INLINE B Needs_No_Actuals (E Id)
{ return Flag22 (Id); }
+ INLINE B Never_Set_In_Source (E Id)
+ { return Flag115 (Id); }
+
INLINE E Next_Inlined_Subprogram (E Id)
{ return Node12 (Id); }
@@ -1470,6 +1514,12 @@
INLINE B Non_Binary_Modulus (E Id)
{ return Flag58 (Base_Type (Id)); }
+ INLINE E Non_Limited_View (E Id)
+ { return Node17 (Id); }
+
+ INLINE L Non_Limited_Views (E Id)
+ { return Elist8 (Id); }
+
INLINE B Nonzero_Is_True (E Id)
{ return Flag162 (Base_Type (Id)); }
@@ -1477,14 +1527,11 @@
{ return Uint8 (Id); }
INLINE U Normalized_Position (E Id)
- { return Uint9 (Id); }
+ { return Uint14 (Id); }
INLINE U Normalized_Position_Max (E Id)
{ return Uint10 (Id); }
- INLINE B Not_Source_Assigned (E Id)
- { return Flag115 (Id); }
-
INLINE E Object_Ref (E Id)
{ return Node17 (Id); }
@@ -1530,6 +1577,9 @@
INLINE B Referenced (E Id)
{ return Flag156 (Id); }
+ INLINE B Referenced_As_LHS (E Id)
+ { return Flag36 (Id); }
+
INLINE N Referenced_Object (E Id)
{ return Node10 (Id); }
@@ -1585,7 +1635,7 @@
{ return Node15 (Id); }
INLINE N Size_Check_Code (E Id)
- { return Node9 (Id); }
+ { return Node19 (Id); }
INLINE B Size_Depends_On_Discriminant (E Id)
{ return Flag177 (Id); }
@@ -1602,6 +1652,9 @@
INLINE E Storage_Size_Variable (E Id)
{ return Node15 (Implementation_Base_Type (Id)); }
+ INLINE L Stored_Constraint (E Id)
+ { return Elist23 (Id); }
+
INLINE B Strict_Alignment (E Id)
{ return Flag145 (Implementation_Base_Type (Id)); }
@@ -1611,46 +1664,16 @@
INLINE N String_Literal_Low_Bound (E Id)
{ return Node15 (Id); }
- INLINE B Suppress_Access_Checks (E Id)
- { return Flag31 (Id); }
-
- INLINE B Suppress_Accessibility_Checks (E Id)
- { return Flag32 (Id); }
-
- INLINE B Suppress_Discriminant_Checks (E Id)
- { return Flag33 (Id); }
-
- INLINE B Suppress_Division_Checks (E Id)
- { return Flag34 (Id); }
-
- INLINE B Suppress_Elaboration_Checks (E Id)
- { return Flag35 (Id); }
-
INLINE B Suppress_Elaboration_Warnings (E Id)
{ return Flag148 (Id); }
- INLINE B Suppress_Index_Checks (E Id)
- { return Flag36 (Id); }
-
INLINE B Suppress_Init_Proc (E Id)
{ return Flag105 (Base_Type (Id)); }
- INLINE B Suppress_Length_Checks (E Id)
- { return Flag37 (Id); }
-
- INLINE B Suppress_Overflow_Checks (E Id)
- { return Flag38 (Id); }
-
- INLINE B Suppress_Range_Checks (E Id)
- { return Flag39 (Id); }
-
- INLINE B Suppress_Storage_Checks (E Id)
- { return Flag40 (Id); }
-
INLINE B Suppress_Style_Checks (E Id)
{ return Flag165 (Id); }
- INLINE B Suppress_Tag_Checks (E Id)
+ INLINE B Treat_As_Volatile (E Id)
{ return Flag41 (Id); }
INLINE E Underlying_Full_View (E Id)
@@ -1719,6 +1742,9 @@
INLINE B Is_Formal (E Id)
{ return IN (Ekind (Id), Formal_Kind); }
+ INLINE B Is_Generic_Subprogram (E Id)
+ { return IN (Ekind (Id), Generic_Subprogram_Kind); }
+
INLINE B Is_Generic_Unit (E Id)
{ return IN (Ekind (Id), Generic_Unit_Kind); }
diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads
new file mode 100644
index 00000000000..882e5c3f6b4
--- /dev/null
+++ b/gcc/ada/err_vars.ads
@@ -0,0 +1,114 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- E R R _ V A R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains variables common to error reporting packages
+-- including Errout and Prj.Err.
+
+with Types; use Types;
+with Uintp; use Uintp;
+
+package Err_Vars is
+
+ Serious_Errors_Detected : Nat;
+ -- This is a count of errors that are serious enough to stop expansion,
+ -- and hence to prevent generation of an object file even if the
+ -- switch -gnatQ is set.
+
+ Total_Errors_Detected : Nat;
+ -- Number of errors detected so far. Includes count of serious errors
+ -- and non-serious errors, so this value is always greater than or
+ -- equal to the Serious_Errors_Detected value.
+
+ Warnings_Detected : Nat;
+ -- Number of warnings detected
+
+ Current_Error_Source_File : Source_File_Index;
+ -- Id of current messages. Used to post file name when unit changes. This
+ -- is initialized to Main_Source_File at the start of a compilation, which
+ -- means that no file names will be output unless there are errors in units
+ -- other than the main unit. However, if the main unit has a pragma
+ -- Source_Reference line, then this is initialized to No_Source_File,
+ -- to force an initial reference to the real source file name.
+
+ Raise_Exception_On_Error : Nat := 0;
+ -- If this value is non-zero, then any attempt to generate an error
+ -- message raises the exception Error_Msg_Exception, and the error
+ -- message is not output. This is used for defending against junk
+ -- resulting from illegalities, and also for substitution of more
+ -- appropriate error messages from higher semantic levels. It is
+ -- a counter so that the increment/decrement protocol nests neatly.
+
+ Error_Msg_Exception : exception;
+ -- Exception raised if Raise_Exception_On_Error is true
+
+ -----------------------------------------------------
+ -- Global Values Used for Error Message Insertions --
+ -----------------------------------------------------
+
+ -- The following global variables are essentially additional parameters
+ -- passed to the error message routine for insertion sequences described
+ -- above. The reason these are passed globally is that the insertion
+ -- mechanism is essentially an untyped one in which the appropriate
+ -- variables are set dependingon the specific insertion characters used.
+
+ Error_Msg_Col : Column_Number;
+ -- Column for @ insertion character in message
+
+ Error_Msg_Uint_1 : Uint;
+ Error_Msg_Uint_2 : Uint;
+ -- Uint values for ^ insertion characters in message
+
+ Error_Msg_Sloc : Source_Ptr;
+ -- Source location for # insertion character in message
+
+ Error_Msg_Name_1 : Name_Id;
+ Error_Msg_Name_2 : Name_Id;
+ Error_Msg_Name_3 : Name_Id;
+ -- Name_Id values for % insertion characters in message
+
+ Error_Msg_Unit_1 : Name_Id;
+ Error_Msg_Unit_2 : Name_Id;
+ -- Name_Id values for $ insertion characters in message
+
+ Error_Msg_Node_1 : Node_Id;
+ Error_Msg_Node_2 : Node_Id;
+ -- Node_Id values for & insertion characters in message
+
+ Error_Msg_Qual_Level : Int := 0;
+ -- Number of levels of qualification required for type name (see the
+ -- description of the } insertion character. Note that this value does
+ -- note get reset by any Error_Msg call, so the caller is responsible
+ -- for resetting it.
+
+ Warn_On_Instance : Boolean := False;
+ -- Normally if a warning is generated in a generic template from the
+ -- analysis of the template, then the warning really belongs in the
+ -- template, and the default value of False for this Boolean achieves
+ -- that effect. If Warn_On_Instance is set True, then the warnings are
+ -- generated on the instantiation (referring to the template) rather
+ -- than on the template itself.
+
+end Err_Vars;
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 7935a63473f..fb1142e2cd4 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.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,8 +35,8 @@ with Casing; use Casing;
with Csets; use Csets;
with Debug; use Debug;
with Einfo; use Einfo;
+with Erroutc; use Erroutc;
with Fname; use Fname;
-with Hostparm;
with Lib; use Lib;
with Namet; use Namet;
with Opt; use Opt;
@@ -51,225 +51,61 @@ with Style;
with Uintp; use Uintp;
with Uname; use Uname;
-package body Errout is
-
- Class_Flag : Boolean := False;
- -- This flag is set True when outputting a reference to a class-wide
- -- type, and is used by Add_Class to insert 'Class at the proper point
-
- Continuation : Boolean;
- -- Indicates if current message is a continuation. Initialized from the
- -- Msg_Cont parameter in Error_Msg_Internal and then set True if a \
- -- insertion character is encountered.
-
- Cur_Msg : Error_Msg_Id;
- -- Id of most recently posted error message
-
- Flag_Source : Source_File_Index;
- -- Source file index for source file where error is being posted
-
- Is_Warning_Msg : Boolean;
- -- Set by Set_Msg_Text to indicate if current message is warning message
-
- Is_Serious_Error : Boolean;
- -- Set by Set_Msg_Text to indicate if current message is serious error
-
- Is_Unconditional_Msg : Boolean;
- -- Set by Set_Msg_Text to indicate if current message is unconditional
-
- Kill_Message : Boolean;
- -- A flag used to kill weird messages (e.g. those containing uninterpreted
- -- implicit type references) if we have already seen at least one message
- -- already. The idea is that we hope the weird message is a junk cascaded
- -- message that should be suppressed.
-
- Last_Killed : Boolean := False;
- -- Set True if the most recently posted non-continuation message was
- -- killed. This is used to determine the processing of any continuation
- -- messages that follow.
-
- List_Pragmas_Index : Int;
- -- Index into List_Pragmas table
-
- List_Pragmas_Mode : Boolean;
- -- Starts True, gets set False by pragma List (Off), True by List (On)
-
- Manual_Quote_Mode : Boolean;
- -- Set True in manual quotation mode
-
- Max_Msg_Length : constant := 80 + 2 * Hostparm.Max_Line_Length;
- -- Maximum length of error message. The addition of Max_Line_Length
- -- ensures that two insertion tokens of maximum length can be accomodated.
-
- Msg_Buffer : String (1 .. Max_Msg_Length);
- -- Buffer used to prepare error messages
-
- Msglen : Integer;
- -- Number of characters currently stored in the message buffer
-
- Suppress_Message : Boolean;
- -- A flag used to suppress certain obviously redundant messages (i.e.
- -- those referring to a node whose type is Any_Type). This suppression
- -- is effective only if All_Errors_Mode is off.
-
- Suppress_Instance_Location : Boolean := False;
- -- Normally, if a # location in a message references a location within
- -- a generic template, then a note is added giving the location of the
- -- instantiation. If this variable is set True, then this note is not
- -- output. This is used for internal processing for the case of an
- -- illegal instantiation. See Error_Msg routine for further details.
-
- -----------------------------------
- -- Error Message Data Structures --
- -----------------------------------
-
- -- The error messages are stored as a linked list of error message objects
- -- sorted into ascending order by the source location (Sloc). Each object
- -- records the text of the message and its source location.
-
- -- The following record type and table are used to represent error
- -- messages, with one entry in the table being allocated for each message.
-
- type Error_Msg_Object is record
- Text : String_Ptr;
- -- Text of error message, fully expanded with all insertions
+with Unchecked_Conversion;
- Next : Error_Msg_Id;
- -- Pointer to next message in error chain
+package body Errout is
- Sfile : Source_File_Index;
- -- Source table index of source file. In the case of an error that
- -- refers to a template, always references the original template
- -- not an instantiation copy.
-
- Sptr : Source_Ptr;
- -- Flag pointer. In the case of an error that refers to a template,
- -- always references the original template, not an instantiation copy.
- -- This value is the actual place in the source that the error message
- -- will be posted.
-
- Fptr : Source_Ptr;
- -- Flag location used in the call to post the error. This is normally
- -- the same as Sptr, except in the case of instantiations, where it
- -- is the original flag location value. This may refer to an instance
- -- when the actual message (and hence Sptr) references the template.
-
- Line : Physical_Line_Number;
- -- Line number for error message
-
- Col : Column_Number;
- -- Column number for error message
-
- Warn : Boolean;
- -- True if warning message (i.e. insertion character ? appeared)
-
- Serious : Boolean;
- -- True if serious error message (not a warning and no | character)
-
- Uncond : Boolean;
- -- True if unconditional message (i.e. insertion character ! appeared)
-
- Msg_Cont : Boolean;
- -- This is used for logical messages that are composed of multiple
- -- individual messages. For messages that are not part of such a
- -- group, or that are the first message in such a group. Msg_Cont
- -- is set to False. For subsequent messages in a group, Msg_Cont
- -- is set to True. This is used to make sure that such a group of
- -- messages is either suppressed or retained as a group (e.g. in
- -- the circuit that deletes identical messages).
-
- Deleted : Boolean;
- -- If this flag is set, the message is not printed. This is used
- -- in the circuit for deleting duplicate/redundant error messages.
- end record;
+ Errors_Must_Be_Ignored : Boolean := False;
+ -- Set to True by procedure Set_Ignore_Errors (True), when calls to
+ -- error message procedures should be ignored (when parsing irrelevant
+ -- text in sources being preprocessed).
- package Errors is new Table.Table (
- Table_Component_Type => Error_Msg_Object,
- Table_Index_Type => Error_Msg_Id,
- Table_Low_Bound => 1,
- Table_Initial => 200,
- Table_Increment => 200,
- Table_Name => "Error");
+ Warn_On_Instance : Boolean;
+ -- Flag set true for warning message to be posted on instance
- Error_Msgs : Error_Msg_Id;
- -- The list of error messages
+ ------------------------------------
+ -- Table of Non-Instance Messages --
+ ------------------------------------
- --------------------------
- -- Warning Mode Control --
- --------------------------
+ -- This table contains an entry for every error message processed by the
+ -- Error_Msg routine that is not posted on generic (or inlined) instance.
+ -- As explained in further detail in the Error_Msg procedure body, this
+ -- table is used to avoid posting redundant messages on instances.
- -- Pragma Warnings allows warnings to be turned off for a specified
- -- region of code, and the following tabl is the data structure used
- -- to keep track of these regions.
-
- -- It contains pairs of source locations, the first being the start
- -- location for a warnings off region, and the second being the end
- -- location. When a pragma Warnings (Off) is encountered, a new entry
- -- is established extending from the location of the pragma to the
- -- end of the current source file. A subsequent pragma Warnings (On)
- -- adjusts the end point of this entry appropriately.
-
- -- If all warnings are suppressed by comamnd switch, then there is a
- -- dummy entry (put there by Errout.Initialize) at the start of the
- -- table which covers all possible Source_Ptr values. Note that the
- -- source pointer values in this table always reference the original
- -- template, not an instantiation copy, in the generic case.
-
- type Warnings_Entry is record
- Start : Source_Ptr;
- Stop : Source_Ptr;
+ type NIM_Record is record
+ Msg : String_Ptr;
+ Loc : Source_Ptr;
end record;
+ -- Type used to store text and location of one message
- package Warnings is new Table.Table (
- Table_Component_Type => Warnings_Entry,
- Table_Index_Type => Natural,
+ package Non_Instance_Msgs is new Table.Table (
+ Table_Component_Type => NIM_Record,
+ Table_Index_Type => Int,
Table_Low_Bound => 1,
Table_Initial => 100,
- Table_Increment => 200,
- Table_Name => "Warnings");
+ Table_Increment => 100,
+ Table_Name => "Non_Instance_Msgs");
-----------------------
-- Local Subprograms --
-----------------------
- procedure Add_Class;
- -- Add 'Class to buffer for class wide type case (Class_Flag set)
-
- function Buffer_Ends_With (S : String) return Boolean;
- -- Tests if message buffer ends with given string preceded by a space
-
- procedure Buffer_Remove (S : String);
- -- Removes given string from end of buffer if it is present
- -- at end of buffer, and preceded by a space.
-
- procedure Debug_Output (N : Node_Id);
- -- Called from Error_Msg_N and Error_Msg_NE to generate line of debug
- -- output giving node number (of node N) if the debug X switch is set.
-
- procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id);
- -- This function is passed the Id values of two error messages. If
- -- either M1 or M2 is a continuation message, or is already deleted,
- -- the call is ignored. Otherwise a check is made to see if M1 and M2
- -- are duplicated or redundant. If so, the message to be deleted and
- -- all its continuations are marked with the Deleted flag set to True.
-
procedure Error_Msg_Internal
- (Msg : String;
- Flag_Location : Source_Ptr;
- Msg_Cont : Boolean);
- -- This is like Error_Msg, except that Flag_Location is known not to be
- -- a location within a instantiation of a generic template. The outer
- -- level routine, Error_Msg, takes care of dealing with the generic case.
- -- Msg_Cont is set True to indicate that the message is a continuation of
- -- a previous message. This means that it must have the same Flag_Location
- -- as the previous message.
-
- procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id);
- -- Given a message id, move to next message id, but skip any deleted
- -- messages, so that this results in E on output being the first non-
- -- deleted message following the input value of E, or No_Error_Msg if
- -- the input value of E was either already No_Error_Msg, or was the
- -- last non-deleted message.
+ (Msg : String;
+ Sptr : Source_Ptr;
+ Optr : Source_Ptr;
+ Msg_Cont : Boolean);
+ -- This is the low level routine used to post messages after dealing with
+ -- the issue of messages placed on instantiations (which get broken up
+ -- into separate calls in Error_Msg). Sptr is the location on which the
+ -- flag will be placed in the output. In the case where the flag is on
+ -- the template, this points directly to the template, not to one of the
+ -- instantiation copies of the template. Optr is the original location
+ -- used to flag the error, and this may indeed point to an instantiation
+ -- copy. So typically we can see Optr pointing to the template location
+ -- in an instantiation copy when Sptr points to the source location of
+ -- the actual instantiation (i.e the line with the new). Msg_Cont is
+ -- set true if this is a continuation message.
function No_Warnings (N : Node_Or_Entity_Id) return Boolean;
-- Determines if warnings should be suppressed for the given node
@@ -281,23 +117,6 @@ package body Errout is
-- or if it refers to an Etype that has an error posted on it, or if
-- it references an Entity that has an error posted on it.
- procedure Output_Error_Msgs (E : in out Error_Msg_Id);
- -- Output source line, error flag, and text of stored error message and
- -- all subsequent messages for the same line and unit. On return E is
- -- set to be one higher than the last message output.
-
- procedure Output_Line_Number (L : Logical_Line_Number);
- -- Output a line number as six digits (with leading zeroes suppressed),
- -- followed by a period and a blank (note that this is 8 characters which
- -- means that tabs in the source line will not get messed up). Line numbers
- -- that match or are less than the last Source_Reference pragma are listed
- -- as all blanks, avoiding output of junk line numbers.
-
- procedure Output_Msg_Text (E : Error_Msg_Id);
- -- Outputs characters of text in the text of the error message E, excluding
- -- any final exclamation point. Note that no end of line is output, the
- -- caller is responsible for adding the end of line.
-
procedure Output_Source_Line
(L : Physical_Line_Number;
Sfile : Source_File_Index;
@@ -307,98 +126,38 @@ package body Errout is
-- indicates if there are errors attached to the line, which forces
-- listing on, even in the presence of pragma List (Off).
- function Same_Error (M1, M2 : Error_Msg_Id) return Boolean;
- -- See if two messages have the same text. Returns true if the text
- -- of the two messages is identical, or if one of them is the same
- -- as the other with an appended "instance at xxx" tag.
-
- procedure Set_Msg_Blank;
- -- Sets a single blank in the message if the preceding character is a
- -- non-blank character other than a left parenthesis. Has no effect if
- -- manual quote mode is turned on.
-
- procedure Set_Msg_Blank_Conditional;
- -- Sets a single blank in the message if the preceding character is a
- -- non-blank character other than a left parenthesis or quote. Has no
- -- effect if manual quote mode is turned on.
-
- procedure Set_Msg_Char (C : Character);
- -- Add a single character to the current message. This routine does not
- -- check for special insertion characters (they are just treated as text
- -- characters if they occur).
-
procedure Set_Msg_Insertion_Column;
-- Handle column number insertion (@ insertion character)
- procedure Set_Msg_Insertion_Name;
- -- Handle name insertion (% insertion character)
-
- procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr);
- -- Handle line number insertion (# insertion character). Loc is the
- -- location to be referenced, and Flag is the location at which the
- -- flag is posted (used to determine whether to add "in file xxx")
-
procedure Set_Msg_Insertion_Node;
-- Handle node (name from node) insertion (& insertion character)
- procedure Set_Msg_Insertion_Reserved_Name;
- -- Handle insertion of reserved word name (* insertion character).
-
- procedure Set_Msg_Insertion_Reserved_Word
- (Text : String;
- J : in out Integer);
- -- Handle reserved word insertion (upper case letters). The Text argument
- -- is the current error message input text, and J is an index which on
- -- entry points to the first character of the reserved word, and on exit
- -- points past the last character of the reserved word.
-
procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr);
-- Handle type reference (right brace insertion character). Flag is the
-- location of the flag, which is provided for the internal call to
-- Set_Msg_Insertion_Line_Number,
- procedure Set_Msg_Insertion_Uint;
- -- Handle Uint insertion (^ insertion character)
-
procedure Set_Msg_Insertion_Unit_Name;
-- Handle unit name insertion ($ insertion character)
- procedure Set_Msg_Insertion_File_Name;
- -- Handle file name insertion (left brace insertion character)
-
- procedure Set_Msg_Int (Line : Int);
- -- Set the decimal representation of the argument in the error message
- -- buffer with no leading zeroes output.
-
- procedure Set_Msg_Name_Buffer;
- -- Output name from Name_Buffer, with surrounding quotes unless manual
- -- quotation mode is in effect.
-
procedure Set_Msg_Node (Node : Node_Id);
-- Add the sequence of characters for the name associated with the
-- given node to the current message.
- procedure Set_Msg_Quote;
- -- Set quote if in normal quote mode, nothing if in manual quote mode
-
- procedure Set_Msg_Str (Text : String);
- -- Add a sequence of characters to the current message. This routine does
- -- not check for special insertion characters (they are just treated as
- -- text characters if they occur).
-
procedure Set_Msg_Text (Text : String; Flag : Source_Ptr);
-- Add a sequence of characters to the current message. The characters may
-- be one of the special insertion characters (see documentation in spec).
-- Flag is the location at which the error is to be posted, which is used
-- to determine whether or not the # insertion needs a file name. The
- -- variables Msg_Buffer, Msglen, Is_Warning_Msg, and Is_Unconditional_Msg
- -- are set on return.
+ -- variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and
+ -- Is_Unconditional_Msg are set on return.
procedure Set_Posted (N : Node_Id);
-- Sets the Error_Posted flag on the given node, and all its parents
-- that are subexpressions and then on the parent non-subexpression
-- construct that contains the original expression (this reduces the
- -- number of cascaded messages)
+ -- number of cascaded messages). Note that this call only has an effect
+ -- for a serious error. For a non-serious error, it has no effect.
procedure Set_Qualification (N : Nat; E : Entity_Id);
-- Outputs up to N levels of qualification for the given entity. For
@@ -416,10 +175,6 @@ package body Errout is
-- to suppress. If the message is to be suppressed then we return True.
-- If the message should be generated (the normal case) False is returned.
- procedure Test_Warning_Msg (Msg : String);
- -- Sets Is_Warning_Msg true if Msg is a warning message (contains a
- -- question mark character), and False otherwise.
-
procedure Unwind_Internal_Type (Ent : in out Entity_Id);
-- This procedure is given an entity id for an internal type, i.e.
-- a type with an internal name. It unwinds the type to try to get
@@ -433,51 +188,6 @@ package body Errout is
-- 'Class appended to its name (see Add_Class procedure), and is
-- otherwise unchanged.
- function Warnings_Suppressed (Loc : Source_Ptr) return Boolean;
- -- Determines if given location is covered by a warnings off suppression
- -- range in the warnings table (or is suppressed by compilation option,
- -- which generates a warning range for the whole source file).
-
- ---------------
- -- Add_Class --
- ---------------
-
- procedure Add_Class is
- begin
- if Class_Flag then
- Class_Flag := False;
- Set_Msg_Char (''');
- Get_Name_String (Name_Class);
- Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
- Set_Msg_Name_Buffer;
- end if;
- end Add_Class;
-
- ----------------------
- -- Buffer_Ends_With --
- ----------------------
-
- function Buffer_Ends_With (S : String) return Boolean is
- Len : constant Natural := S'Length;
-
- begin
- return
- Msglen > Len
- and then Msg_Buffer (Msglen - Len) = ' '
- and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
- end Buffer_Ends_With;
-
- -------------------
- -- Buffer_Remove --
- -------------------
-
- procedure Buffer_Remove (S : String) is
- begin
- if Buffer_Ends_With (S) then
- Msglen := Msglen - S'Length;
- end if;
- end Buffer_Remove;
-
-----------------------
-- Change_Error_Text --
-----------------------
@@ -506,180 +216,6 @@ package body Errout is
end if;
end Change_Error_Text;
- -----------------------------
- -- Check_Duplicate_Message --
- -----------------------------
-
- procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
- L1, L2 : Error_Msg_Id;
- N1, N2 : Error_Msg_Id;
-
- procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
- -- Called to delete message Delete, keeping message Keep. Marks
- -- all messages of Delete with deleted flag set to True, and also
- -- makes sure that for the error messages that are retained the
- -- preferred message is the one retained (we prefer the shorter
- -- one in the case where one has an Instance tag). Note that we
- -- always know that Keep has at least as many continuations as
- -- Delete (since we always delete the shorter sequence).
-
- ----------------
- -- Delete_Msg --
- ----------------
-
- procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
- D, K : Error_Msg_Id;
-
- begin
- D := Delete;
- K := Keep;
-
- loop
- Errors.Table (D).Deleted := True;
-
- -- Adjust error message count
-
- if Errors.Table (D).Warn then
- Warnings_Detected := Warnings_Detected - 1;
- else
- Total_Errors_Detected := Total_Errors_Detected - 1;
-
- if Errors.Table (D).Serious then
- Serious_Errors_Detected := Serious_Errors_Detected - 1;
- end if;
- end if;
-
- -- Substitute shorter of the two error messages
-
- if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
- Errors.Table (K).Text := Errors.Table (D).Text;
- end if;
-
- D := Errors.Table (D).Next;
- K := Errors.Table (K).Next;
-
- if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
- return;
- end if;
- end loop;
- end Delete_Msg;
-
- -- Start of processing for Check_Duplicate_Message
-
- begin
- -- Both messages must be non-continuation messages and not deleted
-
- if Errors.Table (M1).Msg_Cont
- or else Errors.Table (M2).Msg_Cont
- or else Errors.Table (M1).Deleted
- or else Errors.Table (M2).Deleted
- then
- return;
- end if;
-
- -- Definitely not equal if message text does not match
-
- if not Same_Error (M1, M2) then
- return;
- end if;
-
- -- Same text. See if all continuations are also identical
-
- L1 := M1;
- L2 := M2;
-
- loop
- N1 := Errors.Table (L1).Next;
- N2 := Errors.Table (L2).Next;
-
- -- If M1 continuations have run out, we delete M1, either the
- -- messages have the same number of continuations, or M2 has
- -- more and we prefer the one with more anyway.
-
- if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
- Delete_Msg (M1, M2);
- return;
-
- -- If M2 continuatins have run out, we delete M2
-
- elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
- Delete_Msg (M2, M1);
- return;
-
- -- Otherwise see if continuations are the same, if not, keep both
- -- sequences, a curious case, but better to keep everything!
-
- elsif not Same_Error (N1, N2) then
- return;
-
- -- If continuations are the same, continue scan
-
- else
- L1 := N1;
- L2 := N2;
- end if;
- end loop;
- end Check_Duplicate_Message;
-
- ------------------------
- -- Compilation_Errors --
- ------------------------
-
- function Compilation_Errors return Boolean is
- begin
- return Total_Errors_Detected /= 0
- or else (Warnings_Detected /= 0
- and then Warning_Mode = Treat_As_Error);
- end Compilation_Errors;
-
- ------------------
- -- Debug_Output --
- ------------------
-
- procedure Debug_Output (N : Node_Id) is
- begin
- if Debug_Flag_1 then
- Write_Str ("*** following error message posted on node id = #");
- Write_Int (Int (N));
- Write_Str (" ***");
- Write_Eol;
- end if;
- end Debug_Output;
-
- ----------
- -- dmsg --
- ----------
-
- procedure dmsg (Id : Error_Msg_Id) is
- E : Error_Msg_Object renames Errors.Table (Id);
-
- begin
- w ("Dumping error message, Id = ", Int (Id));
- w (" Text = ", E.Text.all);
- w (" Next = ", Int (E.Next));
- w (" Sfile = ", Int (E.Sfile));
-
- Write_Str
- (" Sptr = ");
- Write_Location (E.Sptr);
- Write_Eol;
-
- Write_Str
- (" Fptr = ");
- Write_Location (E.Fptr);
- Write_Eol;
-
- w (" Line = ", Int (E.Line));
- w (" Col = ", Int (E.Col));
- w (" Warn = ", E.Warn);
- w (" Serious = ", E.Serious);
- w (" Uncond = ", E.Uncond);
- w (" Msg_Cont = ", E.Msg_Cont);
- w (" Deleted = ", E.Deleted);
-
- Write_Eol;
- end dmsg;
-
---------------
-- Error_Msg --
---------------
@@ -699,6 +235,17 @@ package body Errout is
-- template in instantiation case, otherwise unchanged).
begin
+ -- It is a fatal error to issue an error message when scanning from
+ -- the internal source buffer (see Sinput for further documentation)
+
+ pragma Assert (Sinput.Source /= Internal_Source_Ptr);
+
+ -- Return if all errors are to be ignored
+
+ if Errors_Must_Be_Ignored then
+ return;
+ end if;
+
-- If we already have messages, and we are trying to place a message
-- at No_Location or in package Standard, then just ignore the attempt
-- since we assume that what is happening is some cascaded junk. Note
@@ -710,17 +257,58 @@ package body Errout is
return;
end if;
+ -- Start procesing of new message
+
Sindex := Get_Source_File_Index (Flag_Location);
- Test_Warning_Msg (Msg);
+ Test_Style_Warning_Serious_Msg (Msg);
+ Orig_Loc := Original_Location (Flag_Location);
- -- It is a fatal error to issue an error message when scanning from
- -- the internal source buffer (see Sinput for further documentation)
+ -- If the current location is in an instantiation, the issue arises
+ -- of whether to post the message on the template or the instantiation.
- pragma Assert (Source /= Internal_Source_Ptr);
+ -- The way we decide is to see if we have posted the same message
+ -- on the template when we compiled the template (the template is
+ -- always compiled before any instantiations). For this purpose,
+ -- we use a separate table of messages. The reason we do this is
+ -- twofold:
- -- Ignore warning message that is suppressed
+ -- First, the messages can get changed by various processing
+ -- including the insertion of tokens etc, making it hard to
+ -- do the comparison.
- Orig_Loc := Original_Location (Flag_Location);
+ -- Second, we will suppress a warning on a template if it is
+ -- not in the current extended source unit. That's reasonable
+ -- and means we don't want the warning on the instantiation
+ -- here either, but it does mean that the main error table
+ -- would not in any case include the message.
+
+ if Flag_Location = Orig_Loc then
+ Non_Instance_Msgs.Append ((new String'(Msg), Flag_Location));
+ Warn_On_Instance := False;
+
+ -- Here we have an instance message
+
+ else
+ -- Delete if debug flag off, and this message duplicates a
+ -- message already posted on the corresponding template
+
+ if not Debug_Flag_GG then
+ for J in Non_Instance_Msgs.First .. Non_Instance_Msgs.Last loop
+ if Msg = Non_Instance_Msgs.Table (J).Msg.all
+ and then Non_Instance_Msgs.Table (J).Loc = Orig_Loc
+ then
+ return;
+ end if;
+ end loop;
+ end if;
+
+ -- No duplicate, so error/warning will be posted on instance
+
+ Warn_On_Instance := Is_Warning_Msg;
+ end if;
+
+ -- Ignore warning message that is suppressed. Note that style
+ -- checks are not considered warning messages for this purpose
if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
return;
@@ -736,7 +324,7 @@ package body Errout is
-- requested location.
if Instantiation (Sindex) = No_Location then
- Error_Msg_Internal (Msg, Flag_Location, False);
+ Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False);
return;
end if;
@@ -756,54 +344,21 @@ package body Errout is
-- instantiation error message can be repeated, pointing to each
-- of the relevant instantiations.
- -- However, before we do this, we need to worry about the case where
- -- indeed we are in an instantiation, but the message is a warning
- -- message. In this case, it almost certainly a warning for the
- -- template itself and so it is posted on the template. At least
- -- this is the default mode, it can be cancelled (resulting the
- -- warning being placed on the instance as in the error case) by
- -- setting the global Warn_On_Instance True.
-
- if (not Warn_On_Instance) and then Is_Warning_Msg then
- Error_Msg_Internal (Msg, Flag_Location, False);
- return;
- end if;
-
- -- Second, we need to worry about the case where there was a real error
- -- in the template, and we are getting a repeat of this error in the
- -- instantiation. We don't want to complain about the instantiation
- -- in this case, since we have already flagged the template.
-
- -- To deal with this case, just see if we have posted a message at
- -- the template location already. If so, assume that the current
- -- message is redundant. There could be cases in which this is not
- -- a correct assumption, but it is not terrible to lose a message
- -- about an incorrect instantiation given that we have already
- -- flagged a message on the template.
+ -- Note: the instantiation mechanism is also shared for inlining
+ -- of subprogram bodies when front end inlining is done. In this
+ -- case the messages have the form:
- for Err in Errors.First .. Errors.Last loop
- if Errors.Table (Err).Sptr = Orig_Loc then
+ -- in inlined body at ...
+ -- original error message
- -- If the current message is a real error, as opposed to a
- -- warning, then we don't want to let a warning on the
- -- template inhibit a real error on the instantiation.
+ -- or
- if Is_Warning_Msg
- or else not Errors.Table (Err).Warn
- then
- return;
- end if;
- end if;
- end loop;
+ -- warning: in inlined body at
+ -- warning: original warning message
-- OK, this is the case where we have an instantiation error, and
-- we need to generate the error on the instantiation, rather than
- -- on the template. First, see if we have posted this exact error
- -- before, and if so suppress it. It is not so easy to use the main
- -- list of errors for this, since they have already been split up
- -- according to the processing below. Consequently we use an auxiliary
- -- data structure that just records these types of messages (it will
- -- never have very many entries).
+ -- on the template.
declare
Actual_Error_Loc : Source_Ptr;
@@ -850,16 +405,35 @@ package body Errout is
-- Suppress instantiation message on continuation lines
- if Msg (1) /= '\' then
- if Is_Warning_Msg then
- Error_Msg_Internal
- ("?in instantiation #",
- Actual_Error_Loc, Msg_Cont_Status);
+ if Msg (Msg'First) /= '\' then
+
+ -- Case of inlined body
+
+ if Inlined_Body (X) then
+ if Is_Warning_Msg then
+ Error_Msg_Internal
+ ("?in inlined body #",
+ Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+
+ else
+ Error_Msg_Internal
+ ("error in inlined body #",
+ Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ end if;
+
+ -- Case of generic instantiation
else
- Error_Msg_Internal
- ("instantiation error #",
- Actual_Error_Loc, Msg_Cont_Status);
+ if Is_Warning_Msg then
+ Error_Msg_Internal
+ ("?in instantiation #",
+ Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+
+ else
+ Error_Msg_Internal
+ ("instantiation error #",
+ Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
+ end if;
end if;
end if;
@@ -873,7 +447,8 @@ package body Errout is
-- Here we output the original message on the outer instantiation
- Error_Msg_Internal (Msg, Actual_Error_Loc, Msg_Cont_Status);
+ Error_Msg_Internal
+ (Msg, Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
end;
end Error_Msg;
@@ -983,14 +558,111 @@ package body Errout is
end if;
end Error_Msg_BC;
+ -------------------
+ -- Error_Msg_CRT --
+ -------------------
+
+ procedure Error_Msg_CRT (Feature : String; N : Node_Id) is
+ CNRT : constant String := " not allowed in no run time mode";
+ CCRT : constant String := " not supported by configuration>";
+
+ S : String (1 .. Feature'Length + 1 + CCRT'Length);
+ L : Natural;
+
+
+ begin
+ S (1) := '|';
+ S (2 .. Feature'Length + 1) := Feature;
+ L := Feature'Length + 2;
+
+ if No_Run_Time_Mode then
+ S (L .. L + CNRT'Length - 1) := CNRT;
+ L := L + CNRT'Length - 1;
+
+ else pragma Assert (Configurable_Run_Time_Mode);
+ S (L .. L + CCRT'Length - 1) := CCRT;
+ L := L + CCRT'Length - 1;
+ end if;
+
+ Error_Msg_N (S (1 .. L), N);
+ Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1;
+ end Error_Msg_CRT;
+
+ -----------------
+ -- Error_Msg_F --
+ -----------------
+
+ procedure Error_Msg_F (Msg : String; N : Node_Id) is
+ SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N));
+ SF : constant Source_Ptr := Source_First (SI);
+ F : Node_Id;
+ S : Source_Ptr;
+
+ begin
+ F := First_Node (N);
+ S := Sloc (F);
+
+ -- The following circuit is a bit subtle. When we have parenthesized
+ -- expressions, then the Sloc will not record the location of the
+ -- paren, but we would like to post the flag on the paren. So what
+ -- we do is to crawl up the tree from the First_Node, adjusting the
+ -- Sloc value for any parentheses we know are present. Yes, we know
+ -- this circuit is not 100% reliable (e.g. because we don't record
+ -- all possible paren level valoues), but this is only for an error
+ -- message so it is good enough.
+
+ Node_Loop : loop
+ Paren_Loop : for J in 1 .. Paren_Count (F) loop
+
+ -- We don't look more than 12 characters behind the current
+ -- location, and in any case not past the front of the source.
+
+ Search_Loop : for K in 1 .. 12 loop
+ exit Search_Loop when S = SF;
+
+ if Source_Text (SI) (S - 1) = '(' then
+ S := S - 1;
+ exit Search_Loop;
+
+ elsif Source_Text (SI) (S - 1) <= ' ' then
+ S := S - 1;
+
+ else
+ exit Search_Loop;
+ end if;
+ end loop Search_Loop;
+ end loop Paren_Loop;
+
+ exit Node_Loop when F = N;
+ F := Parent (F);
+ exit Node_Loop when Nkind (F) not in N_Subexpr;
+ end loop Node_Loop;
+
+ Error_Msg_NEL (Msg, N, N, S);
+ end Error_Msg_F;
+
+ ------------------
+ -- Error_Msg_FE --
+ ------------------
+
+ procedure Error_Msg_FE
+ (Msg : String;
+ N : Node_Id;
+ E : Node_Or_Entity_Id)
+ is
+ begin
+ Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N)));
+ end Error_Msg_FE;
+
------------------------
-- Error_Msg_Internal --
------------------------
procedure Error_Msg_Internal
- (Msg : String;
- Flag_Location : Source_Ptr;
- Msg_Cont : Boolean)
+ (Msg : String;
+ Sptr : Source_Ptr;
+ Optr : Source_Ptr;
+ Msg_Cont : Boolean)
is
Next_Msg : Error_Msg_Id;
-- Pointer to next message at insertion point
@@ -1000,8 +672,6 @@ package body Errout is
Temp_Msg : Error_Msg_Id;
- Orig_Loc : constant Source_Ptr := Original_Location (Flag_Location);
-
procedure Handle_Serious_Error;
-- Internal procedure to do all error message handling for a serious
-- error message, other than bumping the error counts and arranging
@@ -1028,7 +698,7 @@ package body Errout is
if not Try_Semantics
and then Current_Source_Unit /= No_Unit
then
- Set_Fatal_Error (Get_Source_Unit (Orig_Loc));
+ Set_Fatal_Error (Get_Source_Unit (Sptr));
end if;
end Handle_Serious_Error;
@@ -1042,7 +712,7 @@ package body Errout is
Continuation := Msg_Cont;
Suppress_Message := False;
Kill_Message := False;
- Set_Msg_Text (Msg, Orig_Loc);
+ Set_Msg_Text (Msg, Sptr);
-- Kill continuation if parent message killed
@@ -1079,11 +749,44 @@ package body Errout is
return;
end if;
- -- Immediate return if warning message and warnings are suppressed
+ -- Special check for warning message to see if it should be output
- if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
- Cur_Msg := No_Error_Msg;
- return;
+ if Is_Warning_Msg then
+
+ -- Immediate return if warning message and warnings are suppressed
+
+ if Warnings_Suppressed (Optr)
+ or else Warnings_Suppressed (Sptr)
+ then
+ Cur_Msg := No_Error_Msg;
+ return;
+ end if;
+
+ -- If the flag location is in the main extended source unit
+ -- then for sure we want the warning since it definitely belongs
+
+ if In_Extended_Main_Source_Unit (Sptr) then
+ null;
+
+ -- If the flag location is not in the main extended source
+ -- unit then we want to eliminate the warning.
+
+ elsif In_Extended_Main_Code_Unit (Sptr)
+ and then Warn_On_Instance
+ then
+ null;
+
+ -- Keep warning if debug flag G set
+
+ elsif Debug_Flag_GG then
+ null;
+
+ -- Here is where we delete a warning from a with'ed unit
+
+ else
+ Cur_Msg := No_Error_Msg;
+ return;
+ end if;
end if;
-- If message is to be ignored in special ignore message mode, this is
@@ -1103,12 +806,13 @@ package body Errout is
Cur_Msg := Errors.Last;
Errors.Table (Cur_Msg).Text := new String'(Msg_Buffer (1 .. Msglen));
Errors.Table (Cur_Msg).Next := No_Error_Msg;
- Errors.Table (Cur_Msg).Sptr := Orig_Loc;
- Errors.Table (Cur_Msg).Fptr := Flag_Location;
- Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Orig_Loc);
- Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Orig_Loc);
- Errors.Table (Cur_Msg).Col := Get_Column_Number (Orig_Loc);
+ Errors.Table (Cur_Msg).Sptr := Sptr;
+ Errors.Table (Cur_Msg).Optr := Optr;
+ Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Sptr);
+ Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Sptr);
+ Errors.Table (Cur_Msg).Col := Get_Column_Number (Sptr);
Errors.Table (Cur_Msg).Warn := Is_Warning_Msg;
+ Errors.Table (Cur_Msg).Style := Is_Style_Msg;
Errors.Table (Cur_Msg).Serious := Is_Serious_Error;
Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg;
Errors.Table (Cur_Msg).Msg_Cont := Continuation;
@@ -1131,22 +835,45 @@ package body Errout is
-- location (earlier flag location first in the chain).
else
- Prev_Msg := No_Error_Msg;
- Next_Msg := Error_Msgs;
+ -- First a quick check, does this belong at the very end of the
+ -- chain of error messages. This saves a lot of time in the
+ -- normal case if there are lots of messages.
+
+ if Last_Error_Msg /= No_Error_Msg
+ and then Errors.Table (Cur_Msg).Sfile =
+ Errors.Table (Last_Error_Msg).Sfile
+ and then (Sptr > Errors.Table (Last_Error_Msg).Sptr
+ or else
+ (Sptr = Errors.Table (Last_Error_Msg).Sptr
+ and then
+ Optr > Errors.Table (Last_Error_Msg).Optr))
+ then
+ Prev_Msg := Last_Error_Msg;
+ Next_Msg := No_Error_Msg;
- while Next_Msg /= No_Error_Msg loop
- exit when
- Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
+ -- Otherwise do a full sequential search for the insertion point
- if Errors.Table (Cur_Msg).Sfile =
- Errors.Table (Next_Msg).Sfile
- then
- exit when Orig_Loc < Errors.Table (Next_Msg).Sptr;
- end if;
+ else
+ Prev_Msg := No_Error_Msg;
+ Next_Msg := First_Error_Msg;
+ while Next_Msg /= No_Error_Msg loop
+ exit when
+ Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
- Prev_Msg := Next_Msg;
- Next_Msg := Errors.Table (Next_Msg).Next;
- end loop;
+ if Errors.Table (Cur_Msg).Sfile =
+ Errors.Table (Next_Msg).Sfile
+ then
+ exit when Sptr < Errors.Table (Next_Msg).Sptr
+ or else
+ (Sptr = Errors.Table (Next_Msg).Sptr
+ and then
+ Optr < Errors.Table (Next_Msg).Optr);
+ end if;
+
+ Prev_Msg := Next_Msg;
+ Next_Msg := Errors.Table (Next_Msg).Next;
+ end loop;
+ end if;
-- Now we insert the new message in the error chain. The insertion
-- point for the message is after Prev_Msg and before Next_Msg.
@@ -1173,7 +900,6 @@ package body Errout is
if not Errors.Table (Cur_Msg).Uncond
and then not Continuation
then
-
-- Don't delete if prev msg is warning and new msg is
-- an error. This is because we don't want a real error
-- masked by a warning. In all other cases (that is parse
@@ -1181,8 +907,13 @@ package body Errout is
-- we do delete the message. This helps to avoid
-- junk extra messages from cascaded parsing errors
- if not Errors.Table (Prev_Msg).Warn
- or else Errors.Table (Cur_Msg).Warn
+ if not (Errors.Table (Prev_Msg).Warn
+ or
+ Errors.Table (Prev_Msg).Style)
+ or else
+ (Errors.Table (Cur_Msg).Warn
+ or
+ Errors.Table (Cur_Msg).Style)
then
-- All tests passed, delete the message by simply
-- returning without any further processing.
@@ -1203,17 +934,23 @@ package body Errout is
end if;
if Prev_Msg = No_Error_Msg then
- Error_Msgs := Cur_Msg;
+ First_Error_Msg := Cur_Msg;
else
Errors.Table (Prev_Msg).Next := Cur_Msg;
end if;
Errors.Table (Cur_Msg).Next := Next_Msg;
+
+ if Next_Msg = No_Error_Msg then
+ Last_Error_Msg := Cur_Msg;
+ end if;
end if;
-- Bump appropriate statistics count
- if Errors.Table (Cur_Msg).Warn then
+ if Errors.Table (Cur_Msg).Warn
+ or else Errors.Table (Cur_Msg).Style
+ then
Warnings_Detected := Warnings_Detected + 1;
else
Total_Errors_Detected := Total_Errors_Detected + 1;
@@ -1269,18 +1006,41 @@ package body Errout is
return;
end if;
- if No_Warnings (N) or else No_Warnings (E) then
- Test_Warning_Msg (Msg);
+ Test_Style_Warning_Serious_Msg (Msg);
+
+ -- Special handling for warning messages
+
+ if Is_Warning_Msg then
+
+ -- Suppress if no warnings set for either entity or node
- if Is_Warning_Msg then
+ if No_Warnings (N) or else No_Warnings (E) then
return;
end if;
+
+ -- Suppress if inside loop that is known to be null
+
+ declare
+ P : Node_Id;
+
+ begin
+ P := Parent (N);
+ while Present (P) loop
+ if Nkind (P) = N_Loop_Statement and then Is_Null_Loop (P) then
+ return;
+ end if;
+
+ P := Parent (P);
+ end loop;
+ end;
end if;
+ -- Test for message to be output
+
if All_Errors_Mode
or else Msg (Msg'Last) = '!'
or else OK_Node (N)
- or else (Msg (1) = '\' and not Last_Killed)
+ or else (Msg (Msg'First) = '\' and not Last_Killed)
then
Debug_Output (N);
Error_Msg_Node_1 := E;
@@ -1290,11 +1050,26 @@ package body Errout is
Last_Killed := True;
end if;
- if not Is_Warning_Msg then
+ if not Is_Warning_Msg and then not Is_Style_Msg then
Set_Posted (N);
end if;
end Error_Msg_NEL;
+ ------------------
+ -- Error_Msg_NW --
+ ------------------
+
+ procedure Error_Msg_NW
+ (Eflag : Boolean;
+ Msg : String;
+ N : Node_Or_Entity_Id)
+ is
+ begin
+ if Eflag and then In_Extended_Main_Source_Unit (N) then
+ Error_Msg_NEL (Msg, N, N, Sloc (N));
+ end if;
+ end Error_Msg_NW;
+
-----------------
-- Error_Msg_S --
-----------------
@@ -1358,7 +1133,7 @@ package body Errout is
-- Eliminate any duplicated error messages from the list. This is
-- done after the fact to avoid problems with Change_Error_Text.
- Cur := Error_Msgs;
+ Cur := First_Error_Msg;
while Cur /= No_Error_Msg loop
Nxt := Errors.Table (Cur).Next;
@@ -1376,12 +1151,17 @@ package body Errout is
-- Brief Error mode
if Brief_Output or (not Full_List and not Verbose_Mode) then
- E := Error_Msgs;
+ E := First_Error_Msg;
Set_Standard_Error;
while E /= No_Error_Msg loop
if not Errors.Table (E).Deleted and then not Debug_Flag_KK then
- Write_Name (Reference_Name (Errors.Table (E).Sfile));
+ if Full_Path_Name_For_Brief_Errors then
+ Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));
+ else
+ Write_Name (Reference_Name (Errors.Table (E).Sfile));
+ end if;
+
Write_Char (':');
Write_Int (Int (Physical_To_Logical
(Errors.Table (E).Line,
@@ -1409,7 +1189,7 @@ package body Errout is
if Full_List then
List_Pragmas_Index := 1;
List_Pragmas_Mode := True;
- E := Error_Msgs;
+ E := First_Error_Msg;
Write_Eol;
-- First list initial main source file with its error messages
@@ -1447,7 +1227,7 @@ package body Errout is
-- Verbose mode (error lines only with error flags)
if Verbose_Mode and not Full_List then
- E := Error_Msgs;
+ E := First_Error_Msg;
-- Loop through error lines
@@ -1549,26 +1329,59 @@ package body Errout is
Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
Warnings_Detected := 0;
end if;
-
end Finalize;
- ------------------
- -- Get_Location --
- ------------------
-
- function Get_Location (E : Error_Msg_Id) return Source_Ptr is
- begin
- return Errors.Table (E).Sptr;
- end Get_Location;
-
----------------
- -- Get_Msg_Id --
+ -- First_Node --
----------------
- function Get_Msg_Id return Error_Msg_Id is
+ function First_Node (C : Node_Id) return Node_Id is
+ L : constant Source_Ptr := Sloc (C);
+ Sfile : constant Source_File_Index := Get_Source_File_Index (L);
+ Earliest : Node_Id;
+ Eloc : Source_Ptr;
+ Discard : Traverse_Result;
+
+ pragma Warnings (Off, Discard);
+
+ function Test_Earlier (N : Node_Id) return Traverse_Result;
+ -- Function applied to every node in the construct
+
+ function Search_Tree_First is new Traverse_Func (Test_Earlier);
+ -- Create traversal function
+
+ ------------------
+ -- Test_Earlier --
+ ------------------
+
+ function Test_Earlier (N : Node_Id) return Traverse_Result is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ -- Check for earlier. The tests for being in the same file ensures
+ -- against strange cases of foreign code somehow being present. We
+ -- don't want wild placement of messages if that happens, so it is
+ -- best to just ignore this situation.
+
+ if Loc < Eloc
+ and then Get_Source_File_Index (Loc) = Sfile
+ then
+ Earliest := N;
+ Eloc := Loc;
+ end if;
+
+ return OK_Orig;
+ end Test_Earlier;
+
+ -- Start of processing for First_Node
+
begin
- return Cur_Msg;
- end Get_Msg_Id;
+ Earliest := Original_Node (C);
+ Eloc := Sloc (Earliest);
+ Discard := Search_Tree_First (Original_Node (C));
+ return Earliest;
+ end First_Node;
+
----------------
-- Initialize --
@@ -1577,7 +1390,8 @@ package body Errout is
procedure Initialize is
begin
Errors.Init;
- Error_Msgs := No_Error_Msg;
+ First_Error_Msg := No_Error_Msg;
+ Last_Error_Msg := No_Error_Msg;
Serious_Errors_Detected := 0;
Total_Errors_Detected := 0;
Warnings_Detected := 0;
@@ -1594,7 +1408,6 @@ package body Errout is
Warnings.Table (Warnings.Last).Start := Source_Ptr'First;
Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last;
end if;
-
end Initialize;
-----------------
@@ -1652,179 +1465,6 @@ package body Errout is
end if;
end OK_Node;
- -----------------------
- -- Output_Error_Msgs --
- -----------------------
-
- procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
- P : Source_Ptr;
- T : Error_Msg_Id;
- S : Error_Msg_Id;
-
- Flag_Num : Pos;
- Mult_Flags : Boolean := False;
-
- begin
- S := E;
-
- -- Skip deleted messages at start
-
- if Errors.Table (S).Deleted then
- Set_Next_Non_Deleted_Msg (S);
- end if;
-
- -- Figure out if we will place more than one error flag on this line
-
- T := S;
- while T /= No_Error_Msg
- and then Errors.Table (T).Line = Errors.Table (E).Line
- and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
- loop
- if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
- Mult_Flags := True;
- end if;
-
- Set_Next_Non_Deleted_Msg (T);
- end loop;
-
- -- Output the error flags. The circuit here makes sure that the tab
- -- characters in the original line are properly accounted for. The
- -- eight blanks at the start are to match the line number.
-
- if not Debug_Flag_2 then
- Write_Str (" ");
- P := Line_Start (Errors.Table (E).Sptr);
- Flag_Num := 1;
-
- -- Loop through error messages for this line to place flags
-
- T := S;
- while T /= No_Error_Msg
- and then Errors.Table (T).Line = Errors.Table (E).Line
- and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
- loop
- -- Loop to output blanks till current flag position
-
- while P < Errors.Table (T).Sptr loop
- if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
- Write_Char (ASCII.HT);
- else
- Write_Char (' ');
- end if;
-
- P := P + 1;
- end loop;
-
- -- Output flag (unless already output, this happens if more
- -- than one error message occurs at the same flag position).
-
- if P = Errors.Table (T).Sptr then
- if (Flag_Num = 1 and then not Mult_Flags)
- or else Flag_Num > 9
- then
- Write_Char ('|');
- else
- Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
- end if;
-
- P := P + 1;
- end if;
-
- Set_Next_Non_Deleted_Msg (T);
- Flag_Num := Flag_Num + 1;
- end loop;
-
- Write_Eol;
- end if;
-
- -- Now output the error messages
-
- T := S;
- while T /= No_Error_Msg
- and then Errors.Table (T).Line = Errors.Table (E).Line
- and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
-
- loop
- Write_Str (" >>> ");
- Output_Msg_Text (T);
-
- if Debug_Flag_2 then
- while Column < 74 loop
- Write_Char (' ');
- end loop;
-
- Write_Str (" <<<");
- end if;
-
- Write_Eol;
- Set_Next_Non_Deleted_Msg (T);
- end loop;
-
- E := T;
- end Output_Error_Msgs;
-
- ------------------------
- -- Output_Line_Number --
- ------------------------
-
- procedure Output_Line_Number (L : Logical_Line_Number) is
- D : Int; -- next digit
- C : Character; -- next character
- Z : Boolean; -- flag for zero suppress
- N, M : Int; -- temporaries
-
- begin
- if L = No_Line_Number then
- Write_Str (" ");
-
- else
- Z := False;
- N := Int (L);
-
- M := 100_000;
- while M /= 0 loop
- D := Int (N / M);
- N := N rem M;
- M := M / 10;
-
- if D = 0 then
- if Z then
- C := '0';
- else
- C := ' ';
- end if;
- else
- Z := True;
- C := Character'Val (D + 48);
- end if;
-
- Write_Char (C);
- end loop;
-
- Write_Str (". ");
- end if;
- end Output_Line_Number;
-
- ---------------------
- -- Output_Msg_Text --
- ---------------------
-
- procedure Output_Msg_Text (E : Error_Msg_Id) is
- begin
- if Errors.Table (E).Warn then
- if Errors.Table (E).Text'Length > 7
- and then Errors.Table (E).Text (1 .. 7) /= "(style)"
- then
- Write_Str ("warning: ");
- end if;
-
- elsif Opt.Unique_Error_Tag then
- Write_Str ("error: ");
- end if;
-
- Write_Str (Errors.Table (E).Text.all);
- end Output_Msg_Text;
-
------------------------
-- Output_Source_Line --
------------------------
@@ -1842,18 +1482,29 @@ package body Errout is
begin
if Sfile /= Current_Error_Source_File then
- Write_Str ("==============Error messages for source file: ");
+ Write_Str ("==============Error messages for ");
+
+ case Sinput.File_Type (Sfile) is
+ when Sinput.Src =>
+ Write_Str ("source");
+
+ when Sinput.Config =>
+ Write_Str ("configuration pragmas");
+
+ when Sinput.Def =>
+ Write_Str ("symbol definition");
+
+ when Sinput.Preproc =>
+ Write_Str ("preprocessing data");
+ end case;
+
+ Write_Str (" file: ");
Write_Name (Full_File_Name (Sfile));
Write_Eol;
if Num_SRef_Pragmas (Sfile) > 0 then
Write_Str ("--------------Line numbers from file: ");
Write_Name (Full_Ref_Name (Sfile));
-
- -- Write starting line, except do not write it if we had more
- -- than one source reference pragma, since in this case there
- -- is no very useful number to write.
-
Write_Str (" (starting at line ");
Write_Int (Int (First_Mapped_Line (Sfile)));
Write_Char (')');
@@ -1924,58 +1575,6 @@ package body Errout is
end if;
end Output_Source_Line;
- --------------------
- -- Purge_Messages --
- --------------------
-
- procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
- E : Error_Msg_Id;
-
- function To_Be_Purged (E : Error_Msg_Id) return Boolean;
- -- Returns True for a message that is to be purged. Also adjusts
- -- error counts appropriately.
-
- function To_Be_Purged (E : Error_Msg_Id) return Boolean is
- begin
- if E /= No_Error_Msg
- and then Errors.Table (E).Sptr > From
- and then Errors.Table (E).Sptr < To
- then
- if Errors.Table (E).Warn then
- Warnings_Detected := Warnings_Detected - 1;
- else
- Total_Errors_Detected := Total_Errors_Detected - 1;
-
- if Errors.Table (E).Serious then
- Serious_Errors_Detected := Serious_Errors_Detected - 1;
- end if;
- end if;
-
- return True;
-
- else
- return False;
- end if;
- end To_Be_Purged;
-
- -- Start of processing for Purge_Messages
-
- begin
- while To_Be_Purged (Error_Msgs) loop
- Error_Msgs := Errors.Table (Error_Msgs).Next;
- end loop;
-
- E := Error_Msgs;
- while E /= No_Error_Msg loop
- while To_Be_Purged (Errors.Table (E).Next) loop
- Errors.Table (E).Next :=
- Errors.Table (Errors.Table (E).Next).Next;
- end loop;
-
- E := Errors.Table (E).Next;
- end loop;
- end Purge_Messages;
-
-----------------------------
-- Remove_Warning_Messages --
-----------------------------
@@ -2008,8 +1607,8 @@ package body Errout is
function To_Be_Removed (E : Error_Msg_Id) return Boolean is
begin
if E /= No_Error_Msg
- and then Errors.Table (E).Fptr = Loc
- and then Errors.Table (E).Warn
+ and then Errors.Table (E).Optr = Loc
+ and then (Errors.Table (E).Warn or Errors.Table (E).Style)
then
Warnings_Detected := Warnings_Detected - 1;
return True;
@@ -2021,15 +1620,23 @@ package body Errout is
-- Start of processing for Check_For_Warnings
begin
- while To_Be_Removed (Error_Msgs) loop
- Error_Msgs := Errors.Table (Error_Msgs).Next;
+ while To_Be_Removed (First_Error_Msg) loop
+ First_Error_Msg := Errors.Table (First_Error_Msg).Next;
end loop;
- E := Error_Msgs;
+ if First_Error_Msg = No_Error_Msg then
+ Last_Error_Msg := No_Error_Msg;
+ end if;
+
+ E := First_Error_Msg;
while E /= No_Error_Msg loop
while To_Be_Removed (Errors.Table (E).Next) loop
Errors.Table (E).Next :=
Errors.Table (Errors.Table (E).Next).Next;
+
+ if Errors.Table (E).Next = No_Error_Msg then
+ Last_Error_Msg := E;
+ end if;
end loop;
E := Errors.Table (E).Next;
@@ -2072,276 +1679,110 @@ package body Errout is
if Warnings_Detected /= 0 then
declare
Discard : Traverse_Result;
+ pragma Warnings (Off, Discard);
+
begin
Discard := Check_All_Warnings (N);
end;
end if;
end Remove_Warning_Messages;
- ----------------
- -- Same_Error --
- ----------------
-
- function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
- Msg1 : constant String_Ptr := Errors.Table (M1).Text;
- Msg2 : constant String_Ptr := Errors.Table (M2).Text;
-
- Msg2_Len : constant Integer := Msg2'Length;
- Msg1_Len : constant Integer := Msg1'Length;
-
- begin
- return
- Msg1.all = Msg2.all
- or else
- (Msg1_Len - 10 > Msg2_Len
- and then
- Msg2.all = Msg1.all (1 .. Msg2_Len)
- and then
- Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
- or else
- (Msg2_Len - 10 > Msg1_Len
- and then
- Msg1.all = Msg2.all (1 .. Msg1_Len)
- and then
- Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
- end Same_Error;
-
- -------------------
- -- Set_Msg_Blank --
- -------------------
-
- procedure Set_Msg_Blank is
- begin
- if Msglen > 0
- and then Msg_Buffer (Msglen) /= ' '
- and then Msg_Buffer (Msglen) /= '('
- and then not Manual_Quote_Mode
- then
- Set_Msg_Char (' ');
- end if;
- end Set_Msg_Blank;
-
- -------------------------------
- -- Set_Msg_Blank_Conditional --
- -------------------------------
-
- procedure Set_Msg_Blank_Conditional is
+ procedure Remove_Warning_Messages (L : List_Id) is
+ Stat : Node_Id;
begin
- if Msglen > 0
- and then Msg_Buffer (Msglen) /= ' '
- and then Msg_Buffer (Msglen) /= '('
- and then Msg_Buffer (Msglen) /= '"'
- and then not Manual_Quote_Mode
- then
- Set_Msg_Char (' ');
- end if;
- end Set_Msg_Blank_Conditional;
-
- ------------------
- -- Set_Msg_Char --
- ------------------
+ if Is_Non_Empty_List (L) then
+ Stat := First (L);
- procedure Set_Msg_Char (C : Character) is
- begin
-
- -- The check for message buffer overflow is needed to deal with cases
- -- where insertions get too long (in particular a child unit name can
- -- be very long).
-
- if Msglen < Max_Msg_Length then
- Msglen := Msglen + 1;
- Msg_Buffer (Msglen) := C;
- end if;
- end Set_Msg_Char;
-
- ------------------------------
- -- Set_Msg_Insertion_Column --
- ------------------------------
-
- procedure Set_Msg_Insertion_Column is
- begin
- if Style.RM_Column_Check then
- Set_Msg_Str (" in column ");
- Set_Msg_Int (Int (Error_Msg_Col) + 1);
+ while Present (Stat) loop
+ Remove_Warning_Messages (Stat);
+ Next (Stat);
+ end loop;
end if;
- end Set_Msg_Insertion_Column;
-
- ---------------------------------
- -- Set_Msg_Insertion_File_Name --
- ---------------------------------
-
- procedure Set_Msg_Insertion_File_Name is
- begin
- if Error_Msg_Name_1 = No_Name then
- null;
-
- elsif Error_Msg_Name_1 = Error_Name then
- Set_Msg_Blank;
- Set_Msg_Str ("<error>");
+ end Remove_Warning_Messages;
- else
- Set_Msg_Blank;
- Get_Name_String (Error_Msg_Name_1);
- Set_Msg_Quote;
- Set_Msg_Name_Buffer;
- Set_Msg_Quote;
- end if;
+ ---------------------------
+ -- Set_Identifier_Casing --
+ ---------------------------
- -- The following assignments ensure that the second and third percent
- -- insertion characters will correspond to the Error_Msg_Name_2 and
- -- Error_Msg_Name_3 as required.
+ procedure Set_Identifier_Casing
+ (Identifier_Name : System.Address;
+ File_Name : System.Address)
+ is
+ type Big_String is array (Positive) of Character;
+ type Big_String_Ptr is access all Big_String;
- Error_Msg_Name_1 := Error_Msg_Name_2;
- Error_Msg_Name_2 := Error_Msg_Name_3;
+ function To_Big_String_Ptr is new Unchecked_Conversion
+ (System.Address, Big_String_Ptr);
- end Set_Msg_Insertion_File_Name;
+ Ident : constant Big_String_Ptr := To_Big_String_Ptr (Identifier_Name);
+ File : constant Big_String_Ptr := To_Big_String_Ptr (File_Name);
+ Flen : Natural;
- -----------------------------------
- -- Set_Msg_Insertion_Line_Number --
- -----------------------------------
+ Desired_Case : Casing_Type := Mixed_Case;
+ -- Casing required for result. Default value of Mixed_Case is used if
+ -- for some reason we cannot find the right file name in the table.
- procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
- Sindex_Loc : Source_File_Index;
- Sindex_Flag : Source_File_Index;
begin
- Set_Msg_Blank;
-
- if Loc = No_Location then
- Set_Msg_Str ("at unknown location");
-
- elsif Loc <= Standard_Location then
- Set_Msg_Str ("in package Standard");
-
- if Loc = Standard_ASCII_Location then
- Set_Msg_Str (".ASCII");
- end if;
-
- else
- -- Add "at file-name:" if reference is to other than the source
- -- file in which the error message is placed. Note that we check
- -- full file names, rather than just the source indexes, to
- -- deal with generic instantiations from the current file.
-
- Sindex_Loc := Get_Source_File_Index (Loc);
- Sindex_Flag := Get_Source_File_Index (Flag);
-
- if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
- Set_Msg_Str ("at ");
- Get_Name_String
- (Reference_Name (Get_Source_File_Index (Loc)));
- Set_Msg_Name_Buffer;
- Set_Msg_Char (':');
-
- -- If in current file, add text "at line "
-
- else
- Set_Msg_Str ("at line ");
- end if;
+ -- Get length of file name
- -- Output line number for reference
-
- Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
-
- -- Deal with the instantiation case. We may have a reference to,
- -- e.g. a type, that is declared within a generic template, and
- -- what we are really referring to is the occurrence in an instance.
- -- In this case, the line number of the instantiation is also of
- -- interest, and we add a notation:
-
- -- , instance at xxx
-
- -- where xxx is a line number output using this same routine (and
- -- the recursion can go further if the instantiation is itself in
- -- a generic template).
+ Flen := 0;
+ while File (Flen + 1) /= ASCII.NUL loop
+ Flen := Flen + 1;
+ end loop;
- -- The flag location passed to us in this situation is indeed the
- -- line number within the template, but as described in Sinput.L
- -- (file sinput-l.ads, section "Handling Generic Instantiations")
- -- we can retrieve the location of the instantiation itself from
- -- this flag location value.
+ -- Loop through file names to find matching one. This is a bit slow,
+ -- but we only do it in error situations so it is not so terrible.
+ -- Note that if the loop does not exit, then the desired case will
+ -- be left set to Mixed_Case, this can happen if the name was not
+ -- in canonical form, and gets canonicalized on VMS. Possibly we
+ -- could fix this by unconditinally canonicalizing these names ???
- -- Note: this processing is suppressed if Suppress_Instance_Location
- -- is set True. This is used to prevent redundant annotations of the
- -- location of the instantiation in the case where we are placing
- -- the messages on the instantiation in any case.
+ for J in 1 .. Last_Source_File loop
+ Get_Name_String (Full_Debug_Name (J));
- if Instantiation (Sindex_Loc) /= No_Location
- and then not Suppress_Instance_Location
+ if Name_Len = Flen
+ and then Name_Buffer (1 .. Name_Len) = String (File (1 .. Flen))
then
- Set_Msg_Str (", instance ");
- Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
+ Desired_Case := Identifier_Casing (J);
+ exit;
end if;
- end if;
- end Set_Msg_Insertion_Line_Number;
-
- ----------------------------
- -- Set_Msg_Insertion_Name --
- ----------------------------
-
- procedure Set_Msg_Insertion_Name is
- begin
- if Error_Msg_Name_1 = No_Name then
- null;
-
- elsif Error_Msg_Name_1 = Error_Name then
- Set_Msg_Blank;
- Set_Msg_Str ("<error>");
+ end loop;
- else
- Set_Msg_Blank_Conditional;
- Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
+ -- Copy identifier as given to Name_Buffer
- -- Remove %s or %b at end. These come from unit names. If the
- -- caller wanted the (unit) or (body), then they would have used
- -- the $ insertion character. Certainly no error message should
- -- ever have %b or %s explicitly occurring.
+ for J in Name_Buffer'Range loop
+ Name_Buffer (J) := Ident (J);
- if Name_Len > 2
- and then Name_Buffer (Name_Len - 1) = '%'
- and then (Name_Buffer (Name_Len) = 'b'
- or else
- Name_Buffer (Name_Len) = 's')
- then
- Name_Len := Name_Len - 2;
+ if Name_Buffer (J) = ASCII.Nul then
+ Name_Len := J - 1;
+ exit;
end if;
+ end loop;
- -- Remove upper case letter at end, again, we should not be getting
- -- such names, and what we hope is that the remainder makes sense.
-
- if Name_Len > 1
- and then Name_Buffer (Name_Len) in 'A' .. 'Z'
- then
- Name_Len := Name_Len - 1;
- end if;
+ Set_Casing (Desired_Case);
+ end Set_Identifier_Casing;
- -- If operator name or character literal name, just print it as is
- -- Also print as is if it ends in a right paren (case of x'val(nnn))
+ -----------------------
+ -- Set_Ignore_Errors --
+ -----------------------
- if Name_Buffer (1) = '"'
- or else Name_Buffer (1) = '''
- or else Name_Buffer (Name_Len) = ')'
- then
- Set_Msg_Name_Buffer;
+ procedure Set_Ignore_Errors (To : Boolean) is
+ begin
+ Errors_Must_Be_Ignored := To;
+ end Set_Ignore_Errors;
- -- Else output with surrounding quotes in proper casing mode
+ ------------------------------
+ -- Set_Msg_Insertion_Column --
+ ------------------------------
- else
- Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
- Set_Msg_Quote;
- Set_Msg_Name_Buffer;
- Set_Msg_Quote;
- end if;
+ procedure Set_Msg_Insertion_Column is
+ begin
+ if Style.RM_Column_Check then
+ Set_Msg_Str (" in column ");
+ Set_Msg_Int (Int (Error_Msg_Col) + 1);
end if;
-
- -- The following assignments ensure that the second and third percent
- -- insertion characters will correspond to the Error_Msg_Name_2 and
- -- Error_Msg_Name_3 as required.
-
- Error_Msg_Name_1 := Error_Msg_Name_2;
- Error_Msg_Name_2 := Error_Msg_Name_3;
-
- end Set_Msg_Insertion_Name;
+ end Set_Msg_Insertion_Column;
----------------------------
-- Set_Msg_Insertion_Node --
@@ -2385,47 +1826,8 @@ package body Errout is
-- character will correspond to the Error_Msg_Node_2 parameter.
Error_Msg_Node_1 := Error_Msg_Node_2;
-
end Set_Msg_Insertion_Node;
- -------------------------------------
- -- Set_Msg_Insertion_Reserved_Name --
- -------------------------------------
-
- procedure Set_Msg_Insertion_Reserved_Name is
- begin
- Set_Msg_Blank_Conditional;
- Get_Name_String (Error_Msg_Name_1);
- Set_Msg_Quote;
- Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
- Set_Msg_Name_Buffer;
- Set_Msg_Quote;
- end Set_Msg_Insertion_Reserved_Name;
-
- -------------------------------------
- -- Set_Msg_Insertion_Reserved_Word --
- -------------------------------------
-
- procedure Set_Msg_Insertion_Reserved_Word
- (Text : String;
- J : in out Integer)
- is
- begin
- Set_Msg_Blank_Conditional;
- Name_Len := 0;
-
- while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Text (J);
- J := J + 1;
- end loop;
-
- Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
- Set_Msg_Quote;
- Set_Msg_Name_Buffer;
- Set_Msg_Quote;
- end Set_Msg_Insertion_Reserved_Word;
-
--------------------------------------
-- Set_Msg_Insertion_Type_Reference --
--------------------------------------
@@ -2572,28 +1974,8 @@ package body Errout is
end;
end if;
end if;
-
end Set_Msg_Insertion_Type_Reference;
- ----------------------------
- -- Set_Msg_Insertion_Uint --
- ----------------------------
-
- procedure Set_Msg_Insertion_Uint is
- begin
- Set_Msg_Blank;
- UI_Image (Error_Msg_Uint_1);
-
- for J in 1 .. UI_Image_Length loop
- Set_Msg_Char (UI_Image_Buffer (J));
- end loop;
-
- -- The following assignment ensures that a second carret insertion
- -- character will correspond to the Error_Msg_Uint_2 parameter.
-
- Error_Msg_Uint_1 := Error_Msg_Uint_2;
- end Set_Msg_Insertion_Uint;
-
---------------------------------
-- Set_Msg_Insertion_Unit_Name --
---------------------------------
@@ -2619,33 +2001,8 @@ package body Errout is
-- character will correspond to the Error_Msg_Unit_2 parameter.
Error_Msg_Unit_1 := Error_Msg_Unit_2;
-
end Set_Msg_Insertion_Unit_Name;
- -----------------
- -- Set_Msg_Int --
- -----------------
-
- procedure Set_Msg_Int (Line : Int) is
- begin
- if Line > 9 then
- Set_Msg_Int (Line / 10);
- end if;
-
- Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
- end Set_Msg_Int;
-
- -------------------------
- -- Set_Msg_Name_Buffer --
- -------------------------
-
- procedure Set_Msg_Name_Buffer is
- begin
- for J in 1 .. Name_Len loop
- Set_Msg_Char (Name_Buffer (J));
- end loop;
- end Set_Msg_Name_Buffer;
-
------------------
-- Set_Msg_Node --
------------------
@@ -2739,14 +2096,19 @@ package body Errout is
Ref_Ptr := 1;
Src_Ptr := Src_Loc;
- -- Determine if the reference we are dealing with corresponds
- -- to text at the point of the error reference. This will often
- -- be the case for simple identifier references, and is the case
- -- where we can copy the spelling from the source.
+ -- For standard locations, always use mixed case
- if Src_Loc /= No_Location
- and then Src_Loc > Standard_Location
+ if Src_Loc <= No_Location
+ or else Sloc (Node) <= No_Location
then
+ Set_Casing (Mixed_Case);
+
+ else
+ -- Determine if the reference we are dealing with corresponds
+ -- to text at the point of the error reference. This will often
+ -- be the case for simple identifier references, and is the case
+ -- where we can copy the spelling from the source.
+
Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc));
while Ref_Ptr <= Name_Len loop
@@ -2756,61 +2118,30 @@ package body Errout is
Ref_Ptr := Ref_Ptr + 1;
Src_Ptr := Src_Ptr + 1;
end loop;
- end if;
- -- If we get through the loop without a mismatch, then output
- -- the name the way it is spelled in the source program
+ -- If we get through the loop without a mismatch, then output
+ -- the name the way it is spelled in the source program
- if Ref_Ptr > Name_Len then
- Src_Ptr := Src_Loc;
+ if Ref_Ptr > Name_Len then
+ Src_Ptr := Src_Loc;
- for J in 1 .. Name_Len loop
- Name_Buffer (J) := Sbuffer (Src_Ptr);
- Src_Ptr := Src_Ptr + 1;
- end loop;
+ for J in 1 .. Name_Len loop
+ Name_Buffer (J) := Sbuffer (Src_Ptr);
+ Src_Ptr := Src_Ptr + 1;
+ end loop;
- -- Otherwise set the casing using the default identifier casing
+ -- Otherwise set the casing using the default identifier casing
- else
- Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
+ else
+ Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
+ end if;
end if;
end;
Set_Msg_Name_Buffer;
Add_Class;
-
- -- Add 'Class if class wide type
-
- if Class_Flag then
- Set_Msg_Char (''');
- Get_Name_String (Name_Class);
- Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
- Set_Msg_Name_Buffer;
- end if;
end Set_Msg_Node;
- -------------------
- -- Set_Msg_Quote --
- -------------------
-
- procedure Set_Msg_Quote is
- begin
- if not Manual_Quote_Mode then
- Set_Msg_Char ('"');
- end if;
- end Set_Msg_Quote;
-
- -----------------
- -- Set_Msg_Str --
- -----------------
-
- procedure Set_Msg_Str (Text : String) is
- begin
- for J in Text'Range loop
- Set_Msg_Char (Text (J));
- end loop;
- end Set_Msg_Str;
-
------------------
-- Set_Msg_Text --
------------------
@@ -2832,87 +2163,81 @@ package body Errout is
-- Check for insertion character
- if C = '%' then
- Set_Msg_Insertion_Name;
+ case C is
+ when '%' =>
+ Set_Msg_Insertion_Name;
- elsif C = '$' then
- Set_Msg_Insertion_Unit_Name;
+ when '$' =>
+ Set_Msg_Insertion_Unit_Name;
- elsif C = '{' then
- Set_Msg_Insertion_File_Name;
+ when '{' =>
+ Set_Msg_Insertion_File_Name;
- elsif C = '}' then
- Set_Msg_Insertion_Type_Reference (Flag);
+ when '}' =>
+ Set_Msg_Insertion_Type_Reference (Flag);
- elsif C = '*' then
- Set_Msg_Insertion_Reserved_Name;
+ when '*' =>
+ Set_Msg_Insertion_Reserved_Name;
- elsif C = '&' then
- Set_Msg_Insertion_Node;
+ when '&' =>
+ Set_Msg_Insertion_Node;
- elsif C = '#' then
- Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
+ when '#' =>
+ Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
- elsif C = '\' then
- Continuation := True;
+ when '\' =>
+ Continuation := True;
- elsif C = '@' then
- Set_Msg_Insertion_Column;
+ when '@' =>
+ Set_Msg_Insertion_Column;
- elsif C = '^' then
- Set_Msg_Insertion_Uint;
+ when '>' =>
+ Set_Msg_Insertion_Run_Time_Name;
- elsif C = '`' then
- Manual_Quote_Mode := not Manual_Quote_Mode;
- Set_Msg_Char ('"');
- elsif C = '!' then
- Is_Unconditional_Msg := True;
+ when '^' =>
+ Set_Msg_Insertion_Uint;
- elsif C = '?' then
- null;
+ when '`' =>
+ Manual_Quote_Mode := not Manual_Quote_Mode;
+ Set_Msg_Char ('"');
- elsif C = '|' then
- null;
+ when '!' =>
+ Is_Unconditional_Msg := True;
- elsif C = ''' then
- Set_Msg_Char (Text (P));
- P := P + 1;
+ when '?' =>
+ null; -- already dealt with
- -- Upper case letter (start of reserved word if 2 or more)
+ when '|' =>
+ null; -- already dealt with
- elsif C in 'A' .. 'Z'
- and then P <= Text'Last
- and then Text (P) in 'A' .. 'Z'
- then
- P := P - 1;
- Set_Msg_Insertion_Reserved_Word (Text, P);
+ when ''' =>
+ Set_Msg_Char (Text (P));
+ P := P + 1;
- -- Normal character with no special treatment
+ -- Upper case letter
- else
- Set_Msg_Char (C);
- end if;
+ when 'A' .. 'Z' =>
- end loop;
- end Set_Msg_Text;
+ -- Start of reserved word if two or more
- ------------------------------
- -- Set_Next_Non_Deleted_Msg --
- ------------------------------
+ if P <= Text'Last and then Text (P) in 'A' .. 'Z' then
+ P := P - 1;
+ Set_Msg_Insertion_Reserved_Word (Text, P);
- procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
- begin
- if E = No_Error_Msg then
- return;
+ -- Single upper case letter is just inserted
- else
- loop
- E := Errors.Table (E).Next;
- exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
- end loop;
- end if;
- end Set_Next_Non_Deleted_Msg;
+ else
+ Set_Msg_Char (C);
+ end if;
+
+ -- Normal character with no special treatment
+
+ when others =>
+ Set_Msg_Char (C);
+ end case;
+ end loop;
+ end Set_Msg_Text;
----------------
-- Set_Posted --
@@ -2922,30 +2247,33 @@ package body Errout is
P : Node_Id;
begin
- -- We always set Error_Posted on the node itself
+ if Is_Serious_Error then
- Set_Error_Posted (N);
+ -- We always set Error_Posted on the node itself
- -- If it is a subexpression, then set Error_Posted on parents
- -- up to and including the first non-subexpression construct. This
- -- helps avoid cascaded error messages within a single expression.
+ Set_Error_Posted (N);
- P := N;
- loop
- P := Parent (P);
- exit when No (P);
- Set_Error_Posted (P);
- exit when Nkind (P) not in N_Subexpr;
- end loop;
+ -- If it is a subexpression, then set Error_Posted on parents
+ -- up to and including the first non-subexpression construct. This
+ -- helps avoid cascaded error messages within a single expression.
- -- A special check, if we just posted an error on an attribute
- -- definition clause, then also set the entity involved as posted.
- -- For example, this stops complaining about the alignment after
- -- complaining about the size, which is likely to be useless.
+ P := N;
+ loop
+ P := Parent (P);
+ exit when No (P);
+ Set_Error_Posted (P);
+ exit when Nkind (P) not in N_Subexpr;
+ end loop;
+
+ -- A special check, if we just posted an error on an attribute
+ -- definition clause, then also set the entity involved as posted.
+ -- For example, this stops complaining about the alignment after
+ -- complaining about the size, which is likely to be useless.
- if Nkind (P) = N_Attribute_Definition_Clause then
- if Is_Entity_Name (Name (P)) then
- Set_Error_Posted (Entity (Name (P)));
+ if Nkind (P) = N_Attribute_Definition_Clause then
+ if Is_Entity_Name (Name (P)) then
+ Set_Error_Posted (Entity (Name (P)));
+ end if;
end if;
end if;
end Set_Posted;
@@ -2963,67 +2291,6 @@ package body Errout is
end if;
end Set_Qualification;
- ---------------------------
- -- Set_Warnings_Mode_Off --
- ---------------------------
-
- procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
- begin
- -- Don't bother with entries from instantiation copies, since we
- -- will already have a copy in the template, which is what matters
-
- if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
- return;
- end if;
-
- -- If last entry in table already covers us, this is a redundant
- -- pragma Warnings (Off) and can be ignored. This also handles the
- -- case where all warnings are suppressed by command line switch.
-
- if Warnings.Last >= Warnings.First
- and then Warnings.Table (Warnings.Last).Start <= Loc
- and then Loc <= Warnings.Table (Warnings.Last).Stop
- then
- return;
-
- -- Otherwise establish a new entry, extending from the location of
- -- the pragma to the end of the current source file. This ending
- -- point will be adjusted by a subsequent pragma Warnings (On).
-
- else
- Warnings.Increment_Last;
- Warnings.Table (Warnings.Last).Start := Loc;
- Warnings.Table (Warnings.Last).Stop :=
- Source_Last (Current_Source_File);
- end if;
- end Set_Warnings_Mode_Off;
-
- --------------------------
- -- Set_Warnings_Mode_On --
- --------------------------
-
- procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
- begin
- -- Don't bother with entries from instantiation copies, since we
- -- will already have a copy in the template, which is what matters
-
- if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
- return;
- end if;
-
- -- Nothing to do unless command line switch to suppress all warnings
- -- is off, and the last entry in the warnings table covers this
- -- pragma Warnings (On), in which case adjust the end point.
-
- if (Warnings.Last >= Warnings.First
- and then Warnings.Table (Warnings.Last).Start <= Loc
- and then Loc <= Warnings.Table (Warnings.Last).Stop)
- and then Warning_Mode /= Suppress
- then
- Warnings.Table (Warnings.Last).Stop := Loc;
- end if;
- end Set_Warnings_Mode_On;
-
------------------------
-- Special_Msg_Delete --
------------------------
@@ -3084,38 +2351,6 @@ package body Errout is
end if;
end Special_Msg_Delete;
- ------------------------------
- -- Test_Warning_Serious_Msg --
- ------------------------------
-
- procedure Test_Warning_Msg (Msg : String) is
- begin
- Is_Serious_Error := True;
-
- if Msg'Length > 7 and then Msg (1 .. 7) = "(style)" then
- Is_Warning_Msg := True;
- else
- Is_Warning_Msg := False;
- end if;
-
- for J in Msg'Range loop
- if Msg (J) = '?'
- and then (J = Msg'First or else Msg (J - 1) /= ''')
- then
- Is_Warning_Msg := True;
-
- elsif Msg (J) = '|'
- and then (J = Msg'First or else Msg (J - 1) /= ''')
- then
- Is_Serious_Error := False;
- end if;
- end loop;
-
- if Is_Warning_Msg then
- Is_Serious_Error := False;
- end if;
- end Test_Warning_Msg;
-
--------------------------
-- Unwind_Internal_Type --
--------------------------
@@ -3228,24 +2463,6 @@ package body Errout is
if Mchar = '"' then
Set_Msg_Char ('"');
end if;
-
end Unwind_Internal_Type;
- -------------------------
- -- Warnings_Suppressed --
- -------------------------
-
- function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
- begin
- for J in Warnings.First .. Warnings.Last loop
- if Warnings.Table (J).Start <= Loc
- and then Loc <= Warnings.Table (J).Stop
- then
- return True;
- end if;
- end loop;
-
- return False;
- end Warnings_Suppressed;
-
end Errout;
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index 442204819f4..58eaac6b299 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -29,25 +29,36 @@
-- when the parser is embedded into an editor, it may be appropriate
-- to replace the implementation of this package.
+with Err_Vars;
+with Erroutc;
with Table;
with Types; use Types;
with Uintp; use Uintp;
+with System;
+
package Errout is
- Serious_Errors_Detected : Nat;
+ Serious_Errors_Detected : Nat renames Err_Vars.Serious_Errors_Detected;
-- This is a count of errors that are serious enough to stop expansion,
-- and hence to prevent generation of an object file even if the
-- switch -gnatQ is set.
- Total_Errors_Detected : Nat;
+ Total_Errors_Detected : Nat renames Err_Vars.Total_Errors_Detected;
-- Number of errors detected so far. Includes count of serious errors
-- and non-serious errors, so this value is always greater than or
-- equal to the Serious_Errors_Detected value.
- Warnings_Detected : Nat;
+ Warnings_Detected : Nat renames Err_Vars.Warnings_Detected;
-- Number of warnings detected
+ Configurable_Run_Time_Violations : Nat := 0;
+ -- Count of configurable run time violations so far. This is used to
+ -- suppress certain cascaded error messages when we know that we may not
+ -- have fully expanded some items, due to high integrity violations (i.e.
+ -- the use of constructs not permitted by the library in use, or
+ -- improper constructs in No_Run_Time mode).
+
type Compiler_State_Type is (Parsing, Analyzing);
Compiler_State : Compiler_State_Type;
-- Indicates current state of compilation. This is put in the Errout
@@ -55,7 +66,8 @@ package Errout is
-- In particular, an attempt is made by Errout to suppress cascaded
-- error messages in Parsing mode, but not in the other modes.
- Current_Error_Source_File : Source_File_Index;
+ Current_Error_Source_File : Source_File_Index
+ renames Err_Vars.Current_Error_Source_File;
-- Id of current messages. Used to post file name when unit changes. This
-- is initialized to Main_Source_File at the start of a compilation, which
-- means that no file names will be output unless there are errors in units
@@ -63,7 +75,7 @@ package Errout is
-- Source_Reference line, then this is initialized to No_Source_File,
-- to force an initial reference to the real source file name.
- Raise_Exception_On_Error : Nat := 0;
+ Raise_Exception_On_Error : Nat renames Err_Vars.Raise_Exception_On_Error;
-- If this value is non-zero, then any attempt to generate an error
-- message raises the exception Error_Msg_Exception, and the error
-- message is not output. This is used for defending against junk
@@ -71,7 +83,7 @@ package Errout is
-- appropriate error messages from higher semantic levels. It is
-- a counter so that the increment/decrement protocol nests neatly.
- Error_Msg_Exception : exception;
+ Error_Msg_Exception : exception renames Err_Vars.Error_Msg_Exception;
-- Exception raised if Raise_Exception_On_Error is true
-----------------------------------
@@ -205,6 +217,13 @@ package Errout is
-- A second ^ may occur in the message, in which case it is replaced
-- by the decimal conversion of the Uint value in Error_Msg_Uint_2.
+ -- Insertion character > (Right bracket, run time name)
+ -- The character > is replaced by a string of the form (name) if
+ -- Targparm scanned out a Run_Time_Name (see package Targparm for
+ -- details). The name is enclosed in parentheses and output in mixed
+ -- case mode (upper case after any space in the name). If no run time
+ -- name is defined, this insertion character has no effect.
+
-- Insertion character ! (Exclamation: unconditional message)
-- The character ! appearing as the last character of a message makes
-- the message unconditional which means that it is output even if it
@@ -239,7 +258,9 @@ package Errout is
-- Insertion character ' (Quote: literal character)
-- Precedes a character which is placed literally into the message.
-- Used to insert characters into messages that are one of the
- -- insertion characters defined here.
+ -- insertion characters defined here. Also useful in inserting
+ -- sequences of upper case letters (e.g. RM) which are not to be
+ -- treated as keywords.
-- Insertion character \ (Backslash: continuation message)
-- Indicates that the message is a continuation of a message
@@ -265,43 +286,35 @@ package Errout is
-- mechanism is essentially an untyped one in which the appropriate
-- variables are set dependingon the specific insertion characters used.
- Error_Msg_Col : Column_Number;
+ Error_Msg_Col : Column_Number renames Err_Vars.Error_Msg_Col;
-- Column for @ insertion character in message
- Error_Msg_Uint_1 : Uint;
- Error_Msg_Uint_2 : Uint;
+ Error_Msg_Uint_1 : Uint renames Err_Vars.Error_Msg_Uint_1;
+ Error_Msg_Uint_2 : Uint renames Err_Vars.Error_Msg_Uint_2;
-- Uint values for ^ insertion characters in message
- Error_Msg_Sloc : Source_Ptr;
+ Error_Msg_Sloc : Source_Ptr renames Err_Vars.Error_Msg_Sloc;
-- Source location for # insertion character in message
- Error_Msg_Name_1 : Name_Id;
- Error_Msg_Name_2 : Name_Id;
- Error_Msg_Name_3 : Name_Id;
+ Error_Msg_Name_1 : Name_Id renames Err_Vars.Error_Msg_Name_1;
+ Error_Msg_Name_2 : Name_Id renames Err_Vars.Error_Msg_Name_2;
+ Error_Msg_Name_3 : Name_Id renames Err_Vars.Error_Msg_Name_3;
-- Name_Id values for % insertion characters in message
- Error_Msg_Unit_1 : Name_Id;
- Error_Msg_Unit_2 : Name_Id;
+ Error_Msg_Unit_1 : Name_Id renames Err_Vars.Error_Msg_Unit_1;
+ Error_Msg_Unit_2 : Name_Id renames Err_Vars.Error_Msg_Unit_2;
-- Name_Id values for $ insertion characters in message
- Error_Msg_Node_1 : Node_Id;
- Error_Msg_Node_2 : Node_Id;
+ Error_Msg_Node_1 : Node_Id renames Err_Vars.Error_Msg_Node_1;
+ Error_Msg_Node_2 : Node_Id renames Err_Vars.Error_Msg_Node_2;
-- Node_Id values for & insertion characters in message
- Error_Msg_Qual_Level : Int := 0;
+ Error_Msg_Qual_Level : Int renames Err_Vars.Error_Msg_Qual_Level;
-- Number of levels of qualification required for type name (see the
-- description of the } insertion character. Note that this value does
-- note get reset by any Error_Msg call, so the caller is responsible
-- for resetting it.
- Warn_On_Instance : Boolean := False;
- -- Normally if a warning is generated in a generic template from the
- -- analysis of the template, then the warning really belongs in the
- -- template, and the default value of False for this Boolean achieves
- -- that effect. If Warn_On_Instance is set True, then the warnings are
- -- generated on the instantiation (referring to the template) rather
- -- than on the template itself.
-
-----------------------------------------------------
-- Format of Messages and Manual Quotation Control --
-----------------------------------------------------
@@ -367,20 +380,23 @@ package Errout is
-- Message ID Definitions --
----------------------------
- type Error_Msg_Id is new Int;
+ subtype Error_Msg_Id is Erroutc.Error_Msg_Id;
+ function "=" (Left, Right : Error_Msg_Id) return Boolean
+ renames Erroutc."=";
-- A type used to represent specific error messages. Used by the clients
-- of this package only in the context of the Get_Error_Id and
-- Change_Error_Text subprograms.
- No_Error_Msg : constant Error_Msg_Id := 0;
+ No_Error_Msg : constant Error_Msg_Id := Erroutc.No_Error_Msg;
-- A constant which is different from any value returned by Get_Error_Id.
-- Typically used by a client to indicate absense of a saved Id value.
- function Get_Msg_Id return Error_Msg_Id;
+ function Get_Msg_Id return Error_Msg_Id renames Erroutc.Get_Msg_Id;
-- Returns the Id of the message most recently posted using one of the
-- Error_Msg routines.
- function Get_Location (E : Error_Msg_Id) return Source_Ptr;
+ function Get_Location (E : Error_Msg_Id) return Source_Ptr
+ renames Erroutc.Get_Location;
-- Returns the flag location of the error message with the given id E.
------------------------
@@ -479,6 +495,10 @@ package Errout is
-- or if it is a warning and warnings and N is an entity node for which
-- warnings are suppressed.
+ procedure Error_Msg_F (Msg : String; N : Node_Id);
+ -- Similar to Error_Msg_N except that the message is placed on the
+ -- first node of the construct N (First_Node (N)).
+
procedure Error_Msg_NE
(Msg : String;
N : Node_Or_Entity_Id;
@@ -489,6 +509,13 @@ package Errout is
-- text will contain a & or } as usual to mark the insertion point.
-- This routine can be called from the parser or the analyzer.
+ procedure Error_Msg_FE
+ (Msg : String;
+ N : Node_Id;
+ E : Node_Or_Entity_Id);
+ -- Same as Error_Msg_NE, except that the message is placed on the first
+ -- node of the construct N (First_Node (N)).
+
procedure Error_Msg_NEL
(Msg : String;
N : Node_Or_Entity_Id;
@@ -497,12 +524,26 @@ package Errout is
-- Exactly the same as Error_Msg_NE, except that the flag is placed at
-- the specified Flag_Location instead of at Sloc (N).
+ procedure Error_Msg_NW
+ (Eflag : Boolean;
+ Msg : String;
+ N : Node_Or_Entity_Id);
+ -- This routine is used for posting a message conditionally. The message
+ -- is posted (with the same effect as Error_Msg_N (Msg, N) if and only
+ -- if Eflag is True and if the node N is within the main extended source
+ -- unit. Typically this is a warning mode flag.
+
procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String);
-- The error message text of the message identified by Id is replaced by
-- the given text. This text may contain insertion characters in the
-- usual manner, and need not be the same length as the original text.
- procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr);
+ function First_Node (C : Node_Id) return Node_Id;
+ -- Given a construct C, finds the first node in the construct, i.e. the
+ -- one with the lowest Sloc value. This is useful in placing error msgs.
+
+ procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr)
+ renames Erroutc.Purge_Messages;
-- All error messages whose location is in the range From .. To (not
-- including the end points) will be deleted from the error listing.
@@ -510,19 +551,56 @@ package Errout is
-- Remove any warning messages corresponding to the Sloc of N or any
-- of its descendent nodes. No effect if no such warnings.
- procedure Set_Warnings_Mode_Off (Loc : Source_Ptr);
+ procedure Remove_Warning_Messages (L : List_Id);
+ -- Remove warnings on all elements of a list.
+
+ procedure Set_Ignore_Errors (To : Boolean);
+ -- Following a call to this procedure with To=True, all error calls are
+ -- ignored. A call with To=False restores the default treatment in which
+ -- error calls are treated as usual (and as described in this spec).
+
+ procedure Set_Warnings_Mode_Off (Loc : Source_Ptr)
+ renames Erroutc.Set_Warnings_Mode_Off;
-- Called in response to a pragma Warnings (Off) to record the source
-- location from which warnings are to be turned off.
- procedure Set_Warnings_Mode_On (Loc : Source_Ptr);
+ procedure Set_Warnings_Mode_On (Loc : Source_Ptr)
+ renames Erroutc.Set_Warnings_Mode_On;
-- Called in response to a pragma Warnings (On) to record the source
-- location from which warnings are to be turned back on.
- function Compilation_Errors return Boolean;
+ function Compilation_Errors return Boolean
+ renames Erroutc.Compilation_Errors;
-- Returns true if errors have been detected, or warnings in -gnatwe
-- (treat warnings as errors) mode.
- procedure dmsg (Id : Error_Msg_Id);
+ procedure Error_Msg_CRT (Feature : String; N : Node_Id);
+ -- Posts a non-fatal message on node N saying that the feature
+ -- identified by the Feature argument is not supported in either
+ -- configurable run-time mode or no run-time mode (as appropriate).
+ -- In the former case, the name of the library is output if available.
+
+ procedure dmsg (Id : Error_Msg_Id) renames Erroutc.dmsg;
-- Debugging routine to dump an error message
+ ------------------------------------
+ -- Utility Interface for Back End --
+ ------------------------------------
+
+ -- The following subprograms can be used by the back end for the purposes
+ -- of concocting error messages that are not output via Errout, e.g. the
+ -- messages generated by the gcc back end.
+
+ procedure Set_Identifier_Casing
+ (Identifier_Name : System.Address;
+ File_Name : System.Address);
+ -- The identifier is a null terminated string that represents the name
+ -- of an identifier appearing in the source program. File_Name is a null
+ -- terminated string giving the corresponding file name for the identifier
+ -- as obtained from the front end by the use of Full_Debug_Name to the
+ -- source file referenced by the corresponding source location value.
+ -- On return, the name is in Name_Buffer, null terminated with Name_Len
+ -- set. This name is the identifier name as passed, cased according to
+ -- the default identifier casing for the given file.
+
end Errout;
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
new file mode 100644
index 00000000000..e46c7cd6314
--- /dev/null
+++ b/gcc/ada/erroutc.adb
@@ -0,0 +1,1013 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- E R R O U T C --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Warning! Error messages can be generated during Gigi processing by direct
+-- calls to error message routines, so it is essential that the processing
+-- in this body be consistent with the requirements for the Gigi processing
+-- environment, and that in particular, no disallowed table expansion is
+-- allowed to occur.
+
+with Casing; use Casing;
+with Debug; use Debug;
+with Err_Vars; use Err_Vars;
+with Hostparm;
+with Namet; use Namet;
+with Opt; use Opt;
+with Output; use Output;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Targparm; use Targparm;
+with Table;
+with Types; use Types;
+with Uintp; use Uintp;
+
+package body Erroutc is
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ ---------------
+ -- Add_Class --
+ ---------------
+
+ procedure Add_Class is
+ begin
+ if Class_Flag then
+ Class_Flag := False;
+ Set_Msg_Char (''');
+ Get_Name_String (Name_Class);
+ Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
+ Set_Msg_Name_Buffer;
+ end if;
+ end Add_Class;
+
+ ----------------------
+ -- Buffer_Ends_With --
+ ----------------------
+
+ function Buffer_Ends_With (S : String) return Boolean is
+ Len : constant Natural := S'Length;
+
+ begin
+ return
+ Msglen > Len
+ and then Msg_Buffer (Msglen - Len) = ' '
+ and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
+ end Buffer_Ends_With;
+
+ -------------------
+ -- Buffer_Remove --
+ -------------------
+
+ procedure Buffer_Remove (S : String) is
+ begin
+ if Buffer_Ends_With (S) then
+ Msglen := Msglen - S'Length;
+ end if;
+ end Buffer_Remove;
+
+ -----------------------------
+ -- Check_Duplicate_Message --
+ -----------------------------
+
+ procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
+ L1, L2 : Error_Msg_Id;
+ N1, N2 : Error_Msg_Id;
+
+ procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
+ -- Called to delete message Delete, keeping message Keep. Marks
+ -- all messages of Delete with deleted flag set to True, and also
+ -- makes sure that for the error messages that are retained the
+ -- preferred message is the one retained (we prefer the shorter
+ -- one in the case where one has an Instance tag). Note that we
+ -- always know that Keep has at least as many continuations as
+ -- Delete (since we always delete the shorter sequence).
+
+ ----------------
+ -- Delete_Msg --
+ ----------------
+
+ procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
+ D, K : Error_Msg_Id;
+
+ begin
+ D := Delete;
+ K := Keep;
+
+ loop
+ Errors.Table (D).Deleted := True;
+
+ -- Adjust error message count
+
+ if Errors.Table (D).Warn or Errors.Table (D).Style then
+ Warnings_Detected := Warnings_Detected - 1;
+ else
+ Total_Errors_Detected := Total_Errors_Detected - 1;
+
+ if Errors.Table (D).Serious then
+ Serious_Errors_Detected := Serious_Errors_Detected - 1;
+ end if;
+ end if;
+
+ -- Substitute shorter of the two error messages
+
+ if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
+ Errors.Table (K).Text := Errors.Table (D).Text;
+ end if;
+
+ D := Errors.Table (D).Next;
+ K := Errors.Table (K).Next;
+
+ if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
+ return;
+ end if;
+ end loop;
+ end Delete_Msg;
+
+ -- Start of processing for Check_Duplicate_Message
+
+ begin
+ -- Both messages must be non-continuation messages and not deleted
+
+ if Errors.Table (M1).Msg_Cont
+ or else Errors.Table (M2).Msg_Cont
+ or else Errors.Table (M1).Deleted
+ or else Errors.Table (M2).Deleted
+ then
+ return;
+ end if;
+
+ -- Definitely not equal if message text does not match
+
+ if not Same_Error (M1, M2) then
+ return;
+ end if;
+
+ -- Same text. See if all continuations are also identical
+
+ L1 := M1;
+ L2 := M2;
+
+ loop
+ N1 := Errors.Table (L1).Next;
+ N2 := Errors.Table (L2).Next;
+
+ -- If M1 continuations have run out, we delete M1, either the
+ -- messages have the same number of continuations, or M2 has
+ -- more and we prefer the one with more anyway.
+
+ if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
+ Delete_Msg (M1, M2);
+ return;
+
+ -- If M2 continuatins have run out, we delete M2
+
+ elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
+ Delete_Msg (M2, M1);
+ return;
+
+ -- Otherwise see if continuations are the same, if not, keep both
+ -- sequences, a curious case, but better to keep everything!
+
+ elsif not Same_Error (N1, N2) then
+ return;
+
+ -- If continuations are the same, continue scan
+
+ else
+ L1 := N1;
+ L2 := N2;
+ end if;
+ end loop;
+ end Check_Duplicate_Message;
+
+ ------------------------
+ -- Compilation_Errors --
+ ------------------------
+
+ function Compilation_Errors return Boolean is
+ begin
+ return Total_Errors_Detected /= 0
+ or else (Warnings_Detected /= 0
+ and then Warning_Mode = Treat_As_Error);
+ end Compilation_Errors;
+
+ ------------------
+ -- Debug_Output --
+ ------------------
+
+ procedure Debug_Output (N : Node_Id) is
+ begin
+ if Debug_Flag_1 then
+ Write_Str ("*** following error message posted on node id = #");
+ Write_Int (Int (N));
+ Write_Str (" ***");
+ Write_Eol;
+ end if;
+ end Debug_Output;
+
+ ----------
+ -- dmsg --
+ ----------
+
+ procedure dmsg (Id : Error_Msg_Id) is
+ E : Error_Msg_Object renames Errors.Table (Id);
+
+ begin
+ w ("Dumping error message, Id = ", Int (Id));
+ w (" Text = ", E.Text.all);
+ w (" Next = ", Int (E.Next));
+ w (" Sfile = ", Int (E.Sfile));
+
+ Write_Str
+ (" Sptr = ");
+ Write_Location (E.Sptr);
+ Write_Eol;
+
+ Write_Str
+ (" Optr = ");
+ Write_Location (E.Optr);
+ Write_Eol;
+
+ w (" Line = ", Int (E.Line));
+ w (" Col = ", Int (E.Col));
+ w (" Warn = ", E.Warn);
+ w (" Style = ", E.Style);
+ w (" Serious = ", E.Serious);
+ w (" Uncond = ", E.Uncond);
+ w (" Msg_Cont = ", E.Msg_Cont);
+ w (" Deleted = ", E.Deleted);
+
+ Write_Eol;
+ end dmsg;
+
+ ------------------
+ -- Get_Location --
+ ------------------
+
+ function Get_Location (E : Error_Msg_Id) return Source_Ptr is
+ begin
+ return Errors.Table (E).Sptr;
+ end Get_Location;
+
+ ----------------
+ -- Get_Msg_Id --
+ ----------------
+
+ function Get_Msg_Id return Error_Msg_Id is
+ begin
+ return Cur_Msg;
+ end Get_Msg_Id;
+
+ -----------------------
+ -- Output_Error_Msgs --
+ -----------------------
+
+ procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
+ P : Source_Ptr;
+ T : Error_Msg_Id;
+ S : Error_Msg_Id;
+
+ Flag_Num : Pos;
+ Mult_Flags : Boolean := False;
+
+ begin
+ S := E;
+
+ -- Skip deleted messages at start
+
+ if Errors.Table (S).Deleted then
+ Set_Next_Non_Deleted_Msg (S);
+ end if;
+
+ -- Figure out if we will place more than one error flag on this line
+
+ T := S;
+ while T /= No_Error_Msg
+ and then Errors.Table (T).Line = Errors.Table (E).Line
+ and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
+ loop
+ if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
+ Mult_Flags := True;
+ end if;
+
+ Set_Next_Non_Deleted_Msg (T);
+ end loop;
+
+ -- Output the error flags. The circuit here makes sure that the tab
+ -- characters in the original line are properly accounted for. The
+ -- eight blanks at the start are to match the line number.
+
+ if not Debug_Flag_2 then
+ Write_Str (" ");
+ P := Line_Start (Errors.Table (E).Sptr);
+ Flag_Num := 1;
+
+ -- Loop through error messages for this line to place flags
+
+ T := S;
+ while T /= No_Error_Msg
+ and then Errors.Table (T).Line = Errors.Table (E).Line
+ and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
+ loop
+ -- Loop to output blanks till current flag position
+
+ while P < Errors.Table (T).Sptr loop
+ if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
+ Write_Char (ASCII.HT);
+ else
+ Write_Char (' ');
+ end if;
+
+ P := P + 1;
+ end loop;
+
+ -- Output flag (unless already output, this happens if more
+ -- than one error message occurs at the same flag position).
+
+ if P = Errors.Table (T).Sptr then
+ if (Flag_Num = 1 and then not Mult_Flags)
+ or else Flag_Num > 9
+ then
+ Write_Char ('|');
+ else
+ Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
+ end if;
+
+ P := P + 1;
+ end if;
+
+ Set_Next_Non_Deleted_Msg (T);
+ Flag_Num := Flag_Num + 1;
+ end loop;
+
+ Write_Eol;
+ end if;
+
+ -- Now output the error messages
+
+ T := S;
+ while T /= No_Error_Msg
+ and then Errors.Table (T).Line = Errors.Table (E).Line
+ and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
+
+ loop
+ Write_Str (" >>> ");
+ Output_Msg_Text (T);
+
+ if Debug_Flag_2 then
+ while Column < 74 loop
+ Write_Char (' ');
+ end loop;
+
+ Write_Str (" <<<");
+ end if;
+
+ Write_Eol;
+ Set_Next_Non_Deleted_Msg (T);
+ end loop;
+
+ E := T;
+ end Output_Error_Msgs;
+
+ ------------------------
+ -- Output_Line_Number --
+ ------------------------
+
+ procedure Output_Line_Number (L : Logical_Line_Number) is
+ D : Int; -- next digit
+ C : Character; -- next character
+ Z : Boolean; -- flag for zero suppress
+ N, M : Int; -- temporaries
+
+ begin
+ if L = No_Line_Number then
+ Write_Str (" ");
+
+ else
+ Z := False;
+ N := Int (L);
+
+ M := 100_000;
+ while M /= 0 loop
+ D := Int (N / M);
+ N := N rem M;
+ M := M / 10;
+
+ if D = 0 then
+ if Z then
+ C := '0';
+ else
+ C := ' ';
+ end if;
+ else
+ Z := True;
+ C := Character'Val (D + 48);
+ end if;
+
+ Write_Char (C);
+ end loop;
+
+ Write_Str (". ");
+ end if;
+ end Output_Line_Number;
+
+ ---------------------
+ -- Output_Msg_Text --
+ ---------------------
+
+ procedure Output_Msg_Text (E : Error_Msg_Id) is
+ begin
+ if Errors.Table (E).Warn then
+ Write_Str ("warning: ");
+
+ elsif Errors.Table (E).Style then
+ null;
+
+ elsif Opt.Unique_Error_Tag then
+ Write_Str ("error: ");
+ end if;
+
+ Write_Str (Errors.Table (E).Text.all);
+ end Output_Msg_Text;
+
+ --------------------
+ -- Purge_Messages --
+ --------------------
+
+ procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
+ E : Error_Msg_Id;
+
+ function To_Be_Purged (E : Error_Msg_Id) return Boolean;
+ -- Returns True for a message that is to be purged. Also adjusts
+ -- error counts appropriately.
+
+ function To_Be_Purged (E : Error_Msg_Id) return Boolean is
+ begin
+ if E /= No_Error_Msg
+ and then Errors.Table (E).Sptr > From
+ and then Errors.Table (E).Sptr < To
+ then
+ if Errors.Table (E).Warn or Errors.Table (E).Style then
+ Warnings_Detected := Warnings_Detected - 1;
+ else
+ Total_Errors_Detected := Total_Errors_Detected - 1;
+
+ if Errors.Table (E).Serious then
+ Serious_Errors_Detected := Serious_Errors_Detected - 1;
+ end if;
+ end if;
+
+ return True;
+
+ else
+ return False;
+ end if;
+ end To_Be_Purged;
+
+ -- Start of processing for Purge_Messages
+
+ begin
+ while To_Be_Purged (First_Error_Msg) loop
+ First_Error_Msg := Errors.Table (First_Error_Msg).Next;
+ end loop;
+
+ E := First_Error_Msg;
+ while E /= No_Error_Msg loop
+ while To_Be_Purged (Errors.Table (E).Next) loop
+ Errors.Table (E).Next :=
+ Errors.Table (Errors.Table (E).Next).Next;
+ end loop;
+
+ E := Errors.Table (E).Next;
+ end loop;
+ end Purge_Messages;
+
+ ----------------
+ -- Same_Error --
+ ----------------
+
+ function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
+ Msg1 : constant String_Ptr := Errors.Table (M1).Text;
+ Msg2 : constant String_Ptr := Errors.Table (M2).Text;
+
+ Msg2_Len : constant Integer := Msg2'Length;
+ Msg1_Len : constant Integer := Msg1'Length;
+
+ begin
+ return
+ Msg1.all = Msg2.all
+ or else
+ (Msg1_Len - 10 > Msg2_Len
+ and then
+ Msg2.all = Msg1.all (1 .. Msg2_Len)
+ and then
+ Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
+ or else
+ (Msg2_Len - 10 > Msg1_Len
+ and then
+ Msg1.all = Msg2.all (1 .. Msg1_Len)
+ and then
+ Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
+ end Same_Error;
+
+ -------------------
+ -- Set_Msg_Blank --
+ -------------------
+
+ procedure Set_Msg_Blank is
+ begin
+ if Msglen > 0
+ and then Msg_Buffer (Msglen) /= ' '
+ and then Msg_Buffer (Msglen) /= '('
+ and then not Manual_Quote_Mode
+ then
+ Set_Msg_Char (' ');
+ end if;
+ end Set_Msg_Blank;
+
+ -------------------------------
+ -- Set_Msg_Blank_Conditional --
+ -------------------------------
+
+ procedure Set_Msg_Blank_Conditional is
+ begin
+ if Msglen > 0
+ and then Msg_Buffer (Msglen) /= ' '
+ and then Msg_Buffer (Msglen) /= '('
+ and then Msg_Buffer (Msglen) /= '"'
+ and then not Manual_Quote_Mode
+ then
+ Set_Msg_Char (' ');
+ end if;
+ end Set_Msg_Blank_Conditional;
+
+ ------------------
+ -- Set_Msg_Char --
+ ------------------
+
+ procedure Set_Msg_Char (C : Character) is
+ begin
+
+ -- The check for message buffer overflow is needed to deal with cases
+ -- where insertions get too long (in particular a child unit name can
+ -- be very long).
+
+ if Msglen < Max_Msg_Length then
+ Msglen := Msglen + 1;
+ Msg_Buffer (Msglen) := C;
+ end if;
+ end Set_Msg_Char;
+
+ ---------------------------------
+ -- Set_Msg_Insertion_File_Name --
+ ---------------------------------
+
+ procedure Set_Msg_Insertion_File_Name is
+ begin
+ if Error_Msg_Name_1 = No_Name then
+ null;
+
+ elsif Error_Msg_Name_1 = Error_Name then
+ Set_Msg_Blank;
+ Set_Msg_Str ("<error>");
+
+ else
+ Set_Msg_Blank;
+ Get_Name_String (Error_Msg_Name_1);
+ Set_Msg_Quote;
+ Set_Msg_Name_Buffer;
+ Set_Msg_Quote;
+ end if;
+
+ -- The following assignments ensure that the second and third percent
+ -- insertion characters will correspond to the Error_Msg_Name_2 and
+ -- Error_Msg_Name_3 as required.
+
+ Error_Msg_Name_1 := Error_Msg_Name_2;
+ Error_Msg_Name_2 := Error_Msg_Name_3;
+ end Set_Msg_Insertion_File_Name;
+
+ -----------------------------------
+ -- Set_Msg_Insertion_Line_Number --
+ -----------------------------------
+
+ procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
+ Sindex_Loc : Source_File_Index;
+ Sindex_Flag : Source_File_Index;
+
+ begin
+ Set_Msg_Blank;
+
+ if Loc = No_Location then
+ Set_Msg_Str ("at unknown location");
+
+ elsif Loc = System_Location then
+ Set_Msg_Str ("in package System");
+ Set_Msg_Insertion_Run_Time_Name;
+
+ elsif Loc = Standard_Location then
+ Set_Msg_Str ("in package Standard");
+
+ elsif Loc = Standard_ASCII_Location then
+ Set_Msg_Str ("in package Standard.ASCII");
+
+ else
+ -- Add "at file-name:" if reference is to other than the source
+ -- file in which the error message is placed. Note that we check
+ -- full file names, rather than just the source indexes, to
+ -- deal with generic instantiations from the current file.
+
+ Sindex_Loc := Get_Source_File_Index (Loc);
+ Sindex_Flag := Get_Source_File_Index (Flag);
+
+ if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
+ Set_Msg_Str ("at ");
+ Get_Name_String
+ (Reference_Name (Get_Source_File_Index (Loc)));
+ Set_Msg_Name_Buffer;
+ Set_Msg_Char (':');
+
+ -- If in current file, add text "at line "
+
+ else
+ Set_Msg_Str ("at line ");
+ end if;
+
+ -- Output line number for reference
+
+ Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
+
+ -- Deal with the instantiation case. We may have a reference to,
+ -- e.g. a type, that is declared within a generic template, and
+ -- what we are really referring to is the occurrence in an instance.
+ -- In this case, the line number of the instantiation is also of
+ -- interest, and we add a notation:
+
+ -- , instance at xxx
+
+ -- where xxx is a line number output using this same routine (and
+ -- the recursion can go further if the instantiation is itself in
+ -- a generic template).
+
+ -- The flag location passed to us in this situation is indeed the
+ -- line number within the template, but as described in Sinput.L
+ -- (file sinput-l.ads, section "Handling Generic Instantiations")
+ -- we can retrieve the location of the instantiation itself from
+ -- this flag location value.
+
+ -- Note: this processing is suppressed if Suppress_Instance_Location
+ -- is set True. This is used to prevent redundant annotations of the
+ -- location of the instantiation in the case where we are placing
+ -- the messages on the instantiation in any case.
+
+ if Instantiation (Sindex_Loc) /= No_Location
+ and then not Suppress_Instance_Location
+ then
+ Set_Msg_Str (", instance ");
+ Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
+ end if;
+ end if;
+ end Set_Msg_Insertion_Line_Number;
+
+ ----------------------------
+ -- Set_Msg_Insertion_Name --
+ ----------------------------
+
+ procedure Set_Msg_Insertion_Name is
+ begin
+ if Error_Msg_Name_1 = No_Name then
+ null;
+
+ elsif Error_Msg_Name_1 = Error_Name then
+ Set_Msg_Blank;
+ Set_Msg_Str ("<error>");
+
+ else
+ Set_Msg_Blank_Conditional;
+ Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
+
+ -- Remove %s or %b at end. These come from unit names. If the
+ -- caller wanted the (unit) or (body), then they would have used
+ -- the $ insertion character. Certainly no error message should
+ -- ever have %b or %s explicitly occurring.
+
+ if Name_Len > 2
+ and then Name_Buffer (Name_Len - 1) = '%'
+ and then (Name_Buffer (Name_Len) = 'b'
+ or else
+ Name_Buffer (Name_Len) = 's')
+ then
+ Name_Len := Name_Len - 2;
+ end if;
+
+ -- Remove upper case letter at end, again, we should not be getting
+ -- such names, and what we hope is that the remainder makes sense.
+
+ if Name_Len > 1
+ and then Name_Buffer (Name_Len) in 'A' .. 'Z'
+ then
+ Name_Len := Name_Len - 1;
+ end if;
+
+ -- If operator name or character literal name, just print it as is
+ -- Also print as is if it ends in a right paren (case of x'val(nnn))
+
+ if Name_Buffer (1) = '"'
+ or else Name_Buffer (1) = '''
+ or else Name_Buffer (Name_Len) = ')'
+ then
+ Set_Msg_Name_Buffer;
+
+ -- Else output with surrounding quotes in proper casing mode
+
+ else
+ Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
+ Set_Msg_Quote;
+ Set_Msg_Name_Buffer;
+ Set_Msg_Quote;
+ end if;
+ end if;
+
+ -- The following assignments ensure that the second and third percent
+ -- insertion characters will correspond to the Error_Msg_Name_2 and
+ -- Error_Msg_Name_3 as required.
+
+ Error_Msg_Name_1 := Error_Msg_Name_2;
+ Error_Msg_Name_2 := Error_Msg_Name_3;
+ end Set_Msg_Insertion_Name;
+
+ -------------------------------------
+ -- Set_Msg_Insertion_Reserved_Name --
+ -------------------------------------
+
+ procedure Set_Msg_Insertion_Reserved_Name is
+ begin
+ Set_Msg_Blank_Conditional;
+ Get_Name_String (Error_Msg_Name_1);
+ Set_Msg_Quote;
+ Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
+ Set_Msg_Name_Buffer;
+ Set_Msg_Quote;
+ end Set_Msg_Insertion_Reserved_Name;
+
+ -------------------------------------
+ -- Set_Msg_Insertion_Reserved_Word --
+ -------------------------------------
+
+ procedure Set_Msg_Insertion_Reserved_Word
+ (Text : String;
+ J : in out Integer)
+ is
+ begin
+ Set_Msg_Blank_Conditional;
+ Name_Len := 0;
+
+ while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Text (J);
+ J := J + 1;
+ end loop;
+
+ Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
+ Set_Msg_Quote;
+ Set_Msg_Name_Buffer;
+ Set_Msg_Quote;
+ end Set_Msg_Insertion_Reserved_Word;
+
+ -------------------------------------
+ -- Set_Msg_Insertion_Run_Time_Name --
+ -------------------------------------
+
+ procedure Set_Msg_Insertion_Run_Time_Name is
+ begin
+ if Targparm.Run_Time_Name_On_Target /= No_Name then
+ Set_Msg_Blank_Conditional;
+ Set_Msg_Char ('(');
+ Get_Name_String (Targparm.Run_Time_Name_On_Target);
+ Set_Casing (Mixed_Case);
+ Set_Msg_Str (Name_Buffer (1 .. Name_Len));
+ Set_Msg_Char (')');
+ end if;
+ end Set_Msg_Insertion_Run_Time_Name;
+
+ ----------------------------
+ -- Set_Msg_Insertion_Uint --
+ ----------------------------
+
+ procedure Set_Msg_Insertion_Uint is
+ begin
+ Set_Msg_Blank;
+ UI_Image (Error_Msg_Uint_1);
+
+ for J in 1 .. UI_Image_Length loop
+ Set_Msg_Char (UI_Image_Buffer (J));
+ end loop;
+
+ -- The following assignment ensures that a second carret insertion
+ -- character will correspond to the Error_Msg_Uint_2 parameter.
+
+ Error_Msg_Uint_1 := Error_Msg_Uint_2;
+ end Set_Msg_Insertion_Uint;
+
+ -----------------
+ -- Set_Msg_Int --
+ -----------------
+
+ procedure Set_Msg_Int (Line : Int) is
+ begin
+ if Line > 9 then
+ Set_Msg_Int (Line / 10);
+ end if;
+
+ Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
+ end Set_Msg_Int;
+
+ -------------------------
+ -- Set_Msg_Name_Buffer --
+ -------------------------
+
+ procedure Set_Msg_Name_Buffer is
+ begin
+ for J in 1 .. Name_Len loop
+ Set_Msg_Char (Name_Buffer (J));
+ end loop;
+ end Set_Msg_Name_Buffer;
+
+ -------------------
+ -- Set_Msg_Quote --
+ -------------------
+
+ procedure Set_Msg_Quote is
+ begin
+ if not Manual_Quote_Mode then
+ Set_Msg_Char ('"');
+ end if;
+ end Set_Msg_Quote;
+
+ -----------------
+ -- Set_Msg_Str --
+ -----------------
+
+ procedure Set_Msg_Str (Text : String) is
+ begin
+ for J in Text'Range loop
+ Set_Msg_Char (Text (J));
+ end loop;
+ end Set_Msg_Str;
+
+ ------------------------------
+ -- Set_Next_Non_Deleted_Msg --
+ ------------------------------
+
+ procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
+ begin
+ if E = No_Error_Msg then
+ return;
+
+ else
+ loop
+ E := Errors.Table (E).Next;
+ exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
+ end loop;
+ end if;
+ end Set_Next_Non_Deleted_Msg;
+
+ ---------------------------
+ -- Set_Warnings_Mode_Off --
+ ---------------------------
+
+ procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
+ begin
+ -- Don't bother with entries from instantiation copies, since we
+ -- will already have a copy in the template, which is what matters
+
+ if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
+ return;
+ end if;
+
+ -- If last entry in table already covers us, this is a redundant
+ -- pragma Warnings (Off) and can be ignored. This also handles the
+ -- case where all warnings are suppressed by command line switch.
+
+ if Warnings.Last >= Warnings.First
+ and then Warnings.Table (Warnings.Last).Start <= Loc
+ and then Loc <= Warnings.Table (Warnings.Last).Stop
+ then
+ return;
+
+ -- Otherwise establish a new entry, extending from the location of
+ -- the pragma to the end of the current source file. This ending
+ -- point will be adjusted by a subsequent pragma Warnings (On).
+
+ else
+ Warnings.Increment_Last;
+ Warnings.Table (Warnings.Last).Start := Loc;
+ Warnings.Table (Warnings.Last).Stop :=
+ Source_Last (Current_Source_File);
+ end if;
+ end Set_Warnings_Mode_Off;
+
+ --------------------------
+ -- Set_Warnings_Mode_On --
+ --------------------------
+
+ procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
+ begin
+ -- Don't bother with entries from instantiation copies, since we
+ -- will already have a copy in the template, which is what matters
+
+ if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
+ return;
+ end if;
+
+ -- Nothing to do unless command line switch to suppress all warnings
+ -- is off, and the last entry in the warnings table covers this
+ -- pragma Warnings (On), in which case adjust the end point.
+
+ if (Warnings.Last >= Warnings.First
+ and then Warnings.Table (Warnings.Last).Start <= Loc
+ and then Loc <= Warnings.Table (Warnings.Last).Stop)
+ and then Warning_Mode /= Suppress
+ then
+ Warnings.Table (Warnings.Last).Stop := Loc;
+ end if;
+ end Set_Warnings_Mode_On;
+
+ ------------------------------------
+ -- Test_Style_Warning_Serious_Msg --
+ ------------------------------------
+
+ procedure Test_Style_Warning_Serious_Msg (Msg : String) is
+ begin
+ if Msg (Msg'First) = '\' then
+ return;
+ end if;
+
+ Is_Serious_Error := True;
+ Is_Warning_Msg := False;
+
+ Is_Style_Msg :=
+ (Msg'Length > 7
+ and then Msg (Msg'First .. Msg'First + 6) = "(style)");
+
+ for J in Msg'Range loop
+ if Msg (J) = '?'
+ and then (J = Msg'First or else Msg (J - 1) /= ''')
+ then
+ Is_Warning_Msg := True;
+
+ elsif Msg (J) = '|'
+ and then (J = Msg'First or else Msg (J - 1) /= ''')
+ then
+ Is_Serious_Error := False;
+ end if;
+ end loop;
+
+ if Is_Warning_Msg or else Is_Style_Msg then
+ Is_Serious_Error := False;
+ end if;
+ end Test_Style_Warning_Serious_Msg;
+
+ -------------------------
+ -- Warnings_Suppressed --
+ -------------------------
+
+ function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
+ begin
+ for J in Warnings.First .. Warnings.Last loop
+ if Warnings.Table (J).Start <= Loc
+ and then Loc <= Warnings.Table (J).Stop
+ then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end Warnings_Suppressed;
+
+end Erroutc;
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
new file mode 100644
index 00000000000..25b934b3528
--- /dev/null
+++ b/gcc/ada/erroutc.ads
@@ -0,0 +1,398 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- E R R O U T C --
+-- --
+-- S p e c --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This packages contains global variables and routines common to error
+-- reporting packages, including Errout and Prj.Err.
+
+with Hostparm;
+with Table;
+with Types; use Types;
+
+package Erroutc is
+
+ Class_Flag : Boolean := False;
+ -- This flag is set True when outputting a reference to a class-wide
+ -- type, and is used by Add_Class to insert 'Class at the proper point
+
+ Continuation : Boolean := False;
+ -- Indicates if current message is a continuation. Intialized from the
+ -- Msg_Cont parameter in Error_Msg_Internal and then set True if a \
+ -- insertion character is encountered.
+
+ Flag_Source : Source_File_Index;
+ -- Source file index for source file where error is being posted
+
+ Is_Warning_Msg : Boolean := False;
+ -- Set True to indicate if current message is warning message
+
+ Is_Style_Msg : Boolean := False;
+ -- Set True to indicate if the current message is a style message
+
+ Is_Serious_Error : Boolean := False;
+ -- Set by Set_Msg_Text to indicate if current message is serious error
+
+ Is_Unconditional_Msg : Boolean := False;
+ -- Set by Set_Msg_Text to indicate if current message is unconditional
+
+ Kill_Message : Boolean := False;
+ -- A flag used to kill weird messages (e.g. those containing uninterpreted
+ -- implicit type references) if we have already seen at least one message
+ -- already. The idea is that we hope the weird message is a junk cascaded
+ -- message that should be suppressed.
+
+ Last_Killed : Boolean := False;
+ -- Set True if the most recently posted non-continuation message was
+ -- killed. This is used to determine the processing of any continuation
+ -- messages that follow.
+
+ List_Pragmas_Index : Int := 0;
+ -- Index into List_Pragmas table
+
+ List_Pragmas_Mode : Boolean := False;
+ -- Starts True, gets set False by pragma List (Off), True by List (On)
+
+ Manual_Quote_Mode : Boolean := False;
+ -- Set True in manual quotation mode
+
+ Max_Msg_Length : constant := 80 + 2 * Hostparm.Max_Line_Length;
+ -- Maximum length of error message. The addition of Max_Line_Length
+ -- ensures that two insertion tokens of maximum length can be accomodated.
+
+ Msg_Buffer : String (1 .. Max_Msg_Length);
+ -- Buffer used to prepare error messages
+
+ Msglen : Integer := 0;
+ -- Number of characters currently stored in the message buffer
+
+ Suppress_Message : Boolean;
+ -- A flag used to suppress certain obviously redundant messages (i.e.
+ -- those referring to a node whose type is Any_Type). This suppression
+ -- is effective only if All_Errors_Mode is off.
+
+ Suppress_Instance_Location : Boolean := False;
+ -- Normally, if a # location in a message references a location within
+ -- a generic template, then a note is added giving the location of the
+ -- instantiation. If this variable is set True, then this note is not
+ -- output. This is used for internal processing for the case of an
+ -- illegal instantiation. See Error_Msg routine for further details.
+
+ ----------------------------
+ -- Message ID Definitions --
+ ----------------------------
+
+ type Error_Msg_Id is new Int;
+ -- A type used to represent specific error messages. Used by the clients
+ -- of this package only in the context of the Get_Error_Id and
+ -- Change_Error_Text subprograms.
+
+ No_Error_Msg : constant Error_Msg_Id := 0;
+ -- A constant which is different from any value returned by Get_Error_Id.
+ -- Typically used by a client to indicate absense of a saved Id value.
+
+ Cur_Msg : Error_Msg_Id := No_Error_Msg;
+ -- Id of most recently posted error message
+
+ function Get_Msg_Id return Error_Msg_Id;
+ -- Returns the Id of the message most recently posted using one of the
+ -- Error_Msg routines.
+
+ function Get_Location (E : Error_Msg_Id) return Source_Ptr;
+ -- Returns the flag location of the error message with the given id E.
+
+ -----------------------------------
+ -- Error Message Data Structures --
+ -----------------------------------
+
+ -- The error messages are stored as a linked list of error message objects
+ -- sorted into ascending order by the source location (Sloc). Each object
+ -- records the text of the message and its source location.
+
+ -- The following record type and table are used to represent error
+ -- messages, with one entry in the table being allocated for each message.
+
+ type Error_Msg_Object is record
+ Text : String_Ptr;
+ -- Text of error message, fully expanded with all insertions
+
+ Next : Error_Msg_Id;
+ -- Pointer to next message in error chain
+
+ Sfile : Source_File_Index;
+ -- Source table index of source file. In the case of an error that
+ -- refers to a template, always references the original template
+ -- not an instantiation copy.
+
+ Sptr : Source_Ptr;
+ -- Flag pointer. In the case of an error that refers to a template,
+ -- always references the original template, not an instantiation copy.
+ -- This value is the actual place in the source that the error message
+ -- will be posted. Note that an error placed on an instantiation will
+ -- have Sptr pointing to the instantiation point.
+
+ Optr : Source_Ptr;
+ -- Flag location used in the call to post the error. This is normally
+ -- the same as Sptr, except when an error is posted on a particular
+ -- instantiation of a generic. In such a case, Sptr will point to
+ -- the original source location of the instantiation itself, but
+ -- Optr will point to the template location (more accurately to the
+ -- template copy in the instantiation copy corresponding to the
+ -- instantiation referenced by Sptr).
+
+ Line : Physical_Line_Number;
+ -- Line number for error message
+
+ Col : Column_Number;
+ -- Column number for error message
+
+ Warn : Boolean;
+ -- True if warning message (i.e. insertion character ? appeared)
+
+ Style : Boolean;
+ -- True if style message (starts with "(style)")
+
+ Serious : Boolean;
+ -- True if serious error message (not a warning and no | character)
+
+ Uncond : Boolean;
+ -- True if unconditional message (i.e. insertion character ! appeared)
+
+ Msg_Cont : Boolean;
+ -- This is used for logical messages that are composed of multiple
+ -- individual messages. For messages that are not part of such a
+ -- group, or that are the first message in such a group. Msg_Cont
+ -- is set to False. For subsequent messages in a group, Msg_Cont
+ -- is set to True. This is used to make sure that such a group of
+ -- messages is either suppressed or retained as a group (e.g. in
+ -- the circuit that deletes identical messages).
+
+ Deleted : Boolean;
+ -- If this flag is set, the message is not printed. This is used
+ -- in the circuit for deleting duplicate/redundant error messages.
+ end record;
+
+ package Errors is new Table.Table (
+ Table_Component_Type => Error_Msg_Object,
+ Table_Index_Type => Error_Msg_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 200,
+ Table_Increment => 200,
+ Table_Name => "Error");
+
+ First_Error_Msg : Error_Msg_Id;
+ -- The list of error messages, i.e. the first entry on the list of error
+ -- messages. This is not the same as the physically first entry in the
+ -- error message table, since messages are not always inserted in sequence.
+
+ Last_Error_Msg : Error_Msg_Id;
+ -- The last entry on the list of error messages. Note that this is not
+ -- the same as the physically last entry in the error message table, since
+ -- messages are not always inserted in sequence.
+
+ --------------------------
+ -- Warning Mode Control --
+ --------------------------
+
+ -- Pragma Warnings allows warnings to be turned off for a specified
+ -- region of code, and the following tabl is the data structure used
+ -- to keep track of these regions.
+
+ -- It contains pairs of source locations, the first being the start
+ -- location for a warnings off region, and the second being the end
+ -- location. When a pragma Warnings (Off) is encountered, a new entry
+ -- is established extending from the location of the pragma to the
+ -- end of the current source file. A subsequent pragma Warnings (On)
+ -- adjusts the end point of this entry appropriately.
+
+ -- If all warnings are suppressed by comamnd switch, then there is a
+ -- dummy entry (put there by Errout.Initialize) at the start of the
+ -- table which covers all possible Source_Ptr values. Note that the
+ -- source pointer values in this table always reference the original
+ -- template, not an instantiation copy, in the generic case.
+
+ type Warnings_Entry is record
+ Start : Source_Ptr;
+ Stop : Source_Ptr;
+ end record;
+
+ package Warnings is new Table.Table (
+ Table_Component_Type => Warnings_Entry,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "Warnings");
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Add_Class;
+ -- Add 'Class to buffer for class wide type case (Class_Flag set)
+
+ function Buffer_Ends_With (S : String) return Boolean;
+ -- Tests if message buffer ends with given string preceded by a space
+
+ procedure Buffer_Remove (S : String);
+ -- Removes given string from end of buffer if it is present
+ -- at end of buffer, and preceded by a space.
+
+ function Compilation_Errors return Boolean;
+ -- Returns true if errors have been detected, or warnings in -gnatwe
+ -- (treat warnings as errors) mode.
+
+ procedure dmsg (Id : Error_Msg_Id);
+ -- Debugging routine to dump an error message
+
+ procedure Debug_Output (N : Node_Id);
+ -- Called from Error_Msg_N and Error_Msg_NE to generate line of debug
+ -- output giving node number (of node N) if the debug X switch is set.
+
+ procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id);
+ -- This function is passed the Id values of two error messages. If
+ -- either M1 or M2 is a continuation message, or is already deleted,
+ -- the call is ignored. Otherwise a check is made to see if M1 and M2
+ -- are duplicated or redundant. If so, the message to be deleted and
+ -- all its continuations are marked with the Deleted flag set to True.
+
+ procedure Output_Error_Msgs (E : in out Error_Msg_Id);
+ -- Output source line, error flag, and text of stored error message and
+ -- all subsequent messages for the same line and unit. On return E is
+ -- set to be one higher than the last message output.
+
+ procedure Output_Line_Number (L : Logical_Line_Number);
+ -- Output a line number as six digits (with leading zeroes suppressed),
+ -- followed by a period and a blank (note that this is 8 characters which
+ -- means that tabs in the source line will not get messed up). Line numbers
+ -- that match or are less than the last Source_Reference pragma are listed
+ -- as all blanks, avoiding output of junk line numbers.
+
+ procedure Output_Msg_Text (E : Error_Msg_Id);
+ -- Outputs characters of text in the text of the error message E, excluding
+ -- any final exclamation point. Note that no end of line is output, the
+ -- caller is responsible for adding the end of line.
+
+ procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr);
+ -- All error messages whose location is in the range From .. To (not
+ -- including the end points) will be deleted from the error listing.
+
+ function Same_Error (M1, M2 : Error_Msg_Id) return Boolean;
+ -- See if two messages have the same text. Returns true if the text
+ -- of the two messages is identical, or if one of them is the same
+ -- as the other with an appended "instance at xxx" tag.
+
+ procedure Set_Msg_Blank;
+ -- Sets a single blank in the message if the preceding character is a
+ -- non-blank character other than a left parenthesis. Has no effect if
+ -- manual quote mode is turned on.
+
+ procedure Set_Msg_Blank_Conditional;
+ -- Sets a single blank in the message if the preceding character is a
+ -- non-blank character other than a left parenthesis or quote. Has no
+ -- effect if manual quote mode is turned on.
+
+ procedure Set_Msg_Char (C : Character);
+ -- Add a single character to the current message. This routine does not
+ -- check for special insertion characters (they are just treated as text
+ -- characters if they occur).
+
+ procedure Set_Msg_Insertion_File_Name;
+ -- Handle file name insertion (left brace insertion character)
+
+ procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr);
+ -- Handle line number insertion (# insertion character). Loc is the
+ -- location to be referenced, and Flag is the location at which the
+ -- flag is posted (used to determine whether to add "in file xxx")
+
+ procedure Set_Msg_Insertion_Name;
+ -- Handle name insertion (% insertion character)
+
+ procedure Set_Msg_Insertion_Reserved_Name;
+ -- Handle insertion of reserved word name (* insertion character).
+
+ procedure Set_Msg_Insertion_Reserved_Word
+ (Text : String;
+ J : in out Integer);
+ -- Handle reserved word insertion (upper case letters). The Text argument
+ -- is the current error message input text, and J is an index which on
+ -- entry points to the first character of the reserved word, and on exit
+ -- points past the last character of the reserved word.
+
+ procedure Set_Msg_Insertion_Run_Time_Name;
+ -- If package System contains a definition for Run_Time_Name (see package
+ -- Targparm for details), then this procedure will insert a message of
+ -- the form (name) into the current error message, with name set in mixed
+ -- case (upper case after any spaces). If no run time name is defined,
+ -- then this routine has no effect).
+
+ procedure Set_Msg_Insertion_Uint;
+ -- Handle Uint insertion (^ insertion character)
+
+ procedure Set_Msg_Int (Line : Int);
+ -- Set the decimal representation of the argument in the error message
+ -- buffer with no leading zeroes output.
+
+ procedure Set_Msg_Name_Buffer;
+ -- Output name from Name_Buffer, with surrounding quotes unless manual
+ -- quotation mode is in effect.
+
+ procedure Set_Msg_Quote;
+ -- Set quote if in normal quote mode, nothing if in manual quote mode
+
+ procedure Set_Msg_Str (Text : String);
+ -- Add a sequence of characters to the current message. This routine does
+ -- not check for special insertion characters (they are just treated as
+ -- text characters if they occur).
+
+ procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id);
+ -- Given a message id, move to next message id, but skip any deleted
+ -- messages, so that this results in E on output being the first non-
+ -- deleted message following the input value of E, or No_Error_Msg if
+ -- the input value of E was either already No_Error_Msg, or was the
+ -- last non-deleted message.
+
+ procedure Set_Warnings_Mode_Off (Loc : Source_Ptr);
+ -- Called in response to a pragma Warnings (Off) to record the source
+ -- location from which warnings are to be turned off.
+
+ procedure Set_Warnings_Mode_On (Loc : Source_Ptr);
+ -- Called in response to a pragma Warnings (On) to record the source
+ -- location from which warnings are to be turned back on.
+
+ procedure Test_Style_Warning_Serious_Msg (Msg : String);
+ -- Sets Is_Warning_Msg true if Msg is a warning message (contains a
+ -- question mark character), and False otherwise. Sets Is_Style_Msg
+ -- true if Msg is a style message (starts with "(style)"). Sets
+ -- Is_Serious_Error True unless the message is a warning or style
+ -- message or contains the character | indicating a non-serious
+ -- error message. Note that the call has no effect for continuation
+ -- messages (those whose first character is \).
+
+ function Warnings_Suppressed (Loc : Source_Ptr) return Boolean;
+ -- Determines if given location is covered by a warnings off suppression
+ -- range in the warnings table (or is suppressed by compilation option,
+ -- which generates a warning range for the whole source file).
+
+end Erroutc;
diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb
new file mode 100644
index 00000000000..855d464add9
--- /dev/null
+++ b/gcc/ada/errutil.adb
@@ -0,0 +1,744 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- E R R U T I L --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1991-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Err_Vars; use Err_Vars;
+with Erroutc; use Erroutc;
+with Namet; use Namet;
+with Opt; use Opt;
+with Output; use Output;
+with Scans; use Scans;
+with Sinput; use Sinput;
+
+package body Errutil is
+
+ Errors_Must_Be_Ignored : Boolean := False;
+ -- Set to True by procedure Set_Ignore_Errors (True), when calls to
+ -- error message procedures should be ignored (when parsing irrelevant
+ -- text in sources being preprocessed).
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Error_Msg_AP (Msg : String);
+ -- Output a message just after the previous token.
+
+ procedure Output_Source_Line
+ (L : Physical_Line_Number;
+ Sfile : Source_File_Index;
+ Errs : Boolean;
+ Source_Type : String);
+ -- Outputs text of source line L, in file S, together with preceding line
+ -- number, as described above for Output_Line_Number. The Errs parameter
+ -- indicates if there are errors attached to the line, which forces
+ -- listing on, even in the presence of pragma List (Off).
+
+ procedure Set_Msg_Insertion_Column;
+ -- Handle column number insertion (@ insertion character)
+
+ procedure Set_Msg_Text (Text : String; Flag : Source_Ptr);
+ -- Add a sequence of characters to the current message. The characters may
+ -- be one of the special insertion characters (see documentation in spec).
+ -- Flag is the location at which the error is to be posted, which is used
+ -- to determine whether or not the # insertion needs a file name. The
+ -- variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and
+ -- Is_Unconditional_Msg are set on return.
+
+ ------------------
+ -- Error_Msg_AP --
+ ------------------
+
+ procedure Error_Msg_AP (Msg : String) is
+ S1 : Source_Ptr;
+ C : Character;
+
+ begin
+ -- If we had saved the Scan_Ptr value after scanning the previous
+ -- token, then we would have exactly the right place for putting
+ -- the flag immediately at hand. However, that would add at least
+ -- two instructions to a Scan call *just* to service the possibility
+ -- of an Error_Msg_AP call. So instead we reconstruct that value.
+
+ -- We have two possibilities, start with Prev_Token_Ptr and skip over
+ -- the current token, which is made harder by the possibility that this
+ -- token may be in error, or start with Token_Ptr and work backwards.
+ -- We used to take the second approach, but it's hard because of
+ -- comments, and harder still because things that look like comments
+ -- can appear inside strings. So now we take the first approach.
+
+ -- Note: in the case where there is no previous token, Prev_Token_Ptr
+ -- is set to Source_First, which is a reasonable position for the
+ -- error flag in this situation.
+
+ S1 := Prev_Token_Ptr;
+ C := Source (S1);
+
+ -- If the previous token is a string literal, we need a special approach
+ -- since there may be white space inside the literal and we don't want
+ -- to stop on that white space.
+
+ if Prev_Token = Tok_String_Literal then
+ loop
+ S1 := S1 + 1;
+
+ if Source (S1) = C then
+ S1 := S1 + 1;
+ exit when Source (S1) /= C;
+ elsif Source (S1) in Line_Terminator then
+ exit;
+ end if;
+ end loop;
+
+ -- Character literal also needs special handling
+
+ elsif Prev_Token = Tok_Char_Literal then
+ S1 := S1 + 3;
+
+ -- Otherwise we search forward for the end of the current token, marked
+ -- by a line terminator, white space, a comment symbol or if we bump
+ -- into the following token (i.e. the current token)
+
+ else
+ while Source (S1) not in Line_Terminator
+ and then Source (S1) /= ' '
+ and then Source (S1) /= ASCII.HT
+ and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-')
+ and then S1 /= Token_Ptr
+ loop
+ S1 := S1 + 1;
+ end loop;
+ end if;
+
+ -- S1 is now set to the location for the flag
+
+ Error_Msg (Msg, S1);
+
+ end Error_Msg_AP;
+
+ ---------------
+ -- Error_Msg --
+ ---------------
+
+ procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
+
+ Next_Msg : Error_Msg_Id;
+ -- Pointer to next message at insertion point
+
+ Prev_Msg : Error_Msg_Id;
+ -- Pointer to previous message at insertion point
+
+ Sptr : Source_Ptr renames Flag_Location;
+ -- Corresponds to the Sptr value in the error message object
+
+ Optr : Source_Ptr renames Flag_Location;
+ -- Corresponds to the Optr value in the error message object. Note
+ -- that for this usage, Sptr and Optr always have the same value,
+ -- since we do not have to worry about generic instantiations.
+
+ begin
+ if Errors_Must_Be_Ignored then
+ return;
+ end if;
+
+ if Raise_Exception_On_Error /= 0 then
+ raise Error_Msg_Exception;
+ end if;
+
+ Test_Style_Warning_Serious_Msg (Msg);
+ Set_Msg_Text (Msg, Sptr);
+
+ -- Kill continuation if parent message killed
+
+ if Continuation and Last_Killed then
+ return;
+ end if;
+
+ -- Return without doing anything if message is killed and this
+ -- is not the first error message. The philosophy is that if we
+ -- get a weird error message and we already have had a message,
+ -- then we hope the weird message is a junk cascaded message
+
+ -- Immediate return if warning message and warnings are suppressed
+ -- Note that style messages are not warnings for this purpose.
+
+ if Is_Warning_Msg and then Warnings_Suppressed (Sptr) then
+ Cur_Msg := No_Error_Msg;
+ return;
+ end if;
+
+ -- Otherwise build error message object for new message
+
+ Errors.Increment_Last;
+ Cur_Msg := Errors.Last;
+ Errors.Table (Cur_Msg).Text := new String'(Msg_Buffer (1 .. Msglen));
+ Errors.Table (Cur_Msg).Next := No_Error_Msg;
+ Errors.Table (Cur_Msg).Sptr := Sptr;
+ Errors.Table (Cur_Msg).Optr := Optr;
+ Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Sptr);
+ Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Sptr);
+ Errors.Table (Cur_Msg).Col := Get_Column_Number (Sptr);
+ Errors.Table (Cur_Msg).Style := Is_Style_Msg;
+ Errors.Table (Cur_Msg).Warn := Is_Warning_Msg;
+ Errors.Table (Cur_Msg).Serious := Is_Serious_Error;
+ Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg;
+ Errors.Table (Cur_Msg).Msg_Cont := Continuation;
+ Errors.Table (Cur_Msg).Deleted := False;
+
+ Prev_Msg := No_Error_Msg;
+ Next_Msg := First_Error_Msg;
+
+ while Next_Msg /= No_Error_Msg loop
+ exit when
+ Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
+
+ if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile then
+ exit when Sptr < Errors.Table (Next_Msg).Sptr;
+ end if;
+
+ Prev_Msg := Next_Msg;
+ Next_Msg := Errors.Table (Next_Msg).Next;
+ end loop;
+
+ -- Now we insert the new message in the error chain. The insertion
+ -- point for the message is after Prev_Msg and before Next_Msg.
+
+ -- The possible insertion point for the new message is after Prev_Msg
+ -- and before Next_Msg. However, this is where we do a special check
+ -- for redundant parsing messages, defined as messages posted on the
+ -- same line. The idea here is that probably such messages are junk
+ -- from the parser recovering. In full errors mode, we don't do this
+ -- deletion, but otherwise such messages are discarded at this stage.
+
+ if Prev_Msg /= No_Error_Msg
+ and then Errors.Table (Prev_Msg).Line =
+ Errors.Table (Cur_Msg).Line
+ and then Errors.Table (Prev_Msg).Sfile =
+ Errors.Table (Cur_Msg).Sfile
+ then
+ -- Don't delete unconditional messages and at this stage,
+ -- don't delete continuation lines (we attempted to delete
+ -- those earlier if the parent message was deleted.
+
+ if not Errors.Table (Cur_Msg).Uncond
+ and then not Continuation
+ then
+
+ -- Don't delete if prev msg is warning and new msg is
+ -- an error. This is because we don't want a real error
+ -- masked by a warning. In all other cases (that is parse
+ -- errors for the same line that are not unconditional)
+ -- we do delete the message. This helps to avoid
+ -- junk extra messages from cascaded parsing errors
+
+ if not (Errors.Table (Prev_Msg).Warn
+ or
+ Errors.Table (Prev_Msg).Style)
+ or else
+ (Errors.Table (Cur_Msg).Warn
+ or
+ Errors.Table (Cur_Msg).Style)
+ then
+ -- All tests passed, delete the message by simply
+ -- returning without any further processing.
+
+ if not Continuation then
+ Last_Killed := True;
+ end if;
+
+ return;
+ end if;
+ end if;
+ end if;
+
+ -- Come here if message is to be inserted in the error chain
+
+ if not Continuation then
+ Last_Killed := False;
+ end if;
+
+ if Prev_Msg = No_Error_Msg then
+ First_Error_Msg := Cur_Msg;
+ else
+ Errors.Table (Prev_Msg).Next := Cur_Msg;
+ end if;
+
+ Errors.Table (Cur_Msg).Next := Next_Msg;
+
+ -- Bump appropriate statistics count
+
+ if Errors.Table (Cur_Msg).Warn or Errors.Table (Cur_Msg).Style then
+ Warnings_Detected := Warnings_Detected + 1;
+ else
+ Total_Errors_Detected := Total_Errors_Detected + 1;
+
+ if Errors.Table (Cur_Msg).Serious then
+ Serious_Errors_Detected := Serious_Errors_Detected + 1;
+ end if;
+ end if;
+
+ end Error_Msg;
+
+ -----------------
+ -- Error_Msg_S --
+ -----------------
+
+ procedure Error_Msg_S (Msg : String) is
+ begin
+ Error_Msg (Msg, Scan_Ptr);
+ end Error_Msg_S;
+
+ ------------------
+ -- Error_Msg_SC --
+ ------------------
+
+ procedure Error_Msg_SC (Msg : String) is
+ begin
+ -- If we are at end of file, post the flag after the previous token
+
+ if Token = Tok_EOF then
+ Error_Msg_AP (Msg);
+
+ -- For all other cases the message is posted at the current token
+ -- pointer position
+
+ else
+ Error_Msg (Msg, Token_Ptr);
+ end if;
+ end Error_Msg_SC;
+
+ ------------------
+ -- Error_Msg_SP --
+ ------------------
+
+ procedure Error_Msg_SP (Msg : String) is
+ begin
+ -- Note: in the case where there is no previous token, Prev_Token_Ptr
+ -- is set to Source_First, which is a reasonable position for the
+ -- error flag in this situation
+
+ Error_Msg (Msg, Prev_Token_Ptr);
+ end Error_Msg_SP;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (Source_Type : String := "project") is
+ Cur : Error_Msg_Id;
+ Nxt : Error_Msg_Id;
+ E, F : Error_Msg_Id;
+ Err_Flag : Boolean;
+
+ begin
+ -- Eliminate any duplicated error messages from the list. This is
+ -- done after the fact to avoid problems with Change_Error_Text.
+
+ Cur := First_Error_Msg;
+ while Cur /= No_Error_Msg loop
+ Nxt := Errors.Table (Cur).Next;
+
+ F := Nxt;
+ while F /= No_Error_Msg
+ and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
+ loop
+ Check_Duplicate_Message (Cur, F);
+ F := Errors.Table (F).Next;
+ end loop;
+
+ Cur := Nxt;
+ end loop;
+
+ -- Brief Error mode
+
+ if Brief_Output or (not Full_List and not Verbose_Mode) then
+ E := First_Error_Msg;
+ Set_Standard_Error;
+
+ while E /= No_Error_Msg loop
+ if not Errors.Table (E).Deleted then
+ if Full_Path_Name_For_Brief_Errors then
+ Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));
+ else
+ Write_Name (Reference_Name (Errors.Table (E).Sfile));
+ end if;
+
+ Write_Char (':');
+ Write_Int (Int (Physical_To_Logical
+ (Errors.Table (E).Line,
+ Errors.Table (E).Sfile)));
+ Write_Char (':');
+
+ if Errors.Table (E).Col < 10 then
+ Write_Char ('0');
+ end if;
+
+ Write_Int (Int (Errors.Table (E).Col));
+ Write_Str (": ");
+ Output_Msg_Text (E);
+ Write_Eol;
+ end if;
+
+ E := Errors.Table (E).Next;
+ end loop;
+
+ Set_Standard_Output;
+ end if;
+
+ -- Full source listing case
+
+ if Full_List then
+ List_Pragmas_Index := 1;
+ List_Pragmas_Mode := True;
+ E := First_Error_Msg;
+ Write_Eol;
+
+ -- First list initial main source file with its error messages
+
+ for N in 1 .. Last_Source_Line (Main_Source_File) loop
+ Err_Flag :=
+ E /= No_Error_Msg
+ and then Errors.Table (E).Line = N
+ and then Errors.Table (E).Sfile = Main_Source_File;
+
+ Output_Source_Line (N, Main_Source_File, Err_Flag, Source_Type);
+
+ if Err_Flag then
+ Output_Error_Msgs (E);
+
+ Write_Eol;
+ end if;
+
+ end loop;
+
+ -- Then output errors, if any, for subsidiary units
+
+ while E /= No_Error_Msg
+ and then Errors.Table (E).Sfile /= Main_Source_File
+ loop
+ Write_Eol;
+ Output_Source_Line
+ (Errors.Table (E).Line,
+ Errors.Table (E).Sfile,
+ True,
+ Source_Type);
+ Output_Error_Msgs (E);
+ end loop;
+ end if;
+
+ -- Verbose mode (error lines only with error flags)
+
+ if Verbose_Mode then
+ E := First_Error_Msg;
+
+ -- Loop through error lines
+
+ while E /= No_Error_Msg loop
+ Write_Eol;
+ Output_Source_Line
+ (Errors.Table (E).Line,
+ Errors.Table (E).Sfile,
+ True,
+ Source_Type);
+ Output_Error_Msgs (E);
+ end loop;
+ end if;
+
+ -- Output error summary if verbose or full list mode
+
+ if Verbose_Mode or else Full_List then
+
+ -- Extra blank line if error messages or source listing were output
+
+ if Total_Errors_Detected + Warnings_Detected > 0
+ or else Full_List
+ then
+ Write_Eol;
+ end if;
+
+ -- Message giving number of lines read and number of errors detected.
+ -- This normally goes to Standard_Output. The exception is when brief
+ -- mode is not set, verbose mode (or full list mode) is set, and
+ -- there are errors. In this case we send the message to standard
+ -- error to make sure that *something* appears on standard error in
+ -- an error situation.
+
+ -- Formerly, only the "# errors" suffix was sent to stderr, whereas
+ -- "# lines:" appeared on stdout. This caused problems on VMS when
+ -- the stdout buffer was flushed, giving an extra line feed after
+ -- the prefix.
+
+ if Total_Errors_Detected + Warnings_Detected /= 0
+ and then not Brief_Output
+ and then (Verbose_Mode or Full_List)
+ then
+ Set_Standard_Error;
+ end if;
+
+ -- Message giving total number of lines
+
+ Write_Str (" ");
+ Write_Int (Num_Source_Lines (Main_Source_File));
+
+ if Num_Source_Lines (Main_Source_File) = 1 then
+ Write_Str (" line: ");
+ else
+ Write_Str (" lines: ");
+ end if;
+
+ if Total_Errors_Detected = 0 then
+ Write_Str ("No errors");
+
+ elsif Total_Errors_Detected = 1 then
+ Write_Str ("1 error");
+
+ else
+ Write_Int (Total_Errors_Detected);
+ Write_Str (" errors");
+ end if;
+
+ if Warnings_Detected /= 0 then
+ Write_Str (", ");
+ Write_Int (Warnings_Detected);
+ Write_Str (" warning");
+
+ if Warnings_Detected /= 1 then
+ Write_Char ('s');
+ end if;
+
+ if Warning_Mode = Treat_As_Error then
+ Write_Str (" (treated as error");
+
+ if Warnings_Detected /= 1 then
+ Write_Char ('s');
+ end if;
+
+ Write_Char (')');
+ end if;
+ end if;
+
+ Write_Eol;
+ Set_Standard_Output;
+ end if;
+
+ if Maximum_Errors /= 0
+ and then Total_Errors_Detected + Warnings_Detected = Maximum_Errors
+ then
+ Set_Standard_Error;
+ Write_Str ("fatal error: maximum errors reached");
+ Write_Eol;
+ Set_Standard_Output;
+ end if;
+
+ if Warning_Mode = Treat_As_Error then
+ Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
+ Warnings_Detected := 0;
+ end if;
+
+ end Finalize;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Errors.Init;
+ First_Error_Msg := No_Error_Msg;
+ Last_Error_Msg := No_Error_Msg;
+ Serious_Errors_Detected := 0;
+ Total_Errors_Detected := 0;
+ Warnings_Detected := 0;
+ Cur_Msg := No_Error_Msg;
+
+ -- Initialize warnings table, if all warnings are suppressed, supply
+ -- an initial dummy entry covering all possible source locations.
+
+ Warnings.Init;
+
+ end Initialize;
+
+ ------------------------
+ -- Output_Source_Line --
+ ------------------------
+
+ procedure Output_Source_Line
+ (L : Physical_Line_Number;
+ Sfile : Source_File_Index;
+ Errs : Boolean;
+ Source_Type : String)
+ is
+ S : Source_Ptr;
+ C : Character;
+
+ Line_Number_Output : Boolean := False;
+ -- Set True once line number is output
+
+ begin
+ if Sfile /= Current_Error_Source_File then
+ Write_Str ("==============Error messages for ");
+ Write_Str (Source_Type);
+ Write_Str (" file: ");
+ Write_Name (Full_File_Name (Sfile));
+ Write_Eol;
+ Current_Error_Source_File := Sfile;
+ end if;
+
+ if Errs then
+ Output_Line_Number (Physical_To_Logical (L, Sfile));
+ Line_Number_Output := True;
+ end if;
+
+ S := Line_Start (L, Sfile);
+
+ loop
+ C := Source_Text (Sfile) (S);
+ exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF;
+
+ if Errs then
+ Write_Char (C);
+ end if;
+
+ S := S + 1;
+ end loop;
+
+ if Line_Number_Output then
+ Write_Eol;
+ end if;
+ end Output_Source_Line;
+
+ -----------------------
+ -- Set_Ignore_Errors --
+ -----------------------
+
+ procedure Set_Ignore_Errors (To : Boolean) is
+ begin
+ Errors_Must_Be_Ignored := To;
+ end Set_Ignore_Errors;
+
+ ------------------------------
+ -- Set_Msg_Insertion_Column --
+ ------------------------------
+
+ procedure Set_Msg_Insertion_Column is
+ begin
+ if Style.RM_Column_Check then
+ Set_Msg_Str (" in column ");
+ Set_Msg_Int (Int (Error_Msg_Col) + 1);
+ end if;
+ end Set_Msg_Insertion_Column;
+
+ ------------------
+ -- Set_Msg_Text --
+ ------------------
+
+ procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
+ C : Character; -- Current character
+ P : Natural; -- Current index;
+
+ begin
+ Manual_Quote_Mode := False;
+ Msglen := 0;
+ Flag_Source := Get_Source_File_Index (Flag);
+ P := Text'First;
+
+ while P <= Text'Last loop
+ C := Text (P);
+ P := P + 1;
+
+ -- Check for insertion character
+
+ if C = '%' then
+ Set_Msg_Insertion_Name;
+
+ elsif C = '$' then
+ -- '$' is ignored
+
+ null;
+
+ elsif C = '{' then
+ Set_Msg_Insertion_File_Name;
+
+ elsif C = '}' then
+ -- '}' is ignored
+
+ null;
+
+ elsif C = '*' then
+ Set_Msg_Insertion_Reserved_Name;
+
+ elsif C = '&' then
+ -- '&' is ignored
+
+ null;
+
+ elsif C = '#' then
+ Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
+
+ elsif C = '\' then
+ Continuation := True;
+
+ elsif C = '@' then
+ Set_Msg_Insertion_Column;
+
+ elsif C = '^' then
+ Set_Msg_Insertion_Uint;
+
+ elsif C = '`' then
+ Manual_Quote_Mode := not Manual_Quote_Mode;
+ Set_Msg_Char ('"');
+
+ elsif C = '!' then
+ Is_Unconditional_Msg := True;
+
+ elsif C = '?' then
+ null;
+
+ elsif C = '|' then
+ null;
+
+ elsif C = ''' then
+ Set_Msg_Char (Text (P));
+ P := P + 1;
+
+ -- Upper case letter (start of reserved word if 2 or more)
+
+ elsif C in 'A' .. 'Z'
+ and then P <= Text'Last
+ and then Text (P) in 'A' .. 'Z'
+ then
+ P := P - 1;
+ Set_Msg_Insertion_Reserved_Word (Text, P);
+
+ -- Normal character with no special treatment
+
+ else
+ Set_Msg_Char (C);
+ end if;
+
+ end loop;
+ end Set_Msg_Text;
+
+end Errutil;
diff --git a/gcc/ada/errutil.ads b/gcc/ada/errutil.ads
new file mode 100644
index 00000000000..a1f3a5fdf3c
--- /dev/null
+++ b/gcc/ada/errutil.ads
@@ -0,0 +1,250 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- E R R U T I L --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains routines to output error messages and the
+-- corresponding instantiation of Styleg, suitable to instantiate Scng.
+
+-- It is not dependent on the GNAT tree packages (Atree, Sinfo, ...).
+
+-- It uses the same global variables as Errout, located in package
+-- Err_Vars. Like Errout, it also uses the common variables and routines
+-- in package Erroutc.
+
+-- This package is used by the preprocessor (gprep.adb) and the project
+-- manager (prj-err.ads).
+
+with Styleg;
+with Types; use Types;
+
+package Errutil is
+
+ ---------------------------------------------------------
+ -- Error Message Text and Message Insertion Characters --
+ ---------------------------------------------------------
+
+ -- Error message text strings are composed of lower case letters, digits
+ -- and the special characters space, comma, period, colon and semicolon,
+ -- apostrophe and parentheses. Special insertion characters can also
+ -- appear which cause the error message circuit to modify the given
+ -- string as follows:
+
+ -- Ignored insertion characters: the following characters, used as
+ -- insertion characters by Errout are ignored: '$', '&', and '}'.
+ -- If present in an error message, they are not output and are not
+ -- replaced by any text.
+
+ -- Insertion character % (Percent: insert name from Names table)
+ -- The character % is replaced by the text for the name specified by
+ -- the Name_Id value stored in Error_Msg_Name_1. A blank precedes
+ -- the name if it is preceded by a non-blank character other than a
+ -- left parenthesis. The name is enclosed in quotes unless manual
+ -- quotation mode is set. If the Name_Id is set to No_Name, then
+ -- no insertion occurs; if the Name_Id is set to Error_Name, then
+ -- the string <error> is inserted. A second and third % may appear
+ -- in a single message, similarly replaced by the names which are
+ -- specified by the Name_Id values stored in Error_Msg_Name_2 and
+ -- Error_Msg_Name_3. The names are decoded and cased according to
+ -- the current identifier casing mode.
+
+ -- Insertion character { (Left brace: insert literally from names table)
+ -- The character { is treated similarly to %, except that the
+ -- name is output literally as stored in the names table without
+ -- adjusting the casing. This can be used for file names and in
+ -- other situations where the name string is to be output unchanged.
+
+ -- Insertion character * (Asterisk, insert reserved word name)
+ -- The insertion character * is treated exactly like % except that
+ -- the resulting name is cased according to the default conventions
+ -- for reserved words (see package Scans).
+
+ -- Insertion character # (Pound: insert line number reference)
+ -- The character # is replaced by the string indicating the source
+ -- position stored in Error_Msg_Sloc. There are two cases:
+ --
+ -- for locations in current file: at line nnn:ccc
+ -- for locations in other files: at filename:nnn:ccc
+ --
+ -- By convention, the # insertion character is only used at the end
+ -- of an error message, so the above strings only appear as the last
+ -- characters of an error message.
+
+ -- Insertion character @ (At: insert column number reference)
+ -- The character @ is replaced by null if the RM_Column_Check mode is
+ -- off (False). If the switch is on (True), then @ is replaced by the
+ -- text string " in column nnn" where nnn is the decimal representation
+ -- of the column number stored in Error_Msg_Col plus one (the plus one
+ -- is because the number is stored 0-origin and displayed 1-origin).
+
+ -- Insertion character ^ (Carret: insert integer value)
+ -- The character ^ is replaced by the decimal conversion of the Uint
+ -- value stored in Error_Msg_Uint_1, with a possible leading minus.
+ -- A second ^ may occur in the message, in which case it is replaced
+ -- by the decimal conversion of the Uint value in Error_Msg_Uint_2.
+
+ -- Insertion character ! (Exclamation: unconditional message)
+ -- The character ! appearing as the last character of a message makes
+ -- the message unconditional which means that it is output even if it
+ -- would normally be suppressed.
+
+ -- Insertion character ? (Question: warning message)
+ -- The character ? appearing anywhere in a message makes the message
+ -- a warning instead of a normal error message, and the text of the
+ -- message will be preceded by "Warning:" instead of "Error:" The
+ -- handling of warnings if further controlled by the Warning_Mode
+ -- option (-w switch), see package Opt for further details, and
+ -- also by the current setting from pragma Warnings. This pragma
+ -- applies only to warnings issued from the semantic phase (not
+ -- the parser), but currently all relevant warnings are posted
+ -- by the semantic phase anyway. Messages starting with (style)
+ -- are also treated as warning messages.
+
+ -- Insertion character A-Z (Upper case letter: Ada reserved word)
+ -- If two or more upper case letters appear in the message, they are
+ -- taken as an Ada reserved word, and are converted to the default
+ -- case for reserved words (see Scans package spec). Surrounding
+ -- quotes are added unless manual quotation mode is currently set.
+
+ -- Insertion character ` (Backquote: set manual quotation mode)
+ -- The backquote character always appears in pairs. Each backquote
+ -- of the pair is replaced by a double quote character. In addition,
+ -- Any reserved keywords, or name insertions between these backquotes
+ -- are not surrounded by the usual automatic double quotes. See the
+ -- section below on manual quotation mode for further details.
+
+ -- Insertion character ' (Quote: literal character)
+ -- Precedes a character which is placed literally into the message.
+ -- Used to insert characters into messages that are one of the
+ -- insertion characters defined here.
+
+ -- Insertion character \ (Backslash: continuation message)
+ -- Indicates that the message is a continuation of a message
+ -- previously posted. This is used to ensure that such groups
+ -- of messages are treated as a unit. The \ character must be
+ -- the first character of the message text.
+
+ -----------------------------------------------------
+ -- Format of Messages and Manual Quotation Control --
+ -----------------------------------------------------
+
+ -- Messages are generally all in lower case, except for inserted names
+ -- and appear in one of the following two forms:
+
+ -- error: text
+ -- warning: text
+
+ -- The prefixes error and warning are supplied automatically (depending
+ -- on the use of the ? insertion character), and the call to the error
+ -- message routine supplies the text. The "error: " prefix is omitted
+ -- in brief error message formats.
+
+ -- Reserved keywords in the message are in the default keyword case
+ -- (determined from the given source program), surrounded by quotation
+ -- marks. This is achieved by spelling the reserved word in upper case
+ -- letters, which is recognized as a request for insertion of quotation
+ -- marks by the error text processor. Thus for example:
+
+ -- Error_Msg_AP ("IS expected");
+
+ -- would result in the output of one of the following:
+
+ -- error: "is" expected
+ -- error: "IS" expected
+ -- error: "Is" expected
+
+ -- the choice between these being made by looking at the casing convention
+ -- used for keywords (actually the first compilation unit keyword) in the
+ -- source file.
+
+ -- In the case of names, the default mode for the error text processor
+ -- is to surround the name by quotation marks automatically. The case
+ -- used for the identifier names is taken from the source program where
+ -- possible, and otherwise is the default casing convention taken from
+ -- the source file usage.
+
+ -- In some cases, better control over the placement of quote marks is
+ -- required. This is achieved using manual quotation mode. In this mode,
+ -- one or more insertion sequences is surrounded by backquote characters.
+ -- The backquote characters are output as double quote marks, and normal
+ -- automatic insertion of quotes is suppressed between the double quotes.
+ -- For example:
+
+ -- Error_Msg_AP ("`END &;` expected");
+
+ -- generates a message like
+
+ -- error: "end Open_Scope;" expected
+
+ -- where the node specifying the name Open_Scope has been stored in
+ -- Error_Msg_Node_1 prior to the call. The great majority of error
+ -- messages operates in normal quotation mode.
+
+ -- Note: the normal automatic insertion of spaces before insertion
+ -- sequences (such as those that come from & and %) is suppressed in
+ -- manual quotation mode, so blanks, if needed as in the above example,
+ -- must be explicitly present.
+
+ ------------------------------
+ -- Error Output Subprograms --
+ ------------------------------
+
+ procedure Initialize;
+ -- Initializes for output of error messages. Must be called for each
+ -- file before using any of the other routines in the package.
+
+ procedure Finalize (Source_Type : String := "project");
+ -- Finalize processing of error messages for one file and output message
+ -- indicating the number of detected errors.
+ -- Source_Type is used in verbose mode to indicate the type of the source
+ -- being parsed (project file, definition file or input file for the
+ -- preprocessor).
+
+ procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
+ -- Output a message at specified location.
+
+ procedure Error_Msg_S (Msg : String);
+ -- Output a message at current scan pointer location.
+
+ procedure Error_Msg_SC (Msg : String);
+ -- Output a message at the start of the current token, unless we are at
+ -- the end of file, in which case we always output the message after the
+ -- last real token in the file.
+
+ procedure Error_Msg_SP (Msg : String);
+ -- Output a message at the start of the previous token.
+
+ procedure Set_Ignore_Errors (To : Boolean);
+ -- Indicate, when To = True, that all reported errors should
+ -- be ignored. By default reported errors are not ignored.
+
+ package Style is new Styleg
+ (Error_Msg => Error_Msg,
+ Error_Msg_S => Error_Msg_S,
+ Error_Msg_SC => Error_Msg_SC,
+ Error_Msg_SP => Error_Msg_SP);
+ -- Instantiation of the generic style package, suitable for an
+ -- instantiation of Scng.
+
+end Errutil;
diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb
index fbda4a6611c..f8d14bfe2fa 100644
--- a/gcc/ada/eval_fat.adb
+++ b/gcc/ada/eval_fat.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- --
@@ -25,6 +25,7 @@
------------------------------------------------------------------------------
with Einfo; use Einfo;
+with Errout; use Errout;
with Sem_Util; use Sem_Util;
with Ttypef; use Ttypef;
with Targparm; use Targparm;
@@ -72,10 +73,6 @@ package body Eval_Fat is
-- using biased rounding (halfway cases round away from zero), round to
-- even, a floor operation or a ceiling operation depending on the setting
-- of Mode (see corresponding descriptions in Urealp).
- --
- -- In case rounding was specified, Rounding_Was_Biased is set True
- -- if the input was indeed halfway between to machine numbers and
- -- got rounded away from zero to an odd number.
function Eps_Model (RT : R) return T;
-- Return the smallest model number of R.
@@ -83,8 +80,11 @@ package body Eval_Fat is
function Eps_Denorm (RT : R) return T;
-- Return the smallest denormal of type R.
+ function Machine_Emin (RT : R) return Int;
+ -- Return value of the Machine_Emin attribute
+
function Machine_Mantissa (RT : R) return Nat;
- -- Get value of machine mantissa
+ -- Return value of the Machine_Mantissa attribute
--------------
-- Adjacent --
@@ -396,8 +396,6 @@ package body Eval_Fat is
-- Determine correct rounding based on the remainder
-- which is in N and the divisor D.
- Rounding_Was_Biased := False; -- Until proven otherwise
-
case Mode is
when Round_Even =>
@@ -420,10 +418,6 @@ package body Eval_Fat is
if N * 2 >= D then
Fraction := Fraction + 1;
-
- Rounding_Was_Biased := Even and then N * 2 = D;
- -- Check for the case where the result is actually
- -- different from Round_Even.
end if;
when Ceiling =>
@@ -451,54 +445,9 @@ package body Eval_Fat is
----------------
function Eps_Denorm (RT : R) return T is
- Digs : constant UI := Digits_Value (RT);
- Emin : Int;
- Mant : Int;
-
begin
- if Vax_Float (RT) then
- if Digs = VAXFF_Digits then
- Emin := VAXFF_Machine_Emin;
- Mant := VAXFF_Machine_Mantissa;
-
- elsif Digs = VAXDF_Digits then
- Emin := VAXDF_Machine_Emin;
- Mant := VAXDF_Machine_Mantissa;
-
- else
- pragma Assert (Digs = VAXGF_Digits);
- Emin := VAXGF_Machine_Emin;
- Mant := VAXGF_Machine_Mantissa;
- end if;
-
- elsif Is_AAMP_Float (RT) then
- if Digs = AAMPS_Digits then
- Emin := AAMPS_Machine_Emin;
- Mant := AAMPS_Machine_Mantissa;
-
- else
- pragma Assert (Digs = AAMPL_Digits);
- Emin := AAMPL_Machine_Emin;
- Mant := AAMPL_Machine_Mantissa;
- end if;
-
- else
- if Digs = IEEES_Digits then
- Emin := IEEES_Machine_Emin;
- Mant := IEEES_Machine_Mantissa;
-
- elsif Digs = IEEEL_Digits then
- Emin := IEEEL_Machine_Emin;
- Mant := IEEEL_Machine_Mantissa;
-
- else
- pragma Assert (Digs = IEEEX_Digits);
- Emin := IEEEX_Machine_Emin;
- Mant := IEEEX_Machine_Mantissa;
- end if;
- end if;
-
- return Float_Radix ** UI_From_Int (Emin - Mant);
+ return Float_Radix ** UI_From_Int
+ (Machine_Emin (RT) - Machine_Mantissa (RT));
end Eps_Denorm;
---------------
@@ -506,45 +455,8 @@ package body Eval_Fat is
---------------
function Eps_Model (RT : R) return T is
- Digs : constant UI := Digits_Value (RT);
- Emin : Int;
-
begin
- if Vax_Float (RT) then
- if Digs = VAXFF_Digits then
- Emin := VAXFF_Machine_Emin;
-
- elsif Digs = VAXDF_Digits then
- Emin := VAXDF_Machine_Emin;
-
- else
- pragma Assert (Digs = VAXGF_Digits);
- Emin := VAXGF_Machine_Emin;
- end if;
-
- elsif Is_AAMP_Float (RT) then
- if Digs = AAMPS_Digits then
- Emin := AAMPS_Machine_Emin;
-
- else
- pragma Assert (Digs = AAMPL_Digits);
- Emin := AAMPL_Machine_Emin;
- end if;
-
- else
- if Digs = IEEES_Digits then
- Emin := IEEES_Machine_Emin;
-
- elsif Digs = IEEEL_Digits then
- Emin := IEEEL_Machine_Emin;
-
- else
- pragma Assert (Digs = IEEEX_Digits);
- Emin := IEEEX_Machine_Emin;
- end if;
- end if;
-
- return Float_Radix ** UI_From_Int (Emin);
+ return Float_Radix ** UI_From_Int (Machine_Emin (RT));
end Eps_Model;
--------------
@@ -624,19 +536,143 @@ package body Eval_Fat is
-- Machine --
-------------
- function Machine (RT : R; X : T; Mode : Rounding_Mode) return T is
+ function Machine
+ (RT : R;
+ X : T;
+ Mode : Rounding_Mode;
+ Enode : Node_Id)
+ return T
+ is
+ pragma Warnings (Off, Enode); -- not yet referenced
+
X_Frac : T;
X_Exp : UI;
+ Emin : constant UI := UI_From_Int (Machine_Emin (RT));
begin
if UR_Is_Zero (X) then
return X;
+
else
Decompose (RT, X, X_Frac, X_Exp, Mode);
+
+ -- Case of denormalized number or (gradual) underflow
+
+ -- A denormalized number is one with the minimum exponent Emin, but
+ -- that breaks the assumption that the first digit of the mantissa
+ -- is a one. This allows the first non-zero digit to be in any
+ -- of the remaining Mant - 1 spots. The gap between subsequent
+ -- denormalized numbers is the same as for the smallest normalized
+ -- numbers. However, the number of significant digits left decreases
+ -- as a result of the mantissa now having leading seros.
+
+ if X_Exp < Emin then
+ declare
+ Emin_Den : constant UI :=
+ UI_From_Int
+ (Machine_Emin (RT) - Machine_Mantissa (RT) + 1);
+ begin
+ if X_Exp < Emin_Den or not Denorm_On_Target then
+ if UR_Is_Negative (X) then
+ Error_Msg_N
+ ("floating-point value underflows to -0.0?", Enode);
+ return Ureal_M_0;
+
+ else
+ Error_Msg_N
+ ("floating-point value underflows to 0.0?", Enode);
+ return Ureal_0;
+ end if;
+
+ elsif Denorm_On_Target then
+
+ -- Emin - Mant <= X_Exp < Emin, so result is denormal.
+ -- Handle gradual underflow by first computing the
+ -- number of significant bits still available for the
+ -- mantissa and then truncating the fraction to this
+ -- number of bits.
+
+ -- If this value is different from the original
+ -- fraction, precision is lost due to gradual underflow.
+
+ -- We probably should round here and prevent double
+ -- rounding as a result of first rounding to a model
+ -- number and then to a machine number. However, this
+ -- is an extremely rare case that is not worth the extra
+ -- complexity. In any case, a warning is issued in cases
+ -- where gradual underflow occurs.
+
+ declare
+ Denorm_Sig_Bits : constant UI := X_Exp - Emin_Den + 1;
+
+ X_Frac_Denorm : constant T := UR_From_Components
+ (UR_Trunc (Scaling (RT, abs X_Frac, Denorm_Sig_Bits)),
+ Denorm_Sig_Bits,
+ Radix,
+ UR_Is_Negative (X));
+
+ begin
+ if X_Frac_Denorm /= X_Frac then
+ Error_Msg_N
+ ("gradual underflow causes loss of precision?",
+ Enode);
+ X_Frac := X_Frac_Denorm;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+
return Scaling (RT, X_Frac, X_Exp);
end if;
end Machine;
+ ------------------
+ -- Machine_Emin --
+ ------------------
+
+ function Machine_Emin (RT : R) return Int is
+ Digs : constant UI := Digits_Value (RT);
+ Emin : Int;
+
+ begin
+ if Vax_Float (RT) then
+ if Digs = VAXFF_Digits then
+ Emin := VAXFF_Machine_Emin;
+
+ elsif Digs = VAXDF_Digits then
+ Emin := VAXDF_Machine_Emin;
+
+ else
+ pragma Assert (Digs = VAXGF_Digits);
+ Emin := VAXGF_Machine_Emin;
+ end if;
+
+ elsif Is_AAMP_Float (RT) then
+ if Digs = AAMPS_Digits then
+ Emin := AAMPS_Machine_Emin;
+
+ else
+ pragma Assert (Digs = AAMPL_Digits);
+ Emin := AAMPL_Machine_Emin;
+ end if;
+
+ else
+ if Digs = IEEES_Digits then
+ Emin := IEEES_Machine_Emin;
+
+ elsif Digs = IEEEL_Digits then
+ Emin := IEEEL_Machine_Emin;
+
+ else
+ pragma Assert (Digs = IEEEX_Digits);
+ Emin := IEEEX_Machine_Emin;
+ end if;
+ end if;
+
+ return Emin;
+ end Machine_Emin;
+
----------------------
-- Machine_Mantissa --
----------------------
diff --git a/gcc/ada/eval_fat.ads b/gcc/ada/eval_fat.ads
index 30a9fe35dfa..45dfc69c537 100644
--- a/gcc/ada/eval_fat.ads
+++ b/gcc/ada/eval_fat.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -46,13 +46,9 @@ package Eval_Fat is
subtype R is Entity_Id;
-- The compile time representation of the floating-point root type
- type Rounding_Mode is (Floor, Ceiling, Round, Round_Even);
- for Rounding_Mode use (0, 1, 2, 3);
- -- Used to indicate rounding mode for Machine attribute
- -- Note that C code in gigi knows that Round_Even is 3
-
- Rounding_Was_Biased : Boolean;
- -- Set if last use of Machine rounded a halfway case away from zero
+ -- The following functions perform the operation implied by their name
+ -- which corresponds to the name of the attribute which they compute.
+ -- The arguments correspond to the attribute function arguments.
function Adjacent (RT : R; X, Towards : T) return T;
@@ -70,8 +66,6 @@ package Eval_Fat is
function Leading_Part (RT : R; X : T; Radix_Digits : UI) return T;
- function Machine (RT : R; X : T; Mode : Rounding_Mode) return T;
-
function Model (RT : R; X : T) return T;
function Pred (RT : R; X : T) return T;
@@ -88,4 +82,23 @@ package Eval_Fat is
function Unbiased_Rounding (RT : R; X : T) return T;
+ -- The following global declarations are used by the Machine attribute
+
+ type Rounding_Mode is (Floor, Ceiling, Round, Round_Even);
+ for Rounding_Mode use (0, 1, 2, 3);
+ -- Used to indicate rounding mode for Machine attribute
+ -- Note that C code in gigi knows that Round_Even is 3
+
+ -- The Machine attribute is special, in that it takes an extra argument
+ -- indicating the rounding mode, and also an argument Enode that is a
+ -- node used to post warnings (e.g. if asked to convert a negative zero
+ -- on a machine for which Signed_Zeros is False).
+
+ function Machine
+ (RT : R;
+ X : T;
+ Mode : Rounding_Mode;
+ Enode : Node_Id)
+ return T;
+
end Eval_Fat;
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index b63cc53c993..0985ead93a7 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.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- --
@@ -114,6 +114,11 @@ package body Exp_Aggr is
-- an entity that allows to know if the value being created needs to be
-- attached to the final list in case of pragma finalize_Storage_Only.
+ function Has_Mutable_Components (Typ : Entity_Id) return Boolean;
+ -- Return true if one of the component is of a discriminated type with
+ -- defaults. An aggregate for a type with mutable components must be
+ -- expanded into individual assignments.
+
procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id);
-- If the type of the aggregate is a type extension with renamed discrimi-
-- nants, we must initialize the hidden discriminants of the parent.
@@ -132,7 +137,7 @@ package body Exp_Aggr is
procedure Convert_To_Positional
(N : Node_Id;
- Max_Others_Replicate : Nat := 5;
+ Max_Others_Replicate : Nat := 5;
Handle_Bit_Packed : Boolean := False);
-- If possible, convert named notation to positional notation. This
-- conversion is possible only in some static cases. If the conversion
@@ -169,11 +174,14 @@ package body Exp_Aggr is
-- loops and assignments that are needed for the expansion of the array
-- aggregate N.
--
- -- N is the (sub-)aggregate node to be expanded into code.
+ -- N is the (sub-)aggregate node to be expanded into code. This node
+ -- has been fully analyzed, and its Etype is properly set.
--
-- Index is the index node corresponding to the array sub-aggregate N.
--
-- Into is the target expression into which we are copying the aggregate.
+ -- Note that this node may not have been analyzed yet, and so the Etype
+ -- field may not be set.
--
-- Scalar_Comp is True if the component type of the aggregate is scalar.
--
@@ -193,7 +201,7 @@ package body Exp_Aggr is
Target : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty)
- return List_Id;
+ return List_Id;
-- N is a nested (record or array) aggregate that has been marked
-- with 'Delay_Expansion'. Typ is the expected type of the
-- aggregate and Target is a (duplicable) expression that will
@@ -413,9 +421,9 @@ package body Exp_Aggr is
-- Returns a new reference to the index type name.
function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id;
- -- Ind must be a side-effect free expression.
- -- If the input aggregate N to Build_Loop contains no sub-aggregates,
- -- This routine returns the assignment statement
+ -- Ind must be a side-effect free expression. If the input aggregate
+ -- N to Build_Loop contains no sub-aggregates, then this function
+ -- returns the assignment statement:
--
-- Into (Indices, Ind) := Expr;
--
@@ -445,7 +453,7 @@ package body Exp_Aggr is
-- Into (Indices, J) := Expr;
-- end loop;
--
- -- Otherwise we call Build_Code recursively.
+ -- Otherwise we call Build_Code recursively
function Local_Compile_Time_Known_Value (E : Node_Id) return Boolean;
function Local_Expr_Value (E : Node_Id) return Uint;
@@ -465,9 +473,8 @@ package body Exp_Aggr is
Expr_Pos : Node_Id;
Expr : Node_Id;
To_Pos : Node_Id;
-
- U_To : Uint;
- U_Val : Uint := UI_From_Int (Val);
+ U_To : Uint;
+ U_Val : constant Uint := UI_From_Int (Val);
begin
-- Note: do not try to optimize the case of Val = 0, because
@@ -625,7 +632,7 @@ package body Exp_Aggr is
----------------
function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is
- L : List_Id := New_List;
+ L : constant List_Id := New_List;
F : Entity_Id;
A : Node_Id;
@@ -679,7 +686,6 @@ package body Exp_Aggr is
and then Present (Scope (Entity (Into)))
then
F := Find_Final_List (Scope (Entity (Into)));
-
else
F := Find_Final_List (Current_Scope);
end if;
@@ -692,15 +698,16 @@ package body Exp_Aggr is
Add_Loop_Actions (
Build_Array_Aggr_Code
(Expr, Next_Index (Index),
- Into, Scalar_Comp, New_Indices, F));
+ Into, Scalar_Comp, New_Indices, F));
end if;
-- If we get here then we are at a bottom-level (sub-)aggregate
- Indexed_Comp := Checks_Off (
- Make_Indexed_Component (Loc,
- Prefix => New_Copy_Tree (Into),
- Expressions => New_Indices));
+ Indexed_Comp :=
+ Checks_Off
+ (Make_Indexed_Component (Loc,
+ Prefix => New_Copy_Tree (Into),
+ Expressions => New_Indices));
Set_Assignment_OK (Indexed_Comp);
@@ -717,7 +724,7 @@ package body Exp_Aggr is
elsif Present (Next (First (New_Indices))) then
- -- this is a multidimensional array. Recover the component
+ -- This is a multidimensional array. Recover the component
-- type from the outermost aggregate, because subaggregates
-- do not have an assigned type.
@@ -740,10 +747,9 @@ package body Exp_Aggr is
end;
end if;
- if (Nkind (Expr_Q) = N_Aggregate
- or else Nkind (Expr_Q) = N_Extension_Aggregate)
+ if Nkind (Expr_Q) = N_Aggregate
+ or else Nkind (Expr_Q) = N_Extension_Aggregate
then
-
-- At this stage the Expression may not have been
-- analyzed yet because the array aggregate code has not
-- been updated to use the Expansion_Delayed flag and
@@ -837,8 +843,8 @@ package body Exp_Aggr is
L_Body : List_Id;
-- The statements to execute in the loop
- S : List_Id := New_List;
- -- list of statement
+ S : constant List_Id := New_List;
+ -- List of statements
Tcopy : Node_Id;
-- Copy of expression tree, used for checking purposes
@@ -950,7 +956,6 @@ package body Exp_Aggr is
-- end loop;
function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id is
-
W_J : Node_Id;
W_Decl : Node_Id;
@@ -962,13 +967,13 @@ package body Exp_Aggr is
W_Index_Succ : Node_Id;
-- Index_Base'Succ (J)
- W_Increment : Node_Id;
+ W_Increment : Node_Id;
-- W_J := Index_Base'Succ (W)
- W_Body : List_Id := New_List;
+ W_Body : constant List_Id := New_List;
-- The statements to execute in the loop
- S : List_Id := New_List;
+ S : constant List_Id := New_List;
-- list of statement
begin
@@ -995,7 +1000,7 @@ package body Exp_Aggr is
Append_To (S, W_Decl);
- -- construct " while W_J < H"
+ -- Construct " while W_J < H"
W_Iteration_Scheme :=
Make_Iteration_Scheme
@@ -1053,8 +1058,8 @@ package body Exp_Aggr is
return Compile_Time_Known_Value (E)
or else
(Nkind (E) = N_Attribute_Reference
- and then Attribute_Name (E) = Name_Val
- and then Compile_Time_Known_Value (First (Expressions (E))));
+ and then Attribute_Name (E) = Name_Val
+ and then Compile_Time_Known_Value (First (Expressions (E))));
end Local_Compile_Time_Known_Value;
----------------------
@@ -1075,6 +1080,7 @@ package body Exp_Aggr is
Assoc : Node_Id;
Choice : Node_Id;
Expr : Node_Id;
+ Typ : Entity_Id;
Others_Expr : Node_Id := Empty;
@@ -1084,8 +1090,8 @@ package body Exp_Aggr is
-- the code generated by Build_Array_Aggr_Code is executed then these
-- bounds are OK. Otherwise a Constraint_Error would have been raised.
- Aggr_Low : constant Node_Id := Duplicate_Subexpr (Aggr_L);
- Aggr_High : constant Node_Id := Duplicate_Subexpr (Aggr_H);
+ Aggr_Low : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L);
+ Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
-- After Duplicate_Subexpr these are side-effect free.
Low : Node_Id;
@@ -1098,12 +1104,33 @@ package body Exp_Aggr is
Nb_Elements : Int;
-- Number of elements in the positional aggregate
- New_Code : List_Id := New_List;
+ New_Code : constant List_Id := New_List;
-- Start of processing for Build_Array_Aggr_Code
begin
+ -- First before we start, a special case. if we have a bit packed
+ -- array represented as a modular type, then clear the value to
+ -- zero first, to ensure that unused bits are properly cleared.
+
+ Typ := Etype (N);
+
+ if Present (Typ)
+ and then Is_Bit_Packed_Array (Typ)
+ and then Is_Modular_Integer_Type (Packed_Array_Type (Typ))
+ then
+ Append_To (New_Code,
+ Make_Assignment_Statement (Loc,
+ Name => New_Copy_Tree (Into),
+ Expression =>
+ Unchecked_Convert_To (Typ,
+ Make_Integer_Literal (Loc, Uint_0))));
+ end if;
+
+ -- We can skip this
-- STEP 1: Process component associations
+ -- For those associations that may generate a loop, initialize
+ -- Loop_Actions to collect inserted actions that may be crated.
if No (Expressions (N)) then
@@ -1111,22 +1138,24 @@ package body Exp_Aggr is
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
-
Choice := First (Choices (Assoc));
while Present (Choice) loop
-
if Nkind (Choice) = N_Others_Choice then
+ Set_Loop_Actions (Assoc, New_List);
Others_Expr := Expression (Assoc);
exit;
end if;
Get_Index_Bounds (Choice, Low, High);
+ if Low /= High then
+ Set_Loop_Actions (Assoc, New_List);
+ end if;
+
Nb_Choices := Nb_Choices + 1;
Table (Nb_Choices) := (Choice_Lo => Low,
Choice_Hi => High,
Choice_Node => Expression (Assoc));
-
Next (Choice);
end loop;
@@ -1147,7 +1176,6 @@ package body Exp_Aggr is
Low := Table (J).Choice_Lo;
High := Table (J).Choice_Hi;
Expr := Table (J).Choice_Node;
-
Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
end loop;
@@ -1161,7 +1189,6 @@ package body Exp_Aggr is
begin
for J in 0 .. Nb_Choices loop
-
if J = 0 then
Low := Aggr_Low;
else
@@ -1174,7 +1201,7 @@ package body Exp_Aggr is
High := Add (-1, To => Table (J + 1).Choice_Lo);
end if;
- -- If this is an expansion within an init_proc, make
+ -- If this is an expansion within an init proc, make
-- sure that discriminant references are replaced by
-- the corresponding discriminal.
@@ -1261,7 +1288,6 @@ package body Exp_Aggr is
Comp_Type : Entity_Id;
Selector : Entity_Id;
Comp_Expr : Node_Id;
- Comp_Kind : Node_Kind;
Expr_Q : Node_Id;
Internal_Final_List : Node_Id;
@@ -1300,11 +1326,11 @@ package body Exp_Aggr is
F : Node_Id;
Attach : Node_Id;
Init_Pr : Boolean)
- return List_Id;
+ return List_Id;
-- returns the list of statements necessary to initialize the internal
-- controller of the (possible) ancestor typ into target and attach
-- it to finalization list F. Init_Pr conditions the call to the
- -- init_proc since it may already be done due to ancestor initialization
+ -- init proc since it may already be done due to ancestor initialization
---------------------------------
-- Ancestor_Discriminant_Value --
@@ -1341,6 +1367,7 @@ package body Exp_Aggr is
if Disc = Corresp_Disc then
return Duplicate_Subexpr (Expression (Assoc));
end if;
+
Corresp_Disc :=
Corresponding_Discriminant (Corresp_Disc);
end loop;
@@ -1496,19 +1523,21 @@ package body Exp_Aggr is
F : Node_Id;
Attach : Node_Id;
Init_Pr : Boolean)
- return List_Id
+ return List_Id
is
+ L : constant List_Id := New_List;
Ref : Node_Id;
- L : List_Id := New_List;
begin
- -- _init_proc (target._controller);
+ -- Generate:
+ -- init-proc (target._controller);
-- initialize (target._controller);
-- Attach_to_Final_List (target._controller, F);
- Ref := Make_Selected_Component (Loc,
- Prefix => Convert_To (Typ, New_Copy_Tree (Target)),
- Selector_Name => Make_Identifier (Loc, Name_uController));
+ Ref :=
+ Make_Selected_Component (Loc,
+ Prefix => Convert_To (Typ, New_Copy_Tree (Target)),
+ Selector_Name => Make_Identifier (Loc, Name_uController));
Set_Assignment_OK (Ref);
if Init_Pr then
@@ -1537,7 +1566,6 @@ package body Exp_Aggr is
-- Start of processing for Build_Record_Aggr_Code
begin
-
-- Deal with the ancestor part of extension aggregates
-- or with the discriminants of the root type
@@ -1546,14 +1574,13 @@ package body Exp_Aggr is
A : constant Node_Id := Ancestor_Part (N);
begin
-
-- If the ancestor part is a subtype mark "T", we generate
- -- _init_proc (T(tmp)); if T is constrained and
- -- _init_proc (S(tmp)); where S applies an appropriate
+
+ -- init-proc (T(tmp)); if T is constrained and
+ -- init-proc (S(tmp)); where S applies an appropriate
-- constraint if T is unconstrained
if Is_Entity_Name (A) and then Is_Type (Entity (A)) then
-
Ancestor_Is_Subtype_Mark := True;
if Is_Constrained (Entity (A)) then
@@ -1568,13 +1595,15 @@ package body Exp_Aggr is
elsif Has_Discriminants (Entity (A)) then
declare
- Anc_Typ : Entity_Id := Entity (A);
- Discrim : Entity_Id := First_Discriminant (Anc_Typ);
- Anc_Constr : List_Id := New_List;
+ Anc_Typ : constant Entity_Id := Entity (A);
+ Anc_Constr : constant List_Id := New_List;
+ Discrim : Entity_Id;
Disc_Value : Node_Id;
New_Indic : Node_Id;
Subt_Decl : Node_Id;
+
begin
+ Discrim := First_Discriminant (Anc_Typ);
while Present (Discrim) loop
Disc_Value := Ancestor_Discriminant_Value (Discrim);
Append_To (Anc_Constr, Disc_Value);
@@ -1676,6 +1705,8 @@ package body Exp_Aggr is
end if;
end;
+ -- Normal case (not an extension aggregate)
+
else
-- Generate the discriminant expressions, component by component.
-- If the base type is an unchecked union, the discriminants are
@@ -1685,7 +1716,6 @@ package body Exp_Aggr is
if Has_Discriminants (Typ)
and then not Is_Unchecked_Union (Base_Type (Typ))
then
-
-- ??? The discriminants of the object not inherited in the type
-- of the object should be initialized here
@@ -1698,7 +1728,7 @@ package body Exp_Aggr is
Discriminant_Value : Node_Id;
begin
- Discriminant := First_Girder_Discriminant (Typ);
+ Discriminant := First_Stored_Discriminant (Typ);
while Present (Discriminant) loop
@@ -1721,7 +1751,7 @@ package body Exp_Aggr is
Set_No_Ctrl_Actions (Instr);
Append_To (L, Instr);
- Next_Girder_Discriminant (Discriminant);
+ Next_Stored_Discriminant (Discriminant);
end loop;
end;
end if;
@@ -1737,11 +1767,12 @@ package body Exp_Aggr is
while Present (Comp) loop
Selector := Entity (First (Choices (Comp)));
+ -- ???
+
if Ekind (Selector) /= E_Discriminant
or else Nkind (N) = N_Extension_Aggregate
then
Comp_Type := Etype (Selector);
- Comp_Kind := Nkind (Expression (Comp));
Comp_Expr :=
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
@@ -1764,6 +1795,7 @@ package body Exp_Aggr is
New_Copy_Tree (Target)),
Selector_Name =>
Make_Identifier (Loc, Name_uController));
+
Internal_Final_List :=
Make_Selected_Component (Loc,
Prefix => Internal_Final_List,
@@ -1772,14 +1804,18 @@ package body Exp_Aggr is
-- The internal final list can be part of a constant object
Set_Assignment_OK (Internal_Final_List);
+
else
Internal_Final_List := Empty;
end if;
+ -- ???
+
if Is_Delayed_Aggregate (Expr_Q) then
Append_List_To (L,
Late_Expansion (Expr_Q, Comp_Type, Comp_Expr,
Internal_Final_List));
+
else
Instr :=
Make_OK_Assignment_Statement (Loc,
@@ -1826,6 +1862,42 @@ package body Exp_Aggr is
With_Attach => Make_Integer_Literal (Loc, 1)));
end if;
end if;
+
+ -- ???
+
+ elsif Ekind (Selector) = E_Discriminant
+ and then Nkind (N) /= N_Extension_Aggregate
+ and then Nkind (Parent (N)) = N_Component_Association
+ and then Is_Constrained (Typ)
+ then
+ -- We must check that the discriminant value imposed by the
+ -- context is the same as the value given in the subaggregate,
+ -- because after the expansion into assignments there is no
+ -- record on which to perform a regular discriminant check.
+
+ declare
+ D_Val : Elmt_Id;
+ Disc : Entity_Id;
+
+ begin
+ D_Val := First_Elmt (Discriminant_Constraint (Typ));
+ Disc := First_Discriminant (Typ);
+
+ while Chars (Disc) /= Chars (Selector) loop
+ Next_Discriminant (Disc);
+ Next_Elmt (D_Val);
+ end loop;
+
+ pragma Assert (Present (D_Val));
+
+ Append_To (L,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => New_Copy_Tree (Node (D_Val)),
+ Right_Opnd => Expression (Comp)),
+ Reason => CE_Discriminant_Check_Failed));
+ end;
end if;
Next (Comp);
@@ -1834,7 +1906,7 @@ package body Exp_Aggr is
-- If the type is tagged, the tag needs to be initialized (unless
-- compiling for the Java VM where tags are implicit). It is done
-- late in the initialization process because in some cases, we call
- -- the init_proc of an ancestor which will not leave out the right tag
+ -- the init proc of an ancestor which will not leave out the right tag
if Ancestor_Is_Expression then
null;
@@ -1898,8 +1970,7 @@ package body Exp_Aggr is
External_Final_List := Empty;
end if;
- -- initialize and attach the outer object in the is_controlled
- -- case
+ -- Initialize and attach the outer object in the is_controlled case
if Is_Controlled (Typ) then
if Ancestor_Is_Subtype_Mark then
@@ -1912,33 +1983,7 @@ package body Exp_Aggr is
Parameter_Associations => New_List (New_Copy_Tree (Ref))));
end if;
- -- ??? when the ancestor part is an expression, the global
- -- object is already attached at the wrong level. It should
- -- be detached and re-attached. We have a design problem here.
-
- if Ancestor_Is_Expression
- and then Has_Controlled_Component (Init_Typ)
- then
- null;
-
- elsif Has_Controlled_Component (Typ) then
- F := Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
- Selector_Name => Make_Identifier (Loc, Name_uController));
- F := Make_Selected_Component (Loc,
- Prefix => F,
- Selector_Name => Make_Identifier (Loc, Name_F));
-
- Ref := New_Copy_Tree (Target);
- Set_Assignment_OK (Ref);
-
- Append_To (L,
- Make_Attach_Call (
- Obj_Ref => Ref,
- Flist_Ref => F,
- With_Attach => Make_Integer_Literal (Loc, 1)));
-
- else -- is_Controlled (Typ) and not Has_Controlled_Component (Typ)
+ if not Has_Controlled_Component (Typ) then
Ref := New_Copy_Tree (Target);
Set_Assignment_OK (Ref);
Append_To (Start_L,
@@ -1949,7 +1994,7 @@ package body Exp_Aggr is
end if;
end if;
- -- in the Has_Controlled component case, all the intermediate
+ -- In the Has_Controlled component case, all the intermediate
-- controllers must be initialized
if Has_Controlled_Component (Typ) then
@@ -1962,7 +2007,7 @@ package body Exp_Aggr is
Outer_Typ := Base_Type (Typ);
- -- find outer type with a controller
+ -- Find outer type with a controller
while Outer_Typ /= Init_Typ
and then not Has_New_Controlled_Component (Outer_Typ)
@@ -1970,7 +2015,7 @@ package body Exp_Aggr is
Outer_Typ := Etype (Outer_Typ);
end loop;
- -- attach it to the outer record controller to the
+ -- Attach it to the outer record controller to the
-- external final list
if Outer_Typ = Init_Typ then
@@ -1981,7 +2026,8 @@ package body Exp_Aggr is
F => External_Final_List,
Attach => Attach,
Init_Pr => Ancestor_Is_Expression));
- At_Root := True;
+
+ At_Root := True;
Inner_Typ := Init_Typ;
else
@@ -1998,6 +2044,18 @@ package body Exp_Aggr is
not Is_Tagged_Type (Typ) or else Inner_Typ = Outer_Typ;
end if;
+ -- The outer object has to be attached as well
+
+ if Is_Controlled (Typ) then
+ Ref := New_Copy_Tree (Target);
+ Set_Assignment_OK (Ref);
+ Append_To (Start_L,
+ Make_Attach_Call (
+ Obj_Ref => Ref,
+ Flist_Ref => New_Copy_Tree (External_Final_List),
+ With_Attach => New_Copy_Tree (Attach)));
+ end if;
+
-- Initialize the internal controllers for tagged types with
-- more than one controller.
@@ -2008,9 +2066,11 @@ package body Exp_Aggr is
Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)),
Selector_Name =>
Make_Identifier (Loc, Name_uController));
- F := Make_Selected_Component (Loc,
- Prefix => F,
- Selector_Name => Make_Identifier (Loc, Name_F));
+ F :=
+ Make_Selected_Component (Loc,
+ Prefix => F,
+ Selector_Name => Make_Identifier (Loc, Name_F));
+
Append_List_To (Start_L,
Init_Controller (
Target => Target,
@@ -2027,7 +2087,7 @@ package body Exp_Aggr is
Inner_Typ := Etype (Inner_Typ);
end loop;
- -- if not done yet attach the controller of the ancestor part
+ -- If not done yet attach the controller of the ancestor part
if Outer_Typ /= Init_Typ
and then Inner_Typ = Init_Typ
@@ -2037,9 +2097,10 @@ package body Exp_Aggr is
Make_Selected_Component (Loc,
Prefix => Convert_To (Outer_Typ, New_Copy_Tree (Target)),
Selector_Name => Make_Identifier (Loc, Name_uController));
- F := Make_Selected_Component (Loc,
- Prefix => F,
- Selector_Name => Make_Identifier (Loc, Name_F));
+ F :=
+ Make_Selected_Component (Loc,
+ Prefix => F,
+ Selector_Name => Make_Identifier (Loc, Name_F));
Attach := Make_Integer_Literal (Loc, 1);
Append_List_To (Start_L,
@@ -2065,8 +2126,11 @@ package body Exp_Aggr is
Loc : constant Source_Ptr := Sloc (Aggr);
Typ : constant Entity_Id := Etype (Aggr);
Temp : constant Entity_Id := Defining_Identifier (Decl);
- Occ : constant Node_Id := Unchecked_Convert_To (Typ,
- Make_Explicit_Dereference (Loc, New_Reference_To (Temp, Loc)));
+
+ Occ : constant Node_Id :=
+ Unchecked_Convert_To (Typ,
+ Make_Explicit_Dereference (Loc,
+ New_Reference_To (Temp, Loc)));
Access_Type : constant Entity_Id := Etype (Temp);
@@ -2082,7 +2146,7 @@ package body Exp_Aggr is
--------------------------------
procedure Convert_Aggr_In_Assignment (N : Node_Id) is
- Aggr : Node_Id := Expression (N);
+ Aggr : Node_Id := Expression (N);
Typ : constant Entity_Id := Etype (Aggr);
Occ : constant Node_Id := New_Copy_Tree (Name (N));
@@ -2102,11 +2166,82 @@ package body Exp_Aggr is
procedure Convert_Aggr_In_Object_Decl (N : Node_Id) is
Obj : constant Entity_Id := Defining_Identifier (N);
- Aggr : Node_Id := Expression (N);
+ Aggr : Node_Id := Expression (N);
Loc : constant Source_Ptr := Sloc (Aggr);
Typ : constant Entity_Id := Etype (Aggr);
Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc);
+ function Discriminants_Ok return Boolean;
+ -- If the object type is constrained, the discriminants in the
+ -- aggregate must be checked against the discriminants of the subtype.
+ -- This cannot be done using Apply_Discriminant_Checks because after
+ -- expansion there is no aggregate left to check.
+
+ ----------------------
+ -- Discriminants_Ok --
+ ----------------------
+
+ function Discriminants_Ok return Boolean is
+ Cond : Node_Id := Empty;
+ Check : Node_Id;
+ D : Entity_Id;
+ Disc1 : Elmt_Id;
+ Disc2 : Elmt_Id;
+ Val1 : Node_Id;
+ Val2 : Node_Id;
+
+ begin
+ D := First_Discriminant (Typ);
+ Disc1 := First_Elmt (Discriminant_Constraint (Typ));
+ Disc2 := First_Elmt (Discriminant_Constraint (Etype (Obj)));
+
+ while Present (Disc1) and then Present (Disc2) loop
+ Val1 := Node (Disc1);
+ Val2 := Node (Disc2);
+
+ if not Is_OK_Static_Expression (Val1)
+ or else not Is_OK_Static_Expression (Val2)
+ then
+ Check := Make_Op_Ne (Loc,
+ Left_Opnd => Duplicate_Subexpr (Val1),
+ Right_Opnd => Duplicate_Subexpr (Val2));
+
+ if No (Cond) then
+ Cond := Check;
+
+ else
+ Cond := Make_Or_Else (Loc,
+ Left_Opnd => Cond,
+ Right_Opnd => Check);
+ end if;
+
+ elsif Expr_Value (Val1) /= Expr_Value (Val2) then
+ Apply_Compile_Time_Constraint_Error (Aggr,
+ Msg => "incorrect value for discriminant&?",
+ Reason => CE_Discriminant_Check_Failed,
+ Ent => D);
+ return False;
+ end if;
+
+ Next_Discriminant (D);
+ Next_Elmt (Disc1);
+ Next_Elmt (Disc2);
+ end loop;
+
+ -- If any discriminant constraint is non-static, emit a check.
+
+ if Present (Cond) then
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition => Cond,
+ Reason => CE_Discriminant_Check_Failed));
+ end if;
+
+ return True;
+ end Discriminants_Ok;
+
+ -- Start of processing for Convert_Aggr_In_Object_Decl
+
begin
Set_Assignment_OK (Occ);
@@ -2114,6 +2249,14 @@ package body Exp_Aggr is
Aggr := Expression (Aggr);
end if;
+ if Has_Discriminants (Typ)
+ and then Typ /= Etype (Obj)
+ and then Is_Constrained (Etype (Obj))
+ and then not Discriminants_Ok
+ then
+ return;
+ end if;
+
Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ, Obj => Obj));
Set_No_Initialization (N);
Initialize_Discriminants (N, Typ);
@@ -2127,14 +2270,13 @@ package body Exp_Aggr is
Loc : constant Source_Ptr := Sloc (N);
Temp : Entity_Id;
- Instr : Node_Id;
- Target_Expr : Node_Id;
- Parent_Kind : Node_Kind;
- Unc_Decl : Boolean := False;
- Parent_Node : Node_Id;
+ Instr : Node_Id;
+ Target_Expr : Node_Id;
+ Parent_Kind : Node_Kind;
+ Unc_Decl : Boolean := False;
+ Parent_Node : Node_Id;
begin
-
Parent_Node := Parent (N);
Parent_Kind := Nkind (Parent_Node);
@@ -2147,24 +2289,26 @@ package body Exp_Aggr is
begin
Parent_Node := Parent (Parent_Node);
Parent_Kind := Nkind (Parent_Node);
+
if Parent_Kind = N_Object_Declaration then
Unc_Decl :=
not Is_Entity_Name (Object_Definition (Parent_Node))
- or else Has_Discriminants (
- Entity (Object_Definition (Parent_Node)))
- or else Is_Class_Wide_Type (
- Entity (Object_Definition (Parent_Node)));
+ or else Has_Discriminants
+ (Entity (Object_Definition (Parent_Node)))
+ or else Is_Class_Wide_Type
+ (Entity (Object_Definition (Parent_Node)));
end if;
end;
end if;
-- Just set the Delay flag in the following cases where the
-- transformation will be done top down from above
+
-- - internal aggregate (transformed when expanding the parent)
-- - allocators (see Convert_Aggr_In_Allocator)
-- - object decl (see Convert_Aggr_In_Object_Decl)
-- - safe assignments (see Convert_Aggr_Assignments)
- -- so far only the assignments in the init_procs are taken
+ -- so far only the assignments in the init procs are taken
-- into account
if Parent_Kind = N_Aggregate
@@ -2209,231 +2353,316 @@ package body Exp_Aggr is
procedure Convert_To_Positional
(N : Node_Id;
- Max_Others_Replicate : Nat := 5;
+ Max_Others_Replicate : Nat := 5;
Handle_Bit_Packed : Boolean := False)
is
- Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Ndim : constant Pos := Number_Dimensions (Typ);
- Xtyp : constant Entity_Id := Etype (First_Index (Typ));
- Indx : constant Node_Id := First_Index (Base_Type (Typ));
- Blo : constant Node_Id := Type_Low_Bound (Etype (Indx));
- Lo : constant Node_Id := Type_Low_Bound (Xtyp);
- Hi : constant Node_Id := Type_High_Bound (Xtyp);
- Lov : Uint;
- Hiv : Uint;
-
- -- The following constant determines the maximum size of an
- -- aggregate produced by converting named to positional
- -- notation (e.g. from others clauses). This avoids running
- -- away with attempts to convert huge aggregates.
-
- -- The normal limit is 5000, but we increase this limit to
- -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code)
- -- or Restrictions (No_Implicit_Loops) is specified, since in
- -- either case, we are at risk of declaring the program illegal
- -- because of this limit.
-
- Max_Aggr_Size : constant Nat :=
- 5000 + (2 ** 24 - 5000) * Boolean'Pos
- (Restrictions (No_Elaboration_Code)
- or else
- Restrictions (No_Implicit_Loops));
+ Typ : constant Entity_Id := Etype (N);
- begin
- -- For now, we only handle the one dimensional case and aggregates
- -- that are not part of a component_association
+ function Flatten
+ (N : Node_Id;
+ Ix : Node_Id;
+ Ixb : Node_Id)
+ return Boolean;
+ -- Convert the aggregate into a purely positional form if possible.
+
+ function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
+ -- Non trivial for multidimensional aggregate.
+
+ -------------
+ -- Flatten --
+ -------------
+
+ function Flatten
+ (N : Node_Id;
+ Ix : Node_Id;
+ Ixb : Node_Id)
+ return Boolean
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Blo : constant Node_Id := Type_Low_Bound (Etype (Ixb));
+ Lo : constant Node_Id := Type_Low_Bound (Etype (Ix));
+ Hi : constant Node_Id := Type_High_Bound (Etype (Ix));
+ Lov : Uint;
+ Hiv : Uint;
+
+ -- The following constant determines the maximum size of an
+ -- aggregate produced by converting named to positional
+ -- notation (e.g. from others clauses). This avoids running
+ -- away with attempts to convert huge aggregates.
+
+ -- The normal limit is 5000, but we increase this limit to
+ -- 2**24 (about 16 million) if Restrictions (No_Elaboration_Code)
+ -- or Restrictions (No_Implicit_Loops) is specified, since in
+ -- either case, we are at risk of declaring the program illegal
+ -- because of this limit.
+
+ Max_Aggr_Size : constant Nat :=
+ 5000 + (2 ** 24 - 5000) * Boolean'Pos
+ (Restrictions (No_Elaboration_Code)
+ or else
+ Restrictions (No_Implicit_Loops));
+ begin
- if Ndim > 1 or else Nkind (Parent (N)) = N_Aggregate
- or else Nkind (Parent (N)) = N_Component_Association
- then
- return;
- end if;
+ if Nkind (Original_Node (N)) = N_String_Literal then
+ return True;
+ end if;
- -- If already positional, nothing to do!
+ -- Bounds need to be known at compile time
- if No (Component_Associations (N)) then
- return;
- end if;
+ if not Compile_Time_Known_Value (Lo)
+ or else not Compile_Time_Known_Value (Hi)
+ then
+ return False;
+ end if;
- -- Bounds need to be known at compile time
+ -- Get bounds and check reasonable size (positive, not too large)
+ -- Also only handle bounds starting at the base type low bound
+ -- for now since the compiler isn't able to handle different low
+ -- bounds yet. Case such as new String'(3..5 => ' ') will get
+ -- the wrong bounds, though it seems that the aggregate should
+ -- retain the bounds set on its Etype (see C64103E and CC1311B).
- if not Compile_Time_Known_Value (Lo)
- or else not Compile_Time_Known_Value (Hi)
- then
- return;
- end if;
+ Lov := Expr_Value (Lo);
+ Hiv := Expr_Value (Hi);
- -- Normally we do not attempt to convert bit packed arrays. The
- -- exception is when we are explicitly asked to do so (this call
- -- is from the Packed_Array_Aggregate_Handled procedure).
+ if Hiv < Lov
+ or else (Hiv - Lov > Max_Aggr_Size)
+ or else not Compile_Time_Known_Value (Blo)
+ or else (Lov /= Expr_Value (Blo))
+ then
+ return False;
+ end if;
- if Is_Bit_Packed_Array (Typ)
- and then not Handle_Bit_Packed
- then
- return;
- end if;
+ -- Bounds must be in integer range (for array Vals below)
- -- Do not convert to positional if controlled components are
- -- involved since these require special processing
+ if not UI_Is_In_Int_Range (Lov)
+ or else
+ not UI_Is_In_Int_Range (Hiv)
+ then
+ return False;
+ end if;
- if Has_Controlled_Component (Typ) then
- return;
- end if;
+ -- Determine if set of alternatives is suitable for conversion
+ -- and build an array containing the values in sequence.
- -- Get bounds and check reasonable size (positive, not too large)
- -- Also only handle bounds starting at the base type low bound for now
- -- since the compiler isn't able to handle different low bounds yet.
+ declare
+ Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv))
+ of Node_Id := (others => Empty);
+ -- The values in the aggregate sorted appropriately
- Lov := Expr_Value (Lo);
- Hiv := Expr_Value (Hi);
+ Vlist : List_Id;
+ -- Same data as Vals in list form
- if Hiv < Lov
- or else (Hiv - Lov > Max_Aggr_Size)
- or else not Compile_Time_Known_Value (Blo)
- or else (Lov /= Expr_Value (Blo))
- then
- return;
- end if;
+ Rep_Count : Nat;
+ -- Used to validate Max_Others_Replicate limit
- -- Bounds must be in integer range (for array Vals below)
+ Elmt : Node_Id;
+ Num : Int := UI_To_Int (Lov);
+ Choice : Node_Id;
+ Lo, Hi : Node_Id;
- if not UI_Is_In_Int_Range (Lov)
- or else
- not UI_Is_In_Int_Range (Hiv)
- then
- return;
- end if;
+ begin
+ if Present (Expressions (N)) then
+ Elmt := First (Expressions (N));
+
+ while Present (Elmt) loop
+ if Nkind (Elmt) = N_Aggregate
+ and then Present (Next_Index (Ix))
+ and then
+ not Flatten (Elmt, Next_Index (Ix), Next_Index (Ixb))
+ then
+ return False;
+ end if;
- -- Determine if set of alternatives is suitable for conversion
- -- and build an array containing the values in sequence.
+ Vals (Num) := Relocate_Node (Elmt);
+ Num := Num + 1;
- declare
- Vals : array (UI_To_Int (Lov) .. UI_To_Int (Hiv))
- of Node_Id := (others => Empty);
- -- The values in the aggregate sorted appropriately
+ Next (Elmt);
+ end loop;
+ end if;
- Vlist : List_Id;
- -- Same data as Vals in list form
+ if No (Component_Associations (N)) then
+ return True;
+ end if;
- Rep_Count : Nat;
- -- Used to validate Max_Others_Replicate limit
+ Elmt := First (Component_Associations (N));
- Elmt : Node_Id;
- Num : Int := UI_To_Int (Lov);
- Choice : Node_Id;
- Lo, Hi : Node_Id;
+ if Nkind (Expression (Elmt)) = N_Aggregate then
+ if Present (Next_Index (Ix))
+ and then
+ not Flatten
+ (Expression (Elmt), Next_Index (Ix), Next_Index (Ixb))
+ then
+ return False;
+ end if;
+ end if;
- begin
- if Present (Expressions (N)) then
- Elmt := First (Expressions (N));
- while Present (Elmt) loop
- Vals (Num) := Relocate_Node (Elmt);
- Num := Num + 1;
- Next (Elmt);
- end loop;
- end if;
+ Component_Loop : while Present (Elmt) loop
+ Choice := First (Choices (Elmt));
+ Choice_Loop : while Present (Choice) loop
+
+ -- If we have an others choice, fill in the missing elements
+ -- subject to the limit established by Max_Others_Replicate.
+
+ if Nkind (Choice) = N_Others_Choice then
+ Rep_Count := 0;
+
+ for J in Vals'Range loop
+ if No (Vals (J)) then
+ Vals (J) := New_Copy_Tree (Expression (Elmt));
+ Rep_Count := Rep_Count + 1;
+
+ -- Check for maximum others replication. Note that
+ -- we skip this test if either of the restrictions
+ -- No_Elaboration_Code or No_Implicit_Loops is
+ -- active, or if this is a preelaborable unit.
+
+ declare
+ P : constant Entity_Id :=
+ Cunit_Entity (Current_Sem_Unit);
+
+ begin
+ if Restrictions (No_Elaboration_Code)
+ or else Restrictions (No_Implicit_Loops)
+ or else Is_Preelaborated (P)
+ or else (Ekind (P) = E_Package_Body
+ and then
+ Is_Preelaborated (Spec_Entity (P)))
+ then
+ null;
+ elsif Rep_Count > Max_Others_Replicate then
+ return False;
+ end if;
+ end;
+ end if;
+ end loop;
- Elmt := First (Component_Associations (N));
- Component_Loop : while Present (Elmt) loop
+ exit Component_Loop;
- Choice := First (Choices (Elmt));
- Choice_Loop : while Present (Choice) loop
+ -- Case of a subtype mark
- -- If we have an others choice, fill in the missing elements
- -- subject to the limit established by Max_Others_Replicate.
+ elsif Nkind (Choice) = N_Identifier
+ and then Is_Type (Entity (Choice))
+ then
+ Lo := Type_Low_Bound (Etype (Choice));
+ Hi := Type_High_Bound (Etype (Choice));
- if Nkind (Choice) = N_Others_Choice then
- Rep_Count := 0;
+ -- Case of subtype indication
- for J in Vals'Range loop
- if No (Vals (J)) then
- Vals (J) := New_Copy_Tree (Expression (Elmt));
- Rep_Count := Rep_Count + 1;
-
- -- Check for maximum others replication. Note that
- -- we skip this test if either of the restrictions
- -- No_Elaboration_Code or No_Implicit_Loops is
- -- active, or if this is a preelaborable unit.
-
- if Rep_Count > Max_Others_Replicate
- and then not Restrictions (No_Elaboration_Code)
- and then not Restrictions (No_Implicit_Loops)
- and then not
- Is_Preelaborated (Cunit_Entity (Current_Sem_Unit))
- then
- return;
- end if;
+ elsif Nkind (Choice) = N_Subtype_Indication then
+ Lo := Low_Bound (Range_Expression (Constraint (Choice)));
+ Hi := High_Bound (Range_Expression (Constraint (Choice)));
+
+ -- Case of a range
+
+ elsif Nkind (Choice) = N_Range then
+ Lo := Low_Bound (Choice);
+ Hi := High_Bound (Choice);
+
+ -- Normal subexpression case
+
+ else pragma Assert (Nkind (Choice) in N_Subexpr);
+ if not Compile_Time_Known_Value (Choice) then
+ return False;
+
+ else
+ Vals (UI_To_Int (Expr_Value (Choice))) :=
+ New_Copy_Tree (Expression (Elmt));
+ goto Continue;
end if;
- end loop;
+ end if;
+
+ -- Range cases merge with Lo,Hi said
+
+ if not Compile_Time_Known_Value (Lo)
+ or else
+ not Compile_Time_Known_Value (Hi)
+ then
+ return False;
+ else
+ for J in UI_To_Int (Expr_Value (Lo)) ..
+ UI_To_Int (Expr_Value (Hi))
+ loop
+ Vals (J) := New_Copy_Tree (Expression (Elmt));
+ end loop;
+ end if;
- exit Component_Loop;
+ <<Continue>>
+ Next (Choice);
+ end loop Choice_Loop;
- -- Case of a subtype mark
+ Next (Elmt);
+ end loop Component_Loop;
- elsif (Nkind (Choice) = N_Identifier
- and then Is_Type (Entity (Choice)))
- then
- Lo := Type_Low_Bound (Etype (Choice));
- Hi := Type_High_Bound (Etype (Choice));
+ -- If we get here the conversion is possible
- -- Case of subtype indication
+ Vlist := New_List;
+ for J in Vals'Range loop
+ Append (Vals (J), Vlist);
+ end loop;
- elsif Nkind (Choice) = N_Subtype_Indication then
- Lo := Low_Bound (Range_Expression (Constraint (Choice)));
- Hi := High_Bound (Range_Expression (Constraint (Choice)));
+ Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist));
+ Set_Aggregate_Bounds (N, Aggregate_Bounds (Original_Node (N)));
+ return True;
+ end;
+ end Flatten;
- -- Case of a range
+ -------------
+ -- Is_Flat --
+ -------------
- elsif Nkind (Choice) = N_Range then
- Lo := Low_Bound (Choice);
- Hi := High_Bound (Choice);
+ function Is_Flat (N : Node_Id; Dims : Int) return Boolean is
+ Elmt : Node_Id;
- -- Normal subexpression case
+ begin
+ if Dims = 0 then
+ return True;
- else pragma Assert (Nkind (Choice) in N_Subexpr);
- if not Compile_Time_Known_Value (Choice) then
- return;
+ elsif Nkind (N) = N_Aggregate then
+ if Present (Component_Associations (N)) then
+ return False;
- else
- Vals (UI_To_Int (Expr_Value (Choice))) :=
- New_Copy_Tree (Expression (Elmt));
- goto Continue;
+ else
+ Elmt := First (Expressions (N));
+
+ while Present (Elmt) loop
+ if not Is_Flat (Elmt, Dims - 1) then
+ return False;
end if;
- end if;
- -- Range cases merge with Lo,Hi said
+ Next (Elmt);
+ end loop;
- if not Compile_Time_Known_Value (Lo)
- or else
- not Compile_Time_Known_Value (Hi)
- then
- return;
- else
- for J in UI_To_Int (Expr_Value (Lo)) ..
- UI_To_Int (Expr_Value (Hi))
- loop
- Vals (J) := New_Copy_Tree (Expression (Elmt));
- end loop;
- end if;
+ return True;
+ end if;
+ else
+ return True;
+ end if;
+ end Is_Flat;
- <<Continue>>
- Next (Choice);
- end loop Choice_Loop;
+ -- Start of processing for Convert_To_Positional
- Next (Elmt);
- end loop Component_Loop;
+ begin
+ if Is_Flat (N, Number_Dimensions (Typ)) then
+ return;
+ end if;
+
+ if Is_Bit_Packed_Array (Typ)
+ and then not Handle_Bit_Packed
+ then
+ return;
+ end if;
- -- If we get here the conversion is possible
+ -- Do not convert to positional if controlled components are
+ -- involved since these require special processing
- Vlist := New_List;
- for J in Vals'Range loop
- Append (Vals (J), Vlist);
- end loop;
+ if Has_Controlled_Component (Typ) then
+ return;
+ end if;
- Rewrite (N, Make_Aggregate (Loc, Expressions => Vlist));
+ if Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ))) then
Analyze_And_Resolve (N, Typ);
- end;
+ end if;
end Convert_To_Positional;
----------------------------
@@ -2454,11 +2683,17 @@ package body Exp_Aggr is
-- (c) For multidimensional arrays make sure that all subaggregates
-- corresponding to the same dimension have the same bounds.
- -- 2. Check if the aggregate can be statically processed. If this is the
+ -- 2. Check for packed array aggregate which can be converted to a
+ -- constant so that the aggregate disappeares completely.
+
+ -- 3. Check case of nested aggregate. Generally nested aggregates are
+ -- handled during the processing of the parent aggregate.
+
+ -- 4. Check if the aggregate can be statically processed. If this is the
-- case pass it as is to Gigi. Note that a necessary condition for
-- static processing is that the aggregate be fully positional.
- -- 3. If in place aggregate expansion is possible (i.e. no need to create
+ -- 5. If in place aggregate expansion is possible (i.e. no need to create
-- a temporary) then mark the aggregate as such and return. Otherwise
-- create a new temporary and generate the appropriate initialization
-- code.
@@ -2522,6 +2757,14 @@ package body Exp_Aggr is
-- be done in place, because none of the new values can depend on the
-- components of the target of the assignment.
+ function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean;
+ -- A static aggregate in an object declaration can in most cases be
+ -- expanded in place. The one exception is when the aggregate is given
+ -- with component associations that specify different bounds from those
+ -- of the type definition in the object declaration. In this rather
+ -- pathological case the aggregate must slide, and we must introduce
+ -- an intermediate temporary to hold it.
+
procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos);
-- Checks that if an others choice is present in any sub-aggregate no
-- aggregate index is outside the bounds of the index constraint.
@@ -2533,14 +2776,14 @@ package body Exp_Aggr is
----------------------------
procedure Build_Constrained_Type (Positional : Boolean) is
- Loc : constant Source_Ptr := Sloc (N);
- Agg_Type : Entity_Id;
- Comp : Node_Id;
- Decl : Node_Id;
- Typ : constant Entity_Id := Etype (N);
- Indices : List_Id := New_List;
- Num : Int;
- Sub_Agg : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Agg_Type : Entity_Id;
+ Comp : Node_Id;
+ Decl : Node_Id;
+ Typ : constant Entity_Id := Etype (N);
+ Indices : constant List_Id := New_List;
+ Num : Int;
+ Sub_Agg : Node_Id;
begin
Agg_Type :=
@@ -2574,7 +2817,6 @@ package body Exp_Aggr is
end loop;
else
-
-- We know the aggregate type is unconstrained and the
-- aggregate is not processable by the back end, therefore
-- not necessarily positional. Retrieve the bounds of each
@@ -2637,22 +2879,22 @@ package body Exp_Aggr is
elsif Aggr_Hi = Ind_Hi then
Cond :=
Make_Op_Lt (Loc,
- Left_Opnd => Duplicate_Subexpr (Aggr_Lo),
- Right_Opnd => Duplicate_Subexpr (Ind_Lo));
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo));
elsif Aggr_Lo = Ind_Lo then
Cond :=
Make_Op_Gt (Loc,
- Left_Opnd => Duplicate_Subexpr (Aggr_Hi),
- Right_Opnd => Duplicate_Subexpr (Ind_Hi));
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Hi));
else
Cond :=
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Lt (Loc,
- Left_Opnd => Duplicate_Subexpr (Aggr_Lo),
- Right_Opnd => Duplicate_Subexpr (Ind_Lo)),
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Ind_Lo)),
Right_Opnd =>
Make_Op_Gt (Loc,
@@ -2665,8 +2907,8 @@ package body Exp_Aggr is
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Le (Loc,
- Left_Opnd => Duplicate_Subexpr (Aggr_Lo),
- Right_Opnd => Duplicate_Subexpr (Aggr_Hi)),
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi)),
Right_Opnd => Cond);
@@ -2695,10 +2937,10 @@ package body Exp_Aggr is
Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
-- The index type for this dimension.
- Cond : Node_Id := Empty;
+ Cond : Node_Id := Empty;
- Assoc : Node_Id;
- Expr : Node_Id;
+ Assoc : Node_Id;
+ Expr : Node_Id;
begin
-- If index checks are on generate the test
@@ -2722,22 +2964,22 @@ package body Exp_Aggr is
elsif Aggr_Hi = Sub_Hi then
Cond :=
Make_Op_Ne (Loc,
- Left_Opnd => Duplicate_Subexpr (Aggr_Lo),
- Right_Opnd => Duplicate_Subexpr (Sub_Lo));
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo));
elsif Aggr_Lo = Sub_Lo then
Cond :=
Make_Op_Ne (Loc,
- Left_Opnd => Duplicate_Subexpr (Aggr_Hi),
- Right_Opnd => Duplicate_Subexpr (Sub_Hi));
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Hi),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Hi));
else
Cond :=
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Ne (Loc,
- Left_Opnd => Duplicate_Subexpr (Aggr_Lo),
- Right_Opnd => Duplicate_Subexpr (Sub_Lo)),
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo),
+ Right_Opnd => Duplicate_Subexpr_Move_Checks (Sub_Lo)),
Right_Opnd =>
Make_Op_Ne (Loc,
@@ -2784,8 +3026,8 @@ package body Exp_Aggr is
----------------------------
procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos) is
- Assoc : Node_Id;
- Expr : Node_Id;
+ Assoc : Node_Id;
+ Expr : Node_Id;
begin
if Present (Component_Associations (Sub_Aggr)) then
@@ -2823,17 +3065,16 @@ package body Exp_Aggr is
end if;
end Compute_Others_Present;
- -------------------------
- -- Has_Address_Clause --
- -------------------------
+ ------------------------
+ -- Has_Address_Clause --
+ ------------------------
function Has_Address_Clause (D : Node_Id) return Boolean is
- Id : Entity_Id := Defining_Identifier (D);
+ Id : constant Entity_Id := Defining_Identifier (D);
Decl : Node_Id := Next (D);
begin
while Present (Decl) loop
-
if Nkind (Decl) = N_At_Clause
and then Chars (Identifier (Decl)) = Chars (Id)
then
@@ -2943,6 +3184,10 @@ package body Exp_Aggr is
function Check_Component (Comp : Node_Id) return Boolean;
-- Do the recursive traversal, after copy.
+ ---------------------
+ -- Check_Component --
+ ---------------------
+
function Check_Component (Comp : Node_Id) return Boolean is
begin
if Is_Overloaded (Comp) then
@@ -2969,7 +3214,7 @@ package body Exp_Aggr is
and then Check_Component (Prefix (Comp)));
end Check_Component;
- -- Start of processing for Safe_Component
+ -- Start of processing for Safe_Component
begin
-- If the component appears in an association that may
@@ -3052,6 +3297,49 @@ package body Exp_Aggr is
return Safe_Aggregate (N);
end In_Place_Assign_OK;
+ ----------------
+ -- Must_Slide --
+ ----------------
+
+ function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean
+ is
+ Obj_Type : Entity_Id := Etype (Defining_Identifier (Parent (N)));
+
+ L1, L2, H1, H2 : Node_Id;
+
+ begin
+ -- No sliding if the type of the object is not established yet, if
+ -- it is an unconstrained type whose actual subtype comes from the
+ -- aggregate, or if the two types are identical.
+
+ if not Is_Array_Type (Obj_Type) then
+ return False;
+
+ elsif not Is_Constrained (Obj_Type) then
+ return False;
+
+ elsif Typ = Obj_Type then
+ return False;
+
+ else
+ -- Sliding can only occur along the first dimension
+
+ Get_Index_Bounds (First_Index (Typ), L1, H1);
+ Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
+
+ if not Is_Static_Expression (L1)
+ or else not Is_Static_Expression (L2)
+ or else not Is_Static_Expression (H1)
+ or else not Is_Static_Expression (H2)
+ then
+ return False;
+ else
+ return Expr_Value (L1) /= Expr_Value (L2)
+ or else Expr_Value (H1) /= Expr_Value (H2);
+ end if;
+ end if;
+ end Must_Slide;
+
------------------
-- Others_Check --
------------------
@@ -3204,14 +3492,16 @@ package body Exp_Aggr is
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Pos,
Expressions =>
- New_List (Duplicate_Subexpr (Aggr_Lo))),
+ New_List
+ (Duplicate_Subexpr_Move_Checks (Aggr_Lo))),
Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Pos,
- Expressions => New_List (Duplicate_Subexpr (Aggr_Hi))));
+ Expressions => New_List (
+ Duplicate_Subexpr_Move_Checks (Aggr_Hi))));
-- If we are dealing with an aggregate containing an others
-- choice and discrete choices we generate the following test:
@@ -3224,13 +3514,17 @@ package body Exp_Aggr is
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Lt (Loc,
- Left_Opnd => Duplicate_Subexpr (Choices_Lo),
- Right_Opnd => Duplicate_Subexpr (Aggr_Lo)),
+ Left_Opnd =>
+ Duplicate_Subexpr_Move_Checks (Choices_Lo),
+ Right_Opnd =>
+ Duplicate_Subexpr_Move_Checks (Aggr_Lo)),
Right_Opnd =>
Make_Op_Gt (Loc,
- Left_Opnd => Duplicate_Subexpr (Choices_Hi),
- Right_Opnd => Duplicate_Subexpr (Aggr_Hi)));
+ Left_Opnd =>
+ Duplicate_Subexpr (Choices_Hi),
+ Right_Opnd =>
+ Duplicate_Subexpr (Aggr_Hi)));
end if;
if Present (Cond) then
@@ -3270,10 +3564,10 @@ package body Exp_Aggr is
-- Remaining Expand_Array_Aggregate variables
Tmp : Entity_Id;
- -- Holds the temporary aggregate value.
+ -- Holds the temporary aggregate value
Tmp_Decl : Node_Id;
- -- Holds the declaration of Tmp.
+ -- Holds the declaration of Tmp
Aggr_Code : List_Id;
Parent_Node : Node_Id;
@@ -3297,7 +3591,10 @@ package body Exp_Aggr is
pragma Assert (not Raises_Constraint_Error (N));
- -- STEP 1: Check (a)
+ -- STEP 1a.
+
+ -- Check that the index range defined by aggregate bounds is
+ -- compatible with corresponding index subtype.
Index_Compatibility_Check : declare
Aggr_Index_Range : Node_Id := First_Index (Typ);
@@ -3342,11 +3639,17 @@ package body Exp_Aggr is
end loop;
end Index_Compatibility_Check;
- -- STEP 1: Check (b)
+ -- STEP 1b.
+
+ -- If an others choice is present check that no aggregate
+ -- index is outside the bounds of the index constraint.
Others_Check (N, 1);
- -- STEP 1: Check (c)
+ -- STEP 1c.
+
+ -- For multidimensional arrays make sure that all subaggregates
+ -- corresponding to the same dimension have the same bounds.
if Aggr_Dimension > 1 then
Check_Same_Aggr_Bounds (N, 1);
@@ -3354,23 +3657,37 @@ package body Exp_Aggr is
-- STEP 2.
- -- First try to convert to positional form. If the result is not
- -- an aggregate any more, then we are done with the analysis (it
- -- it could be a string literal or an identifier for a temporary
- -- variable following this call). If result is an analyzed aggregate
- -- the transformation was also successful and we are done as well.
+ -- Here we test for is packed array aggregate that we can handle
+ -- at compile time. If so, return with transformation done. Note
+ -- that we do this even if the aggregate is nested, because once
+ -- we have done this processing, there is no more nested aggregate!
+
+ if Packed_Array_Aggregate_Handled (N) then
+ return;
+ end if;
+
+ -- At this point we try to convert to positional form
Convert_To_Positional (N);
+ -- if the result is no longer an aggregate (e.g. it may be a string
+ -- literal, or a temporary which has the needed value), then we are
+ -- done, since there is no longer a nested aggregate.
+
if Nkind (N) /= N_Aggregate then
return;
+ -- We are also done if the result is an analyzed aggregate
+ -- This case could use more comments ???
+
elsif Analyzed (N)
and then N /= Original_Node (N)
then
return;
end if;
+ -- Now see if back end processing is possible
+
if Backend_Processing_Possible (N) then
-- If the aggregate is static but the constraints are not, build
@@ -3405,6 +3722,8 @@ package body Exp_Aggr is
return;
end if;
+ -- STEP 3.
+
-- Delay expansion for nested aggregates it will be taken care of
-- when the parent aggregate is expanded
@@ -3428,17 +3747,10 @@ package body Exp_Aggr is
return;
end if;
- -- STEP 3.
+ -- STEP 4.
-- Look if in place aggregate expansion is possible
- -- First case to test for is packed array aggregate that we can
- -- handle at compile time. If so, return with transformation done.
-
- if Packed_Array_Aggregate_Handled (N) then
- return;
- end if;
-
-- For object declarations we build the aggregate in place, unless
-- the array is bit-packed or the component is controlled.
@@ -3461,6 +3773,7 @@ package body Exp_Aggr is
if Comes_From_Source (Parent (N))
and then Nkind (Parent (N)) = N_Object_Declaration
+ and then not Must_Slide (N, Typ)
and then N = Expression (Parent (N))
and then not Is_Bit_Packed_Array (Typ)
and then not Has_Controlled_Component (Typ)
@@ -3494,6 +3807,13 @@ package body Exp_Aggr is
if Etype (Tmp) /= Etype (N) then
Apply_Length_Check (N, Etype (Tmp));
+
+ if Nkind (N) = N_Raise_Constraint_Error then
+
+ -- Static error, nothing further to expand
+
+ return;
+ end if;
end if;
elsif Maybe_In_Place_OK
@@ -3514,6 +3834,10 @@ package body Exp_Aggr is
return;
+ -- Step 5
+
+ -- In place aggregate expansion is not possible
+
else
Maybe_In_Place_OK := False;
Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
@@ -3597,6 +3921,10 @@ package body Exp_Aggr is
else
Expand_Array_Aggregate (N);
end if;
+
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_N_Aggregate;
----------------------------------
@@ -3616,7 +3944,7 @@ package body Exp_Aggr is
Typ : constant Entity_Id := Etype (N);
begin
- -- If the ancestor is a subtype mark, an init_proc must be called
+ -- If the ancestor is a subtype mark, an init proc must be called
-- on the resulting object which thus has to be materialized in
-- the front-end
@@ -3643,6 +3971,10 @@ package body Exp_Aggr is
Parent_Expr => A);
end if;
end if;
+
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_N_Extension_Aggregate;
-----------------------------
@@ -3654,10 +3986,10 @@ package body Exp_Aggr is
Orig_Tag : Node_Id := Empty;
Parent_Expr : Node_Id := Empty)
is
- Loc : constant Source_Ptr := Sloc (N);
- Comps : constant List_Id := Component_Associations (N);
- Typ : constant Entity_Id := Etype (N);
- Base_Typ : constant Entity_Id := Base_Type (Typ);
+ Loc : constant Source_Ptr := Sloc (N);
+ Comps : constant List_Id := Component_Associations (N);
+ Typ : constant Entity_Id := Etype (N);
+ Base_Typ : constant Entity_Id := Base_Type (Typ);
function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean;
-- Checks the presence of a nested aggregate which needs Late_Expansion
@@ -3668,7 +4000,7 @@ package body Exp_Aggr is
--------------------------------------------------
function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean is
- C : Node_Id;
+ C : Node_Id;
Expr_Q : Node_Id;
begin
@@ -3678,7 +4010,6 @@ package body Exp_Aggr is
C := First (Comps);
while Present (C) loop
-
if Nkind (Expression (C)) = N_Qualified_Expression then
Expr_Q := Expression (Expression (C));
else
@@ -3710,7 +4041,7 @@ package body Exp_Aggr is
end loop;
return False;
- end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps;
+ end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps;
-- Remaining Expand_Record_Aggregate variables
@@ -3721,6 +4052,21 @@ package body Exp_Aggr is
-- Start of processing for Expand_Record_Aggregate
begin
+ -- If the aggregate is to be assigned to an atomic variable, we
+ -- have to prevent a piecemeal assignment even if the aggregate
+ -- is to be expanded. We create a temporary for the aggregate, and
+ -- assign the temporary instead, so that the back end can generate
+ -- an atomic move for it.
+
+ if Is_Atomic (Typ)
+ and then (Nkind (Parent (N)) = N_Object_Declaration
+ or else Nkind (Parent (N)) = N_Assignment_Statement)
+ and then Comes_From_Source (Parent (N))
+ then
+ Expand_Atomic_Aggregate (N, Typ);
+ return;
+ end if;
+
-- Gigi doesn't handle properly temporaries of variable size
-- so we generate it in the front-end
@@ -3751,6 +4097,14 @@ package body Exp_Aggr is
elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
Convert_To_Assignments (N, Typ);
+ -- If some components are mutable, the size of the aggregate component
+ -- may be disctinct from the default size of the type component, so
+ -- we need to expand to insure that the back-end copies the proper
+ -- size of the data.
+
+ elsif Has_Mutable_Components (Typ) then
+ Convert_To_Assignments (N, Typ);
+
-- In all other cases we generate a proper aggregate that
-- can be handled by gigi.
@@ -3764,29 +4118,29 @@ package body Exp_Aggr is
elsif Is_Derived_Type (Typ) then
- -- For untagged types, non-girder discriminants are replaced
- -- with girder discriminants, which are the ones that gigi uses
+ -- For untagged types, non-stored discriminants are replaced
+ -- with stored discriminants, which are the ones that gigi uses
-- to describe the type and its components.
Generate_Aggregate_For_Derived_Type : declare
+ Constraints : constant List_Id := New_List;
First_Comp : Node_Id;
Discriminant : Entity_Id;
- Constraints : List_Id := New_List;
Decl : Node_Id;
Num_Disc : Int := 0;
Num_Gird : Int := 0;
- procedure Prepend_Girder_Values (T : Entity_Id);
- -- Scan the list of girder discriminants of the type, and
+ procedure Prepend_Stored_Values (T : Entity_Id);
+ -- Scan the list of stored discriminants of the type, and
-- add their values to the aggregate being built.
---------------------------
- -- Prepend_Girder_Values --
+ -- Prepend_Stored_Values --
---------------------------
- procedure Prepend_Girder_Values (T : Entity_Id) is
+ procedure Prepend_Stored_Values (T : Entity_Id) is
begin
- Discriminant := First_Girder_Discriminant (T);
+ Discriminant := First_Stored_Discriminant (T);
while Present (Discriminant) loop
New_Comp :=
@@ -3808,9 +4162,9 @@ package body Exp_Aggr is
end if;
First_Comp := New_Comp;
- Next_Girder_Discriminant (Discriminant);
+ Next_Stored_Discriminant (Discriminant);
end loop;
- end Prepend_Girder_Values;
+ end Prepend_Stored_Values;
-- Start of processing for Generate_Aggregate_For_Derived_Type
@@ -3832,25 +4186,25 @@ package body Exp_Aggr is
end if;
end loop;
- -- Insert girder discriminant associations in the correct
- -- order. If there are more girder discriminants than new
+ -- Insert stored discriminant associations in the correct
+ -- order. If there are more stored discriminants than new
-- discriminants, there is at least one new discriminant
- -- that constrains more than one of the girders. In this
- -- case we need to construct a proper subtype of the parent
- -- type, in order to supply values to all the components.
- -- Otherwise there is one-one correspondence between the
- -- constraints and the girder discriminants.
+ -- that constrains more than one of the stored discriminants.
+ -- In this case we need to construct a proper subtype of
+ -- the parent type, in order to supply values to all the
+ -- components. Otherwise there is one-one correspondence
+ -- between the constraints and the stored discriminants.
First_Comp := Empty;
- Discriminant := First_Girder_Discriminant (Base_Type (Typ));
+ Discriminant := First_Stored_Discriminant (Base_Type (Typ));
while Present (Discriminant) loop
Num_Gird := Num_Gird + 1;
- Next_Girder_Discriminant (Discriminant);
+ Next_Stored_Discriminant (Discriminant);
end loop;
- -- Case of more girder discriminants than new discriminants
+ -- Case of more stored discriminants than new discriminants
if Num_Gird > Num_Disc then
@@ -3858,7 +4212,7 @@ package body Exp_Aggr is
-- the proper implementation type for the aggregate, and
-- convert it to the intended target type.
- Discriminant := First_Girder_Discriminant (Base_Type (Typ));
+ Discriminant := First_Stored_Discriminant (Base_Type (Typ));
while Present (Discriminant) loop
New_Comp :=
@@ -3868,7 +4222,7 @@ package body Exp_Aggr is
Typ,
Discriminant_Constraint (Typ)));
Append (New_Comp, Constraints);
- Next_Girder_Discriminant (Discriminant);
+ Next_Stored_Discriminant (Discriminant);
end loop;
Decl :=
@@ -3885,7 +4239,7 @@ package body Exp_Aggr is
(Loc, Constraints)));
Insert_Action (N, Decl);
- Prepend_Girder_Values (Base_Type (Typ));
+ Prepend_Stored_Values (Base_Type (Typ));
Set_Etype (N, Defining_Identifier (Decl));
Set_Analyzed (N);
@@ -3894,11 +4248,11 @@ package body Exp_Aggr is
Analyze (N);
-- Case where we do not have fewer new discriminants than
- -- girder discriminants, so in this case we can simply
- -- use the girder discriminants of the subtype.
+ -- stored discriminants, so in this case we can simply
+ -- use the stored discriminants of the subtype.
else
- Prepend_Girder_Values (Typ);
+ Prepend_Stored_Values (Typ);
end if;
end Generate_Aggregate_For_Derived_Type;
end if;
@@ -4053,8 +4407,9 @@ package body Exp_Aggr is
--------------------------
function Is_Delayed_Aggregate (N : Node_Id) return Boolean is
- Node : Node_Id := N;
+ Node : Node_Id := N;
Kind : Node_Kind := Nkind (Node);
+
begin
if Kind = N_Qualified_Expression then
Node := Expression (Node);
@@ -4076,11 +4431,10 @@ package body Exp_Aggr is
(N : Node_Id;
Typ : Entity_Id;
Target : Node_Id;
- Flist : Node_Id := Empty;
+ Flist : Node_Id := Empty;
Obj : Entity_Id := Empty)
-
- return List_Id is
-
+ return List_Id
+ is
begin
if Is_Record_Type (Etype (N)) then
return Build_Record_Aggr_Code (N, Typ, Target, Flist, Obj);
@@ -4315,14 +4669,19 @@ package body Exp_Aggr is
-- Loop to set the values
- Aggregate_Val := Uint_0;
- Expr := First (Expressions (N));
- for J in 1 .. Len loop
- Aggregate_Val :=
- Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift;
- Shift := Shift + Incr;
- Next (Expr);
- end loop;
+ if Len = 0 then
+ Aggregate_Val := Uint_0;
+ else
+ Expr := First (Expressions (N));
+ Aggregate_Val := Get_Component_Val (Expr) * Uint_2 ** Shift;
+
+ for J in 2 .. Len loop
+ Shift := Shift + Incr;
+ Next (Expr);
+ Aggregate_Val :=
+ Aggregate_Val + Get_Component_Val (Expr) * Uint_2 ** Shift;
+ end loop;
+ end if;
-- Now we can rewrite with the proper value
@@ -4354,6 +4713,30 @@ package body Exp_Aggr is
return False;
end Packed_Array_Aggregate_Handled;
+ ----------------------------
+ -- Has_Mutable_Components --
+ ----------------------------
+
+ function Has_Mutable_Components (Typ : Entity_Id) return Boolean is
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (Typ);
+
+ while Present (Comp) loop
+ if Is_Record_Type (Etype (Comp))
+ and then Has_Discriminants (Etype (Comp))
+ and then not Is_Constrained (Etype (Comp))
+ then
+ return True;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ return False;
+ end Has_Mutable_Components;
+
------------------------------
-- Initialize_Discriminants --
------------------------------
@@ -4378,7 +4761,7 @@ package body Exp_Aggr is
and then Nkind (N) /= N_Extension_Aggregate
then
- -- Call init_proc to set discriminants.
+ -- Call init proc to set discriminants.
-- There should eventually be a special procedure for this ???
Ref := New_Reference_To (Defining_Identifier (N), Loc);
@@ -4438,6 +4821,11 @@ package body Exp_Aggr is
Iteration_Scheme => L_Iter,
Statements => New_List (L_Body));
+ -- Set type of aggregate to be type of lhs in assignment,
+ -- to suppress redundant length checks.
+
+ Set_Etype (N, Etype (Name (Parent (N))));
+
Rewrite (Parent (N), Stat);
Analyze (Parent (N));
return True;
@@ -4452,8 +4840,8 @@ package body Exp_Aggr is
---------------------
procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
- L : Int := Case_Table'First;
- U : Int := Case_Table'Last;
+ L : constant Int := Case_Table'First;
+ U : constant Int := Case_Table'Last;
K : Int;
J : Int;
T : Case_Bounds;
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index bf65d883720..7a5d7737f02 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.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- --
@@ -81,26 +81,32 @@ package body Exp_Attr is
-- or other invalid values do NOT cause a Constraint_Error to be raised.
procedure Expand_Fpt_Attribute
- (N : Node_Id;
- Rtp : Entity_Id;
+ (N : Node_Id;
+ Rtp : Entity_Id;
+ Nam : Name_Id;
Args : List_Id);
-- This procedure expands a call to a floating-point attribute function.
-- N is the attribute reference node, and Args is a list of arguments to
-- be passed to the function call. Rtp is the root type of the floating
-- point type involved (used to select the proper generic instantiation
- -- of the package containing the attribute routines).
+ -- of the package containing the attribute routines). The Nam argument
+ -- is the attribute processing routine to be called. This is normally
+ -- the same as the attribute name, except in the Unaligned_Valid case.
procedure Expand_Fpt_Attribute_R (N : Node_Id);
-- This procedure expands a call to a floating-point attribute function
- -- that takes a single floating-point argument.
+ -- that takes a single floating-point argument. The function to be called
+ -- is always the same as the attribute name.
procedure Expand_Fpt_Attribute_RI (N : Node_Id);
-- This procedure expands a call to a floating-point attribute function
- -- that takes one floating-point argument and one integer argument.
+ -- that takes one floating-point argument and one integer argument. The
+ -- function to be called is always the same as the attribute name.
procedure Expand_Fpt_Attribute_RR (N : Node_Id);
-- This procedure expands a call to a floating-point attribute function
- -- that takes two floating-point arguments.
+ -- that takes two floating-point arguments. The function to be called
+ -- is always the same as the attribute name.
procedure Expand_Pred_Succ (N : Node_Id);
-- Handles expansion of Pred or Succ attributes for case of non-real
@@ -116,7 +122,19 @@ package body Exp_Attr is
function Find_Inherited_TSS
(Typ : Entity_Id;
- Nam : Name_Id) return Entity_Id;
+ Nam : TSS_Name_Type) return Entity_Id;
+ -- Returns the TSS of name Nam of Typ, or of its closest ancestor defining
+ -- such a TSS. Empty is returned is neither Typ nor any of its ancestors
+ -- have such a TSS.
+
+ function Find_Stream_Subprogram
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Entity_Id;
+ -- Returns the stream-oriented subprogram attribute for Typ. For tagged
+ -- types, the corresponding primitive operation is looked up, else the
+ -- appropriate TSS from the type itself, or from its closest ancestor
+ -- defining it, is returned. In both cases, inheritance of representation
+ -- aspects is thus taken into account.
function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
-- Utility for array attributes, returns true on packed constrained
@@ -242,6 +260,7 @@ package body Exp_Attr is
procedure Expand_Fpt_Attribute
(N : Node_Id;
Rtp : Entity_Id;
+ Nam : Name_Id;
Args : List_Id)
is
Loc : constant Source_Ptr := Sloc (N);
@@ -251,7 +270,7 @@ package body Exp_Attr is
begin
-- The function name is the selected component Fat_xxx.yyy where xxx
- -- is the floating-point root type, and yyy is the attribute name
+ -- is the floating-point root type, and yyy is the argument Nam.
-- Note: it would be more usual to have separate RE entries for each
-- of the entities in the Fat packages, but first they have identical
@@ -272,7 +291,7 @@ package body Exp_Attr is
Fnm :=
Make_Selected_Component (Loc,
Prefix => New_Reference_To (RTE (Pkg), Loc),
- Selector_Name => Make_Identifier (Loc, Attribute_Name (N)));
+ Selector_Name => Make_Identifier (Loc, Nam));
-- The generated call is given the provided set of parameters, and then
-- wrapped in a conversion which converts the result to the target type
@@ -284,7 +303,6 @@ package body Exp_Attr is
Parameter_Associations => Args)));
Analyze_And_Resolve (N, Typ);
-
end Expand_Fpt_Attribute;
----------------------------
@@ -300,8 +318,9 @@ package body Exp_Attr is
Rtp : constant Entity_Id := Root_Type (Etype (E1));
begin
- Expand_Fpt_Attribute (N, Rtp, New_List (
- Unchecked_Convert_To (Rtp, Relocate_Node (E1))));
+ Expand_Fpt_Attribute
+ (N, Rtp, Attribute_Name (N),
+ New_List (Unchecked_Convert_To (Rtp, Relocate_Node (E1))));
end Expand_Fpt_Attribute_R;
-----------------------------
@@ -319,9 +338,11 @@ package body Exp_Attr is
E2 : constant Node_Id := Next (E1);
begin
- Expand_Fpt_Attribute (N, Rtp, New_List (
- Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
- Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
+ Expand_Fpt_Attribute
+ (N, Rtp, Attribute_Name (N),
+ New_List (
+ Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
+ Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
end Expand_Fpt_Attribute_RI;
-----------------------------
@@ -338,9 +359,11 @@ package body Exp_Attr is
E2 : constant Node_Id := Next (E1);
begin
- Expand_Fpt_Attribute (N, Rtp, New_List (
- Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
- Unchecked_Convert_To (Rtp, Relocate_Node (E2))));
+ Expand_Fpt_Attribute
+ (N, Rtp, Attribute_Name (N),
+ New_List (
+ Unchecked_Convert_To (Rtp, Relocate_Node (E1)),
+ Unchecked_Convert_To (Rtp, Relocate_Node (E2))));
end Expand_Fpt_Attribute_RR;
----------------------------------
@@ -365,16 +388,65 @@ package body Exp_Attr is
procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
Item : constant Node_Id := Next (First (Exprs));
- Formal_Typ : constant Entity_Id :=
- Etype (Next_Formal (First_Formal (Pname)));
+ Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
+ Formal_Typ : constant Entity_Id := Etype (Formal);
+ Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter);
begin
- -- We have to worry about the type of the second argument
+ -- The expansion depends on Item, the second actual, which is
+ -- the object being streamed in or out.
+
+ -- If the item is a component of a packed array type, and
+ -- a conversion is needed on exit, we introduce a temporary to
+ -- hold the value, because otherwise the packed reference will
+ -- not be properly expanded.
+
+ if Nkind (Item) = N_Indexed_Component
+ and then Is_Packed (Base_Type (Etype (Prefix (Item))))
+ and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
+ and then Is_Written
+ then
+ declare
+ Temp : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('V'));
+ Decl : Node_Id;
+ Assn : Node_Id;
+
+ begin
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition =>
+ New_Occurrence_Of (Formal_Typ, Loc));
+ Set_Etype (Temp, Formal_Typ);
+
+ Assn :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Copy_Tree (Item),
+ Expression =>
+ Unchecked_Convert_To
+ (Etype (Item), New_Occurrence_Of (Temp, Loc)));
+
+ Rewrite (Item, New_Occurrence_Of (Temp, Loc));
+ Insert_Actions (N,
+ New_List (
+ Decl,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Pname, Loc),
+ Parameter_Associations => Exprs),
+ Assn));
+
+ Rewrite (N, Make_Null_Statement (Loc));
+ return;
+ end;
+ end if;
-- For the class-wide dispatching cases, and for cases in which
-- the base type of the second argument matches the base type of
- -- the corresponding formal parameter, we are all set, and can use
- -- the argument unchanged.
+ -- the corresponding formal parameter (that is to say the stream
+ -- operation is not inherited), we are all set, and can use the
+ -- argument unchanged.
-- For all other cases we do an unchecked conversion of the second
-- parameter to the type of the formal of the procedure we are
@@ -382,6 +454,7 @@ package body Exp_Attr is
-- to the root type as required in elementary type case.
if not Is_Class_Wide_Type (Entity (Pref))
+ and then not Is_Class_Wide_Type (Etype (Item))
and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
then
Rewrite (Item,
@@ -644,6 +717,59 @@ package body Exp_Attr is
end Address;
---------------
+ -- Alignment --
+ ---------------
+
+ when Attribute_Alignment => Alignment : declare
+ Ptyp : constant Entity_Id := Etype (Pref);
+ New_Node : Node_Id;
+
+ begin
+ -- For class-wide types, X'Class'Alignment is transformed into a
+ -- direct reference to the Alignment of the class type, so that the
+ -- back end does not have to deal with the X'Class'Alignment
+ -- reference.
+
+ if Is_Entity_Name (Pref)
+ and then Is_Class_Wide_Type (Entity (Pref))
+ then
+ Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
+ return;
+
+ -- For x'Alignment applied to an object of a class wide type,
+ -- transform X'Alignment into a call to the predefined primitive
+ -- operation _Alignment applied to X.
+
+ elsif Is_Class_Wide_Type (Ptyp) then
+ New_Node :=
+ Make_Function_Call (Loc,
+ Name => New_Reference_To
+ (Find_Prim_Op (Ptyp, Name_uAlignment), Loc),
+ Parameter_Associations => New_List (Pref));
+
+ if Typ /= Standard_Integer then
+
+ -- The context is a specific integer type with which the
+ -- original attribute was compatible. The function has a
+ -- specific type as well, so to preserve the compatibility
+ -- we must convert explicitly.
+
+ New_Node := Convert_To (Typ, New_Node);
+ end if;
+
+ Rewrite (N, New_Node);
+ Analyze_And_Resolve (N, Typ);
+ return;
+
+ -- For all other cases, we just have to deal with the case of
+ -- the fact that the result can be universal.
+
+ else
+ Apply_Universal_Integer_Attribute_Checks (N);
+ end if;
+ end Alignment;
+
+ ---------------
-- AST_Entry --
---------------
@@ -884,10 +1010,10 @@ package body Exp_Attr is
-- Task_Entry_Caller or the Protected_Entry_Caller function.
when Attribute_Caller => Caller : declare
- Id_Kind : Entity_Id := RTE (RO_AT_Task_ID);
- Ent : Entity_Id := Entity (Pref);
- Conctype : Entity_Id := Scope (Ent);
- Nest_Depth : Integer := 0;
+ Id_Kind : constant Entity_Id := RTE (RO_AT_Task_ID);
+ Ent : constant Entity_Id := Entity (Pref);
+ Conctype : constant Entity_Id := Scope (Ent);
+ Nest_Depth : Integer := 0;
Name : Node_Id;
S : Entity_Id;
@@ -981,9 +1107,12 @@ package body Exp_Attr is
begin
-- Reference to a parameter where the value is passed as an extra
-- actual, corresponding to the extra formal referenced by the
- -- Extra_Constrained field of the corresponding formal.
+ -- Extra_Constrained field of the corresponding formal. If this
+ -- is an entry in-parameter, it is replaced by a constant renaming
+ -- for which Extra_Constrained is never created.
if Present (Formal_Ent)
+ and then Ekind (Formal_Ent) /= E_Constant
and then Present (Extra_Constrained (Formal_Ent))
then
Rewrite (N,
@@ -1025,16 +1154,11 @@ package body Exp_Attr is
-- within the generic template would have been illegal.
else
- declare
- UT : Entity_Id := Underlying_Type (Ent);
-
- begin
- if Is_Composite_Type (UT) then
- Res := Is_Constrained (Ent);
- else
- Res := True;
- end if;
- end;
+ if Is_Composite_Type (Underlying_Type (Ent)) then
+ Res := Is_Constrained (Ent);
+ else
+ Res := True;
+ end if;
end if;
-- If the prefix is not a variable or is aliased, then
@@ -1335,6 +1459,19 @@ package body Exp_Attr is
Rewrite (N,
Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
+ -- If this is a renaming of a literal, recover the representation
+ -- of the original.
+
+ elsif Ekind (Entity (Pref)) = E_Constant
+ and then Present (Renamed_Object (Entity (Pref)))
+ and then
+ Ekind (Entity (Renamed_Object (Entity (Pref))))
+ = E_Enumeration_Literal
+ then
+ Rewrite (N,
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (Entity (Renamed_Object (Entity (Pref))))));
+
-- X'Enum_Rep where X is an object does a direct unchecked conversion
-- of the object value, as described for the type case above.
@@ -1453,6 +1590,11 @@ package body Exp_Attr is
Expression => Relocate_Node (First (Exprs))));
Set_Etype (N, Entity (Pref));
Set_Analyzed (N);
+
+ -- Note: it might appear that a properly analyzed unchecked conversion
+ -- would be just fine here, but that's not the case, since the full
+ -- range checks performed by the following call are critical!
+
Apply_Type_Conversion_Checks (N);
end Fixed_Value;
@@ -1610,7 +1752,7 @@ package body Exp_Attr is
-- If there is a TSS for Input, just call it
- Fname := Find_Inherited_TSS (P_Type, Name_uInput);
+ Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
if Present (Fname) then
null;
@@ -1659,7 +1801,7 @@ package body Exp_Attr is
-- A special case arises if we have a defined _Read routine,
-- since in this case we are required to call this routine.
- if Present (TSS (B_Type, Name_uRead)) then
+ if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
Build_Record_Or_Elementary_Input_Function
(Loc, U_Type, Decl, Fname);
Insert_Action (N, Decl);
@@ -1724,20 +1866,20 @@ package body Exp_Attr is
-- Now we need to get the entity for the call, and construct
-- a function call node, where we preset a reference to Dnn
-- as the controlling argument (doing an unchecked
- -- conversion to the tagged type to make it look like
- -- a real tagged object).
+ -- conversion to the classwide tagged type to make it
+ -- look like a real tagged object).
- Fname := Find_Prim_Op (Rtyp, Name_uInput);
- Cntrl := Unchecked_Convert_To (Rtyp,
+ Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
+ Cntrl := Unchecked_Convert_To (P_Type,
New_Occurrence_Of (Dnn, Loc));
- Set_Etype (Cntrl, Rtyp);
+ Set_Etype (Cntrl, P_Type);
Set_Parent (Cntrl, N);
end;
-- For tagged types, use the primitive Input function
elsif Is_Tagged_Type (U_Type) then
- Fname := Find_Prim_Op (U_Type, Name_uInput);
+ Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
-- All other record type cases, including protected records.
-- The latter only arise for expander generated code for
@@ -1793,6 +1935,11 @@ package body Exp_Attr is
Expression => Relocate_Node (First (Exprs))));
Set_Etype (N, Entity (Pref));
Set_Analyzed (N);
+
+ -- Note: it might appear that a properly analyzed unchecked conversion
+ -- would be just fine here, but that's not the case, since the full
+ -- range checks performed by the following call are critical!
+
Apply_Type_Conversion_Checks (N);
end Integer_Value;
@@ -1929,7 +2076,8 @@ package body Exp_Attr is
Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Pref),
+ Prefix =>
+ Duplicate_Subexpr_No_Checks (Pref),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, Xnum)))))),
@@ -2006,7 +2154,8 @@ package body Exp_Attr is
Attribute_Name => Name_Pos,
Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Pref),
+ Prefix =>
+ Duplicate_Subexpr_No_Checks (Pref),
Attribute_Name => Name_First,
Expressions =>
New_Copy_List (Exprs)))))))));
@@ -2117,7 +2266,6 @@ package body Exp_Attr is
when Attribute_Output => Output : declare
P_Type : constant Entity_Id := Entity (Pref);
- B_Type : constant Entity_Id := Base_Type (P_Type);
U_Type : constant Entity_Id := Underlying_Type (P_Type);
Pname : Entity_Id;
Decl : Node_Id;
@@ -2135,7 +2283,7 @@ package body Exp_Attr is
-- If TSS for Output is present, just call it
- Pname := Find_Inherited_TSS (P_Type, Name_uOutput);
+ Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
if Present (Pname) then
null;
@@ -2188,7 +2336,7 @@ package body Exp_Attr is
-- A special case arises if we have a defined _Write routine,
-- since in this case we are required to call this routine.
- if Present (TSS (B_Type, Name_uWrite)) then
+ if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
Build_Record_Or_Elementary_Output_Procedure
(Loc, U_Type, Decl, Pname);
Insert_Action (N, Decl);
@@ -2236,12 +2384,12 @@ package body Exp_Attr is
Attribute_Name => Name_Tag))))));
end Tag_Write;
- Pname := Find_Prim_Op (U_Type, Name_uOutput);
+ Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
-- Tagged type case, use the primitive Output function
elsif Is_Tagged_Type (U_Type) then
- Pname := Find_Prim_Op (U_Type, Name_uOutput);
+ Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
-- All other record type cases, including protected records.
-- The latter only arise for expander generated code for
@@ -2273,10 +2421,11 @@ package body Exp_Attr is
-- generate a call to the _Rep_To_Pos function created when the
-- type was frozen. The call has the form
- -- _rep_to_pos (expr, True)
+ -- _rep_to_pos (expr, flag)
- -- The parameter True causes Program_Error to be raised if the
- -- expression has an invalid representation.
+ -- The parameter flag is True if range checks are enabled, causing
+ -- Program_Error to be raised if the expression has an invalid
+ -- representation, and False if range checks are suppressed.
-- For integer types, Pos is equivalent to a simple integer
-- conversion and we rewrite it as such
@@ -2301,13 +2450,12 @@ package body Exp_Attr is
-- Non-standard enumeration type (generate call)
if Present (Enum_Pos_To_Rep (Etyp)) then
- Append_To (Exprs, New_Occurrence_Of (Standard_True, Loc));
-
+ Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Name =>
- New_Reference_To (TSS (Etyp, Name_uRep_To_Pos), Loc),
+ New_Reference_To (TSS (Etyp, TSS_Rep_To_Pos), Loc),
Parameter_Associations => Exprs)));
Analyze_And_Resolve (N, Typ);
@@ -2369,25 +2517,54 @@ package body Exp_Attr is
-- Pos_To_Rep (Rep_To_Pos (x) - 1)
+ -- If the representation is contiguous, we compute instead
+ -- Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
+
if Is_Enumeration_Type (Ptyp)
and then Present (Enum_Pos_To_Rep (Ptyp))
then
- -- Add Boolean parameter True, to request program errror if
- -- we have a bad representation on our hands.
+ if Has_Contiguous_Rep (Ptyp) then
+ Rewrite (N,
+ Unchecked_Convert_To (Ptyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (First_Literal (Ptyp))),
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To
+ (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
+
+ Parameter_Associations =>
+ New_List (
+ Unchecked_Convert_To (Ptyp,
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To (Standard_Integer,
+ Relocate_Node (First (Exprs))),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, 1))),
+ Rep_To_Pos_Flag (Ptyp, Loc))))));
- Append_To (Exprs, New_Occurrence_Of (Standard_True, Loc));
+ else
+ -- Add Boolean parameter True, to request program errror if
+ -- we have a bad representation on our hands. If checks are
+ -- suppressed, then add False instead
- Rewrite (N,
- Make_Indexed_Component (Loc,
- Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
- Expressions => New_List (
- Make_Op_Subtract (Loc,
+ Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
+ Rewrite (N,
+ Make_Indexed_Component (Loc,
+ Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
+ Expressions => New_List (
+ Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Function_Call (Loc,
Name =>
- New_Reference_To (TSS (Ptyp, Name_uRep_To_Pos), Loc),
- Parameter_Associations => Exprs),
+ New_Reference_To (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
+ Parameter_Associations => Exprs),
Right_Opnd => Make_Integer_Literal (Loc, 1)))));
+ end if;
Analyze_And_Resolve (N, Typ);
@@ -2498,7 +2675,7 @@ package body Exp_Attr is
-- The simple case, if there is a TSS for Read, just call it
- Pname := Find_Inherited_TSS (P_Type, Name_uRead);
+ Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
if Present (Pname) then
null;
@@ -2553,7 +2730,7 @@ package body Exp_Attr is
Rewrite (N,
Make_Assignment_Statement (Loc,
- Name => Lhs,
+ Name => Lhs,
Expression => Rhs));
Set_Assignment_OK (Lhs);
Analyze (N);
@@ -2598,7 +2775,7 @@ package body Exp_Attr is
-- this will dispatch in the class-wide case which is what we want
elsif Is_Tagged_Type (U_Type) then
- Pname := Find_Prim_Op (U_Type, Name_uRead);
+ Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
-- All other record type cases, including protected records.
-- The latter only arise for expander generated code for
@@ -2717,8 +2894,8 @@ package body Exp_Attr is
declare
Ptyp : constant Entity_Id := Etype (Pref);
- New_Node : Node_Id;
Siz : Uint;
+ New_Node : Node_Id;
begin
-- Processing for VADS_Size case. Note that this processing removes
@@ -2785,10 +2962,20 @@ package body Exp_Attr is
end if;
end if;
- -- For class-wide types, transform X'Size into a call to
- -- the primitive operation _Size
+ -- For class-wide types, X'Class'Size is transformed into a
+ -- direct reference to the Size of the class type, so that gigi
+ -- does not have to deal with the X'Class'Size reference.
- if Is_Class_Wide_Type (Ptyp) then
+ if Is_Entity_Name (Pref)
+ and then Is_Class_Wide_Type (Entity (Pref))
+ then
+ Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
+ return;
+
+ -- For x'Size applied to an object of a class wide type, transform
+ -- X'Size into a call to the primitive operation _Size applied to X.
+
+ elsif Is_Class_Wide_Type (Ptyp) then
New_Node :=
Make_Function_Call (Loc,
Name => New_Reference_To
@@ -2918,9 +3105,12 @@ package body Exp_Attr is
Rewrite (N,
OK_Convert_To (Typ,
Make_Function_Call (Loc,
- Name => New_Reference_To (Find_Prim_Op (Etype (
- Associated_Storage_Pool (Root_Type (Ptyp))),
- Attribute_Name (N)), Loc),
+ Name =>
+ New_Reference_To
+ (Find_Prim_Op
+ (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
+ Attribute_Name (N)),
+ Loc),
Parameter_Associations => New_List (New_Reference_To (
Associated_Storage_Pool (Root_Type (Ptyp)), Loc)))));
@@ -3011,25 +3201,54 @@ package body Exp_Attr is
-- Pos_To_Rep (Rep_To_Pos (x) + 1)
+ -- If the representation is contiguous, we compute instead
+ -- Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
+
if Is_Enumeration_Type (Ptyp)
and then Present (Enum_Pos_To_Rep (Ptyp))
then
- -- Add Boolean parameter True, to request program errror if
- -- we have a bad representation on our hands.
-
- Append_To (Exprs, New_Occurrence_Of (Standard_True, Loc));
+ if Has_Contiguous_Rep (Ptyp) then
+ Rewrite (N,
+ Unchecked_Convert_To (Ptyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (First_Literal (Ptyp))),
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To
+ (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
+
+ Parameter_Associations =>
+ New_List (
+ Unchecked_Convert_To (Ptyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To (Standard_Integer,
+ Relocate_Node (First (Exprs))),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, 1))),
+ Rep_To_Pos_Flag (Ptyp, Loc))))));
+ else
+ -- Add Boolean parameter True, to request program errror if
+ -- we have a bad representation on our hands. Add False if
+ -- checks are suppressed.
- Rewrite (N,
- Make_Indexed_Component (Loc,
- Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
- Expressions => New_List (
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (TSS (Ptyp, Name_uRep_To_Pos), Loc),
- Parameter_Associations => Exprs),
- Right_Opnd => Make_Integer_Literal (Loc, 1)))));
+ Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
+ Rewrite (N,
+ Make_Indexed_Component (Loc,
+ Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
+ Expressions => New_List (
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To
+ (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
+ Parameter_Associations => Exprs),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)))));
+ end if;
Analyze_And_Resolve (N, Typ);
@@ -3231,12 +3450,43 @@ package body Exp_Attr is
if Is_Enumeration_Type (Etyp)
and then Present (Enum_Pos_To_Rep (Etyp))
then
- Rewrite (N,
- Make_Indexed_Component (Loc,
- Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc),
- Expressions => New_List (
- Convert_To (Standard_Integer,
- Relocate_Node (First (Exprs))))));
+ if Has_Contiguous_Rep (Etyp) then
+ declare
+ Rep_Node : constant Node_Id :=
+ Unchecked_Convert_To (Etyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (First_Literal (Etyp))),
+ Right_Opnd =>
+ (Convert_To (Standard_Integer,
+ Relocate_Node (First (Exprs))))));
+
+ begin
+ Rewrite (N,
+ Unchecked_Convert_To (Etyp,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (First_Literal (Etyp))),
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To
+ (TSS (Etyp, TSS_Rep_To_Pos), Loc),
+ Parameter_Associations => New_List (
+ Rep_Node,
+ Rep_To_Pos_Flag (Etyp, Loc))))));
+ end;
+
+ else
+ Rewrite (N,
+ Make_Indexed_Component (Loc,
+ Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc),
+ Expressions => New_List (
+ Convert_To (Standard_Integer,
+ Relocate_Node (First (Exprs))))));
+ end if;
Analyze_And_Resolve (N, Typ);
end if;
@@ -3252,15 +3502,25 @@ package body Exp_Attr is
when Attribute_Valid => Valid :
declare
Ptyp : constant Entity_Id := Etype (Pref);
- Btyp : Entity_Id := Base_Type (Ptyp);
+ Btyp : Entity_Id := Base_Type (Ptyp);
Tst : Node_Id;
+ Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
+ -- Save the validity checking mode. We always turn off validity
+ -- checking during process of 'Valid since this is one place
+ -- where we do not want the implicit validity checks to intefere
+ -- with the explicit validity check that the programmer is doing.
+
function Make_Range_Test return Node_Id;
-- Build the code for a range test of the form
-- Btyp!(Pref) >= Btyp!(Ptyp'First)
-- and then
-- Btyp!(Pref) <= Btyp!(Ptyp'Last)
+ ---------------------
+ -- Make_Range_Test --
+ ---------------------
+
function Make_Range_Test return Node_Id is
begin
return
@@ -3279,7 +3539,8 @@ package body Exp_Attr is
Right_Opnd =>
Make_Op_Le (Loc,
Left_Opnd =>
- Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
+ Unchecked_Convert_To (Btyp,
+ Duplicate_Subexpr_No_Checks (Pref)),
Right_Opnd =>
Unchecked_Convert_To (Btyp,
@@ -3291,6 +3552,11 @@ package body Exp_Attr is
-- Start of processing for Attribute_Valid
begin
+ -- Turn off validity checks. We do not want any implicit validity
+ -- checks to intefere with the explicit check from the attribute
+
+ Validity_Checks_On := False;
+
-- Floating-point case. This case is handled by the Valid attribute
-- code in the floating-point attribute run-time library.
@@ -3299,10 +3565,34 @@ package body Exp_Attr is
Rtp : constant Entity_Id := Root_Type (Etype (Pref));
begin
- Expand_Fpt_Attribute (N, Rtp, New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Unchecked_Convert_To (Rtp, Pref),
- Attribute_Name => Name_Unrestricted_Access)));
+ -- If the floating-point object might be unaligned, we need
+ -- to call the special routine Unaligned_Valid, which makes
+ -- the needed copy, being careful not to load the value into
+ -- any floating-point register. The argument in this case is
+ -- obj'Address (see Unchecked_Valid routine in s-fatgen.ads).
+
+ if Is_Possibly_Unaligned_Object (Pref) then
+ Set_Attribute_Name (N, Name_Unaligned_Valid);
+ Expand_Fpt_Attribute
+ (N, Rtp, Name_Unaligned_Valid,
+ New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Pref),
+ Attribute_Name => Name_Address)));
+
+ -- In the normal case where we are sure the object is aligned,
+ -- we generate a caqll to Valid, and the argument in this case
+ -- is obj'Unrestricted_Access (after converting obj to the
+ -- right floating-point type).
+
+ else
+ Expand_Fpt_Attribute
+ (N, Rtp, Name_Valid,
+ New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Unchecked_Convert_To (Rtp, Pref),
+ Attribute_Name => Name_Unrestricted_Access)));
+ end if;
-- One more task, we still need a range check. Required
-- only if we have a constraint, since the Valid routine
@@ -3354,7 +3644,7 @@ package body Exp_Attr is
Make_Function_Call (Loc,
Name =>
New_Reference_To
- (TSS (Base_Type (Ptyp), Name_uRep_To_Pos), Loc),
+ (TSS (Base_Type (Ptyp), TSS_Rep_To_Pos), Loc),
Parameter_Associations => New_List (
Pref,
New_Occurrence_Of (Standard_False, Loc))),
@@ -3471,6 +3761,7 @@ package body Exp_Attr is
end if;
Analyze_And_Resolve (N, Standard_Boolean);
+ Validity_Checks_On := Save_Validity_Checks_On;
end Valid;
-----------
@@ -3605,7 +3896,7 @@ package body Exp_Attr is
-- The simple case, if there is a TSS for Write, just call it
- Pname := Find_Inherited_TSS (P_Type, Name_uWrite);
+ Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
if Present (Pname) then
null;
@@ -3665,7 +3956,7 @@ package body Exp_Attr is
-- this will dispatch in the class-wide case which is what we want
elsif Is_Tagged_Type (U_Type) then
- Pname := Find_Prim_Op (U_Type, Name_uWrite);
+ Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
-- All other record type cases, including protected records.
-- The latter only arise for expander generated code for
@@ -3722,7 +4013,8 @@ package body Exp_Attr is
Attribute_Mechanism_Code |
Attribute_Min |
Attribute_Null_Parameter |
- Attribute_Passed_By_Reference =>
+ Attribute_Passed_By_Reference |
+ Attribute_Pool_Address =>
null;
-- The following attributes are also handled by Gigi, but return a
@@ -3730,7 +4022,6 @@ package body Exp_Attr is
-- that the result is in range.
when Attribute_Aft |
- Attribute_Alignment |
Attribute_Bit |
Attribute_Max_Size_In_Storage_Elements
=>
@@ -3775,7 +4066,9 @@ package body Exp_Attr is
Attribute_Signed_Zeros |
Attribute_Small |
Attribute_Storage_Unit |
+ Attribute_Target_Name |
Attribute_Type_Class |
+ Attribute_Unconstrained_Array |
Attribute_Universal_Literal_String |
Attribute_Wchar_T_Size |
Attribute_Word_Size =>
@@ -3793,6 +4086,9 @@ package body Exp_Attr is
end case;
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_N_Attribute_Reference;
----------------------
@@ -3825,7 +4121,8 @@ package body Exp_Attr is
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (First (Expressions (N))),
+ Left_Opnd =>
+ Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
@@ -3841,46 +4138,53 @@ package body Exp_Attr is
function Find_Inherited_TSS
(Typ : Entity_Id;
- Nam : Name_Id) return Entity_Id
+ Nam : TSS_Name_Type) return Entity_Id
is
- P_Type : Entity_Id := Typ;
- Proc : Entity_Id;
+ Btyp : Entity_Id := Typ;
+ Proc : Entity_Id;
begin
- Proc := TSS (Base_Type (Typ), Nam);
+ loop
+ Btyp := Base_Type (Btyp);
+ Proc := TSS (Btyp, Nam);
- -- Check first if there is a TSS given for the type itself.
+ exit when Present (Proc)
+ or else not Is_Derived_Type (Btyp);
- if Present (Proc) then
- return Proc;
- end if;
+ -- If Typ is a derived type, it may inherit attributes from
+ -- some ancestor.
- -- If Typ is a derived type, it may inherit attributes from some
- -- ancestor which is not the ultimate underlying one.
- -- If Typ is a derived tagged type, the corresponding primitive
- -- operation has been created explicitly.
+ Btyp := Etype (Btyp);
+ end loop;
- if Is_Derived_Type (P_Type) then
- if Is_Tagged_Type (P_Type) then
- return Find_Prim_Op (P_Type, Nam);
- else
- while Is_Derived_Type (P_Type) loop
- Proc := TSS (Base_Type (Etype (Typ)), Nam);
+ if No (Proc) then
- if Present (Proc) then
- return Proc;
- else
- P_Type := Base_Type (Etype (P_Type));
- end if;
- end loop;
- end if;
+ -- If nothing else, use the TSS of the root type
+
+ Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
end if;
- -- If nothing else, use the TSS of the root type.
+ return Proc;
- return TSS (Base_Type (Underlying_Type (Typ)), Nam);
end Find_Inherited_TSS;
+ ----------------------------
+ -- Find_Stream_Subprogram --
+ ----------------------------
+
+ function Find_Stream_Subprogram
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Entity_Id is
+ begin
+ if Is_Tagged_Type (Typ)
+ and then Is_Derived_Type (Typ)
+ then
+ return Find_Prim_Op (Typ, Nam);
+ else
+ return Find_Inherited_TSS (Typ, Nam);
+ end if;
+ end Find_Stream_Subprogram;
+
-----------------------
-- Get_Index_Subtype --
-----------------------
diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb
index d99d07ef284..16e6544d281 100644
--- a/gcc/ada/exp_ch11.adb
+++ b/gcc/ada/exp_ch11.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- --
@@ -107,6 +107,16 @@ package body Exp_Ch11 is
-- the call to the cleanup routine that is made from an exception
-- handler for the abort signal is called with aborts deferred.
+ -- This expansion is only done if we have front end exception handling.
+ -- If we have back end exception handling, then the AT END handler is
+ -- left alone, and cleanups (including the exceptional case) are handled
+ -- by the back end.
+
+ -- In the front end case, the exception handler described above handles
+ -- the exceptional case. The AT END handler is left in the generated tree
+ -- and the code generator (e.g. gigi) must still handle proper generation
+ -- of cleanup calls for the non-exceptional case.
+
procedure Expand_At_End_Handler (HSS : Node_Id; Block : Node_Id) is
Clean : constant Entity_Id := Entity (At_End_Proc (HSS));
Loc : constant Source_Ptr := Sloc (Clean);
@@ -117,6 +127,20 @@ package body Exp_Ch11 is
pragma Assert (Present (Clean));
pragma Assert (No (Exception_Handlers (HSS)));
+ -- Don't expand if back end exception handling active
+
+ if Exception_Mechanism = Back_End_ZCX_Exceptions then
+ return;
+ end if;
+
+ -- Don't expand an At End handler if we have already had configurable
+ -- run-time violations, since likely this will just be a matter of
+ -- generating useless cascaded messages
+
+ if Configurable_Run_Time_Violations > 0 then
+ return;
+ end if;
+
if Restrictions (No_Exception_Handlers) then
return;
end if;
@@ -690,9 +714,22 @@ package body Exp_Ch11 is
-- Loop through handlers
Handler := First_Non_Pragma (Handlrs);
- while Present (Handler) loop
+ Handler_Loop : while Present (Handler) loop
Loc := Sloc (Handler);
+ -- Remove source handler if gnat debug flag N is set
+
+ if Debug_Flag_Dot_X and then Comes_From_Source (Handler) then
+ declare
+ H : Node_Id := Handler;
+ begin
+ Next_Non_Pragma (Handler);
+ Remove (H);
+ goto Continue_Handler_Loop;
+ end;
+ end if;
+
+
-- If an exception occurrence is present, then we must declare it
-- and initialize it from the value stored in the TSD
@@ -758,10 +795,10 @@ package body Exp_Ch11 is
if Hostparm.Java_VM then
declare
- Arg : Node_Id
- := Make_Function_Call (Loc,
- Name => New_Occurrence_Of
- (RTE (RE_Current_Target_Exception), Loc));
+ Arg : constant Node_Id :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of
+ (RTE (RE_Current_Target_Exception), Loc));
begin
Prepend_Call_To_Handler (RE_Update_Exception, New_List (Arg));
end;
@@ -801,12 +838,23 @@ package body Exp_Ch11 is
end if;
Next_Non_Pragma (Handler);
- end loop;
+
+ <<Continue_Handler_Loop>>
+ null;
+ end loop Handler_Loop;
+
+ -- If all handlers got removed by gnatdN, then remove the list
+
+ if Debug_Flag_Dot_X
+ and then Is_Empty_List (Exception_Handlers (HSS))
+ then
+ Set_Exception_Handlers (HSS, No_List);
+ end if;
-- The last step for expanding exception handlers is to expand the
-- exception tables if zero cost exception handling is active.
- if Exception_Mechanism = Front_End_ZCX then
+ if Exception_Mechanism = Front_End_ZCX_Exceptions then
Expand_Exception_Handler_Tables (HSS);
end if;
end Expand_Exception_Handlers;
@@ -820,9 +868,12 @@ package body Exp_Ch11 is
-- except : exception_data := (
-- Handled_By_Other => False,
-- Lang => 'A',
- -- Name_Length => exceptE'Length
- -- Full_Name => exceptE'Address
- -- HTable_Ptr => null);
+ -- Name_Length => exceptE'Length,
+ -- Full_Name => exceptE'Address,
+ -- HTable_Ptr => null,
+ -- Import_Code => 0,
+ -- Raise_Hook => null,
+ -- );
-- (protecting test only needed if not at library level)
--
@@ -893,12 +944,18 @@ package body Exp_Ch11 is
Append_To (L, Make_Integer_Literal (Loc, 0));
+ -- Raise_Hook component: null
+
+ Append_To (L, Make_Null (Loc));
+
Set_Expression (N, Make_Aggregate (Loc, Expressions => L));
Analyze_And_Resolve (Expression (N), Etype (Id));
-- Register_Exception (except'Unchecked_Access);
- if not Restrictions (No_Exception_Handlers) then
+ if not Restrictions (No_Exception_Handlers)
+ and then not Restrictions (No_Exception_Registration)
+ then
L := New_List (
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Register_Exception), Loc),
@@ -1016,9 +1073,19 @@ package body Exp_Ch11 is
return;
end if;
+ -- Don't expand a raise statement that does not come from source
+ -- if we have already had configurable run-time violations, since
+ -- most likely it will be junk cascaded nonsense.
+
+ if Configurable_Run_Time_Violations > 0
+ and then not Comes_From_Source (N)
+ then
+ return;
+ end if;
+
-- Convert explicit raise of Program_Error, Constraint_Error, and
- -- Storage_Error into the corresponding raise node (in No_Run_Time
- -- mode all other raises will get normal expansion and be disallowed,
+ -- Storage_Error into the corresponding raise (in High_Integrity_Mode
+ -- all other raises will get normal expansion and be disallowed,
-- but this is also faster in all modes).
if Present (Name (N)) and then Nkind (Name (N)) = N_Identifier then
@@ -1065,24 +1132,25 @@ package body Exp_Ch11 is
Id := Renamed_Object (Id);
end if;
- -- Build a C compatible string in case of no exception handlers,
+ -- Build a C-compatible string in case of no exception handlers,
-- since this is what the last chance handler is expecting.
if Restrictions (No_Exception_Handlers) then
- -- Generate a C null message when Global_Discard_Names is True
- -- or when Debug_Flag_NN is set.
- if Global_Discard_Names or else Debug_Flag_NN then
- Name_Buffer (1) := ASCII.NUL;
+ -- Generate an empty message if configuration pragma
+ -- Suppress_Exception_Locations is set for this unit.
+
+ if Opt.Exception_Locations_Suppressed then
Name_Len := 1;
else
Name_Len := Name_Len + 1;
end if;
- -- Do not generate the message when Global_Discard_Names is True
- -- or when Debug_Flag_NN is set.
+ Name_Buffer (Name_Len) := ASCII.NUL;
+ end if;
+
- elsif Global_Discard_Names or else Debug_Flag_NN then
+ if Opt.Exception_Locations_Suppressed then
Name_Len := 0;
end if;
@@ -1258,7 +1326,7 @@ package body Exp_Ch11 is
Hrc : List_Id;
begin
- if Exception_Mechanism /= Front_End_ZCX then
+ if Exception_Mechanism /= Front_End_ZCX_Exceptions then
return;
end if;
@@ -1277,7 +1345,7 @@ package body Exp_Ch11 is
-- Suppress descriptor if we are in No_Exceptions restrictions mode,
-- since we can never propagate exceptions in any case in this mode.
-- The same consideration applies for No_Exception_Handlers (which
- -- is also set in No_Run_Time mode).
+ -- is also set in High_Integrity_Mode).
if Restrictions (No_Exceptions)
or Restrictions (No_Exception_Handlers)
@@ -1306,14 +1374,7 @@ package body Exp_Ch11 is
begin
Scop := Spec;
while Scop /= Standard_Standard loop
- if Ekind (Scop) = E_Generic_Procedure
- or else
- Ekind (Scop) = E_Generic_Function
- or else
- Ekind (Scop) = E_Generic_Package
- or else
- Is_Eliminated (Scop)
- then
+ if Is_Generic_Unit (Scop) or else Is_Eliminated (Scop) then
return;
end if;
@@ -1352,7 +1413,7 @@ package body Exp_Ch11 is
-- Suppress all subprogram descriptors for the file System.Exceptions.
-- We similarly suppress subprogram descriptors for Ada.Exceptions.
- -- These are all init_proc's for types which cannot raise exceptions.
+ -- These are all init procs for types which cannot raise exceptions.
-- The reason this is done is that otherwise we get embarassing
-- elaboration dependencies.
@@ -1695,7 +1756,7 @@ package body Exp_Ch11 is
begin
-- Nothing to be done if zero length exceptions not active
- if Exception_Mechanism /= Front_End_ZCX then
+ if Exception_Mechanism /= Front_End_ZCX_Exceptions then
return;
end if;
@@ -1851,6 +1912,7 @@ package body Exp_Ch11 is
-- This defines the traversal operation
Discard : Traverse_Result;
+ pragma Warnings (Off, Discard);
function Check_Handler_Entry (N : Node_Id) return Traverse_Result is
begin
@@ -1886,7 +1948,7 @@ package body Exp_Ch11 is
-- Start of processing for Remove_Handler_Entries
begin
- if Exception_Mechanism = Front_End_ZCX then
+ if Exception_Mechanism = Front_End_ZCX_Exceptions then
Discard := Remove_All_Handler_Entries (N);
end if;
end Remove_Handler_Entries;
diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb
index 908ebd64e62..28d6c915076 100644
--- a/gcc/ada/exp_ch13.adb
+++ b/gcc/ada/exp_ch13.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- --
@@ -30,6 +30,7 @@ with Einfo; use Einfo;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Imgv; use Exp_Imgv;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -170,12 +171,11 @@ package body Exp_Ch13 is
procedure Expand_External_Tag_Definition (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ent : constant Entity_Id := Entity (Name (N));
- E : Entity_Id;
- Old_Val : String_Id := Strval (Expr_Value_S (Expression (N)));
+ Old_Val : constant String_Id := Strval (Expr_Value_S (Expression (N)));
New_Val : String_Id;
+ E : Entity_Id;
begin
-
-- For the rep clause "for x'external_tag use y" generate:
-- xV : constant string := y;
@@ -262,6 +262,12 @@ package body Exp_Ch13 is
E_Scope := Scope (E);
+ -- This is an error protection against previous errors
+
+ if No (E_Scope) then
+ return;
+ end if;
+
-- If we are freezing entities defined in protected types, they
-- belong in the enclosing scope, given that the original type
-- has been expanded away. The same is true for entities in task types,
@@ -322,13 +328,14 @@ package body Exp_Ch13 is
elsif Is_Tagged_Type (E)
and then Is_First_Subtype (E)
then
-
-- Check for a definition of External_Tag, whose expansion must
-- be delayed until the dispatch table is built.
declare
- Def : Node_Id :=
- Get_Attribute_Definition_Clause (E, Attribute_External_Tag);
+ Def : constant Node_Id :=
+ Get_Attribute_Definition_Clause
+ (E, Attribute_External_Tag);
+
begin
if Present (Def) then
Expand_External_Tag_Definition (Def);
@@ -354,8 +361,9 @@ package body Exp_Ch13 is
while Present (Decl) loop
if Nkind (Decl) = N_Subprogram_Body
- and then (Chars (Defining_Entity (Decl)) = Name_uInit_Proc
- or else Chars (Defining_Entity (Decl)) = Name_uAssign)
+ and then (Is_Init_Proc (Defining_Entity (Decl))
+ or else
+ Chars (Defining_Entity (Decl)) = Name_uAssign)
then
Analyze (Decl);
diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb
index 669ced7f031..f4aed89e28a 100644
--- a/gcc/ada/exp_ch2.adb
+++ b/gcc/ada/exp_ch2.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -25,19 +25,25 @@
------------------------------------------------------------------------------
with Atree; use Atree;
+with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Smem; use Exp_Smem;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt;
with Nmake; use Nmake;
+with Opt; use Opt;
with Sem; use Sem;
+with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
+with Stand; use Stand;
with Tbuild; use Tbuild;
-with Snames; use Snames;
+with Uintp; use Uintp;
package body Exp_Ch2 is
@@ -45,6 +51,15 @@ package body Exp_Ch2 is
-- Local Subprograms --
-----------------------
+ procedure Expand_Current_Value (N : Node_Id);
+ -- Given a node N for a variable whose Current_Value field is set.
+ -- If the node is for a discrete type, replaces the node with a
+ -- copy of the referenced value. This provides a limited form of
+ -- value propagation for variables which are initialized and have
+ -- not been modified at the time of reference. The call has no
+ -- effect if the Current_Value refers to a conditional with a
+ -- condition other than equality.
+
procedure Expand_Discriminant (N : Node_Id);
-- An occurrence of a discriminant within a discriminated type is replaced
-- with the corresponding discriminal, that is to say the formal parameter
@@ -96,6 +111,151 @@ package body Exp_Ch2 is
-- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives
-- the correct renaming semantics.
+ --------------------------
+ -- Expand_Current_Value --
+ --------------------------
+
+ procedure Expand_Current_Value (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ E : constant Entity_Id := Entity (N);
+ CV : constant Node_Id := Current_Value (E);
+ T : constant Entity_Id := Etype (N);
+ Val : Node_Id;
+ Op : Node_Kind;
+
+ function In_Appropriate_Scope return Boolean;
+ -- Returns true if the current scope is the scope of E, or is a nested
+ -- (to any level) package declaration, package body, or block of this
+ -- scope. The idea is that such references are in the sequential
+ -- execution sequence of statements executed after E is elaborated.
+
+ --------------------------
+ -- In_Appropriate_Scope --
+ --------------------------
+
+ function In_Appropriate_Scope return Boolean is
+ ES : constant Entity_Id := Scope (E);
+ CS : Entity_Id;
+
+ begin
+ CS := Current_Scope;
+
+ loop
+ -- If we are in right scope, replacement is safe
+
+ if CS = ES then
+ return True;
+
+ -- Packages do not affect the determination of safety
+
+ elsif Ekind (CS) = E_Package then
+ CS := Scope (CS);
+ exit when CS = Standard_Standard;
+
+ -- Blocks do not affect the determination of safety
+
+ elsif Ekind (CS) = E_Block then
+ CS := Scope (CS);
+
+ -- Otherwise, the reference is dubious, and we cannot be
+ -- sure that it is safe to do the replacement. Note in
+ -- particular, in a loop (except for the special case
+ -- tested above), we cannot safely do a replacement since
+ -- there may be an assignment at the bottom of the loop
+ -- that will affect a reference at the top of the loop.
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ return False;
+ end In_Appropriate_Scope;
+
+ -- Start of processing for Expand_Current_Value
+
+ begin
+ if True
+
+ -- Do this only for discrete types
+
+ and then Is_Discrete_Type (T)
+
+ -- Do not replace biased types, since it is problematic to
+ -- consistently generate a sensible constant value in this case.
+
+ and then not Has_Biased_Representation (T)
+
+ -- Do not replace lvalues
+
+ and then not Is_Lvalue (N)
+
+ -- Do not replace occurrences that are not in the current scope,
+ -- because in a nested subprogram we know absolutely nothing about
+ -- the sequence of execution.
+
+ and then In_Appropriate_Scope
+
+ -- Do not replace statically allocated objects, because they may
+ -- be modified outside the current scope.
+
+ and then not Is_Statically_Allocated (E)
+
+ -- Do not replace aliased or volatile objects, since we don't know
+ -- what else might change the value
+
+ and then not Is_Aliased (E) and then not Treat_As_Volatile (E)
+
+ -- Debug flag -gnatdM disconnects this optimization
+
+ and then not Debug_Flag_MM
+
+ -- Do not replace occurrences in pragmas (where names typically
+ -- appear not as values, but as simply names. If there are cases
+ -- where values are required, it is only a very minor efficiency
+ -- issue that they do not get replaced when they could be).
+
+ and then Nkind (Parent (N)) /= N_Pragma_Argument_Association
+ then
+ -- Case of Current_Value is a compile time known value
+
+ if Nkind (CV) in N_Subexpr then
+ Val := CV;
+
+ -- Case of Current_Value is a conditional expression reference
+
+ else
+ Get_Current_Value_Condition (N, Op, Val);
+
+ if Op /= N_Op_Eq then
+ return;
+ end if;
+ end if;
+
+ -- If constant value is an occurrence of an enumeration literal,
+ -- then we just make another occurence of the same literal.
+
+ if Is_Entity_Name (Val)
+ and then Ekind (Entity (Val)) = E_Enumeration_Literal
+ then
+ Rewrite (N,
+ Unchecked_Convert_To (T,
+ New_Occurrence_Of (Entity (Val), Loc)));
+
+ -- Otherwise get the value, and convert to appropriate type
+
+ else
+ Rewrite (N,
+ Unchecked_Convert_To (T,
+ Make_Integer_Literal (Loc,
+ Intval => Expr_Rep_Value (Val))));
+ end if;
+
+ Analyze_And_Resolve (N, T);
+ Set_Is_Static_Expression (N, False);
+ end if;
+ end Expand_Current_Value;
+
-------------------------
-- Expand_Discriminant --
-------------------------
@@ -117,7 +277,6 @@ package body Exp_Ch2 is
if Ekind (Scop) = E_Record_Type
or Ekind (Scop) in Incomplete_Or_Private_Kind
then
-
-- Find the origin by walking up the tree till the component
-- declaration
@@ -158,11 +317,10 @@ package body Exp_Ch2 is
if Present (Parent_P)
and then Present (Corresponding_Spec (Parent_P))
then
-
declare
Loc : constant Source_Ptr := Sloc (N);
- D_Fun : Entity_Id := Corresponding_Spec (Parent_P);
- Formal : Entity_Id := First_Formal (D_Fun);
+ D_Fun : constant Entity_Id := Corresponding_Spec (Parent_P);
+ Formal : constant Entity_Id := First_Formal (D_Fun);
New_N : Node_Id;
Disc : Entity_Id;
@@ -224,6 +382,12 @@ package body Exp_Ch2 is
elsif Ekind (E) = E_Component
and then Is_Protected_Private (E)
then
+ -- Protect against junk use of tasking in no run time mode
+
+ if No_Run_Time_Mode then
+ return;
+ end if;
+
Expand_Protected_Private (N);
elsif Ekind (E) = E_Entry_Index_Parameter then
@@ -239,6 +403,23 @@ package body Exp_Ch2 is
and then Is_Shared_Passive (E)
then
Expand_Shared_Passive_Variable (N);
+
+ elsif (Ekind (E) = E_Variable
+ or else
+ Ekind (E) = E_In_Out_Parameter
+ or else
+ Ekind (E) = E_Out_Parameter)
+ and then Present (Current_Value (E))
+ and then Nkind (Current_Value (E)) /= N_Raise_Constraint_Error
+ then
+ Expand_Current_Value (N);
+
+ -- We do want to warn for the case of a boolean variable (not
+ -- a boolean constant) whose value is known at compile time.
+
+ if Is_Boolean_Type (Etype (N)) then
+ Warn_On_Known_Condition (N);
+ end if;
end if;
end Expand_Entity_Reference;
@@ -264,7 +445,61 @@ package body Exp_Ch2 is
Addr_Ent : constant Entity_Id := Node (Last_Elmt (Acc_Stack));
P_Comp_Ref : Entity_Id;
+ function In_Assignment_Context (N : Node_Id) return Boolean;
+ -- Check whether this is a context in which the entry formal may
+ -- be assigned to.
+
+ ---------------------------
+ -- In_Assignment_Context --
+ ---------------------------
+
+ function In_Assignment_Context (N : Node_Id) return Boolean is
+ begin
+ if Nkind (Parent (N)) = N_Procedure_Call_Statement
+ or else Nkind (Parent (N)) = N_Entry_Call_Statement
+ or else
+ (Nkind (Parent (N)) = N_Assignment_Statement
+ and then N = Name (Parent (N)))
+ then
+ return True;
+
+ elsif Nkind (Parent (N)) = N_Parameter_Association then
+ return In_Assignment_Context (Parent (N));
+
+ elsif (Nkind (Parent (N)) = N_Selected_Component
+ or else Nkind (Parent (N)) = N_Indexed_Component)
+ and then In_Assignment_Context (Parent (N))
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end In_Assignment_Context;
+
+ -- Start of processing for Expand_Entry_Parameter
+
begin
+ if Is_Task_Type (Scope (Ent_Spec))
+ and then Comes_From_Source (Ent_Formal)
+ then
+ -- Before replacing the formal with the local renaming that is
+ -- used in the accept block, note if this is an assignment
+ -- context, and note the modification to avoid spurious warnings,
+ -- because the original entity is not used further.
+ -- If the formal is unconstrained, we also generate an extra
+ -- parameter to hold the Constrained attribute of the actual. No
+ -- renaming is generated for this flag.
+
+ if Ekind (Entity (N)) /= E_In_Parameter
+ and then In_Assignment_Context (N)
+ then
+ Note_Possible_Modification (N);
+ end if;
+
+ Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc));
+ return;
+ end if;
+
-- What we need is a reference to the corresponding component of the
-- parameter record object. The Accept_Address field of the entry
-- entity references the address variable that contains the address
@@ -302,7 +537,7 @@ package body Exp_Ch2 is
begin
if Is_Protected_Type (Scope (Subp))
- and then Chars (Subp) /= Name_uInit_Proc
+ and then not Is_Init_Proc (Subp)
and then Present (Protected_Formal (E))
then
Set_Entity (N, Protected_Formal (E));
@@ -453,11 +688,13 @@ package body Exp_Ch2 is
-- This would be trivial, simply a test for an identifier that was a
-- reference to a formal, if it were not for the fact that a previous
-- call to Expand_Entry_Parameter will have modified the reference
- -- to the identifier to be of the form
+ -- to the identifier. A formal of a protected entity is rewritten as
-- typ!(recobj).rec.all'Constrained
-- where rec is a selector whose Entry_Formal link points to the formal
+ -- For a formal of a task entity, the formal is rewritten as a local
+ -- renaming.
function Param_Entity (N : Node_Id) return Entity_Id is
begin
@@ -466,6 +703,11 @@ package body Exp_Ch2 is
if Nkind (N) = N_Identifier then
if Is_Formal (Entity (N)) then
return Entity (N);
+
+ elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration
+ and then Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement
+ then
+ return Entity (N);
end if;
else
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 8037eb56bfc..866ce990b74 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.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- --
@@ -129,8 +129,9 @@ package body Exp_Ch3 is
-- by the descendants.
procedure Expand_Record_Controller (T : Entity_Id);
- -- T must be a record type that Has_Controlled_Component. Add a field _C
- -- of type Record_Controller or Limited_Record_Controller in the record T.
+ -- T must be a record type that Has_Controlled_Component. Add a field
+ -- _controller of type Record_Controller or Limited_Record_Controller
+ -- in the record T.
procedure Freeze_Array_Type (N : Node_Id);
-- Freeze an array type. Deals with building the initialization procedure,
@@ -161,9 +162,9 @@ package body Exp_Ch3 is
-- record types and types containing tasks, three additional formals are
-- added:
--
- -- _Master : Master_Id
- -- _Chain : in out Activation_Chain
- -- _Task_Id : Task_Image_Type
+ -- _Master : Master_Id
+ -- _Chain : in out Activation_Chain
+ -- _Task_Name : String
--
-- The caller must append additional entries for discriminants if required.
@@ -192,21 +193,38 @@ package body Exp_Ch3 is
Predef_List : out List_Id;
Renamed_Eq : out Node_Id);
-- Create a list with the specs of the predefined primitive operations.
- -- This list contains _Size, _Read, _Write, _Input and _Output for
- -- every tagged types, plus _equality, _assign, _deep_finalize and
- -- _deep_adjust for non limited tagged types. _Size, _Read, _Write,
- -- _Input and _Output implement the corresponding attributes that need
- -- to be dispatching when their arguments are classwide. _equality and
- -- _assign, implement equality and assignment that also must be
- -- dispatching. _Deep_Finalize and _Deep_Adjust are empty procedures
- -- unless the type contains some controlled components that require
- -- finalization actions. The list is returned in Predef_List. The
- -- parameter Renamed_Eq either returns the value Empty, or else the
- -- defining unit name for the predefined equality function in the
- -- case where the type has a primitive operation that is a renaming
- -- of predefined equality (but only if there is also an overriding
- -- user-defined equality function). The returned Renamed_Eq will be
- -- passed to the corresponding parameter of Predefined_Primitive_Bodies.
+ -- The following entries are present for all tagged types, and provide
+ -- the results of the corresponding attribute applied to the object.
+ -- Dispatching is required in general, since the result of the attribute
+ -- will vary with the actual object subtype.
+ --
+ -- _alignment provides result of 'Alignment attribute
+ -- _size provides result of 'Size attribute
+ -- typSR provides result of 'Read attribute
+ -- typSW provides result of 'Write attribute
+ -- typSI provides result of 'Input attribute
+ -- typSO provides result of 'Output attribute
+ --
+ -- The following entries are additionally present for non-limited
+ -- tagged types, and implement additional dispatching operations
+ -- for predefined operations:
+ --
+ -- _equality implements "=" operator
+ -- _assign implements assignment operation
+ -- typDF implements deep finalization
+ -- typDA implements deep adust
+ --
+ -- The latter two are empty procedures unless the type contains some
+ -- controlled components that require finalization actions (the deep
+ -- in the name refers to the fact that the action applies to components).
+ --
+ -- The list is returned in Predef_List. The Parameter Renamed_Eq
+ -- either returns the value Empty, or else the defining unit name
+ -- for the predefined equality function in the case where the type
+ -- has a primitive operation that is a renaming of predefined equality
+ -- (but only if there is also an overriding user-defined equality
+ -- function). The returned Renamed_Eq will be passed to the
+ -- corresponding parameter of Predefined_Primitive_Bodies.
function Has_New_Non_Standard_Rep (T : Entity_Id) return Boolean;
-- returns True if there are representation clauses for type T that
@@ -232,16 +250,16 @@ package body Exp_Ch3 is
function Predef_Stream_Attr_Spec
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
- Name : Name_Id;
+ Name : TSS_Name_Type;
For_Body : Boolean := False)
return Node_Id;
- -- Specialized version of Predef_Spec_Or_Body that apply to _read, _write,
- -- _input and _output whose specs are constructed in Exp_Strm.
+ -- Specialized version of Predef_Spec_Or_Body that apply to read, write,
+ -- input and output attribute whose specs are constructed in Exp_Strm.
function Predef_Deep_Spec
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
- Name : Name_Id;
+ Name : TSS_Name_Type;
For_Body : Boolean := False)
return Node_Id;
-- Specialized version of Predef_Spec_Or_Body that apply to _deep_adjust
@@ -413,7 +431,6 @@ package body Exp_Ch3 is
<<Continue>>
Next_Component (Comp);
end loop;
-
end Adjust_Discriminants;
---------------------------
@@ -425,7 +442,6 @@ package body Exp_Ch3 is
Comp_Type : constant Entity_Id := Component_Type (A_Type);
Index_List : List_Id;
Proc_Id : Entity_Id;
- Proc_Body : Node_Id;
Body_Stmts : List_Id;
function Init_Component return List_Id;
@@ -547,16 +563,17 @@ package body Exp_Ch3 is
if Has_Non_Null_Base_Init_Proc (Comp_Type)
or else Needs_Simple_Initialization (Comp_Type)
or else Has_Task (Comp_Type)
- or else (Is_Public (A_Type)
+ or else (not Restrictions (No_Initialize_Scalars)
+ and then Is_Public (A_Type)
and then Root_Type (A_Type) /= Standard_String
and then Root_Type (A_Type) /= Standard_Wide_String)
then
Proc_Id :=
- Make_Defining_Identifier (Loc, Name_uInit_Proc);
+ Make_Defining_Identifier (Loc, Make_Init_Proc_Name (A_Type));
Body_Stmts := Init_One_Dimension (1);
- Proc_Body :=
+ Discard_Node (
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
@@ -565,7 +582,7 @@ package body Exp_Ch3 is
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Body_Stmts));
+ Statements => Body_Stmts)));
Set_Ekind (Proc_Id, E_Procedure);
Set_Is_Public (Proc_Id, Is_Public (A_Type));
@@ -602,7 +619,6 @@ package body Exp_Ch3 is
Set_Is_Null_Init_Proc (Proc_Id);
end if;
end if;
-
end Build_Array_Init_Proc;
-----------------------------
@@ -677,6 +693,10 @@ package body Exp_Ch3 is
Analyze (Decl);
Set_Master_Id (T, M_Id);
+
+ exception
+ when RE_Not_Available =>
+ return;
end Build_Class_Wide_Master;
--------------------------------
@@ -695,7 +715,12 @@ package body Exp_Ch3 is
(Case_Id : Entity_Id;
Variant : Node_Id)
return Node_Id;
- -- Need documentation for this spec ???
+ -- Build a case statement containing only two alternatives. The
+ -- first alternative corresponds exactly to the discrete choices
+ -- given on the variant with contains the components that we are
+ -- generating the checks for. If the discriminant is one of these
+ -- return False. The second alternative is an OTHERS choice that
+ -- will return True indicating the discriminant did not match.
function Build_Dcheck_Function
(Case_Id : Entity_Id;
@@ -716,8 +741,8 @@ package body Exp_Ch3 is
Variant : Node_Id)
return Node_Id
is
+ Alt_List : constant List_Id := New_List;
Actuals_List : List_Id;
- Alt_List : List_Id := New_List;
Case_Node : Node_Id;
Case_Alt_Node : Node_Id;
Choice : Node_Id;
@@ -726,21 +751,13 @@ package body Exp_Ch3 is
Return_Node : Node_Id;
begin
- -- Build a case statement containing only two alternatives. The
- -- first alternative corresponds exactly to the discrete choices
- -- given on the variant with contains the components that we are
- -- generating the checks for. If the discriminant is one of these
- -- return False. The other alternative consists of the choice
- -- "Others" and will return True indicating the discriminant did
- -- not match.
-
Case_Node := New_Node (N_Case_Statement, Loc);
-- Replace the discriminant which controls the variant, with the
-- name of the formal of the checking function.
Set_Expression (Case_Node,
- Make_Identifier (Loc, Chars (Case_Id)));
+ Make_Identifier (Loc, Chars (Case_Id)));
Choice := First (Discrete_Choices (Variant));
@@ -852,6 +869,8 @@ package body Exp_Ch3 is
Set_Debug_Info_Off (Func_Id);
end if;
+ Analyze (Body_Node);
+
Append_Freeze_Action (Rec_Id, Body_Node);
Set_Dcheck_Function (Variant, Func_Id);
return Func_Id;
@@ -948,23 +967,22 @@ package body Exp_Ch3 is
Use_Dl : Boolean)
return List_Id
is
+ Loc : Source_Ptr := Sloc (Rec_Id);
+ Parameter_List : constant List_Id := New_List;
D : Entity_Id;
Formal : Entity_Id;
- Loc : Source_Ptr := Sloc (Rec_Id);
Param_Spec_Node : Node_Id;
- Parameter_List : List_Id := New_List;
begin
if Has_Discriminants (Rec_Id) then
D := First_Discriminant (Rec_Id);
-
while Present (D) loop
Loc := Sloc (D);
if Use_Dl then
Formal := Discriminal (D);
else
- Formal := Make_Defining_Identifier (Loc, Chars (D));
+ Formal := Make_Defining_Identifier (Loc, Chars (D));
end if;
Param_Spec_Node :=
@@ -1031,7 +1049,7 @@ package body Exp_Ch3 is
Proc : constant Entity_Id := Base_Init_Proc (Typ);
Init_Type : constant Entity_Id := Etype (First_Formal (Proc));
Full_Init_Type : constant Entity_Id := Underlying_Type (Init_Type);
- Res : List_Id := New_List;
+ Res : constant List_Id := New_List;
Full_Type : Entity_Id := Typ;
Controller_Typ : Entity_Id;
@@ -1044,13 +1062,14 @@ package body Exp_Ch3 is
return Empty_List;
end if;
- -- Go to full view if private type
+ -- Go to full view if private type. In the case of successive
+ -- private derivations, this can require more than one step.
- if Is_Private_Type (Typ)
- and then Present (Full_View (Typ))
- then
- Full_Type := Full_View (Typ);
- end if;
+ while Is_Private_Type (Full_Type)
+ and then Present (Full_View (Full_Type))
+ loop
+ Full_Type := Full_View (Full_Type);
+ end loop;
-- If Typ is derived, the procedure is the initialization procedure for
-- the root type. Wrap the argument in an conversion to make it type
@@ -1082,7 +1101,7 @@ package body Exp_Ch3 is
if Restrictions (No_Task_Hierarchy) then
-- See comments in System.Tasking.Initialization.Init_RTS
- -- for the value 3.
+ -- for the value 3 (should be rtsfindable constant ???)
Append_To (Args, Make_Integer_Literal (Loc, 3));
else
@@ -1121,6 +1140,12 @@ package body Exp_Ch3 is
begin
if Is_Protected_Type (T) then
T := Corresponding_Record_Type (T);
+
+ elsif Is_Private_Type (T)
+ and then Present (Underlying_Full_View (T))
+ and then Is_Protected_Type (Underlying_Full_View (T))
+ then
+ T := Corresponding_Record_Type (Underlying_Full_View (T));
end if;
Arg :=
@@ -1167,7 +1192,7 @@ package body Exp_Ch3 is
else
if Is_Constrained (Full_Type) then
- Arg := Duplicate_Subexpr (Arg);
+ Arg := Duplicate_Subexpr_No_Checks (Arg);
else
-- The constraints come from the discriminant default
-- exps, they must be reevaluated, so we use New_Copy_Tree
@@ -1240,23 +1265,11 @@ package body Exp_Ch3 is
end if;
end if;
- -- Discard dynamic string allocated for name after call to init_proc,
- -- to avoid storage leaks. This is done for composite types because
- -- the allocated name is used as prefix for the id constructed at run-
- -- time, and this allocated name is not released when the task itself
- -- is freed.
-
- if Has_Task (Full_Type)
- and then not Is_Task_Type (Full_Type)
- then
- Append_To (Res,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Free_Task_Image), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Defining_Identifier (Decl), Loc))));
- end if;
-
return Res;
+
+ exception
+ when RE_Not_Available =>
+ return Empty_List;
end Build_Initialization_Call;
---------------------------
@@ -1289,6 +1302,9 @@ package body Exp_Ch3 is
Set_Master_Id (T, M_Id);
+ exception
+ when RE_Not_Available =>
+ return;
end Build_Master_Renaming;
----------------------------
@@ -1297,9 +1313,9 @@ package body Exp_Ch3 is
procedure Build_Record_Init_Proc (N : Node_Id; Pe : Entity_Id) is
Loc : Source_Ptr := Sloc (N);
+ Discr_Map : constant Elist_Id := New_Elmt_List;
Proc_Id : Entity_Id;
Rec_Type : Entity_Id;
- Discr_Map : Elist_Id := New_Elmt_List;
Set_Tag : Entity_Id := Empty;
function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id;
@@ -1488,6 +1504,10 @@ package body Exp_Ch3 is
end if;
return Res;
+
+ exception
+ when RE_Not_Available =>
+ return Empty_List;
end Build_Assignment;
------------------------------------
@@ -1567,7 +1587,7 @@ package body Exp_Ch3 is
-- In the tasks case,
-- add _Master as the value of the _Master parameter
-- add _Chain as the value of the _Chain parameter.
- -- add _Task_Id as the value of the _Task_Id parameter.
+ -- add _Task_Name as the value of the _Task_Name parameter.
-- At the outer level, these will be variables holding the
-- corresponding values obtained from GNARL or the expander.
--
@@ -1588,7 +1608,7 @@ package body Exp_Ch3 is
end if;
Append_To (Args, Make_Identifier (Loc, Name_uChain));
- Append_To (Args, Make_Identifier (Loc, Name_uTask_Id));
+ Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
First_Discr_Param := Next (Next (Next (First_Discr_Param)));
end if;
@@ -1601,19 +1621,19 @@ package body Exp_Ch3 is
while Present (Parent_Discr) loop
-- Get the initial value for this discriminant
- -- ?????? needs to be cleaned up to use parent_Discr_Constr
+ -- ??? needs to be cleaned up to use parent_Discr_Constr
-- directly.
declare
Discr_Value : Elmt_Id :=
First_Elmt
- (Girder_Constraint (Rec_Type));
+ (Stored_Constraint (Rec_Type));
Discr : Entity_Id :=
- First_Girder_Discriminant (Uparent_Type);
+ First_Stored_Discriminant (Uparent_Type);
begin
while Original_Record_Component (Parent_Discr) /= Discr loop
- Next_Girder_Discriminant (Discr);
+ Next_Stored_Discriminant (Discr);
Next_Elmt (Discr_Value);
end loop;
@@ -1631,7 +1651,8 @@ package body Exp_Ch3 is
-- Case of access discriminants. We replace the reference
-- to the type by a reference to the actual object
--- ???
+-- ??? why is this code deleted without comment
+
-- elsif Nkind (Arg) = N_Attribute_Reference
-- and then Is_Entity_Name (Prefix (Arg))
-- and then Is_Type (Entity (Prefix (Arg)))
@@ -1675,7 +1696,9 @@ package body Exp_Ch3 is
Body_Stmts := New_List;
Body_Node := New_Node (N_Subprogram_Body, Loc);
- Proc_Id := Make_Defining_Identifier (Loc, Name_uInit_Proc);
+ Proc_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_Init_Proc_Name (Rec_Type));
Set_Ekind (Proc_Id, E_Procedure);
Proc_Spec_Node := New_Node (N_Procedure_Specification, Loc);
@@ -1714,7 +1737,7 @@ package body Exp_Ch3 is
-- and call the ancestor _init_proc with a type-converted object
Append_List_To (Body_Stmts,
- Build_Init_Call_Thru (Parameters));
+ Build_Init_Call_Thru (Parameters));
elsif Nkind (Type_Definition (N)) = N_Record_Definition then
Build_Discriminant_Assignments (Body_Stmts);
@@ -1737,9 +1760,9 @@ package body Exp_Ch3 is
if not Null_Present (Record_Extension_Node) then
declare
- Stmts : List_Id :=
- Build_Init_Statements (
- Component_List (Record_Extension_Node));
+ Stmts : constant List_Id :=
+ Build_Init_Statements (
+ Component_List (Record_Extension_Node));
begin
-- The parent field must be initialized first because
@@ -1803,7 +1826,7 @@ package body Exp_Ch3 is
while Present (Next (Nod))
and then (Nkind (Nod) /= N_Procedure_Call_Statement
- or else Chars (Name (Nod)) /= Name_uInit_Proc)
+ or else not Is_Init_Proc (Name (Nod)))
loop
Nod := Next (Nod);
end loop;
@@ -1843,10 +1866,10 @@ package body Exp_Ch3 is
---------------------------
function Build_Init_Statements (Comp_List : Node_Id) return List_Id is
+ Check_List : constant List_Id := New_List;
Alt_List : List_Id;
Statement_List : List_Id;
Stmts : List_Id;
- Check_List : List_Id := New_List;
Per_Object_Constraint_Components : Boolean;
@@ -1886,22 +1909,35 @@ package body Exp_Ch3 is
-- Skip processing for now and ask for a second pass
Per_Object_Constraint_Components := True;
+
else
+ -- Case of explicit initialization
+
if Present (Expression (Decl)) then
Stmts := Build_Assignment (Id, Expression (Decl));
+ -- Case of composite component with its own Init_Proc
+
elsif Has_Non_Null_Base_Init_Proc (Typ) then
Stmts :=
- Build_Initialization_Call (Loc,
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => New_Occurrence_Of (Id, Loc)),
- Typ, True, Rec_Type, Discr_Map => Discr_Map);
+ Build_Initialization_Call
+ (Loc,
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name => New_Occurrence_Of (Id, Loc)),
+ Typ,
+ True,
+ Rec_Type,
+ Discr_Map => Discr_Map);
+
+ -- Case of component needing simple initialization
elsif Component_Needs_Simple_Initialization (Typ) then
Stmts :=
Build_Assignment (Id, Get_Simple_Init_Val (Typ, Loc));
+ -- Nothing needed for this case
+
else
Stmts := No_List;
end if;
@@ -1912,16 +1948,14 @@ package body Exp_Ch3 is
if Present (Stmts) then
- -- Add the initialization of the record controller
- -- before the _Parent field is attached to it when
- -- the attachment can occur. It does not work to
- -- simply initialize the controller first: it must be
- -- initialized after the parent if the parent holds
- -- discriminants that can be used to compute the
- -- offset of the controller. This code relies on
- -- the last statement of the initialization call
- -- being the attachement of the parent. see
- -- Build_Initialization_Call.
+ -- Add the initialization of the record controller before
+ -- the _Parent field is attached to it when the attachment
+ -- can occur. It does not work to simply initialize the
+ -- controller first: it must be initialized after the parent
+ -- if the parent holds discriminants that can be used
+ -- to compute the offset of the controller. We assume here
+ -- that the last statement of the initialization call is the
+ -- attachement of the parent (see Build_Initialization_Call)
if Chars (Id) = Name_uController
and then Rec_Type /= Etype (Rec_Type)
@@ -2067,6 +2101,10 @@ package body Exp_Ch3 is
end if;
return Statement_List;
+
+ exception
+ when RE_Not_Available =>
+ return Empty_List;
end Build_Init_Statements;
-------------------------
@@ -2074,13 +2112,11 @@ package body Exp_Ch3 is
-------------------------
procedure Build_Record_Checks (S : Node_Id; Check_List : List_Id) is
- P : Node_Id;
Subtype_Mark_Id : Entity_Id;
begin
if Nkind (S) = N_Subtype_Indication then
Find_Type (Subtype_Mark (S));
- P := Parent (S);
Subtype_Mark_Id := Entity (Subtype_Mark (S));
-- Remaining processing depends on type
@@ -2195,10 +2231,10 @@ package body Exp_Ch3 is
return False;
end if;
- -- If there are no explicit girder discriminants we have inherited
+ -- If there are no explicit stored discriminants we have inherited
-- the root type discriminants so far, so no renamings occurred.
- if First_Discriminant (Pe) = First_Girder_Discriminant (Pe) then
+ if First_Discriminant (Pe) = First_Stored_Discriminant (Pe) then
return False;
end if;
@@ -2283,7 +2319,9 @@ package body Exp_Ch3 is
if Is_CPP_Class (Rec_Id) then
return False;
- elsif Is_Public (Rec_Id) then
+ elsif not Restrictions (No_Initialize_Scalars)
+ and then Is_Public (Rec_Id)
+ then
return True;
elsif (Has_Discriminants (Rec_Id)
@@ -2431,24 +2469,32 @@ package body Exp_Ch3 is
-- return True;
-- end _Equality;
- procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
+ procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
- F : constant Entity_Id := Make_Defining_Identifier (Loc,
- Name_uEquality);
- X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
- Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y);
- Def : constant Node_Id := Parent (Typ);
- Comps : constant Node_Id := Component_List (Type_Definition (Def));
- Function_Body : Node_Id;
- Stmts : List_Id := New_List;
+ F : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
+
+ X : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_X);
+
+ Y : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_Y);
+
+ Def : constant Node_Id := Parent (Typ);
+ Comps : constant Node_Id := Component_List (Type_Definition (Def));
+ Stmts : constant List_Id := New_List;
begin
if Is_Derived_Type (Typ)
and then not Has_New_Non_Standard_Rep (Typ)
then
declare
- Parent_Eq : Entity_Id := TSS (Root_Type (Typ), Name_uEquality);
+ Parent_Eq : constant Entity_Id :=
+ TSS (Root_Type (Typ), TSS_Composite_Equality);
begin
if Present (Parent_Eq) then
@@ -2458,7 +2504,7 @@ package body Exp_Ch3 is
end;
end if;
- Function_Body :=
+ Discard_Node (
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
@@ -2477,7 +2523,7 @@ package body Exp_Ch3 is
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts));
+ Statements => Stmts)));
-- For unchecked union case, raise program error. This will only
-- happen in the case of dynamic dispatching for a tagged type,
@@ -2512,10 +2558,10 @@ package body Exp_Ch3 is
-----------------------------
procedure Check_Stream_Attributes (Typ : Entity_Id) is
- Comp : Entity_Id;
- Par : constant Entity_Id := Root_Type (Base_Type (Typ));
- Par_Read : Boolean := Present (TSS (Par, Name_uRead));
- Par_Write : Boolean := Present (TSS (Par, Name_uWrite));
+ Comp : Entity_Id;
+ Par : constant Entity_Id := Root_Type (Base_Type (Typ));
+ Par_Read : constant Boolean := Present (TSS (Par, TSS_Stream_Read));
+ Par_Write : constant Boolean := Present (TSS (Par, TSS_Stream_Write));
begin
if Par_Read or else Par_Write then
@@ -2526,10 +2572,10 @@ package body Exp_Ch3 is
and then Is_Limited_Type (Etype (Comp))
then
if (Par_Read and then
- No (TSS (Base_Type (Etype (Comp)), Name_uRead)))
+ No (TSS (Base_Type (Etype (Comp)), TSS_Stream_Read)))
or else
(Par_Write and then
- No (TSS (Base_Type (Etype (Comp)), Name_uWrite)))
+ No (TSS (Base_Type (Etype (Comp)), TSS_Stream_Write)))
then
Error_Msg_N
("|component must have Stream attribute",
@@ -2614,7 +2660,7 @@ package body Exp_Ch3 is
and then not Is_Constrained (Entity (Indic))
then
D := First_Discriminant (T);
- while (Present (D)) loop
+ while Present (D) loop
Append_To (List_Constr, New_Occurrence_Of (D, Loc));
Next_Discriminant (D);
end loop;
@@ -2668,7 +2714,7 @@ package body Exp_Ch3 is
procedure Expand_N_Full_Type_Declaration (N : Node_Id) is
Def_Id : constant Entity_Id := Defining_Identifier (N);
- B_Id : Entity_Id := Base_Type (Def_Id);
+ B_Id : constant Entity_Id := Base_Type (Def_Id);
Par_Id : Entity_Id;
FN : Node_Id;
@@ -2745,7 +2791,7 @@ package body Exp_Ch3 is
end if;
declare
- T_E : Elist_Id := TSS_Elist (FN);
+ T_E : constant Elist_Id := TSS_Elist (FN);
Elmt : Elmt_Id;
begin
@@ -2789,25 +2835,16 @@ package body Exp_Ch3 is
Def_Id : constant Entity_Id := Defining_Identifier (N);
Typ : constant Entity_Id := Etype (Def_Id);
Loc : constant Source_Ptr := Sloc (N);
- Expr : Node_Id := Expression (N);
+ Expr : constant Node_Id := Expression (N);
New_Ref : Node_Id;
Id_Ref : Node_Id;
Expr_Q : Node_Id;
begin
- -- If we have a task type in no run time mode, then complain and ignore
-
- if No_Run_Time
- and then not Restricted_Profile
- and then Is_Task_Type (Typ)
- then
- Disallow_In_No_Run_Time_Mode (N);
- return;
-
-- Don't do anything for deferred constants. All proper actions will
-- be expanded during the redeclaration.
- elsif No (Expr) and Constant_Present (N) then
+ if No (Expr) and Constant_Present (N) then
return;
end if;
@@ -2917,14 +2954,6 @@ package body Exp_Ch3 is
Insert_Actions_After (N,
Build_Initialization_Call (Loc, Id_Ref, Typ));
- -- The initialization call may well set Not_Source_Assigned
- -- to False, because it looks like an modification, but the
- -- proper criterion is whether or not the type is at least
- -- partially initialized, so reset the flag appropriately.
-
- Set_Not_Source_Assigned
- (Def_Id, not Is_Partially_Initialized_Type (Typ));
-
-- If simple initialization is required, then set an appropriate
-- simple initialization expression in place. This special
-- initialization is required even though No_Init_Flag is present.
@@ -3058,6 +3087,19 @@ package body Exp_Ch3 is
and then Expr_Known_Valid (Expr)
then
Set_Is_Known_Valid (Def_Id);
+
+ -- For access types set the Is_Known_Non_Null flag if the
+ -- initializing value is known to be non-null. We can also
+ -- set Can_Never_Be_Null if this is a constant.
+
+ elsif Is_Access_Type (Typ)
+ and then Known_Non_Null (Expr)
+ then
+ Set_Is_Known_Non_Null (Def_Id);
+
+ if Constant_Present (N) then
+ Set_Can_Never_Be_Null (Def_Id);
+ end if;
end if;
-- If validity checking on copies, validate initial expression
@@ -3069,6 +3111,26 @@ package body Exp_Ch3 is
Set_Is_Known_Valid (Def_Id);
end if;
end if;
+
+ if Is_Possibly_Unaligned_Slice (Expr) then
+
+ -- Make a separate assignment that will be expanded into a
+ -- loop, to bypass back-end problems with misaligned arrays.
+
+ declare
+ Stat : constant Node_Id :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Def_Id, Loc),
+ Expression => Relocate_Node (Expr));
+
+ begin
+ Set_Expression (N, Empty);
+ Set_No_Initialization (N);
+ Set_Assignment_OK (Name (Stat));
+ Insert_After (N, Stat);
+ Analyze (Stat);
+ end;
+ end if;
end if;
-- For array type, check for size too large
@@ -3078,6 +3140,9 @@ package body Exp_Ch3 is
Apply_Array_Size_Check (N, Typ);
end if;
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_N_Object_Declaration;
---------------------------------
@@ -3090,8 +3155,8 @@ package body Exp_Ch3 is
-- avoid generating extraneous expanded code.
procedure Expand_N_Subtype_Indication (N : Node_Id) is
- Ran : Node_Id := Range_Expression (Constraint (N));
- Typ : Entity_Id := Entity (Subtype_Mark (N));
+ Ran : constant Node_Id := Range_Expression (Constraint (N));
+ Typ : constant Entity_Id := Entity (Subtype_Mark (N));
begin
if Nkind (Parent (N)) = N_Constrained_Array_Definition or else
@@ -3231,7 +3296,7 @@ package body Exp_Ch3 is
-- instead of a potentially inherited one.
declare
- E : Entity_Id := Last_Entity (T);
+ E : constant Entity_Id := Last_Entity (T);
Comp : Entity_Id;
begin
@@ -3250,6 +3315,10 @@ package body Exp_Ch3 is
end;
End_Scope;
+
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_Record_Controller;
------------------------
@@ -3302,6 +3371,10 @@ package body Exp_Ch3 is
-- tree is coherent with the semantic decoration
Find_Type (Subtype_Indication (Comp_Decl));
+
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_Tagged_Root;
-----------------------
@@ -3313,8 +3386,6 @@ package body Exp_Ch3 is
Base : constant Entity_Id := Base_Type (Typ);
begin
- -- Nothing to do for packed case
-
if not Is_Bit_Packed_Array (Typ) then
-- If the component contains tasks, so does the array type.
@@ -3364,6 +3435,15 @@ package body Exp_Ch3 is
if Typ = Base and then Has_Controlled_Component (Base) then
Build_Controlling_Procs (Base);
end if;
+
+ -- For packed case, there is a default initialization, except
+ -- if the component type is itself a packed structure with an
+ -- initialization procedure.
+
+ elsif Present (Init_Proc (Component_Type (Base)))
+ and then No (Base_Init_Proc (Base))
+ then
+ Build_Array_Init_Proc (Base, N);
end if;
end Freeze_Array_Type;
@@ -3372,35 +3452,69 @@ package body Exp_Ch3 is
-----------------------------
procedure Freeze_Enumeration_Type (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Entity (N);
- Ent : Entity_Id;
- Lst : List_Id;
- Num : Nat;
- Arr : Entity_Id;
- Fent : Entity_Id;
+ Typ : constant Entity_Id := Entity (N);
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Ent : Entity_Id;
+ Lst : List_Id;
+ Num : Nat;
+ Arr : Entity_Id;
+ Fent : Entity_Id;
+ Ityp : Entity_Id;
+ Is_Contiguous : Boolean;
+ Pos_Expr : Node_Id;
+ Last_Repval : Uint;
+
Func : Entity_Id;
- Ityp : Entity_Id;
+ pragma Warnings (Off, Func);
begin
- -- Build list of literal references
-
- Lst := New_List;
- Num := 0;
+ -- Various optimization are possible if the given representation
+ -- is contiguous.
+ Is_Contiguous := True;
Ent := First_Literal (Typ);
+ Last_Repval := Enumeration_Rep (Ent);
+ Next_Literal (Ent);
+
while Present (Ent) loop
- Append_To (Lst, New_Reference_To (Ent, Sloc (Ent)));
- Num := Num + 1;
+ if Enumeration_Rep (Ent) - Last_Repval /= 1 then
+ Is_Contiguous := False;
+ exit;
+ else
+ Last_Repval := Enumeration_Rep (Ent);
+ end if;
+
Next_Literal (Ent);
end loop;
- -- Now build an array declaration
+ if Is_Contiguous then
+ Set_Has_Contiguous_Rep (Typ);
+ Ent := First_Literal (Typ);
+ Num := 1;
+ Lst := New_List (New_Reference_To (Ent, Sloc (Ent)));
+
+ else
+ -- Build list of literal references
+
+ Lst := New_List;
+ Num := 0;
+
+ Ent := First_Literal (Typ);
+ while Present (Ent) loop
+ Append_To (Lst, New_Reference_To (Ent, Sloc (Ent)));
+ Num := Num + 1;
+ Next_Literal (Ent);
+ end loop;
+ end if;
+
+ -- Now build an array declaration.
-- typA : array (Natural range 0 .. num - 1) of ctype :=
- -- (v, v, v, v, v, ....)
+ -- (v, v, v, v, v, ....)
- -- where ctype is the corresponding integer type
+ -- where ctype is the corresponding integer type. If the
+ -- representation is contiguous, we only keep the first literal,
+ -- which provides the offset for Pos_To_Rep computations.
Arr :=
Make_Defining_Identifier (Loc,
@@ -3443,50 +3557,35 @@ package body Exp_Ch3 is
-- when enum-lit'Enum_Rep => return posval;
-- ...
-- when others =>
- -- [raise Program_Error when F]
+ -- [raise Constraint_Error when F "invalid data"]
-- return -1;
-- end case;
-- end;
-- Note: the F parameter determines whether the others case (no valid
- -- representation) raises Program_Error or returns a unique value of
- -- minus one. The latter case is used, e.g. in 'Valid code.
+ -- representation) raises Constraint_Error or returns a unique value
+ -- of minus one. The latter case is used, e.g. in 'Valid code.
-- Note: the reason we use Enum_Rep values in the case here is to
-- avoid the code generator making inappropriate assumptions about
-- the range of the values in the case where the value is invalid.
-- ityp is a signed or unsigned integer type of appropriate width.
- -- Note: in the case of No_Run_Time mode, where we cannot handle
- -- a program error in any case, we suppress the raise and just
- -- return -1 unconditionally (this is an erroneous program in any
- -- case and there is no obligation to raise Program_Error here!)
+ -- Note: if exceptions are not supported, then we suppress the raise
+ -- and return -1 unconditionally (this is an erroneous program in any
+ -- case and there is no obligation to raise Constraint_Error here!)
-- We also do this if pragma Restrictions (No_Exceptions) is active.
- -- First build list of cases
-
- Lst := New_List;
-
- Ent := First_Literal (Typ);
- while Present (Ent) loop
- Append_To (Lst,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices => New_List (
- Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
- Intval => Enumeration_Rep (Ent))),
+ -- Representations are signed
- Statements => New_List (
- Make_Return_Statement (Loc,
- Expression =>
- Make_Integer_Literal (Loc,
- Intval => Enumeration_Pos (Ent))))));
+ if Enumeration_Rep (First_Literal (Typ)) < 0 then
- Next_Literal (Ent);
- end loop;
+ -- The underlying type is signed. Reset the Is_Unsigned_Type
+ -- explicitly, because it might have been inherited from a
+ -- parent type.
- -- Representations are signed
+ Set_Is_Unsigned_Type (Typ, False);
- if Enumeration_Rep (First_Literal (Typ)) < 0 then
if Esize (Typ) <= Standard_Integer_Size then
Ityp := Standard_Integer;
else
@@ -3503,22 +3602,87 @@ package body Exp_Ch3 is
end if;
end if;
+ -- The body of the function is a case statement. First collect
+ -- case alternatives, or optimize the contiguous case.
+
+ Lst := New_List;
+
+ -- If representation is contiguous, Pos is computed by subtracting
+ -- the representation of the first literal.
+
+ if Is_Contiguous then
+ Ent := First_Literal (Typ);
+
+ if Enumeration_Rep (Ent) = Last_Repval then
+
+ -- Another special case: for a single literal, Pos is zero.
+
+ Pos_Expr := Make_Integer_Literal (Loc, Uint_0);
+
+ else
+ Pos_Expr :=
+ Convert_To (Standard_Integer,
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To (Ityp,
+ Make_Identifier (Loc, Name_uA)),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Intval =>
+ Enumeration_Rep (First_Literal (Typ)))));
+ end if;
+
+ Append_To (Lst,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices => New_List (
+ Make_Range (Sloc (Enumeration_Rep_Expr (Ent)),
+ Low_Bound =>
+ Make_Integer_Literal (Loc,
+ Intval => Enumeration_Rep (Ent)),
+ High_Bound =>
+ Make_Integer_Literal (Loc, Intval => Last_Repval))),
+
+ Statements => New_List (
+ Make_Return_Statement (Loc,
+ Expression => Pos_Expr))));
+
+ else
+ Ent := First_Literal (Typ);
+
+ while Present (Ent) loop
+ Append_To (Lst,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices => New_List (
+ Make_Integer_Literal (Sloc (Enumeration_Rep_Expr (Ent)),
+ Intval => Enumeration_Rep (Ent))),
+
+ Statements => New_List (
+ Make_Return_Statement (Loc,
+ Expression =>
+ Make_Integer_Literal (Loc,
+ Intval => Enumeration_Pos (Ent))))));
+
+ Next_Literal (Ent);
+ end loop;
+ end if;
+
-- In normal mode, add the others clause with the test
- if not (No_Run_Time or Restrictions (No_Exceptions)) then
+ if not Restrictions (No_Exception_Handlers) then
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (
- Make_Raise_Program_Error (Loc,
+ Make_Raise_Constraint_Error (Loc,
Condition => Make_Identifier (Loc, Name_uF),
- Reason => PE_Invalid_Data),
+ Reason => CE_Invalid_Data),
Make_Return_Statement (Loc,
Expression =>
Make_Integer_Literal (Loc, -1)))));
- -- If No_Run_Time mode, unconditionally return -1. Same
- -- treatment if we have pragma Restrictions (No_Exceptions).
+ -- If Restriction (No_Exceptions_Handlers) is active then we always
+ -- return -1 (since we cannot usefully raise Constraint_Error in
+ -- this case). See description above for further details.
else
Append_To (Lst,
@@ -3533,7 +3697,7 @@ package body Exp_Ch3 is
-- Now we can build the function body
Fent :=
- Make_Defining_Identifier (Loc, Name_uRep_To_Pos);
+ Make_Defining_Identifier (Loc, Make_TSS_Name (Typ, TSS_Rep_To_Pos));
Func :=
Make_Subprogram_Body (Loc,
@@ -3569,6 +3733,10 @@ package body Exp_Ch3 is
if not Debug_Generated_Code then
Set_Debug_Info_Off (Fent);
end if;
+
+ exception
+ when RE_Not_Available =>
+ return;
end Freeze_Enumeration_Type;
------------------------
@@ -3609,7 +3777,6 @@ package body Exp_Ch3 is
Old_Comp :=
First_Component (Base_Type (Underlying_Type (Etype (Def_Id))));
Comp := First_Component (Def_Id);
-
while Present (Comp) loop
if Ekind (Comp) = E_Component
and then Chars (Comp) = Chars (Old_Comp)
@@ -3658,7 +3825,6 @@ package body Exp_Ch3 is
-- that the Vtable is created in the C++ side and we just use it.
if Is_Tagged_Type (Def_Id) then
-
if Is_CPP_Class (Def_Id) then
Set_All_DT_Position (Def_Id);
Set_Default_Constructor (Def_Id);
@@ -3828,8 +3994,11 @@ package body Exp_Ch3 is
------------------------------
procedure Freeze_Stream_Operations (N : Node_Id; Typ : Entity_Id) is
- Names : constant array (1 .. 4) of Name_Id :=
- (Name_uInput, Name_uOutput, Name_uRead, Name_uWrite);
+ Names : constant array (1 .. 4) of TSS_Name_Type :=
+ (TSS_Stream_Input,
+ TSS_Stream_Output,
+ TSS_Stream_Read,
+ TSS_Stream_Write);
Stream_Op : Entity_Id;
begin
@@ -3868,7 +4037,8 @@ package body Exp_Ch3 is
-- node using Append_Freeze_Actions.
procedure Freeze_Type (N : Node_Id) is
- Def_Id : constant Entity_Id := Entity (N);
+ Def_Id : constant Entity_Id := Entity (N);
+ RACW_Seen : Boolean := False;
begin
-- Process associated access types needing special processing
@@ -3879,16 +4049,20 @@ package body Exp_Ch3 is
begin
while Present (E) loop
- -- If the access type is a RACW, call the expansion procedure
- -- for this remote pointer.
-
if Is_Remote_Access_To_Class_Wide_Type (Node (E)) then
- Remote_Types_Tagged_Full_View_Encountered (Def_Id);
+ RACW_Seen := True;
end if;
E := Next_Elmt (E);
end loop;
end;
+
+ if RACW_Seen then
+
+ -- If there are RACWs designating this type, make stubs now.
+
+ Remote_Types_Tagged_Full_View_Encountered (Def_Id);
+ end if;
end if;
-- Freeze processing for record types
@@ -3911,7 +4085,7 @@ package body Exp_Ch3 is
and then Present (Controller_Component (Def_Id))
then
declare
- Old_C : Entity_Id := Controller_Component (Def_Id);
+ Old_C : constant Entity_Id := Controller_Component (Def_Id);
New_C : Entity_Id;
begin
@@ -3926,6 +4100,33 @@ package body Exp_Ch3 is
End_Scope;
end if;
end;
+
+ -- Similar process if the controller of the subtype is not
+ -- present but the parent has it. This can happen with constrained
+ -- record components where the subtype is an itype.
+
+ elsif Ekind (Def_Id) = E_Record_Subtype
+ and then Is_Itype (Def_Id)
+ and then No (Controller_Component (Def_Id))
+ and then Present (Controller_Component (Etype (Def_Id)))
+ then
+ declare
+ Old_C : constant Entity_Id :=
+ Controller_Component (Etype (Def_Id));
+ New_C : constant Entity_Id := New_Copy (Old_C);
+
+ begin
+ Set_Next_Entity (New_C, First_Entity (Def_Id));
+ Set_First_Entity (Def_Id, New_C);
+
+ -- The freeze node is only used to introduce the controller,
+ -- the back-end has no use for it for a discriminated
+ -- component.
+
+ Set_Freeze_Node (Def_Id, Empty);
+ Set_Has_Delayed_Freeze (Def_Id, False);
+ Remove (N);
+ end;
end if;
-- Freeze processing for array types
@@ -4107,18 +4308,21 @@ package body Exp_Ch3 is
elsif (Controlled_Type (Desig_Type)
and then Convention (Desig_Type) /= Convention_Java)
- or else (Is_Incomplete_Or_Private_Type (Desig_Type)
- and then No (Full_View (Desig_Type))
+ or else
+ (Is_Incomplete_Or_Private_Type (Desig_Type)
+ and then No (Full_View (Desig_Type))
-- An exception is made for types defined in the run-time
-- because Ada.Tags.Tag itself is such a type and cannot
-- afford this unnecessary overhead that would generates a
-- loop in the expansion scheme...
- -- Similarly, if No_Run_Time is enabled, the designated type
- -- cannot be controlled.
- and then not In_Runtime (Def_Id)
- and then not No_Run_Time)
+ and then not In_Runtime (Def_Id)
+
+ -- Another exception is if Restrictions (No_Finalization)
+ -- is active, since then we know nothing is controlled.
+
+ and then not Restrictions (No_Finalization))
-- If the designated type is not frozen yet, its controlled
-- status must be retrieved explicitly.
@@ -4151,7 +4355,7 @@ package body Exp_Ch3 is
Freeze_Enumeration_Type (N);
end if;
- -- private types that are completed by a derivation from a private
+ -- Private types that are completed by a derivation from a private
-- type have an internally generated full view, that needs to be
-- frozen. This must be done explicitly because the two views share
-- the freeze node, and the underlying full view is not visible when
@@ -4175,6 +4379,10 @@ package body Exp_Ch3 is
end if;
Freeze_Stream_Operations (N, Def_Id);
+
+ exception
+ when RE_Not_Available =>
+ return;
end Freeze_Type;
-------------------------
@@ -4215,7 +4423,17 @@ package body Exp_Ch3 is
Expression => Val);
end if;
- return Unchecked_Convert_To (T, Val);
+ Result := Unchecked_Convert_To (T, Val);
+
+ -- Don't truncate result (important for Initialize/Normalize_Scalars)
+
+ if Nkind (Result) = N_Unchecked_Type_Conversion
+ and then Is_Scalar_Type (Underlying_Type (T))
+ then
+ Set_No_Truncation (Result);
+ end if;
+
+ return Result;
-- For scalars, we must have normalize/initialize scalars case
@@ -4267,19 +4485,8 @@ package body Exp_Ch3 is
Val_RE := RE_IS_Isf;
elsif Root_Type (T) = Standard_Float then
Val_RE := RE_IS_Ifl;
-
- -- The form of the following test is quite deliberate, it
- -- catches the case of architectures (the most common case)
- -- where Long_Long_Float is the same as Long_Float, and in
- -- such cases initializes Long_Long_Float variables from the
- -- Long_Float constant (since the Long_Long_Float constant is
- -- only for use on the x86).
-
- elsif Esize (Root_Type (T)) = Esize (Standard_Long_Float) then
+ elsif Root_Type (T) = Standard_Long_Float then
Val_RE := RE_IS_Ilf;
-
- -- Otherwise we have extended real on an x86
-
else pragma Assert (Root_Type (T) = Standard_Long_Long_Float);
Val_RE := RE_IS_Ill;
end if;
@@ -4318,7 +4525,11 @@ package body Exp_Ch3 is
Result := Unchecked_Convert_To (Base_Type (T), Val);
+ -- Ensure result is not truncated, since we want the "bad" bits
+ -- and also kill range check on result.
+
if Nkind (Result) = N_Unchecked_Type_Conversion then
+ Set_No_Truncation (Result);
Set_Kill_Range_Check (Result, True);
end if;
@@ -4377,6 +4588,10 @@ package body Exp_Ch3 is
else
raise Program_Error;
end if;
+
+ exception
+ when RE_Not_Available =>
+ return Empty;
end Get_Simple_Init_Val;
------------------------------
@@ -4466,13 +4681,17 @@ package body Exp_Ch3 is
Append_To (Formals,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uTask_Id),
+ Make_Defining_Identifier (Loc, Name_uTask_Name),
In_Present => True,
Parameter_Type =>
- New_Reference_To (RTE (RE_Task_Image_Type), Loc)));
+ New_Reference_To (Standard_String, Loc)));
end if;
return Formals;
+
+ exception
+ when RE_Not_Available =>
+ return Empty_List;
end Init_Formals;
------------------
@@ -4488,9 +4707,9 @@ package body Exp_Ch3 is
function Make_Eq_Case (Node : Node_Id; CL : Node_Id) return List_Id is
Loc : constant Source_Ptr := Sloc (Node);
+ Result : constant List_Id := New_List;
Variant : Node_Id;
Alt_List : List_Id;
- Result : List_Id := New_List;
begin
Append_To (Result, Make_Eq_If (Node, Component_Items (CL)));
@@ -4610,7 +4829,7 @@ package body Exp_Ch3 is
Renamed_Eq : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
- Res : List_Id := New_List;
+ Res : constant List_Id := New_List;
Prim : Elmt_Id;
Eq_Needed : Boolean;
Eq_Spec : Node_Id;
@@ -4620,6 +4839,10 @@ package body Exp_Ch3 is
-- Returns true if Prim is a renaming of an unresolved predefined
-- equality operation.
+ -------------------------------
+ -- Is_Predefined_Eq_Renaming --
+ -------------------------------
+
function Is_Predefined_Eq_Renaming (Prim : Node_Id) return Boolean is
begin
return Chars (Prim) /= Name_Op_Eq
@@ -4634,6 +4857,18 @@ package body Exp_Ch3 is
begin
Renamed_Eq := Empty;
+ -- Spec of _Alignment
+
+ Append_To (Res, Predef_Spec_Or_Body (Loc,
+ Tag_Typ => Tag_Typ,
+ Name => Name_uAlignment,
+ Profile => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
+ Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
+
+ Ret_Type => Standard_Integer));
+
-- Spec of _Size
Append_To (Res, Predef_Spec_Or_Body (Loc,
@@ -4649,27 +4884,33 @@ package body Exp_Ch3 is
-- Specs for dispatching stream attributes. We skip these for limited
-- types, since there is no question of dispatching in the limited case.
- -- We also skip these operations in No_Run_Time mode, where
- -- dispatching stream operations cannot be used (this is currently
- -- a No_Run_Time restriction).
+ -- We also skip these operations if dispatching is not available
+ -- or if streams are not available (since what's the point?)
- if not (No_Run_Time or else Is_Limited_Type (Tag_Typ)) then
- Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uRead));
- Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uWrite));
- Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uInput));
- Append_To (Res, Predef_Stream_Attr_Spec (Loc, Tag_Typ, Name_uOutput));
+ if not Is_Limited_Type (Tag_Typ)
+ and then RTE_Available (RE_Tag)
+ and then RTE_Available (RE_Root_Stream_Type)
+ then
+ Append_To (Res,
+ Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Read));
+ Append_To (Res,
+ Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Write));
+ Append_To (Res,
+ Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Input));
+ Append_To (Res,
+ Predef_Stream_Attr_Spec (Loc, Tag_Typ, TSS_Stream_Output));
end if;
- if not Is_Limited_Type (Tag_Typ) then
-
- -- Spec of "=" if expanded if the type is not limited and if a
- -- user defined "=" was not already declared for the non-full
- -- view of a private extension
+ -- Spec of "=" if expanded if the type is not limited and if a
+ -- user defined "=" was not already declared for the non-full
+ -- view of a private extension
+ if not Is_Limited_Type (Tag_Typ) then
Eq_Needed := True;
Prim := First_Elmt (Primitive_Operations (Tag_Typ));
while Present (Prim) loop
+
-- If a primitive is encountered that renames the predefined
-- equality operator before reaching any explicit equality
-- primitive, then we still need to create a predefined
@@ -4794,20 +5035,18 @@ package body Exp_Ch3 is
if In_Finalization_Root (Tag_Typ) then
null;
- -- We also skip these in No_Run_Time mode where finalization is
- -- never permissible.
+ -- We also skip these if finalization is not available
- elsif No_Run_Time then
+ elsif Restrictions (No_Finalization) then
null;
elsif Etype (Tag_Typ) = Tag_Typ or else Controlled_Type (Tag_Typ) then
-
if not Is_Limited_Type (Tag_Typ) then
Append_To (Res,
- Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Adjust));
+ Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust));
end if;
- Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Finalize));
+ Append_To (Res, Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize));
end if;
Predef_List := Res;
@@ -4873,7 +5112,7 @@ package body Exp_Ch3 is
function Predef_Deep_Spec
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
- Name : Name_Id;
+ Name : TSS_Name_Type;
For_Body : Boolean := False)
return Node_Id
is
@@ -4881,7 +5120,7 @@ package body Exp_Ch3 is
Type_B : Entity_Id;
begin
- if Name = Name_uDeep_Finalize then
+ if Name = TSS_Deep_Finalize then
Prof := New_List;
Type_B := Standard_Boolean;
@@ -4909,10 +5148,14 @@ package body Exp_Ch3 is
Parameter_Type => New_Reference_To (Type_B, Loc)));
return Predef_Spec_Or_Body (Loc,
- Name => Name,
+ Name => Make_TSS_Name (Tag_Typ, Name),
Tag_Typ => Tag_Typ,
Profile => Prof,
For_Body => For_Body);
+
+ exception
+ when RE_Not_Available =>
+ return Empty;
end Predef_Deep_Spec;
-------------------------
@@ -4928,7 +5171,7 @@ package body Exp_Ch3 is
For_Body : Boolean := False)
return Node_Id
is
- Id : Entity_Id := Make_Defining_Identifier (Loc, Name);
+ Id : constant Entity_Id := Make_Defining_Identifier (Loc, Name);
Spec : Node_Id;
begin
@@ -4969,12 +5212,14 @@ package body Exp_Ch3 is
if For_Body then
return Make_Subprogram_Body (Loc, Spec, Empty_List, Empty);
- -- For the case of _Input and _Output applied to an abstract type,
+ -- For the case of Input/Output attributes applied to an abstract type,
-- generate abstract specifications. These will never be called,
-- but we need the slots allocated in the dispatching table so
-- that typ'Class'Input and typ'Class'Output will work properly.
- elsif (Name = Name_uInput or else Name = Name_uOutput)
+ elsif (Is_TSS (Name, TSS_Stream_Input)
+ or else
+ Is_TSS (Name, TSS_Stream_Output))
and then Is_Abstract (Tag_Typ)
then
return Make_Abstract_Subprogram_Declaration (Loc, Spec);
@@ -4993,21 +5238,21 @@ package body Exp_Ch3 is
function Predef_Stream_Attr_Spec
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
- Name : Name_Id;
+ Name : TSS_Name_Type;
For_Body : Boolean := False)
return Node_Id
is
Ret_Type : Entity_Id;
begin
- if Name = Name_uInput then
+ if Name = TSS_Stream_Input then
Ret_Type := Tag_Typ;
else
Ret_Type := Empty;
end if;
return Predef_Spec_Or_Body (Loc,
- Name => Name,
+ Name => Make_TSS_Name (Tag_Typ, Name),
Tag_Typ => Tag_Typ,
Profile => Build_Stream_Attr_Profile (Loc, Tag_Typ, Name),
Ret_Type => Ret_Type,
@@ -5024,8 +5269,8 @@ package body Exp_Ch3 is
return List_Id
is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
+ Res : constant List_Id := New_List;
Decl : Node_Id;
- Res : List_Id := New_List;
Prim : Elmt_Id;
Eq_Needed : Boolean;
Eq_Name : Name_Id;
@@ -5055,6 +5300,29 @@ package body Exp_Ch3 is
end loop;
end if;
+ -- Body of _Alignment
+
+ Decl := Predef_Spec_Or_Body (Loc,
+ Tag_Typ => Tag_Typ,
+ Name => Name_uAlignment,
+ Profile => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
+ Parameter_Type => New_Reference_To (Tag_Typ, Loc))),
+
+ Ret_Type => Standard_Integer,
+ For_Body => True);
+
+ Set_Handled_Statement_Sequence (Decl,
+ Make_Handled_Sequence_Of_Statements (Loc, New_List (
+ Make_Return_Statement (Loc,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_X),
+ Attribute_Name => Name_Alignment)))));
+
+ Append_To (Res, Decl);
+
-- Body of _Size
Decl := Predef_Spec_Or_Body (Loc,
@@ -5080,16 +5348,17 @@ package body Exp_Ch3 is
-- Bodies for Dispatching stream IO routines. We need these only for
-- non-limited types (in the limited case there is no dispatching).
- -- and we always skip them in No_Run_Time mode where streams are not
- -- permitted.
+ -- We also skip them if dispatching is not available.
- if not (Is_Limited_Type (Tag_Typ) or else No_Run_Time) then
- if No (TSS (Tag_Typ, Name_uRead)) then
+ if not Is_Limited_Type (Tag_Typ)
+ and then not Restrictions (No_Finalization)
+ then
+ if No (TSS (Tag_Typ, TSS_Stream_Read)) then
Build_Record_Read_Procedure (Loc, Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
- if No (TSS (Tag_Typ, Name_uWrite)) then
+ if No (TSS (Tag_Typ, TSS_Stream_Write)) then
Build_Record_Write_Procedure (Loc, Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
@@ -5098,13 +5367,13 @@ package body Exp_Ch3 is
-- the corresponding specs are abstract (see Predef_Spec_Or_Body)
if not Is_Abstract (Tag_Typ) then
- if No (TSS (Tag_Typ, Name_uInput)) then
+ if No (TSS (Tag_Typ, TSS_Stream_Input)) then
Build_Record_Or_Elementary_Input_Function
(Loc, Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
end if;
- if No (TSS (Tag_Typ, Name_uOutput)) then
+ if No (TSS (Tag_Typ, TSS_Stream_Output)) then
Build_Record_Or_Elementary_Output_Procedure
(Loc, Tag_Typ, Decl, Ent);
Append_To (Res, Decl);
@@ -5137,10 +5406,10 @@ package body Exp_Ch3 is
declare
Def : constant Node_Id := Parent (Tag_Typ);
+ Stmts : constant List_Id := New_List;
Variant_Case : Boolean := Has_Discriminants (Tag_Typ);
Comps : Node_Id := Empty;
Typ_Def : Node_Id := Type_Definition (Def);
- Stmts : List_Id := New_List;
begin
if Variant_Case then
@@ -5215,16 +5484,16 @@ package body Exp_Ch3 is
if In_Finalization_Root (Tag_Typ) then
null;
- -- Skip this in no run time mode (where finalization is never allowed)
+ -- Skip this if finalization is not available
- elsif No_Run_Time then
+ elsif Restrictions (No_Finalization) then
null;
elsif (Etype (Tag_Typ) = Tag_Typ or else Is_Controlled (Tag_Typ))
and then not Has_Controlled_Component (Tag_Typ)
then
if not Is_Limited_Type (Tag_Typ) then
- Decl := Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Adjust, True);
+ Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
if Is_Controlled (Tag_Typ) then
Set_Handled_Statement_Sequence (Decl,
@@ -5244,7 +5513,7 @@ package body Exp_Ch3 is
Append_To (Res, Decl);
end if;
- Decl := Predef_Deep_Spec (Loc, Tag_Typ, Name_uDeep_Finalize, True);
+ Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
if Is_Controlled (Tag_Typ) then
Set_Handled_Statement_Sequence (Decl,
@@ -5271,11 +5540,10 @@ package body Exp_Ch3 is
---------------------------------
function Predefined_Primitive_Freeze
- (Tag_Typ : Entity_Id)
- return List_Id
+ (Tag_Typ : Entity_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
- Res : List_Id := New_List;
+ Res : constant List_Id := New_List;
Prim : Elmt_Id;
Frnodes : List_Id;
@@ -5295,5 +5563,4 @@ package body Exp_Ch3 is
return Res;
end Predefined_Primitive_Freeze;
-
end Exp_Ch3;
diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads
index 2c15e1e9552..6d94e1a714b 100644
--- a/gcc/ada/exp_ch3.ads
+++ b/gcc/ada/exp_ch3.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -26,7 +26,7 @@
-- Expand routines for chapter 3 constructs
-with Types; use Types;
+with Types; use Types;
with Elists; use Elists;
package Exp_Ch3 is
@@ -64,9 +64,9 @@ package Exp_Ch3 is
-- component (for array elements). Loc is the source location for the
-- constructed tree, and Typ is the type of the entity (the initialization
-- procedure of the base type is the procedure that actually gets called).
- -- In_Init_Proc has to be set to True when the call is itself in an Init
- -- procedure in order to enable the use of discriminals. Enclos_type is
- -- the type of the init_proc and it is used for various expansion cases
+ -- In_Init_Proc has to be set to True when the call is itself in an init
+ -- proc in order to enable the use of discriminals. Enclos_type is the
+ -- type of the init proc and it is used for various expansion cases
-- including the case where Typ is a task type which is a array component,
-- the indices of the enclosing type are used to build the string that
-- identifies each task at runtime.
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index ba8c00219b2..30be4d754f2 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.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- --
@@ -44,7 +44,6 @@ with Inline; use Inline;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
-with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
@@ -75,11 +74,23 @@ package body Exp_Ch4 is
pragma Inline (Binary_Op_Validity_Checks);
-- Performs validity checks for a binary operator
+ procedure Build_Boolean_Array_Proc_Call
+ (N : Node_Id;
+ Op1 : Node_Id;
+ Op2 : Node_Id);
+ -- If an boolean array assignment can be done in place, build call to
+ -- corresponding library procedure.
+
+ procedure Expand_Allocator_Expression (N : Node_Id);
+ -- Subsidiary to Expand_N_Allocator, for the case when the expression
+ -- is a qualified expression or an aggregate.
+
procedure Expand_Array_Comparison (N : Node_Id);
-- This routine handles expansion of the comparison operators (N_Op_Lt,
-- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
-- code for these operators is similar, differing only in the details of
- -- the actual comparison call that is made.
+ -- the actual comparison call that is made. Special processing (call a
+ -- run-time routine)
function Expand_Array_Equality
(Nod : Node_Id;
@@ -95,7 +106,7 @@ package body Exp_Ch4 is
-- expressions to be compared. A_Typ is the type of the arguments,
-- which may be a private type, in which case Typ is its full view.
-- Bodies is a list on which to attach bodies of local functions that
- -- are created in the process. This is the responsability of the
+ -- are created in the process. This is the responsibility of the
-- caller to insert those bodies at the right place. Nod provides
-- the Sloc value for the generated code.
@@ -136,6 +147,15 @@ package body Exp_Ch4 is
-- purpose of this routine is to find the real type by looking up
-- the tree. We also determine if the operation must be rounded.
+ function Get_Allocator_Final_List
+ (N : Node_Id;
+ T : Entity_Id;
+ PtrT : Entity_Id)
+ return Entity_Id;
+ -- If the designated type is controlled, build final_list expression
+ -- for created object. If context is an access parameter, create a
+ -- local access type to have a usable finalization list.
+
procedure Insert_Dereference_Action (N : Node_Id);
-- N is an expression whose type is an access. When the type is derived
-- from Checked_Pool, expands a call to the primitive 'dereference'.
@@ -172,6 +192,15 @@ package body Exp_Ch4 is
-- Construct the expression corresponding to the tagged membership test.
-- Deals with a second operand being (or not) a class-wide type.
+ function Safe_In_Place_Array_Op
+ (Lhs : Node_Id;
+ Op1 : Node_Id;
+ Op2 : Node_Id)
+ return Boolean;
+ -- In the context of an assignment, where the right-hand side is a
+ -- boolean operation on arrays, check whether operation can be performed
+ -- in place.
+
procedure Unary_Op_Validity_Checks (N : Node_Id);
pragma Inline (Unary_Op_Validity_Checks);
-- Performs validity checks for a unary operator
@@ -188,12 +217,424 @@ package body Exp_Ch4 is
end if;
end Binary_Op_Validity_Checks;
+ ------------------------------------
+ -- Build_Boolean_Array_Proc_Call --
+ ------------------------------------
+
+ procedure Build_Boolean_Array_Proc_Call
+ (N : Node_Id;
+ Op1 : Node_Id;
+ Op2 : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Kind : constant Node_Kind := Nkind (Expression (N));
+ Target : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Name (N),
+ Attribute_Name => Name_Address);
+
+ Arg1 : constant Node_Id := Op1;
+ Arg2 : Node_Id := Op2;
+ Call_Node : Node_Id;
+ Proc_Name : Entity_Id;
+
+ begin
+ if Kind = N_Op_Not then
+ if Nkind (Op1) in N_Binary_Op then
+
+ -- Use negated version of the binary operators.
+
+ if Nkind (Op1) = N_Op_And then
+ Proc_Name := RTE (RE_Vector_Nand);
+
+ elsif Nkind (Op1) = N_Op_Or then
+ Proc_Name := RTE (RE_Vector_Nor);
+
+ else pragma Assert (Nkind (Op1) = N_Op_Xor);
+ Proc_Name := RTE (RE_Vector_Xor);
+ end if;
+
+ Call_Node :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Proc_Name, Loc),
+
+ Parameter_Associations => New_List (
+ Target,
+ Make_Attribute_Reference (Loc,
+ Prefix => Left_Opnd (Op1),
+ Attribute_Name => Name_Address),
+
+ Make_Attribute_Reference (Loc,
+ Prefix => Right_Opnd (Op1),
+ Attribute_Name => Name_Address),
+
+ Make_Attribute_Reference (Loc,
+ Prefix => Left_Opnd (Op1),
+ Attribute_Name => Name_Length)));
+
+ else
+ Proc_Name := RTE (RE_Vector_Not);
+
+ Call_Node :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Proc_Name, Loc),
+ Parameter_Associations => New_List (
+ Target,
+
+ Make_Attribute_Reference (Loc,
+ Prefix => Op1,
+ Attribute_Name => Name_Address),
+
+ Make_Attribute_Reference (Loc,
+ Prefix => Op1,
+ Attribute_Name => Name_Length)));
+ end if;
+
+ else
+ -- We use the following equivalences:
+
+ -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
+ -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
+ -- (not X) xor (not Y) = X xor Y
+ -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
+
+ if Nkind (Op1) = N_Op_Not then
+ if Kind = N_Op_And then
+ Proc_Name := RTE (RE_Vector_Nor);
+
+ elsif Kind = N_Op_Or then
+ Proc_Name := RTE (RE_Vector_Nand);
+
+ else
+ Proc_Name := RTE (RE_Vector_Xor);
+ end if;
+
+ else
+ if Kind = N_Op_And then
+ Proc_Name := RTE (RE_Vector_And);
+
+ elsif Kind = N_Op_Or then
+ Proc_Name := RTE (RE_Vector_Or);
+
+ elsif Nkind (Op2) = N_Op_Not then
+ Proc_Name := RTE (RE_Vector_Nxor);
+ Arg2 := Right_Opnd (Op2);
+
+ else
+ Proc_Name := RTE (RE_Vector_Xor);
+ end if;
+ end if;
+
+ Call_Node :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Proc_Name, Loc),
+ Parameter_Associations => New_List (
+ Target,
+ Make_Attribute_Reference (Loc,
+ Prefix => Arg1,
+ Attribute_Name => Name_Address),
+ Make_Attribute_Reference (Loc,
+ Prefix => Arg2,
+ Attribute_Name => Name_Address),
+ Make_Attribute_Reference (Loc,
+ Prefix => Op1,
+ Attribute_Name => Name_Length)));
+ end if;
+
+ Rewrite (N, Call_Node);
+ Analyze (N);
+
+ exception
+ when RE_Not_Available =>
+ return;
+ end Build_Boolean_Array_Proc_Call;
+
+ ---------------------------------
+ -- Expand_Allocator_Expression --
+ ---------------------------------
+
+ procedure Expand_Allocator_Expression (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Exp : constant Node_Id := Expression (Expression (N));
+ Indic : constant Node_Id := Subtype_Mark (Expression (N));
+ PtrT : constant Entity_Id := Etype (N);
+ T : constant Entity_Id := Entity (Indic);
+ Flist : Node_Id;
+ Node : Node_Id;
+ Temp : Entity_Id;
+
+ Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
+
+ Tag_Assign : Node_Id;
+ Tmp_Node : Node_Id;
+
+ begin
+ if Is_Tagged_Type (T) or else Controlled_Type (T) then
+
+ -- Actions inserted before:
+ -- Temp : constant ptr_T := new T'(Expression);
+ -- <no CW> Temp._tag := T'tag;
+ -- <CTRL> Adjust (Finalizable (Temp.all));
+ -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
+
+ -- We analyze by hand the new internal allocator to avoid
+ -- any recursion and inappropriate call to Initialize
+ if not Aggr_In_Place then
+ Remove_Side_Effects (Exp);
+ end if;
+
+ Temp :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+
+ -- For a class wide allocation generate the following code:
+
+ -- type Equiv_Record is record ... end record;
+ -- implicit subtype CW is <Class_Wide_Subytpe>;
+ -- temp : PtrT := new CW'(CW!(expr));
+
+ if Is_Class_Wide_Type (T) then
+ Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
+
+ Set_Expression (Expression (N),
+ Unchecked_Convert_To (Entity (Indic), Exp));
+
+ Analyze_And_Resolve (Expression (N), Entity (Indic));
+ end if;
+
+ if Aggr_In_Place then
+ Tmp_Node :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => New_Reference_To (PtrT, Loc),
+ Expression =>
+ Make_Allocator (Loc,
+ New_Reference_To (Etype (Exp), Loc)));
+
+ Set_Comes_From_Source
+ (Expression (Tmp_Node), Comes_From_Source (N));
+
+ Set_No_Initialization (Expression (Tmp_Node));
+ Insert_Action (N, Tmp_Node);
+
+ if Controlled_Type (T)
+ and then Ekind (PtrT) = E_Anonymous_Access_Type
+ then
+ -- Create local finalization list for access parameter.
+
+ Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
+ end if;
+
+ Convert_Aggr_In_Allocator (Tmp_Node, Exp);
+ else
+ Node := Relocate_Node (N);
+ Set_Analyzed (Node);
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (PtrT, Loc),
+ Expression => Node));
+ end if;
+
+ -- Suppress the tag assignment when Java_VM because JVM tags
+ -- are represented implicitly in objects.
+
+ if Is_Tagged_Type (T)
+ and then not Is_Class_Wide_Type (T)
+ and then not Java_VM
+ then
+ Tag_Assign :=
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Temp, Loc),
+ Selector_Name =>
+ New_Reference_To (Tag_Component (T), Loc)),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (Access_Disp_Table (T), Loc)));
+
+ -- The previous assignment has to be done in any case
+
+ Set_Assignment_OK (Name (Tag_Assign));
+ Insert_Action (N, Tag_Assign);
+
+ elsif Is_Private_Type (T)
+ and then Is_Tagged_Type (Underlying_Type (T))
+ and then not Java_VM
+ then
+ declare
+ Utyp : constant Entity_Id := Underlying_Type (T);
+ Ref : constant Node_Id :=
+ Unchecked_Convert_To (Utyp,
+ Make_Explicit_Dereference (Loc,
+ New_Reference_To (Temp, Loc)));
+
+ begin
+ Tag_Assign :=
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => Ref,
+ Selector_Name =>
+ New_Reference_To (Tag_Component (Utyp), Loc)),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To (
+ Access_Disp_Table (Utyp), Loc)));
+
+ Set_Assignment_OK (Name (Tag_Assign));
+ Insert_Action (N, Tag_Assign);
+ end;
+ end if;
+
+ if Controlled_Type (Designated_Type (PtrT))
+ and then Controlled_Type (T)
+ then
+ declare
+ Attach : Node_Id;
+ Apool : constant Entity_Id :=
+ Associated_Storage_Pool (PtrT);
+
+ begin
+ -- If it is an allocation on the secondary stack
+ -- (i.e. a value returned from a function), the object
+ -- is attached on the caller side as soon as the call
+ -- is completed (see Expand_Ctrl_Function_Call)
+
+ if Is_RTE (Apool, RE_SS_Pool) then
+ declare
+ F : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('F'));
+ begin
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => F,
+ Object_Definition => New_Reference_To (RTE
+ (RE_Finalizable_Ptr), Loc)));
+
+ Flist := New_Reference_To (F, Loc);
+ Attach := Make_Integer_Literal (Loc, 1);
+ end;
+
+ -- Normal case, not a secondary stack allocation
+
+ else
+ Flist := Find_Final_List (PtrT);
+ Attach := Make_Integer_Literal (Loc, 2);
+ end if;
+
+ if not Aggr_In_Place then
+ Insert_Actions (N,
+ Make_Adjust_Call (
+ Ref =>
+
+ -- An unchecked conversion is needed in the
+ -- classwide case because the designated type
+ -- can be an ancestor of the subtype mark of
+ -- the allocator.
+
+ Unchecked_Convert_To (T,
+ Make_Explicit_Dereference (Loc,
+ New_Reference_To (Temp, Loc))),
+
+ Typ => T,
+ Flist_Ref => Flist,
+ With_Attach => Attach));
+ end if;
+ end;
+ end if;
+
+ Rewrite (N, New_Reference_To (Temp, Loc));
+ Analyze_And_Resolve (N, PtrT);
+
+ elsif Aggr_In_Place then
+ Temp :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Tmp_Node :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => New_Reference_To (PtrT, Loc),
+ Expression => Make_Allocator (Loc,
+ New_Reference_To (Etype (Exp), Loc)));
+
+ Set_Comes_From_Source
+ (Expression (Tmp_Node), Comes_From_Source (N));
+
+ Set_No_Initialization (Expression (Tmp_Node));
+ Insert_Action (N, Tmp_Node);
+ Convert_Aggr_In_Allocator (Tmp_Node, Exp);
+ Rewrite (N, New_Reference_To (Temp, Loc));
+ Analyze_And_Resolve (N, PtrT);
+
+ elsif Is_Access_Type (Designated_Type (PtrT))
+ and then Nkind (Exp) = N_Allocator
+ and then Nkind (Expression (Exp)) /= N_Qualified_Expression
+ then
+ -- Apply constraint to designated subtype indication.
+
+ Apply_Constraint_Check (Expression (Exp),
+ Designated_Type (Designated_Type (PtrT)),
+ No_Sliding => True);
+
+ if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
+
+ -- Propagate constraint_error to enclosing allocator
+
+ Rewrite (Exp, New_Copy (Expression (Exp)));
+ end if;
+ else
+ -- First check against the type of the qualified expression
+ --
+ -- NOTE: The commented call should be correct, but for
+ -- some reason causes the compiler to bomb (sigsegv) on
+ -- ACVC test c34007g, so for now we just perform the old
+ -- (incorrect) test against the designated subtype with
+ -- no sliding in the else part of the if statement below.
+ -- ???
+ --
+ -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
+
+ -- A check is also needed in cases where the designated
+ -- subtype is constrained and differs from the subtype
+ -- given in the qualified expression. Note that the check
+ -- on the qualified expression does not allow sliding,
+ -- but this check does (a relaxation from Ada 83).
+
+ if Is_Constrained (Designated_Type (PtrT))
+ and then not Subtypes_Statically_Match
+ (T, Designated_Type (PtrT))
+ then
+ Apply_Constraint_Check
+ (Exp, Designated_Type (PtrT), No_Sliding => False);
+
+ -- The nonsliding check should really be performed
+ -- (unconditionally) against the subtype of the
+ -- qualified expression, but that causes a problem
+ -- with c34007g (see above), so for now we retain this.
+
+ else
+ Apply_Constraint_Check
+ (Exp, Designated_Type (PtrT), No_Sliding => True);
+ end if;
+ end if;
+
+ exception
+ when RE_Not_Available =>
+ return;
+ end Expand_Allocator_Expression;
+
-----------------------------
-- Expand_Array_Comparison --
-----------------------------
- -- Expansion is only required in the case of array types. The form of
- -- the expansion is:
+ -- Expansion is only required in the case of array types. For the
+ -- unpacked case, an appropriate runtime routine is called. For
+ -- packed cases, and also in some other cases where a runtime
+ -- routine cannot be called, the form of the expansion is:
-- [body for greater_nn; boolean_expression]
@@ -205,12 +646,154 @@ package body Exp_Ch4 is
Op1 : Node_Id := Left_Opnd (N);
Op2 : Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
+ Ctyp : constant Entity_Id := Component_Type (Typ1);
Expr : Node_Id;
Func_Body : Node_Id;
Func_Name : Entity_Id;
+ Comp : RE_Id;
+
+ function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
+ -- Returns True if the length of the given operand is known to be
+ -- less than 4. Returns False if this length is known to be four
+ -- or greater or is not known at compile time.
+
+ ------------------------
+ -- Length_Less_Than_4 --
+ ------------------------
+
+ function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
+ Otyp : constant Entity_Id := Etype (Opnd);
+
+ begin
+ if Ekind (Otyp) = E_String_Literal_Subtype then
+ return String_Literal_Length (Otyp) < 4;
+
+ else
+ declare
+ Ityp : constant Entity_Id := Etype (First_Index (Otyp));
+ Lo : constant Node_Id := Type_Low_Bound (Ityp);
+ Hi : constant Node_Id := Type_High_Bound (Ityp);
+ Lov : Uint;
+ Hiv : Uint;
+
+ begin
+ if Compile_Time_Known_Value (Lo) then
+ Lov := Expr_Value (Lo);
+ else
+ return False;
+ end if;
+
+ if Compile_Time_Known_Value (Hi) then
+ Hiv := Expr_Value (Hi);
+ else
+ return False;
+ end if;
+
+ return Hiv < Lov + 3;
+ end;
+ end if;
+ end Length_Less_Than_4;
+
+ -- Start of processing for Expand_Array_Comparison
+
begin
+ -- Deal first with unpacked case, where we can call a runtime routine
+ -- except that we avoid this for targets for which are not addressable
+ -- by bytes, and for the JVM, since the JVM does not support direct
+ -- addressing of array components.
+
+ if not Is_Bit_Packed_Array (Typ1)
+ and then System_Storage_Unit = Byte'Size
+ and then not Java_VM
+ then
+ -- The call we generate is:
+
+ -- Compare_Array_xn[_Unaligned]
+ -- (left'address, right'address, left'length, right'length) <op> 0
+
+ -- x = U for unsigned, S for signed
+ -- n = 8,16,32,64 for component size
+ -- Add _Unaligned if length < 4 and component size is 8.
+ -- <op> is the standard comparison operator
+
+ if Component_Size (Typ1) = 8 then
+ if Length_Less_Than_4 (Op1)
+ or else
+ Length_Less_Than_4 (Op2)
+ then
+ if Is_Unsigned_Type (Ctyp) then
+ Comp := RE_Compare_Array_U8_Unaligned;
+ else
+ Comp := RE_Compare_Array_S8_Unaligned;
+ end if;
+
+ else
+ if Is_Unsigned_Type (Ctyp) then
+ Comp := RE_Compare_Array_U8;
+ else
+ Comp := RE_Compare_Array_S8;
+ end if;
+ end if;
+
+ elsif Component_Size (Typ1) = 16 then
+ if Is_Unsigned_Type (Ctyp) then
+ Comp := RE_Compare_Array_U16;
+ else
+ Comp := RE_Compare_Array_S16;
+ end if;
+
+ elsif Component_Size (Typ1) = 32 then
+ if Is_Unsigned_Type (Ctyp) then
+ Comp := RE_Compare_Array_U32;
+ else
+ Comp := RE_Compare_Array_S32;
+ end if;
+
+ else pragma Assert (Component_Size (Typ1) = 64);
+ if Is_Unsigned_Type (Ctyp) then
+ Comp := RE_Compare_Array_U64;
+ else
+ Comp := RE_Compare_Array_S64;
+ end if;
+ end if;
+
+ Remove_Side_Effects (Op1, Name_Req => True);
+ Remove_Side_Effects (Op2, Name_Req => True);
+
+ Rewrite (Op1,
+ Make_Function_Call (Sloc (Op1),
+ Name => New_Occurrence_Of (RTE (Comp), Loc),
+
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Op1),
+ Attribute_Name => Name_Address),
+
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Op2),
+ Attribute_Name => Name_Address),
+
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Op1),
+ Attribute_Name => Name_Length),
+
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Op2),
+ Attribute_Name => Name_Length))));
+
+ Rewrite (Op2,
+ Make_Integer_Literal (Sloc (Op2),
+ Intval => Uint_0));
+
+ Analyze_And_Resolve (Op1, Standard_Integer);
+ Analyze_And_Resolve (Op2, Standard_Integer);
+ return;
+ end if;
+
+ -- Cases where we cannot make runtime call
+
-- For (a <= b) we convert to not (a > b)
if Chars (N) = Name_Op_Le then
@@ -264,6 +847,9 @@ package body Exp_Ch4 is
Rewrite (N, Expr);
Analyze_And_Resolve (N, Standard_Boolean);
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_Array_Comparison;
---------------------------
@@ -274,29 +860,47 @@ package body Exp_Ch4 is
-- an example of such a function for Nb_Dimension = 2
-- function Enn (A : arr; B : arr) return boolean is
- -- J1 : integer;
- -- J2 : integer;
- --
-- begin
- -- if A'length (1) /= B'length (1) then
- -- return false;
- -- else
- -- J1 := B'first (1);
- -- for I1 in A'first (1) .. A'last (1) loop
- -- if A'length (2) /= B'length (2) then
- -- return false;
- -- else
- -- J2 := B'first (2);
- -- for I2 in A'first (2) .. A'last (2) loop
- -- if A (I1, I2) /= B (J1, J2) then
- -- return false;
+ -- if (A'length (1) = 0 or else A'length (2) = 0)
+ -- and then
+ -- (B'length (1) = 0 or else B'length (2) = 0)
+ -- then
+ -- return True; -- RM 4.5.2(22)
+ -- end if;
+ --
+ -- if A'length (1) /= B'length (1)
+ -- or else
+ -- A'length (2) /= B'length (2)
+ -- then
+ -- return False; -- RM 4.5.2(23)
+ -- end if;
+ --
+ -- declare
+ -- A1 : Index_type_1 := A'first (1)
+ -- B1 : Index_Type_1 := B'first (1)
+ -- begin
+ -- loop
+ -- declare
+ -- A2 : Index_type_2 := A'first (2);
+ -- B2 : Index_type_2 := B'first (2)
+ -- begin
+ -- loop
+ -- if A (A1, A2) /= B (B1, B2) then
+ -- return False;
-- end if;
- -- J2 := Integer'succ (J2);
+ --
+ -- exit when A2 = A'last (2);
+ -- A2 := Index_type2'succ (A2);
+ -- B2 := Index_type2'succ (B2);
-- end loop;
- -- end if;
- -- J1 := Integer'succ (J1);
+ -- end;
+ --
+ -- exit when A1 = A'last (1);
+ -- A1 := Index_type1'succ (A1);
+ -- B1 := Index_type1'succ (B1);
-- end loop;
- -- end if;
+ -- end;
+ --
-- return true;
-- end Enn;
@@ -310,29 +914,89 @@ package body Exp_Ch4 is
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
- Actuals : List_Id;
- Decls : List_Id := New_List;
- Index_List1 : List_Id := New_List;
- Index_List2 : List_Id := New_List;
- Formals : List_Id;
- Stats : Node_Id;
- Func_Name : Entity_Id;
- Func_Body : Node_Id;
+ Decls : constant List_Id := New_List;
+ Index_List1 : constant List_Id := New_List;
+ Index_List2 : constant List_Id := New_List;
+
+ Actuals : List_Id;
+ Formals : List_Id;
+ Func_Name : Entity_Id;
+ Func_Body : Node_Id;
A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
+ function Arr_Attr
+ (Arr : Entity_Id;
+ Nam : Name_Id;
+ Num : Int)
+ return Node_Id;
+ -- This builds the attribute reference Arr'Nam (Expr).
+
function Component_Equality (Typ : Entity_Id) return Node_Id;
- -- Create one statement to compare corresponding components, designated
- -- by a full set of indices.
+ -- Create one statement to compare corresponding components,
+ -- designated by a full set of indices.
- function Loop_One_Dimension
+ function Handle_One_Dimension
(N : Int;
Index : Node_Id)
- return Node_Id;
- -- Loop over the n'th dimension of the arrays. The single statement
- -- in the body of the loop is a loop over the next dimension, or
- -- the comparison of corresponding components.
+ return Node_Id;
+ -- This procedure returns a declare block:
+ --
+ -- declare
+ -- An : Index_Type_n := A'First (n);
+ -- Bn : Index_Type_n := B'First (n);
+ -- begin
+ -- loop
+ -- xxx
+ -- exit when An = A'Last (n);
+ -- An := Index_Type_n'Succ (An)
+ -- Bn := Index_Type_n'Succ (Bn)
+ -- end loop;
+ -- end;
+ --
+ -- where N is the value of "n" in the above code. Index is the
+ -- N'th index node, whose Etype is Index_Type_n in the above code.
+ -- The xxx statement is either the declare block for the next
+ -- dimension or if this is the last dimension the comparison
+ -- of corresponding components of the arrays.
+ --
+ -- The actual way the code works is to return the comparison
+ -- of corresponding components for the N+1 call. That's neater!
+
+ function Test_Empty_Arrays return Node_Id;
+ -- This function constructs the test for both arrays being empty
+ -- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
+ -- and then
+ -- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
+
+ function Test_Lengths_Correspond return Node_Id;
+ -- This function constructs the test for arrays having different
+ -- lengths in at least one index position, in which case resull
+
+ -- A'length (1) /= B'length (1)
+ -- or else
+ -- A'length (2) /= B'length (2)
+ -- or else
+ -- ...
+
+ --------------
+ -- Arr_Attr --
+ --------------
+
+ function Arr_Attr
+ (Arr : Entity_Id;
+ Nam : Name_Id;
+ Num : Int)
+ return Node_Id
+ is
+ begin
+ return
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Nam,
+ Prefix => New_Reference_To (Arr, Loc),
+ Expressions => New_List (Make_Integer_Literal (Loc, Num)));
+ end Arr_Attr;
------------------------
-- Component_Equality --
@@ -364,119 +1028,159 @@ package body Exp_Ch4 is
Then_Statements => New_List (
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))));
-
end Component_Equality;
- ------------------------
- -- Loop_One_Dimension --
- ------------------------
+ --------------------------
+ -- Handle_One_Dimension --
+ ---------------------------
- function Loop_One_Dimension
+ function Handle_One_Dimension
(N : Int;
Index : Node_Id)
- return Node_Id
+ return Node_Id
is
- I : constant Entity_Id := Make_Defining_Identifier (Loc,
- New_Internal_Name ('I'));
- J : constant Entity_Id := Make_Defining_Identifier (Loc,
- New_Internal_Name ('J'));
- Index_Type : Entity_Id;
- Stats : Node_Id;
+ An : constant Entity_Id := Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('A'));
+ Bn : constant Entity_Id := Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('B'));
+ Index_Type_n : Entity_Id;
begin
if N > Number_Dimensions (Typ) then
return Component_Equality (Typ);
+ end if;
- else
- -- Generate the following:
+ -- Case where we generate a declare block
- -- j: index_type;
- -- ...
+ Index_Type_n := Base_Type (Etype (Index));
+ Append (New_Reference_To (An, Loc), Index_List1);
+ Append (New_Reference_To (Bn, Loc), Index_List2);
- -- if a'length (n) /= b'length (n) then
- -- return false;
- -- else
- -- j := b'first (n);
- -- for i in a'range (n) loop
- -- -- loop over remaining dimensions.
- -- j := index_type'succ (j);
- -- end loop;
- -- end if;
+ return
+ Make_Block_Statement (Loc,
+ Declarations => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => An,
+ Object_Definition =>
+ New_Reference_To (Index_Type_n, Loc),
+ Expression => Arr_Attr (A, Name_First, N)),
- -- retrieve index type for current dimension.
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Bn,
+ Object_Definition =>
+ New_Reference_To (Index_Type_n, Loc),
+ Expression => Arr_Attr (B, Name_First, N))),
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Implicit_Loop_Statement (Nod,
+ Statements => New_List (
+ Handle_One_Dimension (N + 1, Next_Index (Index)),
+
+ Make_Exit_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Reference_To (An, Loc),
+ Right_Opnd => Arr_Attr (A, Name_Last, N))),
+
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (An, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (Index_Type_n, Loc),
+ Attribute_Name => Name_Succ,
+ Expressions => New_List (
+ New_Reference_To (An, Loc)))),
- Index_Type := Base_Type (Etype (Index));
- Append (New_Reference_To (I, Loc), Index_List1);
- Append (New_Reference_To (J, Loc), Index_List2);
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Bn, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (Index_Type_n, Loc),
+ Attribute_Name => Name_Succ,
+ Expressions => New_List (
+ New_Reference_To (Bn, Loc)))))))));
+ end Handle_One_Dimension;
+
+ -----------------------
+ -- Test_Empty_Arrays --
+ -----------------------
+
+ function Test_Empty_Arrays return Node_Id is
+ Alist : Node_Id;
+ Blist : Node_Id;
+
+ Atest : Node_Id;
+ Btest : Node_Id;
- -- Declare index for j as a local variable to the function.
- -- Index i is a loop variable.
+ begin
+ Alist := Empty;
+ Blist := Empty;
+ for J in 1 .. Number_Dimensions (Typ) loop
+ Atest :=
+ Make_Op_Eq (Loc,
+ Left_Opnd => Arr_Attr (A, Name_Length, J),
+ Right_Opnd => Make_Integer_Literal (Loc, 0));
+
+ Btest :=
+ Make_Op_Eq (Loc,
+ Left_Opnd => Arr_Attr (B, Name_Length, J),
+ Right_Opnd => Make_Integer_Literal (Loc, 0));
+
+ if No (Alist) then
+ Alist := Atest;
+ Blist := Btest;
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => J,
- Object_Definition => New_Reference_To (Index_Type, Loc)));
-
- Stats :=
- Make_Implicit_If_Statement (Nod,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (A, Loc),
- Attribute_Name => Name_Length,
- Expressions => New_List (
- Make_Integer_Literal (Loc, N))),
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (B, Loc),
- Attribute_Name => Name_Length,
- Expressions => New_List (
- Make_Integer_Literal (Loc, N)))),
+ else
+ Alist :=
+ Make_Or_Else (Loc,
+ Left_Opnd => Relocate_Node (Alist),
+ Right_Opnd => Atest);
+
+ Blist :=
+ Make_Or_Else (Loc,
+ Left_Opnd => Relocate_Node (Blist),
+ Right_Opnd => Btest);
+ end if;
+ end loop;
- Then_Statements => New_List (
- Make_Return_Statement (Loc,
- Expression => New_Occurrence_Of (Standard_False, Loc))),
+ return
+ Make_And_Then (Loc,
+ Left_Opnd => Alist,
+ Right_Opnd => Blist);
+ end Test_Empty_Arrays;
- Else_Statements => New_List (
+ -----------------------------
+ -- Test_Lengths_Correspond --
+ -----------------------------
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (J, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (B, Loc),
- Attribute_Name => Name_First,
- Expressions => New_List (
- Make_Integer_Literal (Loc, N)))),
-
- Make_Implicit_Loop_Statement (Nod,
- Identifier => Empty,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => I,
- Discrete_Subtype_Definition =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (A, Loc),
- Attribute_Name => Name_Range,
- Expressions => New_List (
- Make_Integer_Literal (Loc, N))))),
-
- Statements => New_List (
- Loop_One_Dimension (N + 1, Next_Index (Index)),
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (J, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Index_Type, Loc),
- Attribute_Name => Name_Succ,
- Expressions => New_List (
- New_Reference_To (J, Loc))))))));
-
- return Stats;
- end if;
- end Loop_One_Dimension;
+ function Test_Lengths_Correspond return Node_Id is
+ Result : Node_Id;
+ Rtest : Node_Id;
+
+ begin
+ Result := Empty;
+ for J in 1 .. Number_Dimensions (Typ) loop
+ Rtest :=
+ Make_Op_Ne (Loc,
+ Left_Opnd => Arr_Attr (A, Name_Length, J),
+ Right_Opnd => Arr_Attr (B, Name_Length, J));
+
+ if No (Result) then
+ Result := Rtest;
+ else
+ Result :=
+ Make_Or_Else (Loc,
+ Left_Opnd => Relocate_Node (Result),
+ Right_Opnd => Rtest);
+ end if;
+ end loop;
+
+ return Result;
+ end Test_Lengths_Correspond;
-- Start of processing for Expand_Array_Equality
@@ -492,7 +1196,7 @@ package body Exp_Ch4 is
Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
- Stats := Loop_One_Dimension (1, First_Index (Typ));
+ -- Build statement sequence for function
Func_Body :=
Make_Subprogram_Body (Loc,
@@ -501,11 +1205,29 @@ package body Exp_Ch4 is
Defining_Unit_Name => Func_Name,
Parameter_Specifications => Formals,
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
- Declarations => Decls,
+
+ Declarations => Decls,
+
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
- Stats,
+
+ Make_Implicit_If_Statement (Nod,
+ Condition => Test_Empty_Arrays,
+ Then_Statements => New_List (
+ Make_Return_Statement (Loc,
+ Expression =>
+ New_Occurrence_Of (Standard_True, Loc)))),
+
+ Make_Implicit_If_Statement (Nod,
+ Condition => Test_Lengths_Correspond,
+ Then_Statements => New_List (
+ Make_Return_Statement (Loc,
+ Expression =>
+ New_Occurrence_Of (Standard_False, Loc)))),
+
+ Handle_One_Dimension (1, First_Index (Typ)),
+
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_True, Loc)))));
@@ -539,19 +1261,18 @@ package body Exp_Ch4 is
-- since we always want to deal with types that have bounds.
procedure Expand_Boolean_Operator (N : Node_Id) is
- Typ : constant Entity_Id := Etype (N);
+ Typ : constant Entity_Id := Etype (N);
begin
if Is_Bit_Packed_Array (Typ) then
Expand_Packed_Boolean_Operator (N);
else
-
- -- For the normal non-packed case, the expansion is
- -- to build a function for carrying out the comparison
- -- (using Make_Boolean_Array_Op) and then inserting it
- -- into the tree. The original operator node is then
- -- rewritten as a call to this function.
+ -- For the normal non-packed case, the general expansion is
+ -- to build a function for carrying out the comparison (using
+ -- Make_Boolean_Array_Op) and then inserting it into the tree.
+ -- The original operator node is then rewritten as a call to
+ -- this function.
declare
Loc : constant Source_Ptr := Sloc (N);
@@ -559,6 +1280,7 @@ package body Exp_Ch4 is
R : constant Node_Id := Relocate_Node (Right_Opnd (N));
Func_Body : Node_Id;
Func_Name : Entity_Id;
+
begin
Convert_To_Actual_Subtype (L);
Convert_To_Actual_Subtype (R);
@@ -566,21 +1288,35 @@ package body Exp_Ch4 is
Ensure_Defined (Etype (R), N);
Apply_Length_Check (R, Etype (L));
- Func_Body := Make_Boolean_Array_Op (Etype (L), N);
- Func_Name := Defining_Unit_Name (Specification (Func_Body));
- Insert_Action (N, Func_Body);
+ if Nkind (Parent (N)) = N_Assignment_Statement
+ and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
+ then
+ Build_Boolean_Array_Proc_Call (Parent (N), L, R);
+
+ elsif Nkind (Parent (N)) = N_Op_Not
+ and then Nkind (N) = N_Op_And
+ and then
+ Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
+ then
+ return;
+ else
- -- Now rewrite the expression with a call
+ Func_Body := Make_Boolean_Array_Op (Etype (L), N);
+ Func_Name := Defining_Unit_Name (Specification (Func_Body));
+ Insert_Action (N, Func_Body);
- Rewrite (N,
- Make_Function_Call (Loc,
- Name => New_Reference_To (Func_Name, Loc),
- Parameter_Associations =>
- New_List
- (L, Make_Type_Conversion
+ -- Now rewrite the expression with a call
+
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Func_Name, Loc),
+ Parameter_Associations =>
+ New_List
+ (L, Make_Type_Conversion
(Loc, New_Reference_To (Etype (L), Loc), R))));
- Analyze_And_Resolve (N, Typ);
+ Analyze_And_Resolve (N, Typ);
+ end if;
end;
end if;
end Expand_Boolean_Operator;
@@ -690,7 +1426,7 @@ package body Exp_Ch4 is
Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
elsif Is_Record_Type (Full_Type) then
- Eq_Op := TSS (Full_Type, Name_uEquality);
+ Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
if Present (Eq_Op) then
if Etype (First_Formal (Eq_Op)) /= Full_Type then
@@ -699,7 +1435,7 @@ package body Exp_Ch4 is
-- to match signature of operation.
declare
- T : Entity_Id := Etype (First_Formal (Eq_Op));
+ T : constant Entity_Id := Etype (First_Formal (Eq_Op));
begin
return
@@ -832,7 +1568,7 @@ package body Exp_Ch4 is
Params : List_Id;
Operand : Node_Id;
- function Copy_Into_R_S (I : Nat) return List_Id;
+ function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id;
-- Builds the sequence of statement:
-- P := Si'First;
-- loop
@@ -843,6 +1579,9 @@ package body Exp_Ch4 is
-- end loop;
--
-- where i is the input parameter I given.
+ -- If the flag Last is true, the exit statement is emitted before
+ -- incrementing the lower bound, to prevent the creation out of
+ -- bound values.
function Init_L (I : Nat) return Node_Id;
-- Builds the statement:
@@ -895,8 +1634,8 @@ package body Exp_Ch4 is
-- Copy_Into_R_S --
-------------------
- function Copy_Into_R_S (I : Nat) return List_Id is
- Stmts : List_Id := New_List;
+ function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id is
+ Stmts : constant List_Id := New_List;
P_Start : Node_Id;
Loop_Stmt : Node_Id;
R_Copy : Node_Id;
@@ -933,9 +1672,15 @@ package body Exp_Ch4 is
Name => P,
Expression => P_Succ);
- Loop_Stmt :=
- Make_Implicit_Loop_Statement (Cnode,
- Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc));
+ if Last then
+ Loop_Stmt :=
+ Make_Implicit_Loop_Statement (Cnode,
+ Statements => New_List (R_Copy, Exit_Stmt, L_Inc, P_Inc));
+ else
+ Loop_Stmt :=
+ Make_Implicit_Loop_Statement (Cnode,
+ Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc));
+ end if;
Append_To (Stmts, Loop_Stmt);
@@ -1206,7 +1951,7 @@ package body Exp_Ch4 is
Append_To (Declare_Stmts,
Make_Implicit_If_Statement (Cnode,
Condition => S_Length_Test (I),
- Then_Statements => Copy_Into_R_S (I)));
+ Then_Statements => Copy_Into_R_S (I, I = Nb_Opnds)));
end loop;
Append_To (Declare_Stmts, Make_Return_Statement (Loc, Expression => R));
@@ -1329,6 +2074,10 @@ package body Exp_Ch4 is
Parameter_Associations => Opnds));
Analyze_And_Resolve (Cnode, Standard_String);
+
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_Concatenate_String;
------------------------
@@ -1359,6 +2108,10 @@ package body Exp_Ch4 is
if not Java_VM then
Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
end if;
+
+ elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then
+ Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
+
else
Set_Procedure_To_Call (N,
Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
@@ -1372,11 +2125,17 @@ package body Exp_Ch4 is
-- Size and initial value is known at compile time
-- Access type is access-to-constant
+ -- The allocator is not part of a constraint on a record component,
+ -- because in that case the inserted actions are delayed until the
+ -- record declaration is fully analyzed, which is too late for the
+ -- analysis of the rewritten allocator.
+
if Is_Access_Constant (PtrT)
and then Nkind (Expression (N)) = N_Qualified_Expression
and then Compile_Time_Known_Value (Expression (Expression (N)))
and then Size_Known_At_Compile_Time (Etype (Expression
(Expression (N))))
+ and then not Is_Record_Type (Current_Scope)
then
-- Here we can do the optimization. For the allocator
@@ -1424,275 +2183,24 @@ package body Exp_Ch4 is
return;
end if;
- -- If the allocator is for a type which requires initialization, and
- -- there is no initial value (i.e. the operand is a subtype indication
- -- rather than a qualifed expression), then we must generate a call to
- -- the initialization routine. This is done using an expression actions
- -- node:
- --
- -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
- --
- -- Here ptr_T is the pointer type for the allocator, and T is the
- -- subtype of the allocator. A special case arises if the designated
- -- type of the access type is a task or contains tasks. In this case
- -- the call to Init (Temp.all ...) is replaced by code that ensures
- -- that the tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
- -- for details). In addition, if the type T is a task T, then the first
- -- argument to Init must be converted to the task record type.
-
if Nkind (Expression (N)) = N_Qualified_Expression then
- declare
- Indic : constant Node_Id := Subtype_Mark (Expression (N));
- T : constant Entity_Id := Entity (Indic);
- Exp : constant Node_Id := Expression (Expression (N));
-
- Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
-
- Tag_Assign : Node_Id;
- Tmp_Node : Node_Id;
-
- begin
- if Is_Tagged_Type (T) or else Controlled_Type (T) then
-
- -- Actions inserted before:
- -- Temp : constant ptr_T := new T'(Expression);
- -- <no CW> Temp._tag := T'tag;
- -- <CTRL> Adjust (Finalizable (Temp.all));
- -- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
-
- -- We analyze by hand the new internal allocator to avoid
- -- any recursion and inappropriate call to Initialize
- if not Aggr_In_Place then
- Remove_Side_Effects (Exp);
- end if;
-
- Temp :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
-
- -- For a class wide allocation generate the following code:
-
- -- type Equiv_Record is record ... end record;
- -- implicit subtype CW is <Class_Wide_Subytpe>;
- -- temp : PtrT := new CW'(CW!(expr));
-
- if Is_Class_Wide_Type (T) then
- Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
-
- Set_Expression (Expression (N),
- Unchecked_Convert_To (Entity (Indic), Exp));
-
- Analyze_And_Resolve (Expression (N), Entity (Indic));
- end if;
-
- if Aggr_In_Place then
- Tmp_Node :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition => New_Reference_To (PtrT, Loc),
- Expression => Make_Allocator (Loc,
- New_Reference_To (Etype (Exp), Loc)));
-
- Set_No_Initialization (Expression (Tmp_Node));
- Insert_Action (N, Tmp_Node);
- Convert_Aggr_In_Allocator (Tmp_Node, Exp);
- else
- Node := Relocate_Node (N);
- Set_Analyzed (Node);
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Constant_Present => True,
- Object_Definition => New_Reference_To (PtrT, Loc),
- Expression => Node));
- end if;
-
- -- Suppress the tag assignment when Java_VM because JVM tags
- -- are represented implicitly in objects.
-
- if Is_Tagged_Type (T)
- and then not Is_Class_Wide_Type (T)
- and then not Java_VM
- then
- Tag_Assign :=
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Reference_To (Temp, Loc),
- Selector_Name =>
- New_Reference_To (Tag_Component (T), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Access_Disp_Table (T), Loc)));
-
- -- The previous assignment has to be done in any case
-
- Set_Assignment_OK (Name (Tag_Assign));
- Insert_Action (N, Tag_Assign);
-
- elsif Is_Private_Type (T)
- and then Is_Tagged_Type (Underlying_Type (T))
- and then not Java_VM
- then
- declare
- Utyp : constant Entity_Id := Underlying_Type (T);
- Ref : constant Node_Id :=
- Unchecked_Convert_To (Utyp,
- Make_Explicit_Dereference (Loc,
- New_Reference_To (Temp, Loc)));
-
- begin
- Tag_Assign :=
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => Ref,
- Selector_Name =>
- New_Reference_To (Tag_Component (Utyp), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (
- Access_Disp_Table (Utyp), Loc)));
-
- Set_Assignment_OK (Name (Tag_Assign));
- Insert_Action (N, Tag_Assign);
- end;
- end if;
-
- if Controlled_Type (Designated_Type (PtrT))
- and then Controlled_Type (T)
- then
- declare
- Flist : Node_Id;
- Attach : Node_Id;
- Apool : constant Entity_Id :=
- Associated_Storage_Pool (PtrT);
-
- begin
- -- If it is an allocation on the secondary stack
- -- (i.e. a value returned from a function), the object
- -- is attached on the caller side as soon as the call
- -- is completed (see Expand_Ctrl_Function_Call)
-
- if Is_RTE (Apool, RE_SS_Pool) then
- declare
- F : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('F'));
- begin
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => F,
- Object_Definition => New_Reference_To (RTE
- (RE_Finalizable_Ptr), Loc)));
-
- Flist := New_Reference_To (F, Loc);
- Attach := Make_Integer_Literal (Loc, 1);
- end;
-
- -- Normal case, not a secondary stack allocation
-
- else
- Flist := Find_Final_List (PtrT);
- Attach := Make_Integer_Literal (Loc, 2);
- end if;
-
- if not Aggr_In_Place then
- Insert_Actions (N,
- Make_Adjust_Call (
- Ref =>
-
- -- An unchecked conversion is needed in the
- -- classwide case because the designated type
- -- can be an ancestor of the subtype mark of
- -- the allocator.
-
- Unchecked_Convert_To (T,
- Make_Explicit_Dereference (Loc,
- New_Reference_To (Temp, Loc))),
-
- Typ => T,
- Flist_Ref => Flist,
- With_Attach => Attach));
- end if;
- end;
- end if;
-
- Rewrite (N, New_Reference_To (Temp, Loc));
- Analyze_And_Resolve (N, PtrT);
-
- elsif Aggr_In_Place then
- Temp :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- Tmp_Node :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition => New_Reference_To (PtrT, Loc),
- Expression => Make_Allocator (Loc,
- New_Reference_To (Etype (Exp), Loc)));
-
- Set_No_Initialization (Expression (Tmp_Node));
- Insert_Action (N, Tmp_Node);
- Convert_Aggr_In_Allocator (Tmp_Node, Exp);
- Rewrite (N, New_Reference_To (Temp, Loc));
- Analyze_And_Resolve (N, PtrT);
-
- elsif Is_Access_Type (Designated_Type (PtrT))
- and then Nkind (Exp) = N_Allocator
- and then Nkind (Expression (Exp)) /= N_Qualified_Expression
- then
- -- Apply constraint to designated subtype indication.
-
- Apply_Constraint_Check (Expression (Exp),
- Designated_Type (Designated_Type (PtrT)),
- No_Sliding => True);
-
- if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
-
- -- Propagate constraint_error to enclosing allocator
-
- Rewrite (Exp, New_Copy (Expression (Exp)));
- end if;
- else
- -- First check against the type of the qualified expression
- --
- -- NOTE: The commented call should be correct, but for
- -- some reason causes the compiler to bomb (sigsegv) on
- -- ACVC test c34007g, so for now we just perform the old
- -- (incorrect) test against the designated subtype with
- -- no sliding in the else part of the if statement below.
- -- ???
- --
- -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
-
- -- A check is also needed in cases where the designated
- -- subtype is constrained and differs from the subtype
- -- given in the qualified expression. Note that the check
- -- on the qualified expression does not allow sliding,
- -- but this check does (a relaxation from Ada 83).
-
- if Is_Constrained (Designated_Type (PtrT))
- and then not Subtypes_Statically_Match
- (T, Designated_Type (PtrT))
- then
- Apply_Constraint_Check
- (Exp, Designated_Type (PtrT), No_Sliding => False);
-
- -- The nonsliding check should really be performed
- -- (unconditionally) against the subtype of the
- -- qualified expression, but that causes a problem
- -- with c34007g (see above), so for now we retain this.
-
- else
- Apply_Constraint_Check
- (Exp, Designated_Type (PtrT), No_Sliding => True);
- end if;
- end if;
- end;
-
- -- Here if not qualified expression case.
- -- In this case, an initialization routine may be required
+ Expand_Allocator_Expression (N);
+
+ -- If the allocator is for a type which requires initialization, and
+ -- there is no initial value (i.e. operand is a subtype indication
+ -- rather than a qualifed expression), then we must generate a call
+ -- to the initialization routine. This is done using an expression
+ -- actions node:
+ --
+ -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
+ --
+ -- Here ptr_T is the pointer type for the allocator, and T is the
+ -- subtype of the allocator. A special case arises if the designated
+ -- type of the access type is a task or contains tasks. In this case
+ -- the call to Init (Temp.all ...) is replaced by code that ensures
+ -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
+ -- for details). In addition, if the type T is a task T, then the
+ -- first argument to Init must be converted to the task record type.
else
declare
@@ -1877,7 +2385,7 @@ package body Exp_Ch4 is
Discr := First_Elmt (Discriminant_Constraint (T));
while Present (Discr) loop
- Append (New_Copy (Elists.Node (Discr)), Args);
+ Append (New_Copy_Tree (Elists.Node (Discr)), Args);
Next_Elmt (Discr);
end loop;
@@ -1889,7 +2397,7 @@ package body Exp_Ch4 is
First_Elmt (Discriminant_Constraint (Full_View (T)));
while Present (Discr) loop
- Append (New_Copy (Elists.Node (Discr)), Args);
+ Append (New_Copy_Tree (Elists.Node (Discr)), Args);
Next_Elmt (Discr);
end loop;
end if;
@@ -1926,13 +2434,13 @@ package body Exp_Ch4 is
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
- -- Case of designated type is task or contains task
+ -- If the designated type is task type or contains tasks,
-- Create block to activate created tasks, and insert
-- declaration for Task_Image variable ahead of call.
if Has_Task (T) then
declare
- L : List_Id := New_List;
+ L : constant List_Id := New_List;
Blk : Node_Id;
begin
@@ -1951,35 +2459,7 @@ package body Exp_Ch4 is
end if;
if Controlled_Type (T) then
-
- -- If the context is an access parameter, we need to create
- -- a non-anonymous access type in order to have a usable
- -- final list, because there is otherwise no pool to which
- -- the allocated object can belong. We create both the type
- -- and the finalization chain here, because freezing an
- -- internal type does not create such a chain.
-
- if Ekind (PtrT) = E_Anonymous_Access_Type then
- declare
- Acc : Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('I'));
- begin
- Insert_Action (N,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Acc,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (T, Loc))));
-
- Build_Final_List (N, Acc);
- Flist := Find_Final_List (Acc);
- end;
-
- else
- Flist := Find_Final_List (PtrT);
- end if;
+ Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
Insert_Actions (N,
Make_Init_Call (
@@ -2002,6 +2482,10 @@ package body Exp_Ch4 is
end if;
end;
end if;
+
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_N_Allocator;
-----------------------
@@ -2158,6 +2642,9 @@ package body Exp_Ch4 is
Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
Expression => Relocate_Node (Elsex))));
+ Set_Assignment_OK (Name (First (Then_Statements (New_If))));
+ Set_Assignment_OK (Name (First (Else_Statements (New_If))));
+
if Present (Then_Actions (N)) then
Insert_List_Before
(First (Then_Statements (New_If)), Then_Actions (N));
@@ -2199,21 +2686,77 @@ package body Exp_Ch4 is
procedure Expand_N_In (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Rtyp : constant Entity_Id := Etype (N);
+ Lop : constant Node_Id := Left_Opnd (N);
+ Rop : constant Node_Id := Right_Opnd (N);
begin
- -- No expansion is required if we have an explicit range
+ -- If we have an explicit range, do a bit of optimization based
+ -- on range analysis (we may be able to kill one or both checks).
+
+ if Nkind (Rop) = N_Range then
+ declare
+ Lcheck : constant Compare_Result :=
+ Compile_Time_Compare (Lop, Low_Bound (Rop));
+ Ucheck : constant Compare_Result :=
+ Compile_Time_Compare (Lop, High_Bound (Rop));
+
+ begin
+ -- If either check is known to fail, replace result
+ -- by False, since the other check does not matter.
+
+ if Lcheck = LT or else Ucheck = GT then
+ Rewrite (N,
+ New_Reference_To (Standard_False, Loc));
+ Analyze_And_Resolve (N, Rtyp);
+ return;
+
+ -- If both checks are known to succeed, replace result
+ -- by True, since we know we are in range.
+
+ elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
+ Rewrite (N,
+ New_Reference_To (Standard_True, Loc));
+ Analyze_And_Resolve (N, Rtyp);
+ return;
+
+ -- If lower bound check succeeds and upper bound check is
+ -- not known to succeed or fail, then replace the range check
+ -- with a comparison against the upper bound.
+
+ elsif Lcheck in Compare_GE then
+ Rewrite (N,
+ Make_Op_Le (Loc,
+ Left_Opnd => Lop,
+ Right_Opnd => High_Bound (Rop)));
+ Analyze_And_Resolve (N, Rtyp);
+ return;
+
+ -- If upper bound check succeeds and lower bound check is
+ -- not known to succeed or fail, then replace the range check
+ -- with a comparison against the lower bound.
+
+ elsif Ucheck in Compare_LE then
+ Rewrite (N,
+ Make_Op_Ge (Loc,
+ Left_Opnd => Lop,
+ Right_Opnd => Low_Bound (Rop)));
+ Analyze_And_Resolve (N, Rtyp);
+ return;
+ end if;
+ end;
+
+ -- For all other cases of an explicit range, nothing to be done
- if Nkind (Right_Opnd (N)) = N_Range then
return;
-- Here right operand is a subtype mark
else
declare
- Typ : Entity_Id := Etype (Right_Opnd (N));
- Obj : Node_Id := Left_Opnd (N);
- Cond : Node_Id := Empty;
- Is_Acc : Boolean := Is_Access_Type (Typ);
+ Typ : Entity_Id := Etype (Rop);
+ Is_Acc : constant Boolean := Is_Access_Type (Typ);
+ Obj : Node_Id := Lop;
+ Cond : Node_Id := Empty;
begin
Remove_Side_Effects (Obj);
@@ -2221,6 +2764,7 @@ package body Exp_Ch4 is
-- For tagged type, do tagged membership operation
if Is_Tagged_Type (Typ) then
+
-- No expansion will be performed when Java_VM, as the
-- JVM back end will handle the membership tests directly
-- (tags are not explicitly represented in Java objects,
@@ -2239,7 +2783,7 @@ package body Exp_Ch4 is
-- type if they come from the original type definition.
elsif Is_Scalar_Type (Typ) then
- Rewrite (Right_Opnd (N),
+ Rewrite (Rop,
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
@@ -2254,6 +2798,8 @@ package body Exp_Ch4 is
return;
end if;
+ -- Here we have a non-scalar type
+
if Is_Acc then
Typ := Designated_Type (Typ);
end if;
@@ -2269,7 +2815,7 @@ package body Exp_Ch4 is
elsif Is_Array_Type (Typ) then
- declare
+ Check_Subscripts : declare
function Construct_Attribute_Reference
(E : Node_Id;
Nam : Name_Id;
@@ -2277,6 +2823,10 @@ package body Exp_Ch4 is
return Node_Id;
-- Build attribute reference E'Nam(Dim)
+ -----------------------------------
+ -- Construct_Attribute_Reference --
+ -----------------------------------
+
function Construct_Attribute_Reference
(E : Node_Id;
Nam : Name_Id;
@@ -2292,13 +2842,16 @@ package body Exp_Ch4 is
Make_Integer_Literal (Loc, Dim)));
end Construct_Attribute_Reference;
+ -- Start processing for Check_Subscripts
+
begin
for J in 1 .. Number_Dimensions (Typ) loop
Evolve_And_Then (Cond,
Make_Op_Eq (Loc,
Left_Opnd =>
Construct_Attribute_Reference
- (Duplicate_Subexpr (Obj), Name_First, J),
+ (Duplicate_Subexpr_No_Checks (Obj),
+ Name_First, J),
Right_Opnd =>
Construct_Attribute_Reference
(New_Occurrence_Of (Typ, Loc), Name_First, J)));
@@ -2307,24 +2860,26 @@ package body Exp_Ch4 is
Make_Op_Eq (Loc,
Left_Opnd =>
Construct_Attribute_Reference
- (Duplicate_Subexpr (Obj), Name_Last, J),
+ (Duplicate_Subexpr_No_Checks (Obj),
+ Name_Last, J),
Right_Opnd =>
Construct_Attribute_Reference
(New_Occurrence_Of (Typ, Loc), Name_Last, J)));
end loop;
if Is_Acc then
- Cond := Make_Or_Else (Loc,
- Left_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd => Obj,
- Right_Opnd => Make_Null (Loc)),
- Right_Opnd => Cond);
+ Cond :=
+ Make_Or_Else (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Obj,
+ Right_Opnd => Make_Null (Loc)),
+ Right_Opnd => Cond);
end if;
Rewrite (N, Cond);
Analyze_And_Resolve (N, Rtyp);
- end;
+ end Check_Subscripts;
-- These are the cases where constraint checks may be
-- required, e.g. records with possible discriminants
@@ -2403,12 +2958,22 @@ package body Exp_Ch4 is
-- was necessary, but it cleans up the code to do it all the time.
if Is_Access_Type (T) then
+
+ -- Check whether the prefix comes from a debug pool, and generate
+ -- the check before rewriting.
+
+ Insert_Dereference_Action (P);
+
Rewrite (P,
Make_Explicit_Dereference (Sloc (N),
Prefix => Relocate_Node (P)));
Analyze_And_Resolve (P, Designated_Type (T));
end if;
+ -- Generate index and validity checks
+
+ Generate_Index_Checks (N);
+
if Validity_Checks_On and then Validity_Check_Subscripts then
Apply_Subscript_Validity_Checks (N);
end if;
@@ -2432,7 +2997,8 @@ package body Exp_Ch4 is
-- convert it to a reference to the corresponding Packed_Array_Type.
-- We only want to do this for simple references, and not for:
- -- Left side of assignment (or prefix of left side of assignment)
+ -- Left side of assignment, or prefix of left side of assignment,
+ -- or prefix of the prefix, to handle packed arrays of packed arrays,
-- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
-- Renaming objects in renaming associations
@@ -2477,6 +3043,20 @@ package body Exp_Ch4 is
then
return;
+ -- If the expression is an index of an indexed component,
+ -- it must be expanded regardless of context.
+
+ elsif Nkind (Parnt) = N_Indexed_Component
+ and then Child /= Prefix (Parnt)
+ then
+ Expand_Packed_Element_Reference (N);
+ return;
+
+ elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
+ and then Name (Parent (Parnt)) = Parnt
+ then
+ return;
+
elsif Nkind (Parnt) = N_Attribute_Reference
and then Attribute_Name (Parnt) = Name_Read
and then Next (First (Expressions (Parnt))) = Child
@@ -2557,6 +3137,10 @@ package body Exp_Ch4 is
Set_Etype (N, Typ);
end if;
+
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_N_Null;
---------------------
@@ -2576,29 +3160,30 @@ package body Exp_Ch4 is
and then Is_Signed_Integer_Type (Etype (N))
and then Do_Overflow_Check (N)
then
- -- Software overflow checking expands abs (expr) into
+ -- The only case to worry about is when the argument is
+ -- equal to the largest negative number, so what we do is
+ -- to insert the check:
- -- (if expr >= 0 then expr else -expr)
+ -- [constraint_error when Expr = typ'Base'First]
-- with the usual Duplicate_Subexpr use coding for expr
- Rewrite (N,
- Make_Conditional_Expression (Loc,
- Expressions => New_List (
- Make_Op_Ge (Loc,
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr (Expr),
- Right_Opnd => Make_Integer_Literal (Loc, 0)),
-
- Duplicate_Subexpr (Expr),
-
- Make_Op_Minus (Loc,
- Right_Opnd => Duplicate_Subexpr (Expr)))));
-
- Analyze_And_Resolve (N);
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
+ Attribute_Name => Name_First)),
+ Reason => CE_Overflow_Check_Failed));
+ end if;
-- Vax floating-point types case
- elsif Vax_Float (Etype (N)) then
+ if Vax_Float (Etype (N)) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Abs;
@@ -2630,7 +3215,7 @@ package body Exp_Ch4 is
end if;
end if;
- -- Arithemtic overflow checks for signed integer/fixed point types
+ -- Arithmetic overflow checks for signed integer/fixed point types
if Is_Signed_Integer_Type (Typ)
or else Is_Fixed_Point_Type (Typ)
@@ -2670,6 +3255,21 @@ package body Exp_Ch4 is
-- Expand_N_Op_Concat --
------------------------
+ Max_Available_String_Operands : Int := -1;
+ -- This is initialized the first time this routine is called. It records
+ -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
+ -- available in the run-time:
+ --
+ -- 0 None available
+ -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
+ -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
+ -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
+ -- 5 All routines including RE_Str_Concat_5 available
+
+ Char_Concat_Available : Boolean;
+ -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
+ -- all three are available, False if any one of these is unavailable.
+
procedure Expand_N_Op_Concat (N : Node_Id) is
Opnds : List_Id;
@@ -2689,6 +3289,31 @@ package body Exp_Ch4 is
-- Component type of concatenation represented by Cnode
begin
+ -- Initialize global variables showing run-time status
+
+ if Max_Available_String_Operands < 1 then
+ if not RTE_Available (RE_Str_Concat) then
+ Max_Available_String_Operands := 0;
+ elsif not RTE_Available (RE_Str_Concat_3) then
+ Max_Available_String_Operands := 2;
+ elsif not RTE_Available (RE_Str_Concat_4) then
+ Max_Available_String_Operands := 3;
+ elsif not RTE_Available (RE_Str_Concat_5) then
+ Max_Available_String_Operands := 4;
+ else
+ Max_Available_String_Operands := 5;
+ end if;
+
+ Char_Concat_Available :=
+ RTE_Available (RE_Str_Concat_CC)
+ and then
+ RTE_Available (RE_Str_Concat_CS)
+ and then
+ RTE_Available (RE_Str_Concat_SC);
+ end if;
+
+ -- Ensure validity of both operands
+
Binary_Op_Validity_Checks (N);
-- If we are the left operand of a concatenation higher up the
@@ -2723,12 +3348,21 @@ package body Exp_Ch4 is
Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
Set_Parent (Opnds, N);
- -- The inner loop gathers concatenation operands
+ -- The inner loop gathers concatenation operands. We gather any
+ -- number of these in the non-string case, or if no concatenation
+ -- routines are available for string (since in that case we will
+ -- treat string like any other non-string case). Otherwise we only
+ -- gather as many operands as can be handled by the available
+ -- procedures in the run-time library (normally 5, but may be
+ -- less for the configurable run-time case).
Inner : while Cnode /= N
and then (Base_Type (Etype (Cnode)) /= Standard_String
or else
- List_Length (Opnds) < 5)
+ Max_Available_String_Operands = 0
+ or else
+ List_Length (Opnds) <
+ Max_Available_String_Operands)
and then Base_Type (Etype (Cnode)) =
Base_Type (Etype (Parent (Cnode)))
loop
@@ -2744,7 +3378,9 @@ package body Exp_Ch4 is
Atyp := Base_Type (Etype (Cnode));
Ctyp := Base_Type (Component_Type (Etype (Cnode)));
- if List_Length (Opnds) > 2 or else Atyp /= Standard_String then
+ if (List_Length (Opnds) > 2 or else Atyp /= Standard_String)
+ or else not Char_Concat_Available
+ then
Opnd := First (Opnds);
loop
if Base_Type (Etype (Opnd)) = Ctyp then
@@ -2761,7 +3397,9 @@ package body Exp_Ch4 is
-- Now call appropriate continuation routine
- if Atyp = Standard_String then
+ if Atyp = Standard_String
+ and then Max_Available_String_Operands > 0
+ then
Expand_Concatenate_String (Cnode, Opnds);
else
Expand_Concatenate_Other (Cnode, Opnds);
@@ -2808,6 +3446,13 @@ package body Exp_Ch4 is
if Nkind (Right_Opnd (N)) = N_Op_Expon
and then Is_Power_Of_2_For_Shift (Right_Opnd (N))
+
+ -- We cannot do this transformation in configurable run time mode if we
+ -- have 64-bit -- integers and long shifts are not available.
+
+ and then
+ (Esize (Ltyp) <= 32
+ or else Support_Long_Shifts_On_Target)
then
Rewrite (N,
Make_Op_Shift_Right (Loc,
@@ -2879,6 +3524,14 @@ package body Exp_Ch4 is
elsif Is_Integer_Type (Typ) then
Apply_Divide_Check (N);
+
+ -- Check for 64-bit division available
+
+ if Esize (Ltyp) > 32
+ and then not Support_64_Bit_Divides_On_Target
+ then
+ Error_Msg_CRT ("64-bit division", N);
+ end if;
end if;
end Expand_N_Op_Divide;
@@ -2887,15 +3540,16 @@ package body Exp_Ch4 is
--------------------
procedure Expand_N_Op_Eq (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Lhs : constant Node_Id := Left_Opnd (N);
- Rhs : constant Node_Id := Right_Opnd (N);
- A_Typ : Entity_Id := Etype (Lhs);
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Lhs : constant Node_Id := Left_Opnd (N);
+ Rhs : constant Node_Id := Right_Opnd (N);
+ Bodies : constant List_Id := New_List;
+ A_Typ : constant Entity_Id := Etype (Lhs);
+
Typl : Entity_Id := A_Typ;
Op_Name : Entity_Id;
Prim : Elmt_Id;
- Bodies : List_Id := New_List;
procedure Build_Equality_Call (Eq : Entity_Id);
-- If a constructed equality exists for the type or for its parent,
@@ -2967,21 +3621,36 @@ package body Exp_Ch4 is
elsif Is_Array_Type (Typl) then
+ -- If we are doing full validity checking, then expand out array
+ -- comparisons to make sure that we check the array elements.
+
+ if Validity_Check_Operands then
+ declare
+ Save_Force_Validity_Checks : constant Boolean :=
+ Force_Validity_Checks;
+ begin
+ Force_Validity_Checks := True;
+ Rewrite (N,
+ Expand_Array_Equality (N, Typl, A_Typ,
+ Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
+
+ Insert_Actions (N, Bodies);
+ Analyze_And_Resolve (N, Standard_Boolean);
+ Force_Validity_Checks := Save_Force_Validity_Checks;
+ end;
+
-- Packed case
- if Is_Bit_Packed_Array (Typl) then
+ elsif Is_Bit_Packed_Array (Typl) then
Expand_Packed_Eq (N);
-- For non-floating-point elementary types, the primitive equality
-- always applies, and block-bit comparison is fine. Floating-point
-- is an exception because of negative zeroes.
- -- However, we never use block bit comparison in No_Run_Time mode,
- -- since this may result in a call to a run time routine
-
elsif Is_Elementary_Type (Component_Type (Typl))
and then not Is_Floating_Point_Type (Component_Type (Typl))
- and then not No_Run_Time
+ and then Support_Composite_Compare_On_Target
then
null;
@@ -3025,16 +3694,41 @@ package body Exp_Ch4 is
end loop;
Op_Name := Node (Prim);
+
+ -- Find the type's predefined equality or an overriding
+ -- user-defined equality. The reason for not simply calling
+ -- Find_Prim_Op here is that there may be a user-defined
+ -- overloaded equality op that precedes the equality that
+ -- we want, so we have to explicitly search (e.g., there
+ -- could be an equality with two different parameter types).
+
else
- Op_Name := Find_Prim_Op (Typl, Name_Op_Eq);
+ if Is_Class_Wide_Type (Typl) then
+ Typl := Root_Type (Typl);
+ end if;
+
+ Prim := First_Elmt (Primitive_Operations (Typl));
+
+ while Present (Prim) loop
+ exit when Chars (Node (Prim)) = Name_Op_Eq
+ and then Etype (First_Formal (Node (Prim))) =
+ Etype (Next_Formal (First_Formal (Node (Prim))))
+ and then Etype (Node (Prim)) = Standard_Boolean;
+
+ Next_Elmt (Prim);
+ pragma Assert (Present (Prim));
+ end loop;
+
+ Op_Name := Node (Prim);
end if;
Build_Equality_Call (Op_Name);
-- If a type support function is present (for complex cases), use it
- elsif Present (TSS (Root_Type (Typl), Name_uEquality)) then
- Build_Equality_Call (TSS (Root_Type (Typl), Name_uEquality));
+ elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
+ Build_Equality_Call
+ (TSS (Root_Type (Typl), TSS_Composite_Equality));
-- Otherwise expand the component by component equality. Note that
-- we never use block-bit coparisons for records, because of the
@@ -3078,6 +3772,7 @@ package body Exp_Ch4 is
Temp : Node_Id;
Rent : RE_Id;
Ent : Entity_Id;
+ Etyp : Entity_Id;
begin
Binary_Op_Validity_Checks (N);
@@ -3112,10 +3807,7 @@ package body Exp_Ch4 is
end;
end if;
- -- At this point the exponentiation must be dynamic since the static
- -- case has already been folded after Resolve by Eval_Op_Expon.
-
- -- Test for case of literal right argument
+ -- Test for case of known right argument
if Compile_Time_Known_Value (Exp) then
Expv := Expr_Value (Exp);
@@ -3148,7 +3840,7 @@ package body Exp_Ch4 is
Xnode :=
Make_Op_Multiply (Loc,
Left_Opnd => Duplicate_Subexpr (Base),
- Right_Opnd => Duplicate_Subexpr (Base));
+ Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
-- X ** 3 = X * X * X
@@ -3158,8 +3850,8 @@ package body Exp_Ch4 is
Left_Opnd =>
Make_Op_Multiply (Loc,
Left_Opnd => Duplicate_Subexpr (Base),
- Right_Opnd => Duplicate_Subexpr (Base)),
- Right_Opnd => Duplicate_Subexpr (Base));
+ Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
+ Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
-- X ** 4 ->
-- En : constant base'type := base * base;
@@ -3178,7 +3870,7 @@ package body Exp_Ch4 is
Expression =>
Make_Op_Multiply (Loc,
Left_Opnd => Duplicate_Subexpr (Base),
- Right_Opnd => Duplicate_Subexpr (Base)))));
+ Right_Opnd => Duplicate_Subexpr_No_Checks (Base)))));
Xnode :=
Make_Op_Multiply (Loc,
@@ -3194,7 +3886,7 @@ package body Exp_Ch4 is
-- Case of (2 ** expression) appearing as an argument of an integer
-- multiplication, or as the right argument of a division of a non-
- -- negative integer. In such cases we lave the node untouched, setting
+ -- negative integer. In such cases we leave the node untouched, setting
-- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
-- of the higher level node converts it into a shift.
@@ -3234,11 +3926,6 @@ package body Exp_Ch4 is
-- Fall through if exponentiation must be done using a runtime routine
- if No_Run_Time then
- Disallow_In_No_Run_Time_Mode (N);
- return;
- end if;
-
-- First deal with modular case
if Is_Modular_Integer_Type (Rtyp) then
@@ -3249,7 +3936,6 @@ package body Exp_Ch4 is
-- to the base type.
if Non_Binary_Modulus (Rtyp) then
-
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
@@ -3289,83 +3975,54 @@ package body Exp_Ch4 is
Analyze_And_Resolve (N, Typ);
return;
- -- Signed integer cases
-
- elsif Rtyp = Base_Type (Standard_Integer) then
- if Ovflo then
- Rent := RE_Exp_Integer;
- else
- Rent := RE_Exn_Integer;
- end if;
-
- elsif Rtyp = Base_Type (Standard_Short_Integer) then
- if Ovflo then
- Rent := RE_Exp_Short_Integer;
- else
- Rent := RE_Exn_Short_Integer;
- end if;
-
- elsif Rtyp = Base_Type (Standard_Short_Short_Integer) then
- if Ovflo then
- Rent := RE_Exp_Short_Short_Integer;
- else
- Rent := RE_Exn_Short_Short_Integer;
- end if;
+ -- Signed integer cases, done using either Integer or Long_Long_Integer.
+ -- It is not worth having routines for Short_[Short_]Integer, since for
+ -- most machines it would not help, and it would generate more code that
+ -- might need certification in the HI-E case.
- elsif Rtyp = Base_Type (Standard_Long_Integer) then
- if Ovflo then
- Rent := RE_Exp_Long_Integer;
- else
- Rent := RE_Exn_Long_Integer;
- end if;
+ -- In the integer cases, we have two routines, one for when overflow
+ -- checks are required, and one when they are not required, since
+ -- there is a real gain in ommitting checks on many machines.
- elsif (Rtyp = Base_Type (Standard_Long_Long_Integer)
- or else Rtyp = Universal_Integer)
+ elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
+ or else (Rtyp = Base_Type (Standard_Long_Integer)
+ and then
+ Esize (Standard_Long_Integer) > Esize (Standard_Integer))
+ or else (Rtyp = Universal_Integer)
then
+ Etyp := Standard_Long_Long_Integer;
+
if Ovflo then
Rent := RE_Exp_Long_Long_Integer;
else
Rent := RE_Exn_Long_Long_Integer;
end if;
- -- Floating-point cases
+ elsif Is_Signed_Integer_Type (Rtyp) then
+ Etyp := Standard_Integer;
- elsif Rtyp = Standard_Float then
if Ovflo then
- Rent := RE_Exp_Float;
- else
- Rent := RE_Exn_Float;
- end if;
-
- elsif Rtyp = Standard_Short_Float then
- if Ovflo then
- Rent := RE_Exp_Short_Float;
+ Rent := RE_Exp_Integer;
else
- Rent := RE_Exn_Short_Float;
+ Rent := RE_Exn_Integer;
end if;
- elsif Rtyp = Standard_Long_Float then
- if Ovflo then
- Rent := RE_Exp_Long_Float;
- else
- Rent := RE_Exn_Long_Float;
- end if;
+ -- Floating-point cases, always done using Long_Long_Float. We do not
+ -- need separate routines for the overflow case here, since in the case
+ -- of floating-point, we generate infinities anyway as a rule (either
+ -- that or we automatically trap overflow), and if there is an infinity
+ -- generated and a range check is required, the check will fail anyway.
else
- pragma Assert
- (Rtyp = Standard_Long_Long_Float or else Rtyp = Universal_Real);
-
- if Ovflo then
- Rent := RE_Exp_Long_Long_Float;
- else
- Rent := RE_Exn_Long_Long_Float;
- end if;
+ pragma Assert (Is_Floating_Point_Type (Rtyp));
+ Etyp := Standard_Long_Long_Float;
+ Rent := RE_Exn_Long_Long_Float;
end if;
-- Common processing for integer cases and floating-point cases.
- -- If we are in the base type, we can call runtime routine directly
+ -- If we are in the right type, we can call runtime routine directly
- if Typ = Rtyp
+ if Typ = Etyp
and then Rtyp /= Universal_Integer
and then Rtyp /= Universal_Real
then
@@ -3375,8 +4032,8 @@ package body Exp_Ch4 is
Parameter_Associations => New_List (Base, Exp)));
-- Otherwise we have to introduce conversions (conversions are also
- -- required in the universal cases, since the runtime routine was
- -- typed using the largest integer or real case.
+ -- required in the universal cases, since the runtime routine is
+ -- typed using one of the standard types.
else
Rewrite (N,
@@ -3384,13 +4041,16 @@ package body Exp_Ch4 is
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (Rent), Loc),
Parameter_Associations => New_List (
- Convert_To (Rtyp, Base),
+ Convert_To (Etyp, Base),
Exp))));
end if;
Analyze_And_Resolve (N, Typ);
return;
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_N_Op_Expon;
--------------------
@@ -3558,7 +4218,7 @@ package body Exp_Ch4 is
procedure Expand_N_Op_Mod (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- T : constant Entity_Id := Etype (N);
+ Typ : constant Entity_Id := Etype (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
DOC : constant Boolean := Do_Overflow_Check (N);
@@ -3597,7 +4257,7 @@ package body Exp_Ch4 is
-- instance and is epsilon more efficient.
Set_Entity (N, Standard_Entity (S_Op_Rem));
- Set_Etype (N, T);
+ Set_Etype (N, Typ);
Set_Do_Overflow_Check (N, DOC);
Set_Do_Division_Check (N, DDC);
Expand_N_Op_Rem (N);
@@ -3610,6 +4270,19 @@ package body Exp_Ch4 is
Apply_Divide_Check (N);
end if;
+ -- Apply optimization x mod 1 = 0. We don't really need that with
+ -- gcc, but it is useful with other back ends (e.g. AAMP), and is
+ -- certainly harmless.
+
+ if Is_Integer_Type (Etype (N))
+ and then Compile_Time_Known_Value (Right)
+ and then Expr_Value (Right) = Uint_1
+ then
+ Rewrite (N, Make_Integer_Literal (Loc, 0));
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end if;
+
-- Deal with annoying case of largest negative number remainder
-- minus one. Gigi does not handle this case correctly, because
-- it generates a divide instruction which may trap in this case.
@@ -3618,7 +4291,13 @@ package body Exp_Ch4 is
-- then the mod value is always 0, and we can just ignore the
-- left operand completely in this case.
- LLB := Expr_Value (Type_Low_Bound (Base_Type (Etype (Left))));
+ -- The operand type may be private (e.g. in the expansion of an
+ -- an intrinsic operation) so we must use the underlying type to
+ -- get the bounds, and convert the literals explicitly.
+
+ LLB :=
+ Expr_Value
+ (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
and then
@@ -3630,12 +4309,14 @@ package body Exp_Ch4 is
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr (Right),
Right_Opnd =>
- Make_Integer_Literal (Loc, -1)),
- Make_Integer_Literal (Loc, Uint_0),
+ Unchecked_Convert_To (Typ,
+ Make_Integer_Literal (Loc, -1))),
+ Unchecked_Convert_To (Typ,
+ Make_Integer_Literal (Loc, Uint_0)),
Relocate_Node (N))));
Set_Analyzed (Next (Next (First (Expressions (N)))));
- Analyze_And_Resolve (N, T);
+ Analyze_And_Resolve (N, Typ);
end if;
end if;
end Expand_N_Op_Mod;
@@ -3648,6 +4329,15 @@ package body Exp_Ch4 is
Loc : constant Source_Ptr := Sloc (N);
Lop : constant Node_Id := Left_Opnd (N);
Rop : constant Node_Id := Right_Opnd (N);
+
+ Lp2 : constant Boolean :=
+ Nkind (Lop) = N_Op_Expon
+ and then Is_Power_Of_2_For_Shift (Lop);
+
+ Rp2 : constant Boolean :=
+ Nkind (Rop) = N_Op_Expon
+ and then Is_Power_Of_2_For_Shift (Rop);
+
Ltyp : constant Entity_Id := Etype (Lop);
Rtyp : constant Entity_Id := Etype (Rop);
Typ : Entity_Id := Etype (N);
@@ -3661,11 +4351,11 @@ package body Exp_Ch4 is
-- N * 0 = 0 * N = 0 for integer types
- if (Compile_Time_Known_Value (Right_Opnd (N))
- and then Expr_Value (Right_Opnd (N)) = Uint_0)
+ if (Compile_Time_Known_Value (Rop)
+ and then Expr_Value (Rop) = Uint_0)
or else
- (Compile_Time_Known_Value (Left_Opnd (N))
- and then Expr_Value (Left_Opnd (N)) = Uint_0)
+ (Compile_Time_Known_Value (Lop)
+ and then Expr_Value (Lop) = Uint_0)
then
Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
Analyze_And_Resolve (N, Typ);
@@ -3674,16 +4364,21 @@ package body Exp_Ch4 is
-- N * 1 = 1 * N = N for integer types
- if Compile_Time_Known_Value (Right_Opnd (N))
- and then Expr_Value (Right_Opnd (N)) = Uint_1
+ -- This optimisation is not done if we are going to
+ -- rewrite the product 1 * 2 ** N to a shift.
+
+ if Compile_Time_Known_Value (Rop)
+ and then Expr_Value (Rop) = Uint_1
+ and then not Lp2
then
- Rewrite (N, Left_Opnd (N));
+ Rewrite (N, Lop);
return;
- elsif Compile_Time_Known_Value (Left_Opnd (N))
- and then Expr_Value (Left_Opnd (N)) = Uint_1
+ elsif Compile_Time_Known_Value (Lop)
+ and then Expr_Value (Lop) = Uint_1
+ and then not Rp2
then
- Rewrite (N, Right_Opnd (N));
+ Rewrite (N, Rop);
return;
end if;
end if;
@@ -3699,14 +4394,10 @@ package body Exp_Ch4 is
-- Is_Power_Of_2_For_Shift is set means that we know that our left
-- operand is an integer, as required for this to work.
- if Nkind (Rop) = N_Op_Expon
- and then Is_Power_Of_2_For_Shift (Rop)
- then
- if Nkind (Lop) = N_Op_Expon
- and then Is_Power_Of_2_For_Shift (Lop)
- then
+ if Rp2 then
+ if Lp2 then
- -- convert 2 ** A * 2 ** B into 2 ** (A + B)
+ -- Convert 2 ** A * 2 ** B into 2 ** (A + B)
Rewrite (N,
Make_Op_Expon (Loc,
@@ -3730,9 +4421,7 @@ package body Exp_Ch4 is
-- Same processing for the operands the other way round
- elsif Nkind (Lop) = N_Op_Expon
- and then Is_Power_Of_2_For_Shift (Lop)
- then
+ elsif Lp2 then
Rewrite (N,
Make_Op_Shift_Left (Loc,
Left_Opnd => Rop,
@@ -3843,6 +4532,12 @@ package body Exp_Ch4 is
Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
end if;
+ -- For navigation purposes, the inequality is treated as an implicit
+ -- reference to the corresponding equality. Preserve the Comes_From_
+ -- source flag so that the proper Xref entry is generated.
+
+ Preserve_Comes_From_Source (Neg, N);
+ Preserve_Comes_From_Source (Right_Opnd (Neg), N);
Rewrite (N, Neg);
Analyze_And_Resolve (N, Standard_Boolean);
end Expand_N_Op_Ne;
@@ -3915,13 +4610,61 @@ package body Exp_Ch4 is
return;
end if;
- -- Case of array operand which is not bit-packed
+ -- Case of array operand which is not bit-packed. If the context is
+ -- a safe assignment, call in-place operation, If context is a larger
+ -- boolean expression in the context of a safe assignment, expansion is
+ -- done by enclosing operation.
Opnd := Relocate_Node (Right_Opnd (N));
Convert_To_Actual_Subtype (Opnd);
Arr := Etype (Opnd);
Ensure_Defined (Arr, N);
+ if Nkind (Parent (N)) = N_Assignment_Statement then
+ if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
+ Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
+ return;
+
+ -- Special case the negation of a binary operation.
+
+ elsif (Nkind (Opnd) = N_Op_And
+ or else Nkind (Opnd) = N_Op_Or
+ or else Nkind (Opnd) = N_Op_Xor)
+ and then Safe_In_Place_Array_Op
+ (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
+ then
+ Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
+ return;
+ end if;
+
+ elsif Nkind (Parent (N)) in N_Binary_Op
+ and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
+ then
+ declare
+ Op1 : constant Node_Id := Left_Opnd (Parent (N));
+ Op2 : constant Node_Id := Right_Opnd (Parent (N));
+ Lhs : constant Node_Id := Name (Parent (Parent (N)));
+
+ begin
+ if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
+ if N = Op1
+ and then Nkind (Op2) = N_Op_Not
+ then
+ -- (not A) op (not B) can be reduced to a single call.
+
+ return;
+
+ elsif N = Op2
+ and then Nkind (Parent (N)) = N_Op_Xor
+ then
+ -- A xor (not B) can also be special-cased.
+
+ return;
+ end if;
+ end if;
+ end;
+ end if;
+
A := Make_Defining_Identifier (Loc, Name_uA);
B := Make_Defining_Identifier (Loc, Name_uB);
J := Make_Defining_Identifier (Loc, Name_uJ);
@@ -4026,6 +4769,7 @@ package body Exp_Ch4 is
procedure Expand_N_Op_Rem (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
@@ -4037,7 +4781,6 @@ package body Exp_Ch4 is
Rlo : Uint;
Rhi : Uint;
ROK : Boolean;
- Typ : Entity_Id;
begin
Binary_Op_Validity_Checks (N);
@@ -4046,6 +4789,19 @@ package body Exp_Ch4 is
Apply_Divide_Check (N);
end if;
+ -- Apply optimization x rem 1 = 0. We don't really need that with
+ -- gcc, but it is useful with other back ends (e.g. AAMP), and is
+ -- certainly harmless.
+
+ if Is_Integer_Type (Etype (N))
+ and then Compile_Time_Known_Value (Right)
+ and then Expr_Value (Right) = Uint_1
+ then
+ Rewrite (N, Make_Integer_Literal (Loc, 0));
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end if;
+
-- Deal with annoying case of largest negative number remainder
-- minus one. Gigi does not handle this case correctly, because
-- it generates a divide instruction which may trap in this case.
@@ -4056,8 +4812,16 @@ package body Exp_Ch4 is
Determine_Range (Right, ROK, Rlo, Rhi);
Determine_Range (Left, LOK, Llo, Lhi);
- LLB := Expr_Value (Type_Low_Bound (Base_Type (Etype (Left))));
- Typ := Etype (N);
+
+ -- The operand type may be private (e.g. in the expansion of an
+ -- an intrinsic operation) so we must use the underlying type to
+ -- get the bounds, and convert the literals explicitly.
+
+ LLB :=
+ Expr_Value
+ (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
+
+ -- Now perform the test, generating code only if needed
if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
and then
@@ -4069,9 +4833,11 @@ package body Exp_Ch4 is
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr (Right),
Right_Opnd =>
- Make_Integer_Literal (Loc, -1)),
+ Unchecked_Convert_To (Typ,
+ Make_Integer_Literal (Loc, -1))),
- Make_Integer_Literal (Loc, Uint_0),
+ Unchecked_Convert_To (Typ,
+ Make_Integer_Literal (Loc, Uint_0)),
Relocate_Node (N))));
@@ -4201,10 +4967,11 @@ package body Exp_Ch4 is
Adjust_Condition (Left);
Adjust_Condition (Right);
Set_Etype (N, Standard_Boolean);
+ end if;
-- Check for cases of left argument is True or False
- elsif Nkind (Left) = N_Identifier then
+ if Nkind (Left) = N_Identifier then
-- If left argument is False, change (False or else Right) to Right.
-- Any actions associated with Right will be executed unconditionally
@@ -4306,26 +5073,48 @@ package body Exp_Ch4 is
Loc : constant Source_Ptr := Sloc (N);
Par : constant Node_Id := Parent (N);
P : constant Node_Id := Prefix (N);
+ Ptyp : Entity_Id := Underlying_Type (Etype (P));
Disc : Entity_Id;
- Ptyp : Entity_Id := Underlying_Type (Etype (P));
New_N : Node_Id;
+ Dcon : Elmt_Id;
function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
-- Gigi needs a temporary for prefixes that depend on a discriminant,
-- unless the context of an assignment can provide size information.
+ -- Don't we have a general routine that does this???
+
+ -----------------------
+ -- In_Left_Hand_Side --
+ -----------------------
function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
begin
- return
- (Nkind (Parent (Comp)) = N_Assignment_Statement
- and then Comp = Name (Parent (Comp)))
- or else
- (Present (Parent (Comp))
- and then Nkind (Parent (Comp)) in N_Subexpr
- and then In_Left_Hand_Side (Parent (Comp)));
+ return (Nkind (Parent (Comp)) = N_Assignment_Statement
+ and then Comp = Name (Parent (Comp)))
+ or else (Present (Parent (Comp))
+ and then Nkind (Parent (Comp)) in N_Subexpr
+ and then In_Left_Hand_Side (Parent (Comp)));
end In_Left_Hand_Side;
+ -- Start of processing for Expand_N_Selected_Component
+
begin
+ -- Insert explicit dereference if required
+
+ if Is_Access_Type (Ptyp) then
+ Insert_Explicit_Dereference (P);
+
+ if Ekind (Etype (P)) = E_Private_Subtype
+ and then Is_For_Access_Subtype (Etype (P))
+ then
+ Set_Etype (P, Base_Type (Etype (P)));
+ end if;
+
+ Ptyp := Etype (P);
+ end if;
+
+ -- Deal with discriminant check required
+
if Do_Discriminant_Check (N) then
-- Present the discrminant checking function to the backend,
@@ -4334,21 +5123,18 @@ package body Exp_Ch4 is
Add_Inlined_Body
(Discriminant_Checking_Func
(Original_Record_Component (Entity (Selector_Name (N)))));
- end if;
- -- Insert explicit dereference call for the checked storage pool case
+ -- Now reset the flag and generate the call
- if Is_Access_Type (Ptyp) then
- Insert_Dereference_Action (P);
- return;
+ Set_Do_Discriminant_Check (N, False);
+ Generate_Discriminant_Check (N);
end if;
- -- Gigi cannot handle unchecked conversions that are the prefix of
- -- a selected component with discriminants. This must be checked
- -- during expansion, because during analysis the type of the selector
- -- is not known at the point the prefix is analyzed. If the conversion
- -- is the target of an assignment, we cannot force the evaluation, of
- -- course.
+ -- Gigi cannot handle unchecked conversions that are the prefix of a
+ -- selected component with discriminants. This must be checked during
+ -- expansion, because during analysis the type of the selector is not
+ -- known at the point the prefix is analyzed. If the conversion is the
+ -- target of an assignment, then we cannot force the evaluation.
if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
and then Has_Discriminants (Etype (N))
@@ -4362,64 +5148,127 @@ package body Exp_Ch4 is
if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
-- If the selector is a discriminant of a constrained record type,
- -- rewrite the expression with the actual value of the discriminant.
- -- Don't do this on the left hand of an assignment statement (this
- -- happens in generated code, and means we really want to set it!)
- -- We also only do this optimization for discrete types, and not
- -- for access types (access discriminants get us into trouble!)
- -- We also do not expand the prefix of an attribute or the
- -- operand of an object renaming declaration.
+ -- we may be able to rewrite the expression with the actual value
+ -- of the discriminant, a useful optimization in some cases.
if Is_Record_Type (Ptyp)
and then Has_Discriminants (Ptyp)
and then Is_Constrained (Ptyp)
- and then Is_Discrete_Type (Etype (N))
- and then (Nkind (Par) /= N_Assignment_Statement
- or else Name (Par) /= N)
- and then (Nkind (Par) /= N_Attribute_Reference
- or else Prefix (Par) /= N)
- and then not Is_Renamed_Object (N)
then
- declare
- D : Entity_Id;
- E : Elmt_Id;
+ -- Do this optimization for discrete types only, and not for
+ -- access types (access discriminants get us into trouble!)
- begin
- D := First_Discriminant (Ptyp);
- E := First_Elmt (Discriminant_Constraint (Ptyp));
+ if not Is_Discrete_Type (Etype (N)) then
+ null;
+
+ -- Don't do this on the left hand of an assignment statement.
+ -- Normally one would think that references like this would
+ -- not occur, but they do in generated code, and mean that
+ -- we really do want to assign the discriminant!
+
+ elsif Nkind (Par) = N_Assignment_Statement
+ and then Name (Par) = N
+ then
+ null;
+
+ -- Don't do this optimization for the prefix of an attribute
+ -- or the operand of an object renaming declaration since these
+ -- are contexts where we do not want the value anyway.
+
+ elsif (Nkind (Par) = N_Attribute_Reference
+ and then Prefix (Par) = N)
+ or else Is_Renamed_Object (N)
+ then
+ null;
+
+ -- Don't do this optimization if we are within the code for a
+ -- discriminant check, since the whole point of such a check may
+ -- be to verify the condition on which the code below depends!
+
+ elsif Is_In_Discriminant_Check (N) then
+ null;
+
+ -- Green light to see if we can do the optimization. There is
+ -- still one condition that inhibits the optimization below
+ -- but now is the time to check the particular discriminant.
+
+ else
+ -- Loop through discriminants to find the matching
+ -- discriminant constraint to see if we can copy it.
+
+ Disc := First_Discriminant (Ptyp);
+ Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
+ Discr_Loop : while Present (Dcon) loop
+
+ -- Check if this is the matching discriminant
- while Present (E) loop
- if D = Entity (Selector_Name (N)) then
+ if Disc = Entity (Selector_Name (N)) then
+
+ -- Here we have the matching discriminant. Check for
+ -- the case of a discriminant of a component that is
+ -- constrained by an outer discriminant, which cannot
+ -- be optimized away.
+
+ if
+ Denotes_Discriminant
+ (Node (Dcon), Check_Protected => True)
+ then
+ exit Discr_Loop;
-- In the context of a case statement, the expression
-- may have the base type of the discriminant, and we
-- need to preserve the constraint to avoid spurious
-- errors on missing cases.
- if Nkind (Parent (N)) = N_Case_Statement
- and then Etype (Node (E)) /= Etype (D)
+ elsif Nkind (Parent (N)) = N_Case_Statement
+ and then Etype (Node (Dcon)) /= Etype (Disc)
then
+ -- RBKD is suspicious of the following code. The
+ -- call to New_Copy instead of New_Copy_Tree is
+ -- suspicious, and the call to Analyze instead
+ -- of Analyze_And_Resolve is also suspicious ???
+
+ -- Wouldn't it be good enough to do a perfectly
+ -- normal Analyze_And_Resolve call using the
+ -- subtype of the discriminant here???
+
Rewrite (N,
Make_Qualified_Expression (Loc,
- Subtype_Mark => New_Occurrence_Of (Etype (D), Loc),
- Expression => New_Copy (Node (E))));
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Disc), Loc),
+ Expression =>
+ New_Copy (Node (Dcon))));
Analyze (N);
+
+ -- In case that comes out as a static expression,
+ -- reset it (a selected component is never static).
+
+ Set_Is_Static_Expression (N, False);
+ return;
+
+ -- Otherwise we can just copy the constraint, but the
+ -- result is certainly not static!
+
+ -- Again the New_Copy here and the failure to even
+ -- to an analyze call is uneasy ???
+
else
- Rewrite (N, New_Copy (Node (E)));
+ Rewrite (N, New_Copy (Node (Dcon)));
+ Set_Is_Static_Expression (N, False);
+ return;
end if;
-
- Set_Is_Static_Expression (N, False);
- return;
end if;
- Next_Elmt (E);
- Next_Discriminant (D);
- end loop;
+ Next_Elmt (Dcon);
+ Next_Discriminant (Disc);
+ end loop Discr_Loop;
- -- Note: the above loop should always terminate, but if
- -- it does not, we just missed an optimization due to
- -- some glitch (perhaps a previous error), so ignore!
- end;
+ -- Note: the above loop should always find a matching
+ -- discriminant, but if it does not, we just missed an
+ -- optimization due to some glitch (perhaps a previous
+ -- error), so ignore.
+
+ end if;
end if;
-- The only remaining processing is in the case of a discriminant of
@@ -4450,7 +5299,6 @@ package body Exp_Ch4 is
Rewrite (N, New_N);
Analyze (N);
end if;
-
end Expand_N_Selected_Component;
--------------------
@@ -4462,8 +5310,39 @@ package body Exp_Ch4 is
Typ : constant Entity_Id := Etype (N);
Pfx : constant Node_Id := Prefix (N);
Ptp : Entity_Id := Etype (Pfx);
- Ent : Entity_Id;
- Decl : Node_Id;
+
+ procedure Make_Temporary;
+ -- Create a named variable for the value of the slice, in
+ -- cases where the back-end cannot handle it properly, e.g.
+ -- when packed types or unaligned slices are involved.
+
+ --------------------
+ -- Make_Temporary --
+ --------------------
+
+ procedure Make_Temporary is
+ Decl : Node_Id;
+ Ent : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
+ begin
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Ent,
+ Object_Definition => New_Occurrence_Of (Typ, Loc));
+
+ Set_No_Initialization (Decl);
+
+ Insert_Actions (N, New_List (
+ Decl,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Ent, Loc),
+ Expression => Relocate_Node (N))));
+
+ Rewrite (N, New_Occurrence_Of (Ent, Loc));
+ Analyze_And_Resolve (N, Typ);
+ end Make_Temporary;
+
+ -- Start of processing for Expand_N_Slice
begin
-- Special handling for access types
@@ -4486,11 +5365,6 @@ package body Exp_Ch4 is
Prefix => Relocate_Node (Pfx)));
Analyze_And_Resolve (Pfx, Ptp);
-
- -- The prefix will now carry the Access_Check flag for the back
- -- end, remove it from slice itself.
-
- Set_Do_Access_Check (N, False);
end if;
end if;
@@ -4528,6 +5402,9 @@ package body Exp_Ch4 is
if Is_Packed (Typ)
and then Nkind (Parent (N)) /= N_Assignment_Statement
+ and then (Nkind (Parent (Parent (N))) /= N_Assignment_Statement
+ or else
+ Parent (N) /= Name (Parent (Parent (N))))
and then Nkind (Parent (N)) /= N_Indexed_Component
and then not Is_Renamed_Object (N)
and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
@@ -4535,24 +5412,15 @@ package body Exp_Ch4 is
or else
Attribute_Name (Parent (N)) /= Name_Address)
then
- Ent :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
+ Make_Temporary;
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Ent,
- Object_Definition => New_Occurrence_Of (Typ, Loc));
-
- Set_No_Initialization (Decl);
+ -- Same transformation for actuals in a function call, where
+ -- Expand_Actuals is not used.
- Insert_Actions (N, New_List (
- Decl,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Ent, Loc),
- Expression => Relocate_Node (N))));
-
- Rewrite (N, New_Occurrence_Of (Ent, Loc));
- Analyze_And_Resolve (N, Typ);
+ elsif Nkind (Parent (N)) = N_Function_Call
+ and then Is_Possibly_Unaligned_Slice (N)
+ then
+ Make_Temporary;
end if;
end Expand_N_Slice;
@@ -4616,11 +5484,16 @@ package body Exp_Ch4 is
if not Is_Constrained (Target_Type) then
if Has_Discriminants (Operand_Type) then
Disc := First_Discriminant (Operand_Type);
+
+ if Disc /= First_Stored_Discriminant (Operand_Type) then
+ Disc := First_Stored_Discriminant (Operand_Type);
+ end if;
+
Cons := New_List;
while Present (Disc) loop
Append_To (Cons,
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Operand),
+ Prefix => Duplicate_Subexpr_Move_Checks (Operand),
Selector_Name =>
Make_Identifier (Loc, Chars (Disc))));
Next_Discriminant (Disc);
@@ -4641,7 +5514,7 @@ package body Exp_Ch4 is
Unchecked_Convert_To (Etype (N_Ix),
Make_Attribute_Reference (Loc,
Prefix =>
- Duplicate_Subexpr
+ Duplicate_Subexpr_No_Checks
(Operand, Name_Req => True),
Attribute_Name => Name_First,
Expressions => New_List (
@@ -4651,7 +5524,7 @@ package body Exp_Ch4 is
Unchecked_Convert_To (Etype (N_Ix),
Make_Attribute_Reference (Loc,
Prefix =>
- Duplicate_Subexpr
+ Duplicate_Subexpr_No_Checks
(Operand, Name_Req => True),
Attribute_Name => Name_Last,
Expressions => New_List (
@@ -4714,10 +5587,16 @@ package body Exp_Ch4 is
-- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
-- Tnn
+ -- This is necessary when there is a conversion of integer to float
+ -- or to fixed-point to ensure that the correct checks are made. It
+ -- is not necessary for float to float where it is enough to simply
+ -- set the Do_Range_Check flag.
+
procedure Real_Range_Check is
Btyp : constant Entity_Id := Base_Type (Target_Type);
Lo : constant Node_Id := Type_Low_Bound (Target_Type);
Hi : constant Node_Id := Type_High_Bound (Target_Type);
+ Xtyp : constant Entity_Id := Etype (Operand);
Conv : Node_Id;
Tnn : Entity_Id;
@@ -4742,25 +5621,77 @@ package body Exp_Ch4 is
-- Nothing to do if expression is an entity on which checks
-- have been suppressed.
- if Is_Entity_Name (Expression (N))
- and then Range_Checks_Suppressed (Entity (Expression (N)))
+ if Is_Entity_Name (Operand)
+ and then Range_Checks_Suppressed (Entity (Operand))
then
return;
end if;
- -- Here we rewrite the conversion as described above
+ -- Nothing to do if bounds are all static and we can tell that
+ -- the expression is within the bounds of the target. Note that
+ -- if the operand is of an unconstrained floating-point type,
+ -- then we do not trust it to be in range (might be infinite)
+
+ declare
+ S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
+ S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
+
+ begin
+ if (not Is_Floating_Point_Type (Xtyp)
+ or else Is_Constrained (Xtyp))
+ and then Compile_Time_Known_Value (S_Lo)
+ and then Compile_Time_Known_Value (S_Hi)
+ and then Compile_Time_Known_Value (Hi)
+ and then Compile_Time_Known_Value (Lo)
+ then
+ declare
+ D_Lov : constant Ureal := Expr_Value_R (Lo);
+ D_Hiv : constant Ureal := Expr_Value_R (Hi);
+ S_Lov : Ureal;
+ S_Hiv : Ureal;
+
+ begin
+ if Is_Real_Type (Xtyp) then
+ S_Lov := Expr_Value_R (S_Lo);
+ S_Hiv := Expr_Value_R (S_Hi);
+ else
+ S_Lov := UR_From_Uint (Expr_Value (S_Lo));
+ S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
+ end if;
+
+ if D_Hiv > D_Lov
+ and then S_Lov >= D_Lov
+ and then S_Hiv <= D_Hiv
+ then
+ Set_Do_Range_Check (Operand, False);
+ return;
+ end if;
+ end;
+ end if;
+ end;
+
+ -- For float to float conversions, we are done
+
+ if Is_Floating_Point_Type (Xtyp)
+ and then
+ Is_Floating_Point_Type (Btyp)
+ then
+ return;
+ end if;
+
+ -- Otherwise rewrite the conversion as described above
Conv := Relocate_Node (N);
Rewrite
(Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
Set_Etype (Conv, Btyp);
- -- Skip overflow check for integer to float conversions,
- -- since it is not needed, and in any case gigi generates
- -- incorrect code for such overflow checks ???
+ -- Enable overflow except in the case of integer to float
+ -- conversions, where it is never required, since we can
+ -- never have overflow in this case.
- if not Is_Integer_Type (Etype (Expression (N))) then
- Set_Do_Overflow_Check (Conv, True);
+ if not Is_Integer_Type (Etype (Operand)) then
+ Enable_Overflow_Check (Conv);
end if;
Tnn :=
@@ -4806,7 +5737,7 @@ package body Exp_Ch4 is
-- so remove the conversion completely, it is useless.
if Operand_Type = Target_Type then
- Rewrite (N, Relocate_Node (Expression (N)));
+ Rewrite (N, Relocate_Node (Operand));
return;
end if;
@@ -4956,21 +5887,22 @@ package body Exp_Ch4 is
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ne (Loc,
- Left_Opnd => Duplicate_Subexpr (Operand),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
Right_Opnd => Make_Null (Loc)),
Right_Opnd =>
Make_Not_In (Loc,
Left_Opnd =>
Make_Explicit_Dereference (Loc,
- Prefix => Duplicate_Subexpr (Operand)),
+ Prefix =>
+ Duplicate_Subexpr_No_Checks (Operand)),
Right_Opnd =>
New_Reference_To (Actual_Target_Type, Loc)));
else
Cond :=
Make_Not_In (Loc,
- Left_Opnd => Duplicate_Subexpr (Operand),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Operand),
Right_Opnd =>
New_Reference_To (Actual_Target_Type, Loc));
end if;
@@ -5098,17 +6030,17 @@ package body Exp_Ch4 is
-- helpful, but still does not catch all cases with 64-bit integers
-- on targets with only 64-bit floats ???
- if Do_Range_Check (Expression (N)) then
- Rewrite (Expression (N),
+ if Do_Range_Check (Operand) then
+ Rewrite (Operand,
Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Standard_Long_Long_Float, Loc),
Expression =>
- Relocate_Node (Expression (N))));
+ Relocate_Node (Operand)));
- Set_Etype (Expression (N), Standard_Long_Long_Float);
- Enable_Range_Check (Expression (N));
- Set_Do_Range_Check (Expression (Expression (N)), False);
+ Set_Etype (Operand, Standard_Long_Long_Float);
+ Enable_Range_Check (Operand);
+ Set_Do_Range_Check (Expression (Operand), False);
end if;
-- Case of array conversions
@@ -5194,6 +6126,55 @@ package body Exp_Ch4 is
-- No other conversions should be passed to Gigi.
+ -- The only remaining step is to generate a range check if we still
+ -- have a type conversion at this stage and Do_Range_Check is set.
+ -- For now we do this only for conversions of discrete types.
+
+ if Nkind (N) = N_Type_Conversion
+ and then Is_Discrete_Type (Etype (N))
+ then
+ declare
+ Expr : constant Node_Id := Expression (N);
+ Ftyp : Entity_Id;
+ Ityp : Entity_Id;
+
+ begin
+ if Do_Range_Check (Expr)
+ and then Is_Discrete_Type (Etype (Expr))
+ then
+ Set_Do_Range_Check (Expr, False);
+
+ -- Before we do a range check, we have to deal with treating
+ -- a fixed-point operand as an integer. The way we do this
+ -- is simply to do an unchecked conversion to an appropriate
+ -- integer type large enough to hold the result.
+
+ -- This code is not active yet, because we are only dealing
+ -- with discrete types so far ???
+
+ if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
+ and then Treat_Fixed_As_Integer (Expr)
+ then
+ Ftyp := Base_Type (Etype (Expr));
+
+ if Esize (Ftyp) >= Esize (Standard_Integer) then
+ Ityp := Standard_Long_Long_Integer;
+ else
+ Ityp := Standard_Integer;
+ end if;
+
+ Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
+ end if;
+
+ -- Reset overflow flag, since the range check will include
+ -- dealing with possible overflow, and generate the check
+
+ Set_Do_Overflow_Check (N, False);
+ Generate_Range_Check
+ (Expr, Target_Type, CE_Range_Check_Failed);
+ end if;
+ end;
+ end if;
end Expand_N_Type_Conversion;
-----------------------------------
@@ -5448,6 +6429,47 @@ package body Exp_Ch4 is
end if;
end Fixup_Universal_Fixed_Operation;
+ ------------------------------
+ -- Get_Allocator_Final_List --
+ ------------------------------
+
+ function Get_Allocator_Final_List
+ (N : Node_Id;
+ T : Entity_Id;
+ PtrT : Entity_Id)
+ return Entity_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Acc : Entity_Id;
+
+ begin
+ -- If the context is an access parameter, we need to create
+ -- a non-anonymous access type in order to have a usable
+ -- final list, because there is otherwise no pool to which
+ -- the allocated object can belong. We create both the type
+ -- and the finalization chain here, because freezing an
+ -- internal type does not create such a chain. The Final_Chain
+ -- that is thus created is shared by the access parameter.
+
+ if Ekind (PtrT) = E_Anonymous_Access_Type then
+ Acc := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
+ Insert_Action (N,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Acc,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (T, Loc))));
+
+ Build_Final_List (N, Acc);
+ Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Acc));
+ return Find_Final_List (Acc);
+
+ else
+ return Find_Final_List (PtrT);
+ end if;
+ end Get_Allocator_Final_List;
+
-------------------------------
-- Insert_Dereference_Action --
-------------------------------
@@ -5501,12 +6523,15 @@ package body Exp_Ch4 is
New_Reference_To (Pool, Loc),
- -- Storage_Address
+ -- Storage_Address. We use the attribute Pool_Address,
+ -- which uses the pointer itself to find the address of
+ -- the object, and which handles unconstrained arrays
+ -- properly by computing the address of the template.
+ -- i.e. the correct address of the corresponding allocation.
Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
- Attribute_Name => Name_Address),
+ Prefix => Duplicate_Subexpr_Move_Checks (N),
+ Attribute_Name => Name_Pool_Address),
-- Size_In_Storage_Elements
@@ -5514,7 +6539,8 @@ package body Exp_Ch4 is
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
- Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
+ Make_Explicit_Dereference (Loc,
+ Duplicate_Subexpr_Move_Checks (N)),
Attribute_Name => Name_Size),
Right_Opnd =>
Make_Integer_Literal (Loc, System_Storage_Unit)),
@@ -5523,9 +6549,13 @@ package body Exp_Ch4 is
Make_Attribute_Reference (Loc,
Prefix =>
- Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
+ Make_Explicit_Dereference (Loc,
+ Duplicate_Subexpr_Move_Checks (N)),
Attribute_Name => Name_Alignment))));
+ exception
+ when RE_Not_Available =>
+ return;
end Insert_Dereference_Action;
------------------------------
@@ -5974,6 +7004,99 @@ package body Exp_Ch4 is
end if;
end Rewrite_Comparison;
+ ----------------------------
+ -- Safe_In_Place_Array_Op --
+ ----------------------------
+
+ function Safe_In_Place_Array_Op
+ (Lhs : Node_Id;
+ Op1 : Node_Id;
+ Op2 : Node_Id)
+ return Boolean
+ is
+ Target : Entity_Id;
+
+ function Is_Safe_Operand (Op : Node_Id) return Boolean;
+ -- Operand is safe if it cannot overlap part of the target of the
+ -- operation. If the operand and the target are identical, the operand
+ -- is safe. The operand can be empty in the case of negation.
+
+ function Is_Unaliased (N : Node_Id) return Boolean;
+ -- Check that N is a stand-alone entity.
+
+ ------------------
+ -- Is_Unaliased --
+ ------------------
+
+ function Is_Unaliased (N : Node_Id) return Boolean is
+ begin
+ return
+ Is_Entity_Name (N)
+ and then No (Address_Clause (Entity (N)))
+ and then No (Renamed_Object (Entity (N)));
+ end Is_Unaliased;
+
+ ---------------------
+ -- Is_Safe_Operand --
+ ---------------------
+
+ function Is_Safe_Operand (Op : Node_Id) return Boolean is
+ begin
+ if No (Op) then
+ return True;
+
+ elsif Is_Entity_Name (Op) then
+ return Is_Unaliased (Op);
+
+ elsif Nkind (Op) = N_Indexed_Component
+ or else Nkind (Op) = N_Selected_Component
+ then
+ return Is_Unaliased (Prefix (Op));
+
+ elsif Nkind (Op) = N_Slice then
+ return
+ Is_Unaliased (Prefix (Op))
+ and then Entity (Prefix (Op)) /= Target;
+
+ elsif Nkind (Op) = N_Op_Not then
+ return Is_Safe_Operand (Right_Opnd (Op));
+
+ else
+ return False;
+ end if;
+ end Is_Safe_Operand;
+
+ -- Start of processing for Is_Safe_In_Place_Array_Op
+
+ begin
+ -- We skip this processing if the component size is not the
+ -- same as a system storage unit (since at least for NOT
+ -- this would cause problems).
+
+ if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
+ return False;
+
+ -- Cannot do in place stuff on Java_VM since cannot pass addresses
+
+ elsif Java_VM then
+ return False;
+
+ -- Cannot do in place stuff if non-standard Boolean representation
+
+ elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
+ return False;
+
+ elsif not Is_Unaliased (Lhs) then
+ return False;
+ else
+ Target := Entity (Lhs);
+
+ return
+ Is_Safe_Operand (Op1)
+ and then Is_Safe_Operand (Op2);
+ end if;
+ end Safe_In_Place_Array_Op;
+
-----------------------
-- Tagged_Membership --
-----------------------
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index b0b71b4507b..5fd2dc9c512 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
@@ -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- --
@@ -268,7 +268,7 @@ package body Exp_Ch5 is
end;
end Possible_Unaligned_Slice;
- -- Determine if Lhs, Rhs are formal arrays or non-local arrays
+ -- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
Lhs_Formal : constant Boolean := Is_Formal_Array (Act_Lhs);
Rhs_Formal : constant Boolean := Is_Formal_Array (Act_Rhs);
@@ -304,10 +304,13 @@ package body Exp_Ch5 is
-- case of one dimensional arrays, parameters can be slices that
-- are passed by reference, so we can have aliasing for assignments
-- from one parameter to another, or assignments between parameters
- -- and non-local variables.
+ -- and nonlocal variables. However, if the array subtype is a
+ -- constrained first subtype in the parameter case, then we don't
+ -- have to worry about overlap, since slice assignments aren't
+ -- possible (other than for a slice denoting the whole array).
-- Note: overlap is never possible if there is a change of
- -- representation, so we can exclude this case
+ -- representation, so we can exclude this case.
if Ndim = 1
and then not Crep
@@ -317,6 +320,9 @@ package body Exp_Ch5 is
(Lhs_Formal and Rhs_Non_Local_Var)
or else
(Rhs_Formal and Lhs_Non_Local_Var))
+ and then
+ (not Is_Constrained (Etype (Lhs))
+ or else not Is_First_Subtype (Etype (Lhs)))
-- In the case of compiling for the Java Virtual Machine,
-- slices are always passed by making a copy, so we don't
@@ -459,8 +465,21 @@ package body Exp_Ch5 is
-- Gigi can always handle the assignment if the right side is a string
-- literal (note that overlap is definitely impossible in this case).
+ -- If the type is packed, a string literal is always converted into a
+ -- aggregate, except in the case of a null slice, for which no aggregate
+ -- can be written. In that case, rewrite the assignment as a null
+ -- statement, a length check has already been emitted to verify that
+ -- the range of the left-hand side is empty.
elsif Nkind (Rhs) = N_String_Literal then
+ if Ekind (R_Type) = E_String_Literal_Subtype
+ and then String_Literal_Length (R_Type) = 0
+ and then Is_Bit_Packed_Array (L_Type)
+ then
+ Rewrite (N, Make_Null_Statement (Loc));
+ Analyze (N);
+ end if;
+
return;
-- If either operand is bit packed, then we need a loop, since we
@@ -675,8 +694,8 @@ package body Exp_Ch5 is
elsif Restrictions (No_Implicit_Conditionals) then
declare
- T : Entity_Id := Make_Defining_Identifier (Loc,
- Chars => Name_T);
+ T : constant Entity_Id := Make_Defining_Identifier (Loc,
+ Chars => Name_T);
begin
Rewrite (N,
@@ -723,7 +742,7 @@ package body Exp_Ch5 is
Prefix =>
Make_Indexed_Component (Loc,
Prefix =>
- Duplicate_Subexpr (Larray, True),
+ Duplicate_Subexpr_Move_Checks (Larray, True),
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
@@ -738,7 +757,7 @@ package body Exp_Ch5 is
Prefix =>
Make_Indexed_Component (Loc,
Prefix =>
- Duplicate_Subexpr (Rarray, True),
+ Duplicate_Subexpr_Move_Checks (Rarray, True),
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
@@ -785,6 +804,10 @@ package body Exp_Ch5 is
Analyze (N, Suppress => All_Checks);
end;
+
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_Assign_Array;
------------------------------
@@ -878,8 +901,8 @@ package body Exp_Ch5 is
-- Now construct the assignment statement
declare
- ExprL : List_Id := New_List;
- ExprR : List_Id := New_List;
+ ExprL : constant List_Id := New_List;
+ ExprR : constant List_Id := New_List;
begin
for J in 1 .. Ndim loop
@@ -972,7 +995,7 @@ package body Exp_Ch5 is
Rhs : constant Node_Id := Expression (Expression (N));
R_Rec : constant Node_Id := Expression (Expression (N));
R_Typ : constant Entity_Id := Base_Type (Etype (R_Rec));
- L_Typ : constant Entity_Id := Etype (Lhs);
+ L_Typ : constant Entity_Id := Base_Type (Etype (Lhs));
Decl : constant Node_Id := Declaration_Node (R_Typ);
RDef : Node_Id;
F : Entity_Id;
@@ -1129,7 +1152,7 @@ package body Exp_Ch5 is
-- Start of processing for Expand_Assign_Record
begin
- -- Note that we use the base type for this processing. This results
+ -- Note that we use the base types for this processing. This results
-- in some extra work in the constrained case, but the change of
-- representation case is so unusual that it is not worth the effort.
@@ -1177,7 +1200,7 @@ package body Exp_Ch5 is
-- For array types, deal with slice assignments and setting the flags
-- to indicate if it can be statically determined which direction the
- -- move should go in. Also deal with generating length checks.
+ -- move should go in. Also deal with generating range/length checks.
procedure Expand_N_Assignment_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
@@ -1187,6 +1210,16 @@ package body Exp_Ch5 is
Exp : Node_Id;
begin
+ -- First deal with generation of range check if required. For now
+ -- we do this only for discrete types.
+
+ if Do_Range_Check (Rhs)
+ and then Is_Discrete_Type (Typ)
+ then
+ Set_Do_Range_Check (Rhs, False);
+ Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
+ end if;
+
-- Check for a special case where a high level transformation is
-- required. If we have either of:
@@ -1300,6 +1333,13 @@ package body Exp_Ch5 is
Rewrite (Prefix (Lhs),
New_Occurrence_Of (Tnn, Loc));
+
+ -- We do not need to reanalyze that assignment, and we do not need
+ -- to worry about references to the temporary, but we do need to
+ -- make sure that the temporary is not marked as a true constant
+ -- since we now have a generate assignment to it!
+
+ Set_Is_True_Constant (Tnn, False);
end;
end if;
@@ -1332,9 +1372,14 @@ package body Exp_Ch5 is
-- necessary if the Lhs is aliased. The private determinants must be
-- visible to build the discriminant constraints.
+ -- Only an explicit dereference that comes from source indicates
+ -- aliasing. Access to formals of protected operations and entries
+ -- create dereferences but are not semantic aliasings.
+
elsif Is_Private_Type (Etype (Lhs))
and then Has_Discriminants (Typ)
and then Nkind (Lhs) = N_Explicit_Dereference
+ and then Comes_From_Source (Lhs)
then
declare
Lt : constant Entity_Id := Etype (Lhs);
@@ -1411,6 +1456,18 @@ package body Exp_Ch5 is
(Expression (Rhs), Designated_Type (Etype (Lhs)));
end if;
+ -- If we are assigning an access type and the left side is an
+ -- entity, then make sure that Is_Known_Non_Null properly
+ -- reflects the state of the entity after the assignment
+
+ if Is_Access_Type (Typ)
+ and then Is_Entity_Name (Lhs)
+ and then Known_Non_Null (Rhs)
+ and then Safe_To_Capture_Value (N, Entity (Lhs))
+ then
+ Set_Is_Known_Non_Null (Entity (Lhs), Known_Non_Null (Rhs));
+ end if;
+
-- Case of assignment to a bit packed array element
if Nkind (Lhs) = N_Indexed_Component
@@ -1465,8 +1522,8 @@ package body Exp_Ch5 is
-- operation profile.
declare
- Op : constant Entity_Id
- := Find_Prim_Op (Typ, Name_uAssign);
+ Op : constant Entity_Id :=
+ Find_Prim_Op (Typ, Name_uAssign);
F_Typ : Entity_Id := Etype (First_Formal (Op));
begin
@@ -1523,10 +1580,11 @@ package body Exp_Ch5 is
-- implementation of adjust for record_controllers (see
-- s-finimp.adb)
- -- This is skipped in No_Run_Time mode, where we in any
- -- case exclude the possibility of finalization going on!
+ -- This is skipped if we have no finalization
- if Expand_Ctrl_Actions and then not No_Run_Time then
+ if Expand_Ctrl_Actions
+ and then not Restrictions (No_Finalization)
+ then
L := New_List (
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
@@ -1661,7 +1719,7 @@ package body Exp_Ch5 is
elsif Is_Local_Variable_Reference (Lhs) then
Set_Is_Known_Valid (Entity (Lhs), False);
- -- Check for case of a non-local variable on the left side
+ -- Check for case of a nonlocal variable on the left side
-- which is currently known to be valid. In this case, we
-- simply ensure that the right side is valid. We only play
-- the game of copying validity status for local variables,
@@ -1698,6 +1756,10 @@ package body Exp_Ch5 is
then
Check_Valid_Lvalue_Subscripts (Lhs);
end if;
+
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_N_Assignment_Statement;
------------------------------
@@ -1716,134 +1778,177 @@ package body Exp_Ch5 is
-----------------------------
procedure Expand_N_Case_Statement (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Expr : constant Node_Id := Expression (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Expr : constant Node_Id := Expression (N);
+ Alt : Node_Id;
+ Len : Nat;
+ Cond : Node_Id;
+ Choice : Node_Id;
+ Chlist : List_Id;
begin
-- Check for the situation where we know at compile time which
-- branch will be taken
if Compile_Time_Known_Value (Expr) then
- declare
- Val : constant Uint := Expr_Value (Expr);
- Alt : Node_Id;
- Choice : Node_Id;
+ Alt := Find_Static_Alternative (N);
- begin
- Alt := First (Alternatives (N));
- Search : loop
- Choice := First (Discrete_Choices (Alt));
- while Present (Choice) loop
+ -- Move the statements from this alternative after the case
+ -- statement. They are already analyzed, so will be skipped
+ -- by the analyzer.
- -- Others choice, always matches
+ Insert_List_After (N, Statements (Alt));
- if Nkind (Choice) = N_Others_Choice then
- exit Search;
+ -- That leaves the case statement as a shell. The alternative
+ -- that will be executed is reset to a null list. So now we can
+ -- kill the entire case statement.
- -- Range, check if value is in the range
+ Kill_Dead_Code (Expression (N));
+ Kill_Dead_Code (Alternatives (N));
+ Rewrite (N, Make_Null_Statement (Loc));
+ return;
+ end if;
- elsif Nkind (Choice) = N_Range then
- exit Search when
- Val >= Expr_Value (Low_Bound (Choice))
- and then
- Val <= Expr_Value (High_Bound (Choice));
+ -- Here if the choice is not determined at compile time
- -- Choice is a subtype name. Note that we know it must
- -- be a static subtype, since otherwise it would have
- -- been diagnosed as illegal.
+ declare
+ Last_Alt : constant Node_Id := Last (Alternatives (N));
- elsif Is_Entity_Name (Choice)
- and then Is_Type (Entity (Choice))
- then
- exit when Is_In_Range (Expr, Etype (Choice));
+ Others_Present : Boolean;
+ Others_Node : Node_Id;
- -- Choice is a subtype indication
+ Then_Stms : List_Id;
+ Else_Stms : List_Id;
- elsif Nkind (Choice) = N_Subtype_Indication then
- declare
- C : constant Node_Id := Constraint (Choice);
- R : constant Node_Id := Range_Expression (C);
+ begin
+ if Nkind (First (Discrete_Choices (Last_Alt))) = N_Others_Choice then
+ Others_Present := True;
+ Others_Node := Last_Alt;
+ else
+ Others_Present := False;
+ end if;
- begin
- exit Search when
- Val >= Expr_Value (Low_Bound (R))
- and then
- Val <= Expr_Value (High_Bound (R));
- end;
+ -- First step is to worry about possible invalid argument. The RM
+ -- requires (RM 5.4(13)) that if the result is invalid (e.g. it is
+ -- outside the base range), then Constraint_Error must be raised.
- -- Choice is a simple expression
+ -- Case of validity check required (validity checks are on, the
+ -- expression is not known to be valid, and the case statement
+ -- comes from source -- no need to validity check internally
+ -- generated case statements).
- else
- exit Search when Val = Expr_Value (Choice);
- end if;
+ if Validity_Check_Default then
+ Ensure_Valid (Expr);
+ end if;
- Next (Choice);
- end loop;
+ -- If there is only a single alternative, just replace it with
+ -- the sequence of statements since obviously that is what is
+ -- going to be executed in all cases.
- Next (Alt);
- pragma Assert (Present (Alt));
- end loop Search;
+ Len := List_Length (Alternatives (N));
- -- The above loop *must* terminate by finding a match, since
- -- we know the case statement is valid, and the value of the
- -- expression is known at compile time. When we fall out of
- -- the loop, Alt points to the alternative that we know will
- -- be selected at run time.
+ if Len = 1 then
+ -- We still need to evaluate the expression if it has any
+ -- side effects.
- -- Move the statements from this alternative after the case
- -- statement. They are already analyzed, so will be skipped
- -- by the analyzer.
+ Remove_Side_Effects (Expression (N));
- Insert_List_After (N, Statements (Alt));
+ Insert_List_After (N, Statements (First (Alternatives (N))));
-- That leaves the case statement as a shell. The alternative
- -- that wlil be executed is reset to a null list. So now we can
+ -- that will be executed is reset to a null list. So now we can
-- kill the entire case statement.
Kill_Dead_Code (Expression (N));
- Kill_Dead_Code (Alternatives (N));
Rewrite (N, Make_Null_Statement (Loc));
- end;
+ return;
+ end if;
- -- Here if the choice is not determined at compile time
+ -- An optimization. If there are only two alternatives, and only
+ -- a single choice, then rewrite the whole case statement as an
+ -- if statement, since this can result in susbequent optimizations.
+ -- This helps not only with case statements in the source of a
+ -- simple form, but also with generated code (discriminant check
+ -- functions in particular)
- -- If the last alternative is not an Others choice, replace it with an
- -- N_Others_Choice. Note that we do not bother to call Analyze on the
- -- modified case statement, since it's only effect would be to compute
- -- the contents of the Others_Discrete_Choices node laboriously, and of
- -- course we already know the list of choices that corresponds to the
- -- others choice (it's the list we are replacing!)
+ if Len = 2 then
+ Chlist := Discrete_Choices (First (Alternatives (N)));
- else
- declare
- Altnode : constant Node_Id := Last (Alternatives (N));
- Others_Node : Node_Id;
+ if List_Length (Chlist) = 1 then
+ Choice := First (Chlist);
- begin
- if Nkind (First (Discrete_Choices (Altnode)))
- /= N_Others_Choice
- then
- Others_Node := Make_Others_Choice (Sloc (Altnode));
- Set_Others_Discrete_Choices
- (Others_Node, Discrete_Choices (Altnode));
- Set_Discrete_Choices (Altnode, New_List (Others_Node));
- end if;
+ Then_Stms := Statements (First (Alternatives (N)));
+ Else_Stms := Statements (Last (Alternatives (N)));
- -- If checks are on, ensure argument is valid (RM 5.4(13)). This
- -- is only done for case statements frpm in the source program.
- -- We don't just call Ensure_Valid here, because the requirement
- -- is more strenous than usual, in that it is required that
- -- Constraint_Error be raised.
+ -- For TRUE, generate "expression", not expression = true
- if Comes_From_Source (N)
- and then Validity_Checks_On
- and then Validity_Check_Default
- and then not Expr_Known_Valid (Expr)
- then
- Insert_Valid_Check (Expr);
+ if Nkind (Choice) = N_Identifier
+ and then Entity (Choice) = Standard_True
+ then
+ Cond := Expression (N);
+
+ -- For FALSE, generate "expression" and switch then/else
+
+ elsif Nkind (Choice) = N_Identifier
+ and then Entity (Choice) = Standard_False
+ then
+ Cond := Expression (N);
+ Else_Stms := Statements (First (Alternatives (N)));
+ Then_Stms := Statements (Last (Alternatives (N)));
+
+ -- For a range, generate "expression in range"
+
+ elsif Nkind (Choice) = N_Range
+ or else (Nkind (Choice) = N_Attribute_Reference
+ and then Attribute_Name (Choice) = Name_Range)
+ or else (Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice)))
+ or else Nkind (Choice) = N_Subtype_Indication
+ then
+ Cond :=
+ Make_In (Loc,
+ Left_Opnd => Expression (N),
+ Right_Opnd => Relocate_Node (Choice));
+
+ -- For any other subexpression "expression = value"
+
+ else
+ Cond :=
+ Make_Op_Eq (Loc,
+ Left_Opnd => Expression (N),
+ Right_Opnd => Relocate_Node (Choice));
+ end if;
+
+ -- Now rewrite the case as an IF
+
+ Rewrite (N,
+ Make_If_Statement (Loc,
+ Condition => Cond,
+ Then_Statements => Then_Stms,
+ Else_Statements => Else_Stms));
+ Analyze (N);
+ return;
end if;
- end;
- end if;
+ end if;
+
+ -- If the last alternative is not an Others choice, replace it
+ -- with an N_Others_Choice. Note that we do not bother to call
+ -- Analyze on the modified case statement, since it's only effect
+ -- would be to compute the contents of the Others_Discrete_Choices
+ -- which is not needed by the back end anyway.
+
+ -- The reason we do this is that the back end always needs some
+ -- default for a switch, so if we have not supplied one in the
+ -- processing above for validity checking, then we need to
+ -- supply one here.
+
+ if not Others_Present then
+ Others_Node := Make_Others_Choice (Sloc (Last_Alt));
+ Set_Others_Discrete_Choices
+ (Others_Node, Discrete_Choices (Last_Alt));
+ Set_Discrete_Choices (Last_Alt, New_List (Others_Node));
+ end if;
+ end;
end Expand_N_Case_Statement;
-----------------------------
@@ -1905,6 +2010,7 @@ package body Exp_Ch5 is
-- cases of constant elsif conditions).
procedure Expand_N_If_Statement (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
Hed : Node_Id;
E : Node_Id;
New_If : Node_Id;
@@ -2044,6 +2150,86 @@ package body Exp_Ch5 is
end if;
end loop;
end if;
+
+ -- Some more optimizations applicable if we still have an IF statement
+
+ if Nkind (N) /= N_If_Statement then
+ return;
+ end if;
+
+ -- Another optimization, special cases that can be simplified
+
+ -- if expression then
+ -- return true;
+ -- else
+ -- return false;
+ -- end if;
+
+ -- can be changed to:
+
+ -- return expression;
+
+ -- and
+
+ -- if expression then
+ -- return false;
+ -- else
+ -- return true;
+ -- end if;
+
+ -- can be changed to:
+
+ -- return not (expression);
+
+ if Nkind (N) = N_If_Statement
+ and then No (Elsif_Parts (N))
+ and then Present (Else_Statements (N))
+ and then List_Length (Then_Statements (N)) = 1
+ and then List_Length (Else_Statements (N)) = 1
+ then
+ declare
+ Then_Stm : Node_Id := First (Then_Statements (N));
+ Else_Stm : Node_Id := First (Else_Statements (N));
+
+ begin
+ if Nkind (Then_Stm) = N_Return_Statement
+ and then
+ Nkind (Else_Stm) = N_Return_Statement
+ then
+ declare
+ Then_Expr : constant Node_Id := Expression (Then_Stm);
+ Else_Expr : constant Node_Id := Expression (Else_Stm);
+
+ begin
+ if Nkind (Then_Expr) = N_Identifier
+ and then
+ Nkind (Else_Expr) = N_Identifier
+ then
+ if Entity (Then_Expr) = Standard_True
+ and then Entity (Else_Expr) = Standard_False
+ then
+ Rewrite (N,
+ Make_Return_Statement (Loc,
+ Expression => Relocate_Node (Condition (N))));
+ Analyze (N);
+ return;
+
+ elsif Entity (Then_Expr) = Standard_False
+ and then Entity (Else_Expr) = Standard_True
+ then
+ Rewrite (N,
+ Make_Return_Statement (Loc,
+ Expression =>
+ Make_Op_Not (Loc,
+ Right_Opnd => Relocate_Node (Condition (N)))));
+ Analyze (N);
+ return;
+ end if;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
end Expand_N_If_Statement;
-----------------------------
@@ -2097,8 +2283,8 @@ package body Exp_Ch5 is
Loop_Id : constant Entity_Id := Defining_Identifier (LPS);
Ltype : constant Entity_Id := Etype (Loop_Id);
Btype : constant Entity_Id := Base_Type (Ltype);
+ Expr : Node_Id;
New_Id : Entity_Id;
- Lo, Hi : Node_Id;
begin
if not Is_Enumeration_Type (Btype)
@@ -2111,8 +2297,25 @@ package body Exp_Ch5 is
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Loop_Id), 'P'));
- Lo := Type_Low_Bound (Ltype);
- Hi := Type_High_Bound (Ltype);
+ -- If the type has a contiguous representation, successive
+ -- values can be generated as offsets from the first literal.
+
+ if Has_Contiguous_Rep (Btype) then
+ Expr :=
+ Unchecked_Convert_To (Btype,
+ Make_Op_Add (Loc,
+ Left_Opnd =>
+ Make_Integer_Literal (Loc,
+ Enumeration_Rep (First_Literal (Btype))),
+ Right_Opnd => New_Reference_To (New_Id, Loc)));
+ else
+ -- Use the constructed array Enum_Pos_To_Rep.
+
+ Expr :=
+ Make_Indexed_Component (Loc,
+ Prefix => New_Reference_To (Enum_Pos_To_Rep (Btype), Loc),
+ Expressions => New_List (New_Reference_To (New_Id, Loc)));
+ end if;
Rewrite (N,
Make_Loop_Statement (Loc,
@@ -2165,19 +2368,13 @@ package body Exp_Ch5 is
Defining_Identifier => Loop_Id,
Constant_Present => True,
Object_Definition => New_Reference_To (Ltype, Loc),
- Expression =>
- Make_Indexed_Component (Loc,
- Prefix =>
- New_Reference_To (Enum_Pos_To_Rep (Btype), Loc),
- Expressions => New_List (
- New_Reference_To (New_Id, Loc))))),
+ Expression => Expr)),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements (N)))),
End_Label => End_Label (N)));
-
Analyze (N);
end;
@@ -2532,17 +2729,20 @@ package body Exp_Ch5 is
-- Start of processing for No_Secondary_Stack_Case
begin
- -- No copy needed if result is from a function call for the
- -- same type with the same constrainedness (is the latter a
- -- necessary check, or could gigi produce the bounds ???).
+ -- No copy needed if result is from a function call.
-- In this case the result is already being returned by
-- reference with the stack pointer depressed.
+ -- To make up for a gcc 2.8.1 deficiency (???), we perform
+ -- the copy for array types if the constrained status of the
+ -- target type is different from that of the expression.
+
if Requires_Transient_Scope (T)
- and then Is_Constrained (T) = Is_Constrained (Return_Type)
- and then (Nkind (Exp) = N_Function_Call
- or else
- Nkind (Original_Node (Exp)) = N_Function_Call)
+ and then
+ (not Is_Array_Type (T)
+ or else Is_Constrained (T) = Is_Constrained (Return_Type)
+ or else Controlled_Type (T))
+ and then Nkind (Exp) = N_Function_Call
then
Set_By_Ref (N);
@@ -2624,20 +2824,23 @@ package body Exp_Ch5 is
end loop;
end;
- -- Optimize the case where the result is from a function call for
- -- the same type with the same constrainedness (is the latter a
- -- necessary check, or could gigi produce the bounds ???). In this
+ -- Optimize the case where the result is a function call. In this
-- case either the result is already on the secondary stack, or is
-- already being returned with the stack pointer depressed and no
-- further processing is required except to set the By_Ref flag to
-- ensure that gigi does not attempt an extra unnecessary copy.
-- (actually not just unnecessary but harmfully wrong in the case
-- of a controlled type, where gigi does not know how to do a copy).
+ -- To make up for a gcc 2.8.1 deficiency (???), we perform
+ -- the copy for array types if the constrained status of the
+ -- target type is different from that of the expression.
if Requires_Transient_Scope (T)
- and then Is_Constrained (T) = Is_Constrained (Return_Type)
- and then (Nkind (Exp) = N_Function_Call
- or else Nkind (Original_Node (Exp)) = N_Function_Call)
+ and then
+ (not Is_Array_Type (T)
+ or else Is_Constrained (T) = Is_Constrained (Return_Type)
+ or else Controlled_Type (T))
+ and then Nkind (Exp) = N_Function_Call
then
Set_By_Ref (N);
@@ -2705,6 +2908,10 @@ package body Exp_Ch5 is
end if;
end if;
end if;
+
+ exception
+ when RE_Not_Available =>
+ return;
end Expand_N_Return_Statement;
------------------------------
@@ -2725,11 +2932,14 @@ package body Exp_Ch5 is
-- Tags are not saved and restored when Java_VM because JVM tags
-- are represented implicitly in objects.
- Res : List_Id;
- Tag_Tmp : Entity_Id;
- Prev_Tmp : Entity_Id;
- Next_Tmp : Entity_Id;
- Ctrl_Ref : Node_Id;
+ Res : List_Id;
+ Tag_Tmp : Entity_Id;
+ Prev_Tmp : Entity_Id;
+ Next_Tmp : Entity_Id;
+ Ctrl_Ref : Node_Id;
+ Ctrl_Ref2 : Node_Id := Empty;
+ Prev_Tmp2 : Entity_Id := Empty; -- prevent warning
+ Next_Tmp2 : Entity_Id := Empty; -- prevent warning
begin
Res := New_List;
@@ -2737,7 +2947,7 @@ package body Exp_Ch5 is
-- Finalize the target of the assignment when controlled.
-- We have two exceptions here:
- -- 1. If we are in an init_proc since it is an initialization
+ -- 1. If we are in an init proc since it is an initialization
-- more than an assignment
-- 2. If the left-hand side is a temporary that was not initialized
@@ -2747,7 +2957,7 @@ package body Exp_Ch5 is
-- it may be a component of an entry formal, in which case it has
-- been rewritten and does not appear to come from source either.
- -- Init_Proc case
+ -- Case of init proc
if not Ctrl_Act then
null;
@@ -2762,7 +2972,7 @@ package body Exp_Ch5 is
else
Append_List_To (Res,
Make_Final_Call (
- Ref => Duplicate_Subexpr (L),
+ Ref => Duplicate_Subexpr_No_Checks (L),
Typ => Etype (L),
With_Detach => New_Reference_To (Standard_False, Loc)));
end if;
@@ -2781,7 +2991,7 @@ package body Exp_Ch5 is
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
Expression =>
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (L),
+ Prefix => Duplicate_Subexpr_No_Checks (L),
Selector_Name => New_Reference_To (Tag_Component (T), Loc))));
-- Otherwise Tag_Tmp not used
@@ -2792,10 +3002,11 @@ package body Exp_Ch5 is
-- Save the Finalization Pointers in local variables Prev_Tmp and
-- Next_Tmp. For objects with Has_Controlled_Component set, these
- -- pointers are in the Record_Controller
+ -- pointers are in the Record_Controller and if it is also
+ -- Is_Controlled, we need to save the object pointers as well.
if Ctrl_Act then
- Ctrl_Ref := Duplicate_Subexpr (L);
+ Ctrl_Ref := Duplicate_Subexpr_No_Checks (L);
if Has_Controlled_Component (T) then
Ctrl_Ref :=
@@ -2803,6 +3014,10 @@ package body Exp_Ch5 is
Prefix => Ctrl_Ref,
Selector_Name =>
New_Reference_To (Controller_Component (T), Loc));
+
+ if Is_Controlled (T) then
+ Ctrl_Ref2 := Duplicate_Subexpr_No_Checks (L);
+ end if;
end if;
Prev_Tmp := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
@@ -2836,6 +3051,41 @@ package body Exp_Ch5 is
New_Copy_Tree (Ctrl_Ref)),
Selector_Name => Make_Identifier (Loc, Name_Next))));
+ if Present (Ctrl_Ref2) then
+ Prev_Tmp2 :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
+
+ Append_To (Res,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Prev_Tmp2,
+
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Finalizable_Ptr), Loc),
+
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Finalizable), Ctrl_Ref2),
+ Selector_Name => Make_Identifier (Loc, Name_Prev))));
+
+ Next_Tmp2 :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
+
+ Append_To (Res,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Next_Tmp2,
+
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Finalizable_Ptr), Loc),
+
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Finalizable),
+ New_Copy_Tree (Ctrl_Ref2)),
+ Selector_Name => Make_Identifier (Loc, Name_Next))));
+ end if;
+
-- If not controlled type, then Prev_Tmp and Ctrl_Ref unused
else
@@ -2854,7 +3104,7 @@ package body Exp_Ch5 is
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (L),
+ Prefix => Duplicate_Subexpr_No_Checks (L),
Selector_Name => New_Reference_To (Tag_Component (T), Loc)),
Expression => New_Reference_To (Tag_Tmp, Loc)));
end if;
@@ -2881,22 +3131,48 @@ package body Exp_Ch5 is
New_Copy_Tree (Ctrl_Ref)),
Selector_Name => Make_Identifier (Loc, Name_Next)),
Expression => New_Reference_To (Next_Tmp, Loc)));
+
+ if Present (Ctrl_Ref2) then
+ Append_To (Res,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Finalizable),
+ New_Copy_Tree (Ctrl_Ref2)),
+ Selector_Name => Make_Identifier (Loc, Name_Prev)),
+ Expression => New_Reference_To (Prev_Tmp2, Loc)));
+
+ Append_To (Res,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Finalizable),
+ New_Copy_Tree (Ctrl_Ref2)),
+ Selector_Name => Make_Identifier (Loc, Name_Next)),
+ Expression => New_Reference_To (Next_Tmp2, Loc)));
+ end if;
end if;
-- Adjust the target after the assignment when controlled. (not in
- -- the init_proc since it is an initialization more than an
+ -- the init proc since it is an initialization more than an
-- assignment)
if Ctrl_Act then
Append_List_To (Res,
Make_Adjust_Call (
- Ref => Duplicate_Subexpr (L),
+ Ref => Duplicate_Subexpr_Move_Checks (L),
Typ => Etype (L),
Flist_Ref => New_Reference_To (RTE (RE_Global_Final_List), Loc),
With_Attach => Make_Integer_Literal (Loc, 0)));
end if;
return Res;
+
+ exception
+ when RE_Not_Available =>
+ return Empty_List;
end Make_Tag_Ctrl_Assignment;
end Exp_Ch5;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index f4a33e06bca..d51aaa8ece4 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,6 +42,7 @@ with Exp_Intr; use Exp_Intr;
with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
+with Fname; use Fname;
with Freeze; use Freeze;
with Hostparm; use Hostparm;
with Inline; use Inline;
@@ -99,25 +100,25 @@ package body Exp_Ch6 is
-- For each actual of an in-out parameter which is a numeric conversion
-- of the form T(A), where A denotes a variable, we insert the declaration:
--
- -- Temp : T := T(A);
+ -- Temp : T := T (A);
--
-- prior to the call. Then we replace the actual with a reference to Temp,
-- and append the assignment:
--
- -- A := T' (Temp);
+ -- A := TypeA (Temp);
--
- -- after the call. Here T' is the actual type of variable A.
+ -- after the call. Here TypeA is the actual type of variable A.
-- For out parameters, the initial declaration has no expression.
- -- If A is not an entity name, we generate instead:
+ -- If A is not an entity name, we generate instead:
--
- -- Var : T' renames A;
+ -- Var : TypeA renames A;
-- Temp : T := Var; -- omitting expression for out parameter.
-- ...
- -- Var := T' (Temp);
+ -- Var := TypeA (Temp);
--
-- For other in-out parameters, we emit the required constraint checks
-- before and/or after the call.
-
+ --
-- For all parameter modes, actuals that denote components and slices
-- of packed arrays are expanded into suitable temporaries.
@@ -197,13 +198,13 @@ package body Exp_Ch6 is
procedure Detect_Infinite_Recursion (N : Node_Id; Spec : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Var_List : Elist_Id := New_Elmt_List;
+ Var_List : constant Elist_Id := New_Elmt_List;
-- List of globals referenced by body of procedure
- Call_List : Elist_Id := New_Elmt_List;
+ Call_List : constant Elist_Id := New_Elmt_List;
-- List of recursive calls in body of procedure
- Shad_List : Elist_Id := New_Elmt_List;
+ Shad_List : constant Elist_Id := New_Elmt_List;
-- List of entity id's for entities created to capture the
-- value of referenced globals on entry to the procedure.
@@ -301,7 +302,7 @@ package body Exp_Ch6 is
elsif Ekind (Ent) /= E_Variable
or else not Is_Scalar_Type (Etype (Ent))
- or else Is_Volatile (Ent)
+ or else Treat_As_Volatile (Ent)
then
return Abandon;
@@ -491,11 +492,12 @@ package body Exp_Ch6 is
E_Formal : Entity_Id;
procedure Add_Call_By_Copy_Code;
- -- For In and In-Out parameters, where the parameter must be passed
- -- by copy, this routine generates a temporary variable into which
- -- the actual is copied, and then passes this as the parameter. This
- -- routine also takes care of any constraint checks required for the
- -- type conversion case (on both the way in and the way out).
+ -- For cases where the parameter must be passed by copy, this routine
+ -- generates a temporary variable into which the actual is copied and
+ -- then passes this as the parameter. For an OUT or IN OUT parameter,
+ -- an assignment is also generated to copy the result back. The call
+ -- also takes care of any constraint checks required for the type
+ -- conversion case (on both the way in and the way out).
procedure Add_Packed_Call_By_Copy_Code;
-- This is used when the actual involves a reference to an element
@@ -622,27 +624,37 @@ package body Exp_Ch6 is
Rewrite (N_Node, Make_Null_Statement (Loc));
end if;
- -- If type conversion, use reverse conversion on exit
+ -- For IN parameter, all we do is to replace the actual
- if Nkind (Actual) = N_Type_Conversion then
- if Conversion_OK (Actual) then
- Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
+ if Ekind (Formal) = E_In_Parameter then
+ Rewrite (Actual, New_Reference_To (Temp, Loc));
+ Analyze (Actual);
+
+ -- Processing for OUT or IN OUT parameter
+
+ else
+ -- If type conversion, use reverse conversion on exit
+
+ if Nkind (Actual) = N_Type_Conversion then
+ if Conversion_OK (Actual) then
+ Expr := OK_Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
+ else
+ Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
+ end if;
else
- Expr := Convert_To (V_Typ, New_Occurrence_Of (Temp, Loc));
+ Expr := New_Occurrence_Of (Temp, Loc);
end if;
- else
- Expr := New_Occurrence_Of (Temp, Loc);
- end if;
- Rewrite (Actual, New_Reference_To (Temp, Loc));
- Analyze (Actual);
+ Rewrite (Actual, New_Reference_To (Temp, Loc));
+ Analyze (Actual);
- Append_To (Post_Call,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Var, Loc),
- Expression => Expr));
+ Append_To (Post_Call,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Var, Loc),
+ Expression => Expr));
- Set_Assignment_OK (Name (Last (Post_Call)));
+ Set_Assignment_OK (Name (Last (Post_Call)));
+ end if;
end Add_Call_By_Copy_Code;
----------------------------------
@@ -708,7 +720,7 @@ package body Exp_Ch6 is
---------------------------
procedure Check_Fortran_Logical is
- Logical : Entity_Id := Etype (Formal);
+ Logical : constant Entity_Id := Etype (Formal);
Var : Entity_Id;
-- Note: this is very incomplete, e.g. it does not handle arrays
@@ -883,6 +895,11 @@ package body Exp_Ch6 is
elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
Add_Call_By_Copy_Code;
+ -- References to possibly unaligned slices of arrays are expanded
+
+ elsif Is_Possibly_Unaligned_Slice (Actual) then
+ Add_Call_By_Copy_Code;
+
-- Deal with access types where the actual subtpe and the
-- formal subtype are not the same, requiring a check.
@@ -897,9 +914,9 @@ package body Exp_Ch6 is
Add_Call_By_Copy_Code;
elsif Is_Entity_Name (Actual)
- and then Is_Volatile (Entity (Actual))
+ and then Treat_As_Volatile (Entity (Actual))
and then not Is_Scalar_Type (Etype (Entity (Actual)))
- and then not Is_Volatile (E_Formal)
+ and then not Treat_As_Volatile (E_Formal)
then
Add_Call_By_Copy_Code;
@@ -910,53 +927,43 @@ package body Exp_Ch6 is
Add_Call_By_Copy_Code;
end if;
- -- The only processing required for IN parameters is in the packed
- -- array case, where we expand the indexed component (the circuit
- -- in Exp_Ch4 deliberately left indexed components appearing as
- -- actuals untouched, so that the special processing above for
- -- the OUT and IN OUT cases could be performed. We could make the
- -- test in Exp_Ch4 more complex and have it detect the parameter
- -- mode, but it is easier simply to handle all cases here.
-
- -- Similarly, we have to expand slices of packed arrays here
+ -- Processing for IN parameters
else
+ -- For IN parameters is in the packed array case, we expand an
+ -- indexed component (the circuit in Exp_Ch4 deliberately left
+ -- indexed components appearing as actuals untouched, so that
+ -- the special processing above for the OUT and IN OUT cases
+ -- could be performed. We could make the test in Exp_Ch4 more
+ -- complex and have it detect the parameter mode, but it is
+ -- easier simply to handle all cases here.
+
if Nkind (Actual) = N_Indexed_Component
and then Is_Packed (Etype (Prefix (Actual)))
then
Reset_Packed_Prefix;
Expand_Packed_Element_Reference (Actual);
- elsif Is_Ref_To_Bit_Packed_Array (Actual) then
- Add_Packed_Call_By_Copy_Code;
+ -- If we have a reference to a bit packed array, we copy it,
+ -- since the actual must be byte aligned.
- elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
- declare
- Typ : constant Entity_Id := Etype (Actual);
+ -- Is this really necessary in all cases???
- Ent : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
+ elsif Is_Ref_To_Bit_Packed_Array (Actual) then
+ Add_Packed_Call_By_Copy_Code;
- Decl : constant Node_Id :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Ent,
- Object_Definition =>
- New_Occurrence_Of (Typ, Loc));
+ -- Similarly, we have to expand slices of packed arrays here
+ -- because the result must be byte aligned.
- begin
- Set_No_Initialization (Decl);
+ elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
+ Add_Call_By_Copy_Code;
- Insert_Actions (N, New_List (
- Decl,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Ent, Loc),
- Expression => Relocate_Node (Actual))));
+ -- Only processing remaining is to pass by copy if this is a
+ -- reference to a possibly unaligned slice, since the caller
+ -- expects an appropriately aligned argument.
- Rewrite
- (Actual, New_Occurrence_Of (Ent, Loc));
- Analyze_And_Resolve (Actual, Typ);
- end;
+ elsif Is_Possibly_Unaligned_Slice (Actual) then
+ Add_Call_By_Copy_Code;
end if;
end if;
@@ -1114,7 +1121,6 @@ package body Exp_Ch6 is
Make_Identifier (Loc, Chars (EF))));
Analyze_And_Resolve (Expr, Etype (EF));
-
end Add_Extra_Actual;
---------------------------
@@ -1135,9 +1141,10 @@ package body Exp_Ch6 is
-- original derived type declaration to find the proper parent.
if Nkind (Parent (S)) /= N_Full_Type_Declaration
- or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
- or else Nkind (Type_Definition (Original_Node (Parent (S))))
- /= N_Derived_Type_Definition
+ or else not Is_Derived_Type (Defining_Identifier (Parent (S)))
+ or else Nkind (Type_Definition (Original_Node (Parent (S))))
+ /= N_Derived_Type_Definition
+ or else not In_Instance
then
return Empty;
@@ -1157,7 +1164,6 @@ package body Exp_Ch6 is
or else Is_Tagged_Type (Par)
or else Nkind (Parent (Par)) /= N_Subtype_Declaration
or else not In_Open_Scopes (Scope (Par))
- or else not In_Instance
then
return Empty;
@@ -1165,6 +1171,14 @@ package body Exp_Ch6 is
Gen_Par := Generic_Parent_Type (Parent (Par));
end if;
+ -- If the generic parent type is still the generic type, this
+ -- is a private formal, not a derived formal, and there are no
+ -- operations inherited from the formal.
+
+ if Nkind (Parent (Gen_Par)) = N_Formal_Type_Declaration then
+ return Empty;
+ end if;
+
Gen_Prim := Collect_Primitive_Operations (Gen_Par);
Elmt := First_Elmt (Gen_Prim);
@@ -1242,6 +1256,7 @@ package body Exp_Ch6 is
-- Replace call to Raise_Exception by call to Raise_Exception_Always
-- if we can tell that the first parameter cannot possibly be null.
+ -- This helps optimization and also generation of warnings.
if not Restrictions (No_Exception_Handlers)
and then Is_RTE (Subp, RE_Raise_Exception)
@@ -1267,16 +1282,29 @@ package body Exp_Ch6 is
end if;
end if;
- -- First step, compute extra actuals, corresponding to any
+ -- First step, compute extra actuals, corresponding to any
-- Extra_Formals present. Note that we do not access Extra_Formals
- -- directly, instead we simply note the presence of the extra
+ -- directly, instead we simply note the presence of the extra
-- formals as we process the regular formals and collect the
-- corresponding actuals in Extra_Actuals.
+ -- We also generate any required range checks for actuals as we go
+ -- through the loop, since this is a convenient place to do this.
+
Formal := First_Formal (Subp);
Actual := First_Actual (N);
-
while Present (Formal) loop
+
+ -- Generate range check if required (not activated yet ???)
+
+-- if Do_Range_Check (Actual) then
+-- Set_Do_Range_Check (Actual, False);
+-- Generate_Range_Check
+-- (Actual, Etype (Formal), CE_Range_Check_Failed);
+-- end if;
+
+ -- Prepare to examine current entry
+
Prev := Actual;
Prev_Orig := Original_Node (Prev);
@@ -1318,15 +1346,17 @@ package body Exp_Ch6 is
-- occur as out parameter actuals on calls to stream
-- procedures.
- if Nkind (Act_Prev) = N_Type_Conversion
+ while Nkind (Act_Prev) = N_Type_Conversion
or else Nkind (Act_Prev) = N_Unchecked_Type_Conversion
- then
+ loop
Act_Prev := Expression (Act_Prev);
- end if;
+ end loop;
Add_Extra_Actual (
Make_Attribute_Reference (Sloc (Prev),
- Prefix => Duplicate_Subexpr (Act_Prev, Name_Req => True),
+ Prefix =>
+ Duplicate_Subexpr_No_Checks
+ (Act_Prev, Name_Req => True),
Attribute_Name => Name_Constrained),
Extra_Constrained (Formal));
end;
@@ -1447,7 +1477,7 @@ package body Exp_Ch6 is
-- expander-generated actuals and when -gnatdj is set.
if Ekind (Etype (Formal)) /= E_Anonymous_Access_Type
- or else Suppress_Accessibility_Checks (Subp)
+ or else Access_Checks_Suppressed (Subp)
then
null;
@@ -1477,7 +1507,7 @@ package body Exp_Ch6 is
else
Cond :=
Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (Prev),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Prev),
Right_Opnd => Make_Null (Loc));
Insert_Action (Prev,
Make_Raise_Constraint_Error (Loc,
@@ -1485,12 +1515,13 @@ package body Exp_Ch6 is
Reason => CE_Access_Parameter_Is_Null));
end if;
- -- Perform appropriate validity checks on parameters
+ -- Perform appropriate validity checks on parameters that
+ -- are entities.
if Validity_Checks_On then
-
if Ekind (Formal) = E_In_Parameter
and then Validity_Check_In_Params
+ and then Is_Entity_Name (Actual)
then
Ensure_Valid (Actual);
@@ -1519,6 +1550,30 @@ package body Exp_Ch6 is
Check_Valid_Lvalue_Subscripts (Actual);
end if;
+ -- Mark any scalar OUT parameter that is a simple variable
+ -- as no longer known to be valid (unless the type is always
+ -- valid). This reflects the fact that if an OUT parameter
+ -- is never set in a procedure, then it can become invalid
+ -- on return from the procedure.
+
+ if Ekind (Formal) = E_Out_Parameter
+ and then Is_Entity_Name (Actual)
+ and then Ekind (Entity (Actual)) = E_Variable
+ and then not Is_Known_Valid (Etype (Actual))
+ then
+ Set_Is_Known_Valid (Entity (Actual), False);
+ end if;
+
+ -- For an OUT or IN OUT parameter of an access type, if the
+ -- actual is an entity, then it is no longer known to be non-null.
+
+ if Ekind (Formal) /= E_In_Parameter
+ and then Is_Entity_Name (Actual)
+ and then Is_Access_Type (Etype (Actual))
+ then
+ Set_Is_Known_Non_Null (Entity (Actual), False);
+ end if;
+
-- If the formal is class wide and the actual is an aggregate, force
-- evaluation so that the back end who does not know about class-wide
-- type, does not generate a temporary of the wrong size.
@@ -1543,7 +1598,8 @@ package body Exp_Ch6 is
Make_Implicit_If_Statement (N,
Condition =>
Make_Op_Not (Loc,
- Get_Remotely_Callable (Duplicate_Subexpr (Actual))),
+ Get_Remotely_Callable
+ (Duplicate_Subexpr_Move_Checks (Actual))),
Then_Statements => New_List (
Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of (RTE
@@ -1556,7 +1612,7 @@ package body Exp_Ch6 is
-- If we are expanding a rhs of an assignement we need to check if
-- tag propagation is needed. This code belongs theorically in Analyze
- -- Assignment but has to be done earlier (bottom-up) because the
+ -- Assignment but has to be done earlier (bottom-up) because the
-- assignment might be transformed into a declaration for an uncons-
-- trained value, if the expression is classwide.
@@ -1580,7 +1636,17 @@ package body Exp_Ch6 is
if Present (Ass)
and then Is_Class_Wide_Type (Etype (Name (Ass)))
then
- Propagate_Tag (Name (Ass), N);
+ if Etype (N) /= Root_Type (Etype (Name (Ass))) then
+ Error_Msg_NE
+ ("tag-indeterminate expression must have type&"
+ & "('R'M 5.2 (6))", N, Root_Type (Etype (Name (Ass))));
+ else
+ Propagate_Tag (Name (Ass), N);
+ end if;
+
+ -- The call will be rewritten as a dispatching call, and
+ -- expanded as such.
+
return;
end if;
end;
@@ -1600,6 +1666,10 @@ package body Exp_Ch6 is
and then not Java_VM
then
Expand_Dispatch_Call (N);
+
+ -- The following return is worrisome. Is it really OK to
+ -- skip all remaining processing in this procedure ???
+
return;
-- Similarly, expand calls to RCI subprograms on which pragma
@@ -1710,14 +1780,13 @@ package body Exp_Ch6 is
elsif
Ekind (Etype (Parent_Formal)) = E_Anonymous_Access_Type
- and then
- Designated_Type (Etype (Parent_Formal))
- /= Designated_Type (Etype (Actual))
+ and then Designated_Type (Etype (Parent_Formal))
+ /=
+ Designated_Type (Etype (Actual))
and then not Is_Controlling_Formal (Formal)
then
-
-- This unchecked conversion is not necessary unless
- -- inlining is unabled, because in that case the type
+ -- inlining is enabled, because in that case the type
-- mismatch may become visible in the body about to be
-- inlined.
@@ -1740,6 +1809,10 @@ package body Exp_Ch6 is
Subp := Parent_Subp;
end if;
+ if Is_RTE (Subp, RE_Abort_Task) then
+ Check_Restriction (No_Abort_Statements, N);
+ end if;
+
-- Some more special cases for cases other than explicit dereference
if Nkind (Name (N)) /= N_Explicit_Dereference then
@@ -1758,8 +1831,9 @@ package body Exp_Ch6 is
(N, Convert_To (Etype (N), New_Occurrence_Of (Subp, Loc)));
else
Rewrite (N, New_Occurrence_Of (Subp, Loc));
- Resolve (N, Etype (N));
end if;
+
+ Resolve (N);
end if;
-- Handle case of access to protected subprogram type
@@ -1778,9 +1852,13 @@ package body Exp_Ch6 is
Parm : List_Id;
Nam : Node_Id;
Obj : Node_Id;
- Ptr : Node_Id := Prefix (Name (N));
- T : Entity_Id := Equivalent_Type (Base_Type (Etype (Ptr)));
- D_T : Entity_Id := Designated_Type (Base_Type (Etype (Ptr)));
+ Ptr : constant Node_Id := Prefix (Name (N));
+
+ T : constant Entity_Id :=
+ Equivalent_Type (Base_Type (Etype (Ptr)));
+
+ D_T : constant Entity_Id :=
+ Designated_Type (Base_Type (Etype (Ptr)));
begin
Obj := Make_Selected_Component (Loc,
@@ -1813,7 +1891,6 @@ package body Exp_Ch6 is
end if;
Set_First_Named_Actual (Call, First_Named_Actual (N));
-
Set_Etype (Call, Etype (D_T));
-- We do not re-analyze the call to avoid infinite recursion.
@@ -1845,7 +1922,9 @@ package body Exp_Ch6 is
if Is_Inlined (Subp) then
declare
- Spec : constant Node_Id := Unit_Declaration_Node (Subp);
+ Bod : Node_Id;
+ Must_Inline : Boolean := False;
+ Spec : constant Node_Id := Unit_Declaration_Node (Subp);
begin
-- Verify that the body to inline has already been seen,
@@ -1853,21 +1932,42 @@ package body Exp_Ch6 is
-- does not occur earlier. This avoids order-of-elaboration
-- problems in gigi.
- if Present (Spec)
- and then Nkind (Spec) = N_Subprogram_Declaration
- and then Present (Body_To_Inline (Spec))
- and then (In_Extended_Main_Code_Unit (N)
- or else In_Extended_Main_Code_Unit (Parent (N)))
- and then (not In_Same_Extended_Unit
- (Sloc (Body_To_Inline (Spec)), Loc)
- or else
- Earlier_In_Extended_Unit
- (Sloc (Body_To_Inline (Spec)), Loc))
+ if No (Spec)
+ or else Nkind (Spec) /= N_Subprogram_Declaration
+ or else No (Body_To_Inline (Spec))
then
+ Must_Inline := False;
+
+ else
+ Bod := Body_To_Inline (Spec);
+
+ if (In_Extended_Main_Code_Unit (N)
+ or else In_Extended_Main_Code_Unit (Parent (N))
+ or else Is_Always_Inlined (Subp))
+ and then (not In_Same_Extended_Unit (Sloc (Bod), Loc)
+ or else
+ Earlier_In_Extended_Unit (Sloc (Bod), Loc))
+ then
+ Must_Inline := True;
+
+ -- If we are compiling a package body that is not the main
+ -- unit, it must be for inlining/instantiation purposes,
+ -- in which case we inline the call to insure that the same
+ -- temporaries are generated when compiling the body by
+ -- itself. Otherwise link errors can occur.
+
+ elsif not (In_Extended_Main_Code_Unit (N))
+ and then In_Package_Body
+ then
+ Must_Inline := True;
+ end if;
+ end if;
+
+ if Must_Inline then
Expand_Inlined_Call (N, Subp, Orig_Subp);
else
- -- Let the back-end handle it.
+ -- Let the back end handle it
Add_Inlined_Body (Subp);
@@ -1877,10 +1977,10 @@ package body Exp_Ch6 is
and then No (Body_To_Inline (Spec))
and then not Has_Completion (Subp)
and then In_Same_Extended_Unit (Sloc (Spec), Loc)
- and then Ineffective_Inline_Warnings
then
- Error_Msg_N
- ("call cannot be inlined before body is seen?", N);
+ Cannot_Inline
+ ("cannot inline& (body not seen yet)?",
+ N, Subp);
end if;
end if;
end;
@@ -1938,12 +2038,11 @@ package body Exp_Ch6 is
Next_Actual (Actual);
end loop;
- -- Now we have Formal and Actual pointing to the first
- -- potentially droppable argument. We can drop all the
- -- trailing arguments whose actual matches the default.
- -- Note that we know that all remaining formals have
- -- defaults, because we checked that this requirement
- -- was met before setting First_Optional_Parameter.
+ -- We have Formal and Actual pointing to the first potentially
+ -- droppable argument. We can drop all the trailing arguments
+ -- whose actual matches the default. Note that we know that all
+ -- remaining formals have defaults, because we checked that this
+ -- requirement was met before setting First_Optional_Parameter.
-- We use Fully_Conformant_Expressions to check for identity
-- between formals and actuals, which may miss some cases, but
@@ -1994,7 +2093,9 @@ package body Exp_Ch6 is
declare
Temp : Node_Id;
Passoc : Node_Id;
- Junk : Node_Id;
+
+ Discard : Node_Id;
+ pragma Warnings (Off, Discard);
begin
-- First step, remove all the named parameters from the
@@ -2018,7 +2119,7 @@ package body Exp_Ch6 is
end loop;
while Present (Next (Temp)) loop
- Junk := Remove_Next (Temp);
+ Discard := Remove_Next (Temp);
end loop;
end if;
@@ -2051,7 +2152,6 @@ package body Exp_Ch6 is
end if;
end;
end if;
-
end Expand_Call;
--------------------------
@@ -2063,7 +2163,13 @@ package body Exp_Ch6 is
Subp : Entity_Id;
Orig_Subp : Entity_Id)
is
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Is_Predef : constant Boolean :=
+ Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Subp)));
+ Orig_Bod : constant Node_Id :=
+ Body_To_Inline (Unit_Declaration_Node (Subp));
+
Blk : Node_Id;
Bod : Node_Id;
Decl : Node_Id;
@@ -2074,8 +2180,6 @@ package body Exp_Ch6 is
Lab_Id : Node_Id;
New_A : Node_Id;
Num_Ret : Int := 0;
- Orig_Bod : constant Node_Id :=
- Body_To_Inline (Unit_Declaration_Node (Subp));
Ret_Type : Entity_Id;
Targ : Node_Id;
Temp : Entity_Id;
@@ -2088,6 +2192,14 @@ package body Exp_Ch6 is
-- Replace occurrence of a formal with the corresponding actual, or
-- the thunk generated for it.
+ function Process_Sloc (Nod : Node_Id) return Traverse_Result;
+ -- If the call being expanded is that of an internal subprogram,
+ -- set the sloc of the generated block to that of the call itself,
+ -- so that the expansion is skipped by the -next- command in gdb.
+ -- Same processing for a subprogram in a predefined file, e.g.
+ -- Ada.Tags. If Debug_Generated_Code is true, suppress this change
+ -- to simplify our own development.
+
procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
-- If the function body is a single expression, replace call with
-- expression, else insert block appropriately.
@@ -2161,8 +2273,9 @@ package body Exp_Ch6 is
if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
then
- -- function body is a single expression. No need for
+ -- Function body is a single expression. No need for
-- exit label.
+
null;
else
@@ -2214,6 +2327,16 @@ package body Exp_Ch6 is
return OK;
+ -- Remove pragma Unreferenced since it may refer to formals that
+ -- are not visible in the inlined body, and in any case we will
+ -- not be posting warnings on the inlined body so it is unneeded.
+
+ elsif Nkind (N) = N_Pragma
+ and then Chars (N) = Name_Unreferenced
+ then
+ Rewrite (N, Make_Null_Statement (Sloc (N)));
+ return OK;
+
else
return OK;
end if;
@@ -2221,16 +2344,31 @@ package body Exp_Ch6 is
procedure Replace_Formals is new Traverse_Proc (Process_Formals);
+ ------------------
+ -- Process_Sloc --
+ ------------------
+
+ function Process_Sloc (Nod : Node_Id) return Traverse_Result is
+ begin
+ if not Debug_Generated_Code then
+ Set_Sloc (Nod, Sloc (N));
+ Set_Comes_From_Source (Nod, False);
+ end if;
+
+ return OK;
+ end Process_Sloc;
+
+ procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
+
---------------------------
-- Rewrite_Function_Call --
---------------------------
procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
- HSS : Node_Id := Handled_Statement_Sequence (Blk);
- Fst : Node_Id := First (Statements (HSS));
+ HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
+ Fst : constant Node_Id := First (Statements (HSS));
begin
-
-- Optimize simple case: function body is a single return statement,
-- which has been expanded into an assignment.
@@ -2263,7 +2401,7 @@ package body Exp_Ch6 is
and then Is_Entity_Name (Name (Parent (N)))
then
- -- replace assignment with the block.
+ -- Replace assignment with the block
Rewrite (Parent (N), Blk);
@@ -2278,7 +2416,7 @@ package body Exp_Ch6 is
----------------------------
procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
- HSS : Node_Id := Handled_Statement_Sequence (Blk);
+ HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
begin
if Is_Empty_List (Declarations (Blk)) then
@@ -2292,6 +2430,20 @@ package body Exp_Ch6 is
-- Start of processing for Expand_Inlined_Call
begin
+ -- Check for special case of To_Address call, and if so, just
+ -- do an unchecked conversion instead of expanding the call.
+ -- Not only is this more efficient, but it also avoids a
+ -- problem with order of elaboration when address clauses
+ -- are inlined (address expr elaborated at wrong point).
+
+ if Subp = RTE (RE_To_Address) then
+ Rewrite (N,
+ Unchecked_Convert_To
+ (RTE (RE_Address),
+ Relocate_Node (First_Actual (N))));
+ return;
+ end if;
+
if Nkind (Orig_Bod) = N_Defining_Identifier then
-- Subprogram is a renaming_as_body. Calls appearing after the
@@ -2307,11 +2459,9 @@ package body Exp_Ch6 is
-- that nested inlined calls appear in the main unit.
Save_Env (Subp, Empty);
- Set_Copied_Sloc (N, Defining_Entity (Orig_Bod));
-
- Bod :=
- Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
+ Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
+ Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
Blk :=
Make_Block_Statement (Loc,
Declarations => Declarations (Bod),
@@ -2338,7 +2488,6 @@ package body Exp_Ch6 is
-- are scalars and require copying to preserve semantics.
while Present (F) loop
-
if Present (Renamed_Object (F)) then
Error_Msg_N (" cannot inline call to recursive subprogram", N);
return;
@@ -2366,12 +2515,25 @@ package body Exp_Ch6 is
Temp_Typ := Etype (A);
end if;
- if (not Is_Entity_Name (A)
- and then Nkind (A) /= N_Integer_Literal
- and then Nkind (A) /= N_Real_Literal)
+ -- Comments needed here ???
- or else Is_Scalar_Type (Etype (A))
+ if (Is_Entity_Name (A)
+ and then
+ (not Is_Scalar_Type (Etype (A))
+ or else Ekind (Entity (A)) = E_Enumeration_Literal))
+
+ or else Nkind (A) = N_Real_Literal
+ or else Nkind (A) = N_Integer_Literal
+ or else Nkind (A) = N_Character_Literal
then
+ if Etype (F) /= Etype (A) then
+ Set_Renamed_Object
+ (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
+ else
+ Set_Renamed_Object (F, A);
+ end if;
+
+ else
Temp :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('C'));
@@ -2379,13 +2541,12 @@ package body Exp_Ch6 is
-- If the actual for an in/in-out parameter is a view conversion,
-- make it into an unchecked conversion, given that an untagged
-- type conversion is not a proper object for a renaming.
+
-- In-out conversions that involve real conversions have already
-- been transformed in Expand_Actuals.
if Nkind (A) = N_Type_Conversion
- and then
- (Ekind (F) = E_In_Out_Parameter
- or else not Is_Tagged_Type (Etype (F)))
+ and then Ekind (F) /= E_In_Parameter
then
New_A := Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
@@ -2420,14 +2581,6 @@ package body Exp_Ch6 is
Prepend (Decl, Declarations (Blk));
Set_Renamed_Object (F, Temp);
-
- else
- if Etype (F) /= Etype (A) then
- Set_Renamed_Object
- (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
- else
- Set_Renamed_Object (F, A);
- end if;
end if;
Next_Formal (F);
@@ -2471,6 +2624,12 @@ package body Exp_Ch6 is
Replace_Formals (Blk);
Set_Parent (Blk, N);
+ if not Comes_From_Source (Subp)
+ or else Is_Predef
+ then
+ Reset_Slocs (Blk);
+ end if;
+
if Present (Exit_Lab) then
-- If the body was a single expression, the single return statement
@@ -2489,14 +2648,29 @@ package body Exp_Ch6 is
end if;
-- Analyze Blk with In_Inlined_Body set, to avoid spurious errors on
- -- conflicting private views that Gigi would ignore.
+ -- conflicting private views that Gigi would ignore. If this is a
+ -- predefined unit, analyze with checks off, as is done in the non-
+ -- inlined run-time units.
declare
I_Flag : constant Boolean := In_Inlined_Body;
begin
In_Inlined_Body := True;
- Analyze (Blk);
+
+ if Is_Predef then
+ declare
+ Style : constant Boolean := Style_Check;
+ begin
+ Style_Check := False;
+ Analyze (Blk, Suppress => All_Checks);
+ Style_Check := Style;
+ end;
+
+ else
+ Analyze (Blk);
+ end if;
+
In_Inlined_Body := I_Flag;
end;
@@ -2526,9 +2700,8 @@ package body Exp_Ch6 is
Typ : constant Entity_Id := Etype (N);
function Returned_By_Reference return Boolean;
- -- If the return type is returned through the secondary stack. i.e.
- -- by reference, we don't want to create a temporary to force stack
- -- checking.
+ -- If the return type is returned through the secondary stack. that is
+ -- by reference, we don't want to create a temp to force stack checking.
function Returned_By_Reference return Boolean is
S : Entity_Id := Current_Scope;
@@ -2567,6 +2740,9 @@ package body Exp_Ch6 is
if May_Generate_Large_Temp (Typ)
and then Nkind (Parent (N)) /= N_Assignment_Statement
and then
+ (Nkind (Parent (N)) /= N_Qualified_Expression
+ or else Nkind (Parent (Parent (N))) /= N_Assignment_Statement)
+ and then
(Nkind (Parent (N)) /= N_Object_Declaration
or else Expression (Parent (N)) /= N)
and then not Returned_By_Reference
@@ -2577,8 +2753,9 @@ package body Exp_Ch6 is
declare
Loc : constant Source_Ptr := Sloc (N);
- Temp_Obj : constant Entity_Id := Make_Defining_Identifier (Loc,
- New_Internal_Name ('F'));
+ Temp_Obj : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('F'));
Temp_Typ : Entity_Id := Typ;
Decl : Node_Id;
A : Node_Id;
@@ -2694,12 +2871,14 @@ package body Exp_Ch6 is
----------------
procedure Add_Return (S : List_Id) is
- Last_S : constant Node_Id := Last (S);
- -- Get original node, in case raise has been rewritten
-
begin
- if not Is_Transfer (Last_S) then
- Append_To (S, Make_Return_Statement (Sloc (Last_S)));
+ if not Is_Transfer (Last (S)) then
+
+ -- The source location for the return is the end label
+ -- of the procedure in all cases. This is a bit odd when
+ -- there are exception handlers, but not much else we can do.
+
+ Append_To (S, Make_Return_Statement (Sloc (End_Label (H))));
end if;
end Add_Return;
@@ -2998,30 +3177,24 @@ package body Exp_Ch6 is
Expand_N_Subprogram_Body (
Unit_Declaration_Node (Corresponding_Body (N)));
end if;
-
end Expand_N_Subprogram_Body_Stub;
-------------------------------------
-- Expand_N_Subprogram_Declaration --
-------------------------------------
- -- The first task to be performed is the construction of default
- -- expression functions for in parameters with default values. These
- -- are parameterless inlined functions that are used to evaluate
- -- default expressions that are more complicated than simple literals
- -- or identifiers referencing constants and variables.
-
-- If the declaration appears within a protected body, it is a private
-- operation of the protected type. We must create the corresponding
-- protected subprogram an associated formals. For a normal protected
-- operation, this is done when expanding the protected type declaration.
procedure Expand_N_Subprogram_Declaration (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Subp : Entity_Id := Defining_Entity (N);
- Scop : Entity_Id := Scope (Subp);
- Prot_Sub : Entity_Id;
- Prot_Bod : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Subp : constant Entity_Id := Defining_Entity (N);
+ Scop : constant Entity_Id := Scope (Subp);
+ Prot_Decl : Node_Id;
+ Prot_Bod : Node_Id;
+ Prot_Id : Entity_Id;
begin
-- Deal with case of protected subprogram
@@ -3032,7 +3205,7 @@ package body Exp_Ch6 is
and then Is_Protected_Type (Scop)
then
if No (Protected_Body_Subprogram (Subp)) then
- Prot_Sub :=
+ Prot_Decl :=
Make_Subprogram_Declaration (Loc,
Specification =>
Build_Protected_Sub_Specification
@@ -3040,8 +3213,9 @@ package body Exp_Ch6 is
-- The protected subprogram is declared outside of the protected
-- body. Given that the body has frozen all entities so far, we
- -- freeze the subprogram explicitly. If the body is a subunit,
- -- the insertion point is before the stub in the parent.
+ -- analyze the subprogram and perform freezing actions explicitly.
+ -- If the body is a subunit, the insertion point is before the
+ -- stub in the parent.
Prot_Bod := Parent (List_Containing (N));
@@ -3049,12 +3223,13 @@ package body Exp_Ch6 is
Prot_Bod := Corresponding_Stub (Parent (Prot_Bod));
end if;
- Insert_Before (Prot_Bod, Prot_Sub);
+ Insert_Before (Prot_Bod, Prot_Decl);
+ Prot_Id := Defining_Unit_Name (Specification (Prot_Decl));
New_Scope (Scope (Scop));
- Analyze (Prot_Sub);
- Set_Protected_Body_Subprogram (Subp,
- Defining_Unit_Name (Specification (Prot_Sub)));
+ Analyze (Prot_Decl);
+ Create_Extra_Formals (Prot_Id);
+ Set_Protected_Body_Subprogram (Subp, Prot_Id);
Pop_Scope;
end if;
end if;
@@ -3132,8 +3307,10 @@ package body Exp_Ch6 is
declare
Decls : List_Id;
- Obj_Ptr : Entity_Id := Make_Defining_Identifier
- (Loc, New_Internal_Name ('T'));
+ Obj_Ptr : constant Entity_Id := Make_Defining_Identifier (Loc,
+ Chars =>
+ New_Internal_Name ('T'));
+
begin
Decls := New_List (
Make_Full_Type_Declaration (Loc,
@@ -3265,7 +3442,6 @@ package body Exp_Ch6 is
Set_Returns_By_Ref (E);
end if;
end;
-
end Freeze_Subprogram;
end Exp_Ch6;
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index a05d36f5a56..f9844cd3b33 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.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- --
@@ -31,15 +31,16 @@
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
+with Errout; use Errout;
with Exp_Ch9; use Exp_Ch9;
with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
+with Fname; use Fname;
with Freeze; use Freeze;
with Hostparm; use Hostparm;
with Lib; use Lib;
-with Lib.Xref; use Lib.Xref;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
@@ -168,10 +169,10 @@ package body Exp_Ch7 is
Adjust_Case => Name_Adjust,
Finalize_Case => Name_Finalize);
- Deep_Name_Of : constant array (Final_Primitives) of Name_Id :=
- (Initialize_Case => Name_uDeep_Initialize,
- Adjust_Case => Name_uDeep_Adjust,
- Finalize_Case => Name_uDeep_Finalize);
+ Deep_Name_Of : constant array (Final_Primitives) of TSS_Name_Type :=
+ (Initialize_Case => TSS_Deep_Initialize,
+ Adjust_Case => TSS_Deep_Adjust,
+ Finalize_Case => TSS_Deep_Finalize);
procedure Build_Record_Deep_Procs (Typ : Entity_Id);
-- Build the deep Initialize/Adjust/Finalize for a record Typ with
@@ -209,6 +210,24 @@ package body Exp_Ch7 is
-- according to the first parameter, these procedures operate on the
-- record type Typ.
+ procedure Check_Visibly_Controlled
+ (Prim : Final_Primitives;
+ Typ : Entity_Id;
+ E : in out Entity_Id;
+ Cref : in out Node_Id);
+ -- The controlled operation declared for a derived type may not be
+ -- overriding, if the controlled operations of the parent type are
+ -- hidden, for example when the parent is a private type whose full
+ -- view is controlled. For other primitive operations we modify the
+ -- name of the operation to indicate that it is not overriding, but
+ -- this is not possible for Initialize, etc. because they have to be
+ -- retrievable by name. Before generating the proper call to one of
+ -- these operations we check whether Typ is known to be controlled at
+ -- the point of definition. If it is not then we must retrieve the
+ -- hidden operation of the parent and use it instead. This is one
+ -- case that might be solved more cleanly once Overriding pragmas or
+ -- declarations are in place.
+
function Convert_View
(Proc : Entity_Id;
Arg : Node_Id;
@@ -244,7 +263,7 @@ package body Exp_Ch7 is
-- component is itself controlled and is attached to the upper-level
-- finalization chain. Its adjust primitive is in charge of calling
-- adjust on the components and adusting the finalization pointer to
- -- match their new location (see a-finali.adb)
+ -- match their new location (see a-finali.adb).
-- It is not possible to use a similar technique for arrays that have
-- Has_Controlled_Component set. In this case, deep procedures are
@@ -270,6 +289,19 @@ package body Exp_Ch7 is
-- case (1) this is not important since we are exiting the scope
-- anyway.
+ -- Other details:
+ -- - Type extensions will have a new record controller at each derivation
+ -- level containing controlled components.
+ -- - For types that are both Is_Controlled and Has_Controlled_Components,
+ -- the record controller and the object itself are handled separately.
+ -- It could seem simpler to attach the object at the end of its record
+ -- controller but this would not tackle view conversions properly.
+ -- - A classwide type can always potentially have controlled components
+ -- but the record controller of the corresponding actual type may not
+ -- be nown at compile time so the dispatch table contains a special
+ -- field that allows to compute the offset of the record controller
+ -- dynamically. See s-finimp.Deep_Tag_Attach and a-tags.RC_Offset
+
-- Here is a simple example of the expansion of a controlled block :
-- declare
@@ -299,8 +331,11 @@ package body Exp_Ch7 is
-- end _Clean;
-- X : Controlled;
- -- Initialize (X);
- -- Attach_To_Final_List (_L, Finalizable (X), 1);
+ -- begin
+ -- Abort_Defer;
+ -- Initialize (X);
+ -- Attach_To_Final_List (_L, Finalizable (X), 1);
+ -- at end: Abort_Undefer;
-- Y : Controlled := Init;
-- Adjust (Y);
-- Attach_To_Final_List (_L, Finalizable (Y), 1);
@@ -310,17 +345,19 @@ package body Exp_Ch7 is
-- C : Controlled;
-- end record;
-- W : R;
- -- Deep_Initialize (W, _L, 1);
+ -- begin
+ -- Abort_Defer;
+ -- Deep_Initialize (W, _L, 1);
+ -- at end: Abort_Under;
-- Z : R := (C => X);
-- Deep_Adjust (Z, _L, 1);
-- begin
- -- Finalize (X);
- -- X := Y;
- -- Adjust (X);
-
+ -- _Assign (X, Y);
-- Deep_Finalize (W, False);
+ -- <save W's final pointers>
-- W := Z;
+ -- <restore W's final pointers>
-- Deep_Adjust (W, _L, 0);
-- at end
-- _Clean;
@@ -332,6 +369,12 @@ package body Exp_Ch7 is
-- objects, or any of the list controllers associated with library
-- level access to controlled objects
+ procedure Clean_Simple_Protected_Objects (N : Node_Id);
+ -- Protected objects without entries are not controlled types, and the
+ -- locks have to be released explicitly when such an object goes out
+ -- of scope. Traverse declarations in scope to determine whether such
+ -- objects are present.
+
----------------------------
-- Build_Array_Deep_Procs --
----------------------------
@@ -394,12 +437,11 @@ package body Exp_Ch7 is
New_Reference_To
(RTE (RE_List_Controller), Loc));
- -- The type may have been frozen already, and this is a late
- -- freezing action, in which case the declaration must be elaborated
- -- at once. If the call is for an allocator, the chain must also be
- -- created now, because the freezing of the type does not build one.
- -- Otherwise, the declaration is one of the freezing actions for a
- -- user-defined type.
+ -- The type may have been frozen already, and this is a late freezing
+ -- action, in which case the declaration must be elaborated at once.
+ -- If the call is for an allocator, the chain must also be created now,
+ -- because the freezing of the type does not build one. Otherwise, the
+ -- declaration is one of the freezing actions for a user-defined type.
if Is_Frozen (Typ)
or else (Nkind (N) = N_Allocator
@@ -455,6 +497,364 @@ package body Exp_Ch7 is
Stmts => Make_Deep_Record_Body (Finalize_Case, Typ)));
end Build_Record_Deep_Procs;
+ -------------------
+ -- Cleanup_Array --
+ -------------------
+
+ function Cleanup_Array
+ (N : Node_Id;
+ Obj : Node_Id;
+ Typ : Entity_Id)
+ return List_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Index_List : List_Id := New_List;
+
+ function Free_Component return List_Id;
+ -- Generate the code to finalize the task or protected subcomponents
+ -- of a single component of the array.
+
+ function Free_One_Dimension (Dim : Int) return List_Id;
+ -- Generate a loop over one dimension of the array.
+
+ --------------------
+ -- Free_Component --
+ --------------------
+
+ function Free_Component return List_Id is
+ Stmts : List_Id := New_List;
+ Tsk : Node_Id;
+ C_Typ : Entity_Id := Component_Type (Typ);
+
+ begin
+ -- Component type is known to contain tasks or protected objects
+
+ Tsk :=
+ Make_Indexed_Component (Loc,
+ Prefix => Duplicate_Subexpr_No_Checks (Obj),
+ Expressions => Index_List);
+
+ Set_Etype (Tsk, C_Typ);
+
+ if Is_Task_Type (C_Typ) then
+ Append_To (Stmts, Cleanup_Task (N, Tsk));
+
+ elsif Is_Simple_Protected_Type (C_Typ) then
+ Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
+
+ elsif Is_Record_Type (C_Typ) then
+ Stmts := Cleanup_Record (N, Tsk, C_Typ);
+
+ elsif Is_Array_Type (C_Typ) then
+ Stmts := Cleanup_Array (N, Tsk, C_Typ);
+ end if;
+
+ return Stmts;
+ end Free_Component;
+
+ ------------------------
+ -- Free_One_Dimension --
+ ------------------------
+
+ function Free_One_Dimension (Dim : Int) return List_Id is
+ Index : Entity_Id;
+
+ begin
+ if Dim > Number_Dimensions (Typ) then
+ return Free_Component;
+
+ -- Here we generate the required loop
+
+ else
+ Index :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
+
+ Append (New_Reference_To (Index, Loc), Index_List);
+
+ return New_List (
+ Make_Implicit_Loop_Statement (N,
+ Identifier => Empty,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Index,
+ Discrete_Subtype_Definition =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Obj),
+ Attribute_Name => Name_Range,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim))))),
+ Statements => Free_One_Dimension (Dim + 1)));
+ end if;
+ end Free_One_Dimension;
+
+ -- Start of processing for Cleanup_Array
+
+ begin
+ return Free_One_Dimension (1);
+ end Cleanup_Array;
+
+ --------------------
+ -- Cleanup_Record --
+ --------------------
+
+ function Cleanup_Record
+ (N : Node_Id;
+ Obj : Node_Id;
+ Typ : Entity_Id)
+ return List_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Tsk : Node_Id;
+ Comp : Entity_Id;
+ Stmts : List_Id := New_List;
+ U_Typ : constant Entity_Id := Underlying_Type (Typ);
+
+ begin
+ if Has_Discriminants (U_Typ)
+ and then Nkind (Parent (U_Typ)) = N_Full_Type_Declaration
+ and then
+ Nkind (Type_Definition (Parent (U_Typ))) = N_Record_Definition
+ and then
+ Present
+ (Variant_Part
+ (Component_List (Type_Definition (Parent (U_Typ)))))
+ then
+ -- For now, do not attempt to free a component that may appear in
+ -- a variant, and instead issue a warning. Doing this "properly"
+ -- would require building a case statement and would be quite a
+ -- mess. Note that the RM only requires that free "work" for the
+ -- case of a task access value, so already we go way beyond this
+ -- in that we deal with the array case and non-discriminated
+ -- record cases.
+
+ Error_Msg_N
+ ("task/protected object in variant record will not be freed?", N);
+ return New_List (Make_Null_Statement (Loc));
+ end if;
+
+ Comp := First_Component (Typ);
+
+ while Present (Comp) loop
+ if Has_Task (Etype (Comp))
+ or else Has_Simple_Protected_Object (Etype (Comp))
+ then
+ Tsk :=
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr_No_Checks (Obj),
+ Selector_Name => New_Occurrence_Of (Comp, Loc));
+ Set_Etype (Tsk, Etype (Comp));
+
+ if Is_Task_Type (Etype (Comp)) then
+ Append_To (Stmts, Cleanup_Task (N, Tsk));
+
+ elsif Is_Simple_Protected_Type (Etype (Comp)) then
+ Append_To (Stmts, Cleanup_Protected_Object (N, Tsk));
+
+ elsif Is_Record_Type (Etype (Comp)) then
+
+ -- Recurse, by generating the prefix of the argument to
+ -- the eventual cleanup call.
+
+ Append_List_To
+ (Stmts, Cleanup_Record (N, Tsk, Etype (Comp)));
+
+ elsif Is_Array_Type (Etype (Comp)) then
+ Append_List_To
+ (Stmts, Cleanup_Array (N, Tsk, Etype (Comp)));
+ end if;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ return Stmts;
+ end Cleanup_Record;
+
+ -------------------------------
+ -- Cleanup_Protected_Object --
+ -------------------------------
+
+ function Cleanup_Protected_Object
+ (N : Node_Id;
+ Ref : Node_Id)
+ return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc),
+ Parameter_Associations => New_List (
+ Concurrent_Ref (Ref)));
+ end Cleanup_Protected_Object;
+
+ ------------------------------------
+ -- Clean_Simple_Protected_Objects --
+ ------------------------------------
+
+ procedure Clean_Simple_Protected_Objects (N : Node_Id) is
+ E : Entity_Id;
+ Stmts : List_Id := Statements (Handled_Statement_Sequence (N));
+ Stmt : Node_Id := Last (Stmts);
+
+ begin
+ E := First_Entity (Current_Scope);
+
+ while Present (E) loop
+ if (Ekind (E) = E_Variable
+ or else Ekind (E) = E_Constant)
+ and then Has_Simple_Protected_Object (Etype (E))
+ and then not Has_Task (Etype (E))
+ then
+ declare
+ Typ : constant Entity_Id := Etype (E);
+ Ref : constant Node_Id := New_Occurrence_Of (E, Sloc (Stmt));
+
+ begin
+ if Is_Simple_Protected_Type (Typ) then
+ Append_To (Stmts, Cleanup_Protected_Object (N, Ref));
+
+ elsif Has_Simple_Protected_Object (Typ) then
+ if Is_Record_Type (Typ) then
+ Append_List_To (Stmts, Cleanup_Record (N, Ref, Typ));
+
+ elsif Is_Array_Type (Typ) then
+ Append_List_To (Stmts, Cleanup_Array (N, Ref, Typ));
+ end if;
+ end if;
+ end;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ -- Analyze inserted cleanup statements.
+
+ if Present (Stmt) then
+ Stmt := Next (Stmt);
+
+ while Present (Stmt) loop
+ Analyze (Stmt);
+ Next (Stmt);
+ end loop;
+ end if;
+ end Clean_Simple_Protected_Objects;
+
+ ------------------
+ -- Cleanup_Task --
+ ------------------
+
+ function Cleanup_Task
+ (N : Node_Id;
+ Ref : Node_Id)
+ return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Free_Task), Loc),
+ Parameter_Associations =>
+ New_List (Concurrent_Ref (Ref)));
+ end Cleanup_Task;
+
+ ---------------------------------
+ -- Has_Simple_Protected_Object --
+ ---------------------------------
+
+ function Has_Simple_Protected_Object (T : Entity_Id) return Boolean is
+ Comp : Entity_Id;
+
+ begin
+ if Is_Simple_Protected_Type (T) then
+ return True;
+
+ elsif Is_Array_Type (T) then
+ return Has_Simple_Protected_Object (Component_Type (T));
+
+ elsif Is_Record_Type (T) then
+ Comp := First_Component (T);
+
+ while Present (Comp) loop
+ if Has_Simple_Protected_Object (Etype (Comp)) then
+ return True;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ return False;
+
+ else
+ return False;
+ end if;
+ end Has_Simple_Protected_Object;
+
+ ------------------------------
+ -- Is_Simple_Protected_Type --
+ ------------------------------
+
+ function Is_Simple_Protected_Type (T : Entity_Id) return Boolean is
+ begin
+ return Is_Protected_Type (T) and then not Has_Entries (T);
+ end Is_Simple_Protected_Type;
+
+ ------------------------------
+ -- Check_Visibly_Controlled --
+ ------------------------------
+
+ procedure Check_Visibly_Controlled
+ (Prim : Final_Primitives;
+ Typ : Entity_Id;
+ E : in out Entity_Id;
+ Cref : in out Node_Id)
+ is
+ Parent_Type : Entity_Id;
+ Op : Entity_Id;
+
+ begin
+ if Is_Derived_Type (Typ)
+ and then Comes_From_Source (E)
+ and then Is_Overriding_Operation (E)
+ and then
+ (not Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Root_Type (Typ)))))
+ then
+ -- We know that the explicit operation on the type overrode
+ -- the inherited operation of the parent, and that the derivation
+ -- is from a private type that is not visibly controlled.
+
+ Parent_Type := Etype (Typ);
+ Op := Find_Prim_Op (Parent_Type, Name_Of (Prim));
+
+ if Present (Op)
+ and then Is_Hidden (Op)
+ and then Scope (Scope (Typ)) /= Scope (Op)
+ and then not In_Open_Scopes (Scope (Typ))
+ then
+ -- If the parent operation is not visible, and the derived
+ -- type is not declared in a child unit, then the explicit
+ -- operation does not override, and we must use the operation
+ -- of the parent.
+
+ E := Op;
+
+ -- Wrap the object to be initialized into the proper
+ -- unchecked conversion, to be compatible with the operation
+ -- to be called.
+
+ if Nkind (Cref) = N_Unchecked_Type_Conversion then
+ Cref := Unchecked_Convert_To (Parent_Type, Expression (Cref));
+ else
+ Cref := Unchecked_Convert_To (Parent_Type, Cref);
+ end if;
+ end if;
+ end if;
+ end Check_Visibly_Controlled;
+
---------------------
-- Controlled_Type --
---------------------
@@ -511,9 +911,11 @@ package body Exp_Ch7 is
-- Class-wide types must be treated as controlled because they may
-- contain an extension that has controlled components
+ -- We can skip this if finalization is not available
+
return (Is_Class_Wide_Type (T)
- and then not No_Run_Time
- and then not In_Finalization_Root (T))
+ and then not In_Finalization_Root (T)
+ and then not Restrictions (No_Finalization))
or else Is_Controlled (T)
or else Has_Some_Controlled_Component (T)
or else (Is_Concurrent_Type (T)
@@ -720,7 +1122,7 @@ package body Exp_Ch7 is
Clean : Entity_Id;
Mark : Entity_Id := Empty;
- New_Decls : List_Id := New_List;
+ New_Decls : constant List_Id := New_List;
Blok : Node_Id;
Wrapped : Boolean;
Chain : Entity_Id := Empty;
@@ -759,6 +1161,19 @@ package body Exp_Ch7 is
and then not Is_Task_Allocation
and then not Is_Asynchronous_Call
then
+ Clean_Simple_Protected_Objects (N);
+ return;
+ end if;
+
+ -- If the current scope is the subprogram body that is the rewriting
+ -- of a task body, and the descriptors have not been delayed (due to
+ -- some nested instantiations) do not generate redundant cleanup
+ -- actions: the cleanup procedure already exists for this body.
+
+ if Nkind (N) = N_Subprogram_Body
+ and then Nkind (Original_Node (N)) = N_Task_Body
+ and then not Delay_Subprogram_Descriptors (Corresponding_Spec (N))
+ then
return;
end if;
@@ -941,11 +1356,12 @@ package body Exp_Ch7 is
-------------------------------
procedure Expand_Ctrl_Function_Call (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Rtype : constant Entity_Id := Etype (N);
- Utype : constant Entity_Id := Underlying_Type (Rtype);
- Ref : Node_Id;
- Action : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Rtype : constant Entity_Id := Etype (N);
+ Utype : constant Entity_Id := Underlying_Type (Rtype);
+ Ref : Node_Id;
+ Action : Node_Id;
+ Action2 : Node_Id := Empty;
Attach_Level : Uint := Uint_1;
Len_Ref : Node_Id := Empty;
@@ -957,25 +1373,25 @@ package body Exp_Ch7 is
-- Creates a reference to the last component of the array object
-- designated by Ref whose type is Typ.
+ --------------------------
+ -- Last_Array_Component --
+ --------------------------
+
function Last_Array_Component
(Ref : Node_Id;
Typ : Entity_Id)
return Node_Id
is
- N : Int;
- Index_List : List_Id := New_List;
+ Index_List : constant List_Id := New_List;
begin
- N := 1;
- while N <= Number_Dimensions (Typ) loop
+ for N in 1 .. Number_Dimensions (Typ) loop
Append_To (Index_List,
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Ref),
+ Prefix => Duplicate_Subexpr_No_Checks (Ref),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, N))));
-
- N := N + 1;
end loop;
return
@@ -1000,21 +1416,34 @@ package body Exp_Ch7 is
-- because of the duplication
Set_Analyzed (N);
- Ref := Duplicate_Subexpr (N);
+ Ref := Duplicate_Subexpr_No_Checks (N);
-- Now we can generate the Attach Call, note that this value is
-- always in the (secondary) stack and thus is attached to a singly
-- linked final list:
- --
+
-- Resx := F (X)'reference;
-- Attach_To_Final_List (_Lx, Resx.all, 1);
+
-- or when there are controlled components
+
+ -- Attach_To_Final_List (_Lx, Resx._controller, 1);
+
+ -- or when it is both is_controlled and has_controlled_components
+
-- Attach_To_Final_List (_Lx, Resx._controller, 1);
- -- or if it is an array with is_controlled components
+ -- Attach_To_Final_List (_Lx, Resx, 1);
+
+ -- or if it is an array with is_controlled (and has_controlled)
+
-- Attach_To_Final_List (_Lx, Resx (Resx'last), 3);
-- An attach level of 3 means that a whole array is to be
- -- attached to the finalization list
- -- or if it is an array with has_controlled components
+ -- attached to the finalization list (including the controlled
+ -- components)
+
+ -- or if it is an array with has_controlled components but not
+ -- is_controlled
+
-- Attach_To_Final_List (_Lx, Resx (Resx'last)._controller, 3);
if Has_Controlled_Component (Rtype) then
@@ -1026,7 +1455,9 @@ package body Exp_Ch7 is
if Is_Array_Type (T2) then
Len_Ref :=
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Unchecked_Convert_To (T2, Ref)),
+ Prefix =>
+ Duplicate_Subexpr_Move_Checks
+ (Unchecked_Convert_To (T2, Ref)),
Attribute_Name => Name_Length);
end if;
@@ -1034,16 +1465,26 @@ package body Exp_Ch7 is
if T1 /= T2 then
Ref := Unchecked_Convert_To (T2, Ref);
end if;
+
Ref := Last_Array_Component (Ref, T2);
Attach_Level := Uint_3;
T1 := Component_Type (T2);
T2 := Underlying_Type (T1);
end loop;
- if Has_Controlled_Component (T2) then
+ -- If the type has controlled components, go to the controller
+ -- except in the case of arrays of controlled objects since in
+ -- this case objects and their components are already chained
+ -- and the head of the chain is the last array element.
+
+ if Is_Array_Type (Rtype) and then Is_Controlled (T2) then
+ null;
+
+ elsif Has_Controlled_Component (T2) then
if T1 /= T2 then
Ref := Unchecked_Convert_To (T2, Ref);
end if;
+
Ref :=
Make_Selected_Component (Loc,
Prefix => Ref,
@@ -1060,6 +1501,16 @@ package body Exp_Ch7 is
Flist_Ref => Find_Final_List (Current_Scope),
With_Attach => Make_Integer_Literal (Loc, Attach_Level));
+ -- If it is also Is_Controlled we need to attach the global object
+
+ if Is_Controlled (Rtype) then
+ Action2 :=
+ Make_Attach_Call (
+ Obj_Ref => Duplicate_Subexpr_No_Checks (N),
+ Flist_Ref => Find_Final_List (Current_Scope),
+ With_Attach => Make_Integer_Literal (Loc, Attach_Level));
+ end if;
+
else
-- Here, we have a controlled type that does not seem to have
-- controlled components but it could be a class wide type whose
@@ -1092,6 +1543,9 @@ package body Exp_Ch7 is
end if;
Insert_Action (N, Action);
+ if Present (Action2) then
+ Insert_Action (N, Action2);
+ end if;
end Expand_Ctrl_Function_Call;
---------------------------
@@ -1106,7 +1560,7 @@ package body Exp_Ch7 is
-- ENcode entity names in package body
procedure Expand_N_Package_Body (N : Node_Id) is
- Ent : Entity_Id := Corresponding_Spec (N);
+ Ent : constant Entity_Id := Corresponding_Spec (N);
begin
-- This is done only for non-generic packages
@@ -1550,6 +2004,15 @@ package body Exp_Ch7 is
Cref := Unchecked_Convert_To (Utyp, Cref);
end if;
+ -- If the object is unanalyzed, set its expected type for use
+ -- in Convert_View in case an additional conversion is needed.
+
+ if No (Etype (Cref))
+ and then Nkind (Cref) /= N_Unchecked_Type_Conversion
+ then
+ Set_Etype (Cref, Typ);
+ end if;
+
-- We do not need to attach to one of the Global Final Lists
-- the objects whose type is Finalize_Storage_Only
@@ -1568,10 +2031,10 @@ package body Exp_Ch7 is
or else Is_Class_Wide_Type (Typ)
then
if Is_Tagged_Type (Utyp) then
- Proc := Find_Prim_Op (Utyp, Deep_Name_Of (Adjust_Case));
+ Proc := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
else
- Proc := TSS (Utyp, Deep_Name_Of (Adjust_Case));
+ Proc := TSS (Utyp, TSS_Deep_Adjust);
end if;
Cref := Convert_View (Proc, Cref, 2);
@@ -1600,14 +2063,6 @@ package body Exp_Ch7 is
Parameter_Associations => New_List (Cref2)));
Append_To (Res, Make_Attach_Call (Cref, Flist_Ref, Attach));
-
- -- Treat this as a reference to Adjust if the Adjust routine
- -- comes from source. The call is not explicit, but it is near
- -- enough, and we won't typically get explicit adjust calls.
-
- if Comes_From_Source (Proc) then
- Generate_Reference (Proc, Ref);
- end if;
end if;
return Res;
@@ -1663,9 +2118,9 @@ package body Exp_Ch7 is
Is_Asynchronous_Call_Block : Boolean)
return Node_Id
is
- Loc : constant Source_Ptr := Sloc (Clean);
+ Loc : constant Source_Ptr := Sloc (Clean);
+ Stmt : constant List_Id := New_List;
- Stmt : List_Id := New_List;
Sbody : Node_Id;
Spec : Node_Id;
Name : Node_Id;
@@ -1766,7 +2221,7 @@ package body Exp_Ch7 is
if Has_Entries (Pid)
or else Has_Interrupt_Handler (Pid)
- or else Has_Attach_Handler (Pid)
+ or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
then
if Abort_Allowed
or else Restrictions (No_Entry_Queue) = False
@@ -2083,7 +2538,6 @@ package body Exp_Ch7 is
Formals : List_Id;
Proc_Name : Entity_Id;
Handler : List_Id := No_List;
- Subp_Body : Node_Id;
Type_B : Entity_Id;
begin
@@ -2104,7 +2558,7 @@ package body Exp_Ch7 is
Append_To (Formals,
Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
In_Present => True,
Out_Present => True,
Parameter_Type => New_Reference_To (Typ, Loc)));
@@ -2123,9 +2577,11 @@ package body Exp_Ch7 is
Reason => PE_Finalize_Raised_Exception))));
end if;
- Proc_Name := Make_Defining_Identifier (Loc, Deep_Name_Of (Prim));
+ Proc_Name :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (Typ, Deep_Name_Of (Prim)));
- Subp_Body :=
+ Discard_Node (
Make_Subprogram_Body (Loc,
Specification =>
Make_Procedure_Specification (Loc,
@@ -2136,7 +2592,7 @@ package body Exp_Ch7 is
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts,
- Exception_Handlers => Handler));
+ Exception_Handlers => Handler)));
return Proc_Name;
end Make_Deep_Proc;
@@ -2162,6 +2618,7 @@ package body Exp_Ch7 is
Prefix => Obj_Ref,
Selector_Name =>
Make_Identifier (Loc, Name_uController));
+ Res : constant List_Id := New_List;
begin
if Is_Return_By_Reference_Type (Typ) then
@@ -2172,53 +2629,78 @@ package body Exp_Ch7 is
case Prim is
when Initialize_Case =>
- declare
- Res : constant List_Id := New_List;
-
- begin
- Append_List_To (Res,
- Make_Init_Call (
- Ref => Controller_Ref,
- Typ => Controller_Typ,
- Flist_Ref => Make_Identifier (Loc, Name_L),
- With_Attach => Make_Identifier (Loc, Name_B)));
-
- -- When the type is also a controlled type by itself,
- -- Initialize it and attach it at the end of the internal
- -- finalization chain
-
- if Is_Controlled (Typ) then
- Append_To (Res,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (
- Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
-
- Parameter_Associations =>
- New_List (New_Copy_Tree (Obj_Ref))));
-
- Append_To (Res, Make_Attach_Call (
- Obj_Ref => New_Copy_Tree (Obj_Ref),
- Flist_Ref =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Controller_Ref),
- Selector_Name => Make_Identifier (Loc, Name_F)),
- With_Attach => Make_Integer_Literal (Loc, 1)));
- end if;
-
- return Res;
- end;
+ Append_List_To (Res,
+ Make_Init_Call (
+ Ref => Controller_Ref,
+ Typ => Controller_Typ,
+ Flist_Ref => Make_Identifier (Loc, Name_L),
+ With_Attach => Make_Identifier (Loc, Name_B)));
+
+ -- When the type is also a controlled type by itself,
+ -- Initialize it and attach it to the finalization chain
+
+ if Is_Controlled (Typ) then
+ Append_To (Res,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (
+ Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
+ Parameter_Associations =>
+ New_List (New_Copy_Tree (Obj_Ref))));
+
+ Append_To (Res, Make_Attach_Call (
+ Obj_Ref => New_Copy_Tree (Obj_Ref),
+ Flist_Ref => Make_Identifier (Loc, Name_L),
+ With_Attach => Make_Identifier (Loc, Name_B)));
+ end if;
when Adjust_Case =>
- return
+ Append_List_To (Res,
Make_Adjust_Call (Controller_Ref, Controller_Typ,
Make_Identifier (Loc, Name_L),
- Make_Identifier (Loc, Name_B));
+ Make_Identifier (Loc, Name_B)));
+
+ -- When the type is also a controlled type by itself,
+ -- Adjust it it and attach it to the finalization chain
+
+ if Is_Controlled (Typ) then
+ Append_To (Res,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (
+ Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
+ Parameter_Associations =>
+ New_List (New_Copy_Tree (Obj_Ref))));
+
+ Append_To (Res, Make_Attach_Call (
+ Obj_Ref => New_Copy_Tree (Obj_Ref),
+ Flist_Ref => Make_Identifier (Loc, Name_L),
+ With_Attach => Make_Identifier (Loc, Name_B)));
+ end if;
when Finalize_Case =>
- return
+ if Is_Controlled (Typ) then
+ Append_To (Res,
+ Make_Implicit_If_Statement (Obj_Ref,
+ Condition => Make_Identifier (Loc, Name_B),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE_Finalize_One), Loc),
+ Parameter_Associations => New_List (
+ OK_Convert_To (RTE (RE_Finalizable),
+ New_Copy_Tree (Obj_Ref))))),
+
+ Else_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (
+ Find_Prim_Op (Typ, Name_Of (Prim)), Loc),
+ Parameter_Associations =>
+ New_List (New_Copy_Tree (Obj_Ref))))));
+ end if;
+
+ Append_List_To (Res,
Make_Final_Call (Controller_Ref, Controller_Typ,
- Make_Identifier (Loc, Name_B));
+ Make_Identifier (Loc, Name_B)));
end case;
+ return Res;
end Make_Deep_Record_Body;
----------------------
@@ -2287,9 +2769,9 @@ package body Exp_Ch7 is
or else Is_Class_Wide_Type (Typ)
then
if Is_Tagged_Type (Utyp) then
- Proc := Find_Prim_Op (Utyp, Deep_Name_Of (Finalize_Case));
+ Proc := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
else
- Proc := TSS (Utyp, Deep_Name_Of (Finalize_Case));
+ Proc := TSS (Utyp, TSS_Deep_Finalize);
end if;
Cref := Convert_View (Proc, Cref);
@@ -2343,13 +2825,6 @@ package body Exp_Ch7 is
end if;
end if;
- -- Treat this as a reference to Finalize if the Finalize routine
- -- comes from source. The call is not explicit, but it is near
- -- enough, and we won't typically get explicit adjust calls.
-
- if Comes_From_Source (Proc) then
- Generate_Reference (Proc, Ref);
- end if;
return Res;
end Make_Final_Call;
@@ -2451,6 +2926,8 @@ package body Exp_Ch7 is
else -- Is_Controlled (Utyp)
Proc := Find_Prim_Op (Utyp, Name_Of (Initialize_Case));
+ Check_Visibly_Controlled (Initialize_Case, Typ, Proc, Cref);
+
Cref := Convert_View (Proc, Cref);
Cref2 := New_Copy_Tree (Cref);
@@ -2461,14 +2938,6 @@ package body Exp_Ch7 is
Append_To (Res,
Make_Attach_Call (Cref, Flist_Ref, Attach));
-
- -- Treat this as a reference to Initialize if Initialize routine
- -- comes from source. The call is not explicit, but it is near
- -- enough, and we won't typically get explicit adjust calls.
-
- if Comes_From_Source (Proc) then
- Generate_Reference (Proc, Ref);
- end if;
end if;
return Res;
@@ -2822,7 +3291,7 @@ package body Exp_Ch7 is
Loc : constant Source_Ptr := Sloc (N);
E : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
- Etyp : Entity_Id := Etype (N);
+ Etyp : constant Entity_Id := Etype (N);
begin
Insert_Actions (N, New_List (
diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads
index d2b486e5580..63026d9f2ad 100644
--- a/gcc/ada/exp_ch7.ads
+++ b/gcc/ada/exp_ch7.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -97,9 +97,9 @@ package Exp_Ch7 is
-- have been previously analyzed) that references the object to be
-- initialized. Typ is the expected type of Ref, which is a controlled
-- type (Is_Controlled) or a type with controlled components
- -- (Has_Controlled). 'Dynamic_Case' controls the way the object is
- -- attached which is different whether the object is dynamically
- -- allocated or not.
+ -- (Has_Controlled). With_Attach is an integer expression representing
+ -- the level of attachment, see Attach_To_Final_Lists' NB_Link param
+ -- documentation in s-finimp.ads.
--
-- This function will generate the appropriate calls to make
-- sure that the objects referenced by Ref are initialized. The
@@ -117,39 +117,38 @@ package Exp_Ch7 is
-- have been previously analyzed) that references the object to be
-- adjusted. Typ is the expected type of Ref, which is a controlled
-- type (Is_Controlled) or a type with controlled components
- -- (Has_Controlled).
+ -- (Has_Controlled). With_Attach is an integer expression representing
+ -- the level of attachment, see Attach_To_Final_Lists' NB_Link param
+ -- documentation in s-finimp.ads.
--
-- This function will generate the appropriate calls to make
-- sure that the objects referenced by Ref are adjusted. The generated
-- code is quite different depending on the fact the type IS_Controlled
-- or HAS_Controlled but this is not the problem of the caller, the
- -- details are in the body. If the parameter With_Attach is set to
- -- True, the finalizable objects involved are attached to the proper
- -- finalization chain. The objects must be attached when the adjust
+ -- details are in the body. The objects must be attached when the adjust
-- takes place after an initialization expression but not when it takes
-- place after a regular assignment.
- --
- -- The description of With_Attach is completely obsolete ???
function Make_Final_Call
(Ref : Node_Id;
Typ : Entity_Id;
With_Detach : Node_Id)
return List_Id;
- -- Ref is an expression (with no-side effect and is not required to
- -- have been previously analyzed) that references the object
- -- to be Finalized. Typ is the expected type of Ref, which is a
+ -- Ref is an expression (with no-side effect and is not required
+ -- to have been previously analyzed) that references the object to
+ -- be Finalized. Typ is the expected type of Ref, which is a
-- controlled type (Is_Controlled) or a type with controlled
- -- components (Has_Controlled).
+ -- components (Has_Controlled). With_Attach is an integer
+ -- expression representing the level of attachment, see
+ -- Attach_To_Final_Lists' NB_Link param documentation in
+ -- s-finimp.ads.
--
-- This function will generate the appropriate calls to make
-- sure that the objects referenced by Ref are finalized. The generated
-- code is quite different depending on the fact the type IS_Controlled
-- or HAS_Controlled but this is not the problem of the caller, the
- -- details are in the body. If the parameter With_Detach is set to
- -- True, the finalizable objects involved are detached from the proper
- -- finalization chain. The objects must be detached when finalizing an
- -- unchecked deallocated object but not when finalizing the target of
+ -- details are in the body. The objects must be detached when finalizing
+ -- an unchecked deallocated object but not when finalizing the target of
-- an assignment, it is not necessary either on scope exit.
procedure Expand_Ctrl_Function_Call (N : Node_Id);
@@ -157,6 +156,47 @@ package Exp_Ch7 is
-- say attach the result of the call to the current finalization list,
-- which is the one of the transient scope created for such constructs.
+ --------------------------------------------
+ -- Task and Protected Object finalization --
+ --------------------------------------------
+
+ function Cleanup_Array
+ (N : Node_Id;
+ Obj : Node_Id;
+ Typ : Entity_Id)
+ return List_Id;
+ -- Generate loops to finalize any tasks or simple protected objects
+ -- that are subcomponents of an array.
+
+ function Cleanup_Protected_Object
+ (N : Node_Id;
+ Ref : Node_Id)
+ return Node_Id;
+ -- Generate code to finalize a protected object without entries.
+
+ function Cleanup_Record
+ (N : Node_Id;
+ Obj : Node_Id;
+ Typ : Entity_Id)
+ return List_Id;
+ -- For each subcomponent of a record that contains tasks or simple
+ -- protected objects, generate the appropriate finalization call.
+
+ function Cleanup_Task
+ (N : Node_Id;
+ Ref : Node_Id)
+ return Node_Id;
+ -- Generate code to finalize a task.
+
+ function Has_Simple_Protected_Object (T : Entity_Id) return Boolean;
+ -- Check whether composite type contains a simple protected component.
+
+ function Is_Simple_Protected_Type (T : Entity_Id) return Boolean;
+ -- Check whether argument is a protected type without entries.
+ -- Protected types with entries are controlled, and their cleanup
+ -- is handled by the standard finalization machinery. For simple
+ -- protected types we generate inline code to release their locks.
+
--------------------------------
-- Transient Scope Management --
--------------------------------
diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb
index 8f26a4a3f7f..94598856ed6 100644
--- a/gcc/ada/exp_ch8.adb
+++ b/gcc/ada/exp_ch8.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -28,11 +28,13 @@ with Atree; use Atree;
with Einfo; use Einfo;
with Exp_Dbug; use Exp_Dbug;
with Exp_Util; use Exp_Util;
+with Freeze; use Freeze;
with Nlists; use Nlists;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
with Sinfo; use Sinfo;
with Stand; use Stand;
+with Targparm; use Targparm;
package body Exp_Ch8 is
@@ -82,7 +84,7 @@ package body Exp_Ch8 is
-- More comments needed for this para ???
procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is
- Nam : Node_Id := Name (N);
+ Nam : constant Node_Id := Name (N);
T : Entity_Id;
Decl : Node_Id;
@@ -211,7 +213,7 @@ package body Exp_Ch8 is
elsif Nkind (Nam) = N_Selected_Component then
declare
- Rec_Type : Entity_Id := Etype (Prefix (Nam));
+ Rec_Type : constant Entity_Id := Etype (Prefix (Nam));
begin
if Present (Component_Clause (Entity (Selector_Name (Nam))))
@@ -253,6 +255,17 @@ package body Exp_Ch8 is
Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N));
Find_Type (Subtype_Mark (N));
Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N)));
+
+ -- Freeze the class-wide subtype here to ensure that the subtype
+ -- and equivalent type are frozen before the renaming. This is
+ -- required for targets where Frontend_Layout_On_Target is true.
+ -- For targets where Gigi is used, class-wide subtype should not
+ -- be frozen (in that case the subtype is marked as already frozen
+ -- when it's created).
+
+ if Frontend_Layout_On_Target then
+ Freeze_Before (N, Entity (Subtype_Mark (N)));
+ end if;
end if;
-- Create renaming entry for debug information
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 7fadd373690..08c824dcedd 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.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- --
@@ -198,12 +198,16 @@ package body Exp_Ch9 is
function Build_Selected_Name
(Prefix, Selector : Name_Id;
Append_Char : Character := ' ')
- return Name_Id;
+ return Name_Id;
-- Build a name in the form of Prefix__Selector, with an optional
-- character appended. This is used for internal subprograms generated
-- for operations of protected types, including barrier functions. In
-- order to simplify the work of the debugger, the prefix includes the
- -- characters PT.
+ -- characters PT. For the subprograms generated for entry bodies and
+ -- entry barriers, the generated name includes a sequence number that
+ -- makes names unique in the presence of entry overloading. This is
+ -- necessary because entry body procedures and barrier functions all
+ -- have the same signature.
procedure Build_Simple_Entry_Call
(N : Node_Id;
@@ -301,29 +305,33 @@ package body Exp_Ch9 is
Tsk : Entity_Id)
return Node_Id
is
+ Ttyp : constant Entity_Id := Etype (Tsk);
Expr : Node_Id;
Num : Node_Id;
Lo : Node_Id;
Hi : Node_Id;
Prev : Entity_Id;
S : Node_Id;
- Ttyp : Entity_Id := Etype (Tsk);
+
+ function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id;
+ -- Compute difference between bounds of entry family.
--------------------------
-- Actual_Family_Offset --
--------------------------
- function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id;
- -- Compute difference between bounds of entry family.
-
function Actual_Family_Offset (Hi, Lo : Node_Id) return Node_Id is
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- Replace a reference to a discriminant with a selected component
-- denoting the discriminant of the target task.
+ -----------------------------
+ -- Actual_Discriminant_Ref --
+ -----------------------------
+
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
- Typ : Entity_Id := Etype (Bound);
+ Typ : constant Entity_Id := Etype (Bound);
B : Node_Id;
begin
@@ -352,6 +360,8 @@ package body Exp_Ch9 is
Expressions => New_List (B));
end Actual_Discriminant_Ref;
+ -- Start of processing for Actual_Family_Offset
+
begin
return
Make_Op_Subtract (Sloc,
@@ -359,6 +369,8 @@ package body Exp_Ch9 is
Right_Opnd => Actual_Discriminant_Ref (Lo));
end Actual_Family_Offset;
+ -- Start of processing for Actual_Index_Expression
+
begin
-- The queues of entries and entry families appear in textual
-- order in the associated record. The entry index is computed as
@@ -504,7 +516,6 @@ package body Exp_Ch9 is
Type_Definition => Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Reference_To (Corresponding_Record_Type (Pid), Loc))));
-
end Add_Object_Pointer;
------------------------------
@@ -517,10 +528,10 @@ package body Exp_Ch9 is
Name : Name_Id;
Loc : Source_Ptr)
is
+ Def : constant Node_Id := Protected_Definition (Parent (Typ));
+ Body_Ent : constant Entity_Id := Corresponding_Body (Parent (Typ));
P : Node_Id;
Pdef : Entity_Id;
- Def : Node_Id := Protected_Definition (Parent (Typ));
- Body_Ent : constant Entity_Id := Corresponding_Body (Parent (Typ));
begin
pragma Assert (Nkind (Def) = N_Protected_Definition);
@@ -552,7 +563,11 @@ package body Exp_Ch9 is
begin
if Has_Attach_Handler (Typ) then
if Restricted_Profile then
- Protection_Type := RE_Protection_Entry;
+ if Has_Entries (Typ) then
+ Protection_Type := RE_Protection_Entry;
+ else
+ Protection_Type := RE_Protection;
+ end if;
else
Protection_Type := RE_Static_Interrupt_Protection;
end if;
@@ -583,7 +598,6 @@ package body Exp_Ch9 is
Prefix => Make_Identifier (Loc, Name),
Selector_Name => Make_Identifier (Loc, Name_uObject))));
end;
-
end Add_Private_Declarations;
-----------------------
@@ -625,7 +639,7 @@ package body Exp_Ch9 is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Block_Statement (Loc,
- Handled_Statement_Sequence => Stats)));
+ Handled_Statement_Sequence => Stats)));
else
New_S := Stats;
@@ -666,7 +680,6 @@ package body Exp_Ch9 is
-- still deferred, which is the case for a "when all others" handler.
return New_S;
-
end Build_Accept_Body;
-----------------------------------
@@ -724,7 +737,6 @@ package body Exp_Ch9 is
Analyze (First (Decls));
end if;
-
end Build_Activation_Chain_Entity;
----------------------------
@@ -740,10 +752,10 @@ package body Exp_Ch9 is
Loc : constant Source_Ptr := Sloc (N);
Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N);
Index_Spec : constant Node_Id := Entry_Index_Specification
- (Ent_Formals);
+ (Ent_Formals);
+ Op_Decls : constant List_Id := New_List;
Bdef : Entity_Id;
Bspec : Node_Id;
- Op_Decls : List_Id := New_List;
begin
Bdef :=
@@ -773,7 +785,8 @@ package body Exp_Ch9 is
declare
Index_Id : constant Entity_Id := Defining_Identifier (Index_Spec);
Index_Con : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('J'));
begin
Set_Entry_Index_Constant (Index_Id, Index_Con);
@@ -861,11 +874,11 @@ package body Exp_Ch9 is
begin
Set_Corresponding_Record_Type (Ctyp, Rec_Ent);
- Set_Ekind (Rec_Ent, E_Record_Type);
- Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp));
- Set_Is_Concurrent_Record_Type (Rec_Ent, True);
+ Set_Ekind (Rec_Ent, E_Record_Type);
+ Set_Has_Delayed_Freeze (Rec_Ent, Has_Delayed_Freeze (Ctyp));
+ Set_Is_Concurrent_Record_Type (Rec_Ent, True);
Set_Corresponding_Concurrent_Type (Rec_Ent, Ctyp);
- Set_Girder_Constraint (Rec_Ent, No_Elist);
+ Set_Stored_Constraint (Rec_Ent, No_Elist);
Cdecls := New_List;
-- Use discriminals to create list of discriminants for record, and
@@ -875,7 +888,7 @@ package body Exp_Ch9 is
-- a) The original discriminant.
-- b) The discriminal for use in the task.
-- c) The discriminant of the corresponding record.
- -- d) The discriminal for the init_proc of the corresponding record.
+ -- d) The discriminal for the init proc of the corresponding record.
-- e) The local variable that renames the discriminant in the procedure
-- for the task body.
@@ -1061,7 +1074,6 @@ package body Exp_Ch9 is
Then_Statements => Stats),
Elsif_Parts (If_St));
end if;
-
end Add_If_Clause;
------------------------------
@@ -1174,7 +1186,6 @@ package body Exp_Ch9 is
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Ret)));
-
end Build_Find_Body_Index;
--------------------------------
@@ -1208,7 +1219,6 @@ package body Exp_Ch9 is
New_Reference_To (RTE (RE_Protected_Entry_Index), Loc))),
Subtype_Mark => New_Occurrence_Of (
RTE (RE_Protected_Entry_Index), Loc));
-
end Build_Find_Body_Index_Spec;
-------------------------
@@ -1281,9 +1291,9 @@ package body Exp_Ch9 is
return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
+ Op_Decls : constant List_Id := New_List;
Edef : Entity_Id;
Espec : Node_Id;
- Op_Decls : List_Id := New_List;
Op_Stats : List_Id;
Ohandle : Node_Id;
Complete : Node_Id;
@@ -1551,8 +1561,6 @@ package body Exp_Ch9 is
is
Loc : constant Source_Ptr := Sloc (N);
Op_Spec : Node_Id;
- Op_Def : Entity_Id;
- Sub_Name : Name_Id;
P_Op_Spec : Node_Id;
Uactuals : List_Id;
Pformal : Node_Id;
@@ -1665,11 +1673,8 @@ package body Exp_Ch9 is
begin
Op_Spec := Specification (N);
- Op_Def := Defining_Unit_Name (Op_Spec);
Exc_Safe := Is_Exception_Safe (N);
- Sub_Name := Chars (Defining_Unit_Name (Specification (N)));
-
P_Op_Spec :=
Build_Protected_Sub_Specification (N,
Pid, Unprotected => False);
@@ -1744,7 +1749,7 @@ package body Exp_Ch9 is
if Has_Entries (Pid)
or else Has_Interrupt_Handler (Pid)
- or else Has_Attach_Handler (Pid)
+ or else (Has_Attach_Handler (Pid) and then not Restricted_Profile)
then
if Abort_Allowed
or else Restrictions (No_Entry_Queue) = False
@@ -1860,7 +1865,7 @@ package body Exp_Ch9 is
External : Boolean := True)
is
Loc : constant Source_Ptr := Sloc (N);
- Sub : Entity_Id := Entity (Name);
+ Sub : constant Entity_Id := Entity (Name);
New_Sub : Node_Id;
Params : List_Id;
@@ -2015,6 +2020,7 @@ package body Exp_Ch9 is
declare
Loc : constant Source_Ptr := Sloc (N);
Parms : constant List_Id := Parameter_Associations (N);
+ Stats : constant List_Id := New_List;
Pdecl : Node_Id;
Xdecl : Node_Id;
Decls : List_Id;
@@ -2032,7 +2038,6 @@ package body Exp_Ch9 is
Formal : Node_Id;
N_Node : Node_Id;
N_Var : Node_Id;
- Stats : List_Id := New_List;
Comm_Name : Entity_Id;
begin
@@ -2125,7 +2130,7 @@ package body Exp_Ch9 is
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('I')),
+ Chars => New_Internal_Name ('J')),
Aliased_Present => True,
Object_Definition =>
New_Reference_To (Etype (Formal), Loc));
@@ -2431,11 +2436,12 @@ package body Exp_Ch9 is
N : Node_Id;
Args : List_Id)
is
- T : constant Entity_Id := Entity (Expression (N));
- Init : constant Entity_Id := Base_Init_Proc (T);
- Loc : constant Source_Ptr := Sloc (N);
+ T : constant Entity_Id := Entity (Expression (N));
+ Init : constant Entity_Id := Base_Init_Proc (T);
+ Loc : constant Source_Ptr := Sloc (N);
+ Chain : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_uChain);
- Chain : Entity_Id := Make_Defining_Identifier (Loc, Name_uChain);
Blkent : Entity_Id;
Block : Node_Id;
@@ -2538,7 +2544,6 @@ package body Exp_Ch9 is
return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
- Sub_Name : Name_Id;
N_Op_Spec : Node_Id;
Op_Decls : List_Id;
@@ -2548,8 +2553,6 @@ package body Exp_Ch9 is
-- parameter representing the object.
Op_Decls := Declarations (N);
- Sub_Name := Chars (Defining_Unit_Name (Specification (N)));
-
N_Op_Spec :=
Build_Protected_Sub_Specification
(N, Pid, Unprotected => True);
@@ -3138,6 +3141,70 @@ package body Exp_Ch9 is
if Present (Ann) then
Append_Elmt (Ann, Accept_Address (Ent));
+ Set_Needs_Debug_Info (Ann);
+ end if;
+
+ -- Create renaming declarations for the entry formals. Each
+ -- reference to a formal becomes a dereference of a component
+ -- of the parameter block, whose address is held in Ann.
+ -- These declarations are eventually inserted into the accept
+ -- block, and analyzed there so that they have the proper scope
+ -- for gdb and do not conflict with other declarations.
+
+ if Present (Parameter_Specifications (N))
+ and then Present (Handled_Statement_Sequence (N))
+ then
+ declare
+ Formal : Entity_Id;
+ New_F : Entity_Id;
+ Comp : Entity_Id;
+ Decl : Node_Id;
+
+ begin
+ New_Scope (Ent);
+ Formal := First_Formal (Ent);
+
+ while Present (Formal) loop
+ Comp := Entry_Component (Formal);
+ New_F :=
+ Make_Defining_Identifier (Sloc (Formal), Chars (Formal));
+ Set_Etype (New_F, Etype (Formal));
+ Set_Scope (New_F, Ent);
+ Set_Needs_Debug_Info (New_F); -- That's the whole point.
+
+ if Ekind (Formal) = E_In_Parameter then
+ Set_Ekind (New_F, E_Constant);
+ else
+ Set_Ekind (New_F, E_Variable);
+ Set_Extra_Constrained (New_F, Extra_Constrained (Formal));
+ end if;
+
+ Set_Actual_Subtype (New_F, Actual_Subtype (Formal));
+
+ Decl :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => New_F,
+ Subtype_Mark => New_Reference_To (Etype (Formal), Loc),
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Entry_Parameters_Type (Ent),
+ New_Reference_To (Ann, Loc)),
+ Selector_Name =>
+ New_Reference_To (Comp, Loc))));
+
+ if No (Declarations (N)) then
+ Set_Declarations (N, New_List);
+ end if;
+
+ Append (Decl, Declarations (N));
+ Set_Renamed_Object (Formal, New_F);
+ Next_Formal (Formal);
+ end loop;
+
+ End_Scope;
+ end;
end if;
end if;
end Expand_Accept_Declarations;
@@ -3210,7 +3277,6 @@ package body Exp_Ch9 is
Insert_After (Decl1, Decl2);
Set_Equivalent_Type (T, E_T);
-
end Expand_Access_Protected_Subprogram_Type;
--------------------------
@@ -3219,14 +3285,20 @@ package body Exp_Ch9 is
procedure Expand_Entry_Barrier (N : Node_Id; Ent : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Prot : constant Entity_Id := Scope (Ent);
+ Spec_Decl : constant Node_Id := Parent (Prot);
+ Cond : constant Node_Id :=
+ Condition (Entry_Body_Formal_Part (N));
Func : Node_Id;
B_F : Node_Id;
- Prot : constant Entity_Id := Scope (Ent);
- Spec_Decl : Node_Id := Parent (Prot);
Body_Decl : Node_Id;
- Cond : Node_Id := Condition (Entry_Body_Formal_Part (N));
begin
+ if No_Run_Time_Mode then
+ Error_Msg_CRT ("entry barrier", N);
+ return;
+ end if;
+
-- The body of the entry barrier must be analyzed in the context of
-- the protected object, but its scope is external to it, just as any
-- other unprotected version of a protected operation. The specification
@@ -3254,6 +3326,7 @@ package body Exp_Ch9 is
Set_Privals (Spec_Decl, N, Loc);
Set_Discriminals (Spec_Decl);
Set_Scope (Func, Scope (Prot));
+
else
Analyze (Cond);
end if;
@@ -3282,11 +3355,16 @@ package body Exp_Ch9 is
then
return;
+ -- Check for case of _object.all.field (note that the explicit
+ -- dereference gets inserted by analyze/expand of _object.field)
+
elsif Present (Renamed_Object (Entity (Cond)))
and then
Nkind (Renamed_Object (Entity (Cond))) = N_Selected_Component
and then
- Chars (Prefix (Renamed_Object (Entity (Cond)))) = Name_uObject
+ Chars
+ (Prefix
+ (Prefix (Renamed_Object (Entity (Cond))))) = Name_uObject
then
return;
end if;
@@ -3318,9 +3396,8 @@ package body Exp_Ch9 is
if Present (Index_Spec) then
Set_Entry_Index_Constant (
Defining_Identifier (Index_Spec),
- Make_Defining_Identifier (Loc, New_Internal_Name ('I')));
+ Make_Defining_Identifier (Loc, New_Internal_Name ('J')));
end if;
-
end if;
end Expand_Entry_Body_Declarations;
@@ -3363,7 +3440,6 @@ package body Exp_Ch9 is
Expression => Aggr))));
Analyze (N);
-
end Expand_N_Abort_Statement;
-------------------------------
@@ -3389,6 +3465,7 @@ package body Exp_Ch9 is
-- begin
-- begin
-- Accept_Call (entry-index, Ann);
+ -- Renaming_Declarations for formals
-- <statement sequence from N_Accept_Statement node>
-- Complete_Rendezvous;
-- <<Lnn>>
@@ -3434,6 +3511,7 @@ package body Exp_Ch9 is
Acstack : constant Elist_Id := Accept_Address (Eent);
Ann : constant Entity_Id := Node (Last_Elmt (Acstack));
Ttyp : constant Entity_Id := Etype (Scope (Eent));
+ Blkent : Entity_Id;
Call : Node_Id;
Block : Node_Id;
@@ -3485,6 +3563,26 @@ package body Exp_Ch9 is
elsif Opt.Task_Dispatching_Policy /= 'F'
and then (No (Stats) or else Null_Statements (Statements (Stats)))
then
+ -- Remove declarations for renamings, because the parameter block
+ -- will not be assigned.
+
+ declare
+ D : Node_Id;
+ Next_D : Node_Id;
+
+ begin
+ D := First (Declarations (N));
+
+ while Present (D) loop
+ Next_D := Next (D);
+ if Nkind (D) = N_Object_Renaming_Declaration then
+ Remove (D);
+ end if;
+
+ D := Next_D;
+ end loop;
+ end;
+
if Present (Declarations (N)) then
Insert_Actions (N, Declarations (N));
end if;
@@ -3511,12 +3609,22 @@ package body Exp_Ch9 is
-- Construct the block, using the declarations from the accept
-- statement if any to initialize the declarations of the block.
+ Blkent := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+ Set_Ekind (Blkent, E_Block);
+ Set_Etype (Blkent, Standard_Void_Type);
+ Set_Scope (Blkent, Current_Scope);
+
Block :=
Make_Block_Statement (Loc,
+ Identifier => New_Reference_To (Blkent, Loc),
Declarations => Declarations (N),
Handled_Statement_Sequence => Build_Accept_Body (N));
-- Prepend call to Accept_Call to main statement sequence
+ -- If the accept has exception handlers, the statement sequence
+ -- is wrapped in a block. Insert call and renaming declarations
+ -- in the declarations of the block, so they are elaborated before
+ -- the handlers.
Call :=
Make_Procedure_Call_Statement (Loc,
@@ -3525,9 +3633,57 @@ package body Exp_Ch9 is
Entry_Index_Expression (Loc, Entity (Ename), Eindx, Ttyp),
New_Reference_To (Ann, Loc)));
- Prepend (Call, Statements (Stats));
+ if Parent (Stats) = N then
+ Prepend (Call, Statements (Stats));
+ else
+ Set_Declarations
+ (Parent (Stats),
+ New_List (Call));
+ end if;
+
Analyze (Call);
+ New_Scope (Blkent);
+
+ declare
+ D : Node_Id;
+ Next_D : Node_Id;
+ Typ : Entity_Id;
+ begin
+ D := First (Declarations (N));
+
+ while Present (D) loop
+ Next_D := Next (D);
+
+ if Nkind (D) = N_Object_Renaming_Declaration then
+ -- The renaming declarations for the formals were
+ -- created during analysis of the accept statement,
+ -- and attached to the list of declarations. Place
+ -- them now in the context of the accept block or
+ -- subprogram.
+
+ Remove (D);
+ Typ := Entity (Subtype_Mark (D));
+ Insert_After (Call, D);
+ Analyze (D);
+
+ -- If the formal is class_wide, it does not have an
+ -- actual subtype. The analysis of the renaming declaration
+ -- creates one, but we need to retain the class-wide
+ -- nature of the entity.
+
+ if Is_Class_Wide_Type (Typ) then
+ Set_Etype (Defining_Identifier (D), Typ);
+ end if;
+
+ end if;
+
+ D := Next_D;
+ end loop;
+ end;
+
+ End_Scope;
+
-- Replace the accept statement by the new block
Rewrite (N, Block);
@@ -3537,7 +3693,6 @@ package body Exp_Ch9 is
Remove_Last_Elmt (Acstack);
end if;
-
end Expand_N_Accept_Statement;
----------------------------------
@@ -3555,15 +3710,16 @@ package body Exp_Ch9 is
-- B : Boolean;
-- C : Boolean;
-- P : parms := (parm, parm, parm);
- --
+
-- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions.
- --
+
-- procedure _clean is
-- begin
-- ...
-- Cancel_Task_Entry_Call (C);
-- ...
-- end _clean;
+
-- begin
-- Abort_Defer;
-- Task_Entry_Call
@@ -3572,6 +3728,7 @@ package body Exp_Ch9 is
-- P'Address,
-- Asynchronous_Call,
-- B);
+
-- begin
-- begin
-- Abort_Undefer;
@@ -3579,6 +3736,7 @@ package body Exp_Ch9 is
-- at end
-- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions.
-- end;
+
-- exception
-- when Abort_Signal => Abort_Undefer;
-- end;
@@ -3611,11 +3769,10 @@ package body Exp_Ch9 is
-- declare
-- P : E1_Params := (param, param, param);
-- Bnn : Communications_Block;
+
-- begin
-- declare
- --
-- -- Clean is added by Exp_Ch7.Expand_Cleanup_Actions.
- --
-- procedure _clean is
-- begin
-- ...
@@ -3624,6 +3781,7 @@ package body Exp_Ch9 is
-- end if;
-- ...
-- end _clean;
+
-- begin
-- begin
-- Protected_Entry_Call (
@@ -3638,11 +3796,13 @@ package body Exp_Ch9 is
-- at end
-- _clean; -- Added by Exp_Ch7.Expand_Cleanup_Actions.
-- end;
+
-- exception
- -- when Abort_Signal =>
- -- Abort_Undefer;
- -- null;
+ -- when Abort_Signal =>
+ -- Abort_Undefer;
+ -- null;
-- end;
+
-- if not Cancelled (Bnn) then
-- triggered statements
-- end if;
@@ -3686,9 +3846,9 @@ package body Exp_Ch9 is
Trig : constant Node_Id := Triggering_Alternative (N);
Abrt : constant Node_Id := Abortable_Part (N);
Tstats : constant List_Id := Statements (Trig);
+ Astats : constant List_Id := Statements (Abrt);
Ecall : Node_Id;
- Astats : List_Id := Statements (Abrt);
Concval : Node_Id;
Ename : Node_Id;
Index : Node_Id;
@@ -4076,7 +4236,6 @@ package body Exp_Ch9 is
Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
Analyze (N_Orig);
-
end Expand_N_Asynchronous_Select;
-------------------------------------
@@ -4295,7 +4454,6 @@ package body Exp_Ch9 is
Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
Analyze (N);
-
end Expand_N_Conditional_Entry_Call;
---------------------------------------
@@ -4349,10 +4507,13 @@ package body Exp_Ch9 is
procedure Expand_N_Entry_Body (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Dec : constant Node_Id := Parent (Current_Scope);
+ Ent_Formals : constant Node_Id := Entry_Body_Formal_Part (N);
+ Index_Spec : constant Node_Id :=
+ Entry_Index_Specification (Ent_Formals);
Next_Op : Node_Id;
- Dec : Node_Id := Parent (Current_Scope);
- Ent_Formals : Node_Id := Entry_Body_Formal_Part (N);
- Index_Spec : Node_Id := Entry_Index_Specification (Ent_Formals);
+ First_Decl : constant Node_Id := First (Declarations (N));
+ Index_Decl : List_Id;
begin
-- Add the renamings for private declarations and discriminants.
@@ -4363,9 +4524,19 @@ package body Exp_Ch9 is
(Declarations (N), Defining_Identifier (Dec), Name_uObject, Loc);
if Present (Index_Spec) then
- Append_List_To (Declarations (N),
+ Index_Decl :=
Index_Constant_Declaration
- (N, Defining_Identifier (Index_Spec), Defining_Identifier (Dec)));
+ (N,
+ Defining_Identifier (Index_Spec), Defining_Identifier (Dec));
+
+ -- If the entry has local declarations, insert index declaration
+ -- before them, because the index may be used therein.
+
+ if Present (First_Decl) then
+ Insert_List_Before (First_Decl, Index_Decl);
+ else
+ Append_List_To (Declarations (N), Index_Decl);
+ end if;
end if;
-- Associate privals and discriminals with the next protected
@@ -4395,6 +4566,11 @@ package body Exp_Ch9 is
Index : Node_Id;
begin
+ if No_Run_Time_Mode then
+ Error_Msg_CRT ("entry call", N);
+ return;
+ end if;
+
-- If this entry call is part of an asynchronous select, don't
-- expand it here; it will be expanded with the select statement.
-- Don't expand timed entry calls either, as they are translated
@@ -4415,7 +4591,6 @@ package body Exp_Ch9 is
Extract_Entry (N, Concval, Ename, Index);
Build_Simple_Entry_Call (N, Concval, Ename, Index);
end if;
-
end Expand_N_Entry_Call_Statement;
--------------------------------
@@ -4525,9 +4700,7 @@ package body Exp_Ch9 is
Insert_After (Last_Decl, Decl);
Last_Decl := Decl;
-
end if;
-
end Expand_N_Entry_Declaration;
-----------------------------
@@ -4567,6 +4740,7 @@ package body Exp_Ch9 is
-- Unlock (_object._object'Access);
-- Abort_Undefer.all;
-- end _clean;
+
-- begin
-- Abort_Defer.all;
-- Lock (_object._object'Access);
@@ -4588,10 +4762,12 @@ package body Exp_Ch9 is
-- Unlock (_object._object'Access);
-- Abort_Undefer.all;
-- end _clean;
+
-- begin
-- Abort_Defer.all;
-- Lock (_object._object'Access);
-- return pfuncN (_object);
+
-- at end
-- _clean;
-- end pfunc;
@@ -4605,6 +4781,7 @@ package body Exp_Ch9 is
-- <private object renamings>
-- type poVP is access poV;
-- _Object : ptVP := ptVP!(O);
+
-- begin
-- begin
-- <statement sequence>
@@ -4630,6 +4807,11 @@ package body Exp_Ch9 is
Num_Entries : Natural := 0;
begin
+ if No_Run_Time_Mode then
+ Error_Msg_CRT ("protected body", N);
+ return;
+ end if;
+
if Nkind (Parent (N)) = N_Subunit then
-- This is the proper body corresponding to a stub. The declarations
@@ -4652,7 +4834,6 @@ package body Exp_Ch9 is
Analyze (N);
while Present (Op_Body) loop
-
case Nkind (Op_Body) is
when N_Subprogram_Declaration =>
null;
@@ -4853,9 +5034,9 @@ package body Exp_Ch9 is
Pdef : constant Node_Id := Protected_Definition (N);
-- This contains two lists; one for visible and one for private decls
- Rec_Decl : Node_Id;
- Cdecls : List_Id;
- Discr_Map : Elist_Id := New_Elmt_List;
+ Rec_Decl : Node_Id;
+ Cdecls : List_Id;
+ Discr_Map : constant Elist_Id := New_Elmt_List;
Priv : Node_Id;
Pent : Entity_Id;
New_Priv : Node_Id;
@@ -4863,7 +5044,6 @@ package body Exp_Ch9 is
Comp_Id : Entity_Id;
Sub : Node_Id;
Current_Node : Node_Id := N;
- Nam : Name_Id;
Bdef : Entity_Id := Empty; -- avoid uninit warning
Edef : Entity_Id := Empty; -- avoid uninit warning
Entries_Aggr : Node_Id;
@@ -4945,7 +5125,7 @@ package body Exp_Ch9 is
end;
end if;
- -- Fill in the component declarations.
+ -- Fill in the component declarations
-- Add components for entry families. For each entry family,
-- create an anonymous type declaration with the same size, and
@@ -4979,9 +5159,13 @@ package body Exp_Ch9 is
end loop;
if Restricted_Profile then
- Protection_Subtype :=
- New_Reference_To (RTE (RE_Protection_Entry), Loc);
-
+ if Has_Entries (Prottyp) then
+ Protection_Subtype :=
+ New_Reference_To (RTE (RE_Protection_Entry), Loc);
+ else
+ Protection_Subtype :=
+ New_Reference_To (RTE (RE_Protection), Loc);
+ end if;
else
Protection_Subtype :=
Make_Subtype_Indication
@@ -5042,7 +5226,7 @@ package body Exp_Ch9 is
pragma Assert (Present (Pdef));
- -- Add private field components.
+ -- Add private field components
if Present (Private_Declarations (Pdef)) then
Priv := First (Private_Declarations (Pdef));
@@ -5191,10 +5375,12 @@ package body Exp_Ch9 is
E_Count := E_Count + 1;
Comp_Id := Defining_Identifier (Comp);
Set_Privals_Chain (Comp_Id, New_Elmt_List);
- Nam := Chars (Comp_Id);
Edef :=
Make_Defining_Identifier (Loc,
- Build_Selected_Name (Protnm, New_Internal_Name ('E')));
+ Build_Selected_Name
+ (Protnm,
+ New_External_Name (Chars (Comp_Id), Suffix_Index => -1),
+ 'E'));
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
@@ -5211,7 +5397,10 @@ package body Exp_Ch9 is
Bdef :=
Make_Defining_Identifier (Loc,
- Build_Selected_Name (Protnm, New_Internal_Name ('B')));
+ Build_Selected_Name
+ (Protnm,
+ New_External_Name (Chars (Comp_Id), Suffix_Index => -1),
+ 'B'));
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
@@ -5254,10 +5443,12 @@ package body Exp_Ch9 is
E_Count := E_Count + 1;
Comp_Id := Defining_Identifier (Comp);
Set_Privals_Chain (Comp_Id, New_Elmt_List);
- Nam := Chars (Comp_Id);
Edef :=
Make_Defining_Identifier (Loc,
- Build_Selected_Name (Protnm, New_Internal_Name ('E')));
+ Build_Selected_Name
+ (Protnm,
+ New_External_Name (Chars (Comp_Id), Suffix_Index => -1),
+ 'E'));
Sub :=
Make_Subprogram_Declaration (Loc,
@@ -5275,7 +5466,10 @@ package body Exp_Ch9 is
Bdef :=
Make_Defining_Identifier (Loc,
- Build_Selected_Name (Protnm, New_Internal_Name ('B')));
+ Build_Selected_Name
+ (Protnm,
+ New_External_Name (Chars (Comp_Id), Suffix_Index => -1),
+ 'B'));
Sub :=
Make_Subprogram_Declaration (Loc,
Specification =>
@@ -5289,7 +5483,7 @@ package body Exp_Ch9 is
Current_Node := Sub;
-- Collect pointers to the protected subprogram and the
- -- barrier of the current entry, for insertion into
+ -- barrier of the current entry, for insertion into
-- Entry_Bodies_Array.
Append (
@@ -5398,34 +5592,34 @@ package body Exp_Ch9 is
-- <private object renamings>
-- type poVP is access poV;
-- _Object : ptVP := ptVP!(O);
- --
+
-- begin
-- begin
-- <start of statement sequence for entry>
- --
+
-- -- Requeue from one protected entry body to another protected
-- -- entry.
- --
+
-- Requeue_Protected_Entry (
-- _object._object'Access,
-- new._object'Access,
-- E,
-- Abort_Present);
-- return;
- --
+
-- <some more of the statement sequence for entry>
- --
+
-- -- Requeue from an entry body to a task entry.
- --
+
-- Requeue_Protected_To_Task_Entry (
-- New._task_id,
-- E,
-- Abort_Present);
-- return;
- --
+
-- <rest of statement sequence for entry>
-- Complete_Entry_Body (_Object._Object);
- --
+
-- exception
-- when all others =>
-- Exceptional_Complete_Entry_Body (
@@ -5434,7 +5628,7 @@ package body Exp_Ch9 is
-- end entE;
-- Requeue of a task entry call to a task entry.
- --
+
-- Accept_Call (E, Ann);
-- <start of statement sequence for accept statement>
-- Requeue_Task_Entry (New._task_id, E, Abort_Present);
@@ -5442,12 +5636,13 @@ package body Exp_Ch9 is
-- <rest of statement sequence for accept statement>
-- <<Lnn>>
-- Complete_Rendezvous;
+
-- exception
-- when all others =>
-- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
-- Requeue of a task entry call to a protected entry.
- --
+
-- Accept_Call (E, Ann);
-- <start of statement sequence for accept statement>
-- Requeue_Task_To_Protected_Entry (
@@ -5459,6 +5654,7 @@ package body Exp_Ch9 is
-- <rest of statement sequence for accept statement>
-- <<Lnn>>
-- Complete_Rendezvous;
+
-- exception
-- when all others =>
-- Exceptional_Complete_Rendezvous (Get_GNAT_Exception);
@@ -5598,7 +5794,6 @@ package body Exp_Ch9 is
Set_Analyzed (Skip_Stat);
Insert_After (N, Skip_Stat);
-
end Expand_N_Requeue_Statement;
-------------------------------
@@ -5609,21 +5804,25 @@ package body Exp_Ch9 is
Loc : constant Source_Ptr := Sloc (N);
Alts : constant List_Id := Select_Alternatives (N);
+ -- Note: in the below declarations a lot of new lists are allocated
+ -- unconditionally which may well not end up being used. That's
+ -- not a good idea since it wastes space gratuitously ???
+
Accept_Case : List_Id;
- Accept_List : List_Id := New_List;
+ Accept_List : constant List_Id := New_List;
Alt : Node_Id;
- Alt_List : List_Id := New_List;
+ Alt_List : constant List_Id := New_List;
Alt_Stats : List_Id;
Ann : Entity_Id := Empty;
Block : Node_Id;
Check_Guard : Boolean := True;
- Decls : List_Id := New_List;
- Stats : List_Id := New_List;
- Body_List : List_Id := New_List;
- Trailing_List : List_Id := New_List;
+ Decls : constant List_Id := New_List;
+ Stats : constant List_Id := New_List;
+ Body_List : constant List_Id := New_List;
+ Trailing_List : constant List_Id := New_List;
Choices : List_Id;
Else_Present : Boolean := False;
@@ -5637,7 +5836,7 @@ package body Exp_Ch9 is
Delay_Min : Entity_Id;
Delay_Num : Int := 1;
Delay_Alt_List : List_Id := New_List;
- Delay_List : List_Id := New_List;
+ Delay_List : constant List_Id := New_List;
D : Entity_Id;
M : Entity_Id;
@@ -5815,6 +6014,8 @@ package body Exp_Ch9 is
Make_Defining_Identifier (Sloc (Ename),
New_External_Name (Chars (Ename), 'A', Num_Accept));
+ Set_Needs_Debug_Info (PB_Ent, Comes_From_Source (Alt));
+
Proc_Body :=
Make_Subprogram_Body (Loc,
Specification =>
@@ -5877,7 +6078,7 @@ package body Exp_Ch9 is
----------------------
function Make_Select_Call (Select_Mode : Entity_Id) return Node_Id is
- Params : List_Id := New_List;
+ Params : constant List_Id := New_List;
begin
Append (
@@ -6645,7 +6846,6 @@ package body Exp_Ch9 is
Next (Alt);
end loop;
-
end Expand_N_Selective_Accept;
--------------------------------------
@@ -6680,7 +6880,7 @@ package body Exp_Ch9 is
-- procedure tnameB (_Task : access tnameV) is
-- discriminal : dtype renames _Task.discriminant;
- --
+
-- procedure _clean is
-- begin
-- Abort_Defer.all;
@@ -6688,6 +6888,7 @@ package body Exp_Ch9 is
-- Abort_Undefer.all;
-- return;
-- end _clean;
+
-- begin
-- Abort_Undefer.all;
-- <declarations>
@@ -6726,15 +6927,6 @@ package body Exp_Ch9 is
New_N : Node_Id;
begin
- -- Do not attempt expansion if in no run time mode
-
- if No_Run_Time
- and then not Restricted_Profile
- then
- Disallow_In_No_Run_Time_Mode (N);
- return;
- end if;
-
-- Here we start the expansion by generating discriminal declarations
Add_Discriminal_Declarations (Declarations (N), Ttyp, Name_uTask, Loc);
@@ -6829,7 +7021,6 @@ package body Exp_Ch9 is
-- _Priority : Integer := priority_expression;
-- _Size : Size_Type := Size_Type (size_expression);
-- _Task_Info : Task_Info_Type := task_info_expression;
- -- _Task_Name : Task_Image_Type := new String'(task_name_expression);
-- end record;
-- The discriminants are present only if the corresponding task type has
@@ -6863,11 +7054,6 @@ package body Exp_Ch9 is
-- present in the pragma, and is used to provide the Task_Image parameter
-- to the call to Create_Task.
- -- The _Task_Name field is present only if a Task_Name pragma appears in
- -- the task definition. The expression captures the argument that was
- -- present in the pragma, and is used to provide the Task_Id parameter
- -- to the call to Create_Task.
-
-- When a task is declared, an instance of the task value record is
-- created. The elaboration of this declaration creates the correct
-- bounds for the entry families, and also evaluates the size, priority,
@@ -6913,17 +7099,9 @@ package body Exp_Ch9 is
Body_Decl : Node_Id;
begin
- -- Do not attempt expansion if in no run time mode
-
- if No_Run_Time
- and then not Restricted_Profile
- then
- Disallow_In_No_Run_Time_Mode (N);
- return;
-
-- If already expanded, nothing to do
- elsif Present (Corresponding_Record_Type (Tasktyp)) then
+ if Present (Corresponding_Record_Type (Tasktyp)) then
return;
end if;
@@ -7000,16 +7178,41 @@ package body Exp_Ch9 is
-- Add the _Priority component if a Priority pragma is present
if Present (Taskdef) and then Has_Priority_Pragma (Taskdef) then
- Append_To (Cdecls,
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uPriority),
- Subtype_Indication => New_Reference_To (Standard_Integer, Loc),
- Expression => New_Copy (
- Expression (First (
- Pragma_Argument_Associations (
- Find_Task_Or_Protected_Pragma
- (Taskdef, Name_Priority)))))));
+ declare
+ Prag : constant Node_Id :=
+ Find_Task_Or_Protected_Pragma (Taskdef, Name_Priority);
+ Expr : Node_Id;
+
+ begin
+ Expr := First (Pragma_Argument_Associations (Prag));
+
+ if Nkind (Expr) = N_Pragma_Argument_Association then
+ Expr := Expression (Expr);
+ end if;
+
+ Expr := New_Copy (Expr);
+
+ -- Add conversion to proper type to do range check if required
+ -- Note that for runtime units, we allow out of range interrupt
+ -- priority values to be used in a priority pragma. This is for
+ -- the benefit of some versions of System.Interrupts which use
+ -- a special server task with maximum interrupt priority.
+
+ if Chars (Prag) = Name_Priority
+ and then not GNAT_Mode
+ then
+ Rewrite (Expr, Convert_To (RTE (RE_Priority), Expr));
+ else
+ Rewrite (Expr, Convert_To (RTE (RE_Any_Priority), Expr));
+ end if;
+
+ Append_To (Cdecls,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uPriority),
+ Subtype_Indication => New_Reference_To (Standard_Integer, Loc),
+ Expression => Expr));
+ end;
end if;
-- Add the _Task_Size component if a Storage_Size pragma is present
@@ -7049,29 +7252,6 @@ package body Exp_Ch9 is
(Taskdef, Name_Task_Info)))))));
end if;
- -- Add the _Task_Name component if a Task_Name pragma is present
-
- if Present (Taskdef) and then Has_Task_Name_Pragma (Taskdef) then
- Append_To (Cdecls,
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uTask_Info),
- Subtype_Indication =>
- New_Reference_To (RTE (RE_Task_Image_Type), Loc),
- Expression =>
- Make_Allocator (Loc,
- Expression =>
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Standard_String, Loc),
- Expression =>
- New_Copy (
- Expression (First (
- Pragma_Argument_Associations (
- Find_Task_Or_Protected_Pragma
- (Taskdef, Name_Task_Name)))))))));
- end if;
-
Insert_After (Size_Decl, Rec_Decl);
-- Analyze the record declaration immediately after construction,
@@ -7089,6 +7269,12 @@ package body Exp_Ch9 is
Insert_After (Rec_Decl, Body_Decl);
+ -- The subprogram does not comes from source, so we have to indicate
+ -- the need for debugging information explicitly.
+
+ Set_Needs_Debug_Info
+ (Defining_Entity (Proc_Spec), Comes_From_Source (Original_Node (N)));
+
-- Now we can freeze the corresponding record. This needs manually
-- freezing, since it is really part of the task type, and the task
-- type is frozen at this stage. We of course need the initialization
@@ -7248,8 +7434,7 @@ package body Exp_Ch9 is
New_List (New_Copy (Expression (D_Stat))));
end if;
- -- Create a Duration and a Delay_Mode object used for passing a delay
- -- value
+ -- Create Duration and Delay_Mode objects for passing a delay value
D := Make_Defining_Identifier (Loc, New_Internal_Name ('D'));
M := Make_Defining_Identifier (Loc, New_Internal_Name ('M'));
@@ -7386,7 +7571,6 @@ package body Exp_Ch9 is
Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
Analyze (N);
-
end Expand_N_Timed_Entry_Call;
----------------------------------------
@@ -7438,13 +7622,17 @@ package body Exp_Ch9 is
-- need another placeholder for the label.
procedure Expand_Protected_Body_Declarations
- (N : Node_Id;
+ (N : Node_Id;
Spec_Id : Entity_Id)
is
Op : Node_Id;
begin
- if Expander_Active then
+ if No_Run_Time_Mode then
+ Error_Msg_CRT ("protected body", N);
+ return;
+
+ elsif Expander_Active then
-- Associate privals with the first subprogram or entry
-- body to be expanded. These are used to expand references
@@ -7518,7 +7706,6 @@ package body Exp_Ch9 is
Ename := Selector_Name (Prefix (Nam));
Index := First (Expressions (Nam));
end if;
-
end Extract_Entry;
-------------------
@@ -7593,7 +7780,6 @@ package body Exp_Ch9 is
Make_Op_Subtract (Loc,
Left_Opnd => Convert_Discriminant_Ref (Hi),
Right_Opnd => Convert_Discriminant_Ref (Lo));
-
end Family_Offset;
-----------------
@@ -7716,7 +7902,7 @@ package body Exp_Ch9 is
return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
- Decls : List_Id := New_List;
+ Decls : constant List_Id := New_List;
Index_Con : constant Entity_Id := Entry_Index_Constant (Index_Id);
Index_Typ : Entity_Id;
@@ -7762,7 +7948,7 @@ package body Exp_Ch9 is
Hi := Replace_Discriminant (Hi);
Lo := Replace_Discriminant (Lo);
- Index_Typ := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+ Index_Typ := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
Append (
Make_Subtype_Declaration (Loc,
@@ -7820,23 +8006,22 @@ package body Exp_Ch9 is
(Protect_Rec : Entity_Id)
return List_Id
is
- Loc : constant Source_Ptr := Sloc (Protect_Rec);
- P_Arr : Entity_Id;
- Pdef : Node_Id;
- Pdec : Node_Id;
- Ptyp : Node_Id;
- Pnam : Name_Id;
- Args : List_Id;
- L : List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Protect_Rec);
+ P_Arr : Entity_Id;
+ Pdef : Node_Id;
+ Pdec : Node_Id;
+ Ptyp : constant Node_Id :=
+ Corresponding_Concurrent_Type (Protect_Rec);
+ Args : List_Id;
+ L : constant List_Id := New_List;
+ Has_Entry : constant Boolean := Has_Entries (Ptyp);
+ Restricted : constant Boolean := Restricted_Profile;
begin
-- We may need two calls to properly initialize the object, one
-- to Initialize_Protection, and possibly one to Install_Handlers
-- if we have a pragma Attach_Handler.
- Ptyp := Corresponding_Concurrent_Type (Protect_Rec);
- Pnam := Chars (Ptyp);
-
-- Get protected declaration. In the case of a task type declaration,
-- this is simply the parent of the protected type entity.
-- In the single protected object
@@ -7886,8 +8071,11 @@ package body Exp_Ch9 is
and then Has_Priority_Pragma (Pdef)
then
Append_To (Args,
- Duplicate_Subexpr (Expression (First (Pragma_Argument_Associations
- (Find_Task_Or_Protected_Pragma (Pdef, Name_Priority))))));
+ Duplicate_Subexpr_No_Checks
+ (Expression
+ (First
+ (Pragma_Argument_Associations
+ (Find_Task_Or_Protected_Pragma (Pdef, Name_Priority))))));
elsif Has_Interrupt_Handler (Ptyp)
or else Has_Attach_Handler (Ptyp)
@@ -7904,7 +8092,7 @@ package body Exp_Ch9 is
New_Reference_To (RTE (RE_Unspecified_Priority), Loc));
end if;
- if Has_Entries (Ptyp)
+ if Has_Entry
or else Has_Interrupt_Handler (Ptyp)
or else Has_Attach_Handler (Ptyp)
then
@@ -7913,12 +8101,14 @@ package body Exp_Ch9 is
-- It is a pointer to the record generated by the compiler to
-- represent the protected object.
- Append_To (Args,
- Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Attribute_Name => Name_Address));
+ if Has_Entry or else not Restricted then
+ Append_To (Args,
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Attribute_Name => Name_Address));
+ end if;
- if Has_Entries (Ptyp) then
+ if Has_Entry then
-- Entry_Bodies parameter. This is a pointer to an array of
-- pointers to the entry body procedures and barrier functions
-- of the object. If the protected type has no entries this
@@ -7948,7 +8138,7 @@ package body Exp_Ch9 is
Attribute_Name => Name_Unrestricted_Access));
end if;
- else
+ elsif not Restricted then
Append_To (Args, Make_Null (Loc));
Append_To (Args, Make_Null (Loc));
end if;
@@ -7963,6 +8153,13 @@ package body Exp_Ch9 is
RTE (RE_Initialize_Protection_Entries), Loc),
Parameter_Associations => Args));
+ elsif not Has_Entry and then Restricted then
+ Append_To (L,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (
+ RTE (RE_Initialize_Protection), Loc),
+ Parameter_Associations => Args));
+
else
Append_To (L,
Make_Procedure_Call_Statement (Loc,
@@ -7984,22 +8181,27 @@ package body Exp_Ch9 is
-- and we have to make the following call:
-- Install_Handlers (_object,
-- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
+ -- or, in the case of Ravenscar:
+ -- Install_Handlers
+ -- ((Expr1, Proc1'access), ...., (ExprN, ProcN'access));
declare
- Args : List_Id := New_List;
- Table : List_Id := New_List;
+ Args : constant List_Id := New_List;
+ Table : constant List_Id := New_List;
Ritem : Node_Id := First_Rep_Item (Ptyp);
begin
- -- Appends the _object argument
+ if not Restricted then
+ -- Appends the _object argument
- Append_To (Args,
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => Make_Identifier (Loc, Name_uObject)),
- Attribute_Name => Name_Unchecked_Access));
+ Append_To (Args,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name => Make_Identifier (Loc, Name_uObject)),
+ Attribute_Name => Name_Unchecked_Access));
+ end if;
-- Build the Attach_Handler table argument
@@ -8008,19 +8210,23 @@ package body Exp_Ch9 is
and then Chars (Ritem) = Name_Attach_Handler
then
declare
- Handler : Node_Id :=
+ Handler : constant Node_Id :=
First (Pragma_Argument_Associations (Ritem));
- Interrupt : Node_Id :=
+ Interrupt : constant Node_Id :=
Next (Handler);
+ Expr : Node_Id := Expression (Interrupt);
begin
+
Append_To (Table,
Make_Aggregate (Loc, Expressions => New_List (
- Duplicate_Subexpr (Expression (Interrupt)),
+ Unchecked_Convert_To
+ (RTE (RE_System_Interrupt_Id), Expr),
Make_Attribute_Reference (Loc,
Prefix => Make_Selected_Component (Loc,
Make_Identifier (Loc, Name_uInit),
- Duplicate_Subexpr (Expression (Handler))),
+ Duplicate_Subexpr_No_Checks
+ (Expression (Handler))),
Attribute_Name => Name_Access))));
end;
end if;
@@ -8201,7 +8407,7 @@ package body Exp_Ch9 is
Append_To (Args, Make_Identifier (Loc, Name_uChain));
- -- Task name parameter. Take this from the _Task_Info parameter to the
+ -- Task name parameter. Take this from the _Task_Id parameter to the
-- init call unless there is a Task_Name pragma, in which case we take
-- the value from the pragma.
@@ -8209,12 +8415,14 @@ package body Exp_Ch9 is
and then Has_Task_Name_Pragma (Tdef)
then
Append_To (Args,
- Make_Selected_Component (Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => Make_Identifier (Loc, Name_uTask_Info)));
+ New_Copy (
+ Expression (First (
+ Pragma_Argument_Associations (
+ Find_Task_Or_Protected_Pragma
+ (Tdef, Name_Task_Name))))));
else
- Append_To (Args, Make_Identifier (Loc, Name_uTask_Id));
+ Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
end if;
-- Created_Task parameter. This is the _Task_Id field of the task
@@ -8278,6 +8486,7 @@ package body Exp_Ch9 is
Set_Ekind (D_Minal, E_Constant);
Set_Etype (D_Minal, Etype (D));
+ Set_Scope (D_Minal, Pdef);
Set_Discriminal (D, D_Minal);
Set_Discriminal_Link (D_Minal, D);
@@ -8306,8 +8515,7 @@ package body Exp_Ch9 is
Prec_Def : constant Entity_Id := Type_Definition (Prec_Decl);
Obj_Decl : Node_Id;
P_Subtype : Entity_Id;
- New_Decl : Entity_Id;
- Assoc_L : Elist_Id := New_Elmt_List;
+ Assoc_L : constant Elist_Id := New_Elmt_List;
Op_Id : Entity_Id;
begin
@@ -8350,8 +8558,8 @@ package body Exp_Ch9 is
Op_Id := Defining_Unit_Name (Specification (Op));
end if;
- New_Decl := New_Copy_Tree (P_Decl, Assoc_L,
- New_Scope => Op_Id);
+ Discard_Node
+ (New_Copy_Tree (P_Decl, Assoc_L, New_Scope => Op_Id));
end if;
Set_Protected_Operation (P_Id, Op);
@@ -8388,7 +8596,6 @@ package body Exp_Ch9 is
Set_Etype (Priv, P_Subtype);
Set_Is_Aliased (Priv);
Set_Object_Ref (Body_Ent, Priv);
-
end Set_Privals;
----------------------------
@@ -8406,6 +8613,10 @@ package body Exp_Ch9 is
-- determinants of the protected object, and need to be processed
-- separately because they are not attached to the tree.
+ procedure Update_Index_Types (N : Node_Id);
+ -- Similarly, update the types of expressions in indexed components
+ -- which may depend on other discriminants.
+
-------------
-- Process --
-------------
@@ -8414,7 +8625,7 @@ package body Exp_Ch9 is
begin
if Is_Entity_Name (N) then
declare
- E : Entity_Id := Entity (N);
+ E : constant Entity_Id := Entity (N);
begin
if Present (E)
@@ -8425,37 +8636,7 @@ package body Exp_Ch9 is
and then Etype (N) /= Etype (E)
then
Set_Etype (N, Etype (Entity (Original_Node (N))));
-
- -- If the prefix has an actual subtype that is different
- -- from the nominal one, update the types of the indices,
- -- so that the proper constraints are applied. Do not
- -- apply this transformation to a packed array, where the
- -- index type is computed for a byte array and is different
- -- from the source index.
-
- if Nkind (Parent (N)) = N_Indexed_Component
- and then
- not Is_Bit_Packed_Array (Etype (Prefix (Parent (N))))
- then
- declare
- Indx1 : Node_Id;
- I_Typ : Node_Id;
-
- begin
- Indx1 := First (Expressions (Parent (N)));
- I_Typ := First_Index (Etype (N));
-
- while Present (Indx1) and then Present (I_Typ) loop
-
- if not Is_Entity_Name (Indx1) then
- Set_Etype (Indx1, Base_Type (Etype (I_Typ)));
- end if;
-
- Next (Indx1);
- Next_Index (I_Typ);
- end loop;
- end;
- end if;
+ Update_Index_Types (N);
elsif Present (E)
and then Ekind (E) = E_Constant
@@ -8497,6 +8678,7 @@ package body Exp_Ch9 is
and then Has_Discriminants (Etype (Prefix (N)))
then
Set_Etype (N, Base_Type (Etype (N)));
+ Update_Index_Types (N);
return OK;
else
@@ -8534,6 +8716,40 @@ package body Exp_Ch9 is
end loop;
end Update_Array_Bounds;
+ ------------------------
+ -- Update_Index_Types --
+ ------------------------
+
+ procedure Update_Index_Types (N : Node_Id) is
+ Indx1 : Node_Id;
+ I_Typ : Node_Id;
+ begin
+ -- If the prefix has an actual subtype that is different
+ -- from the nominal one, update the types of the indices,
+ -- so that the proper constraints are applied. Do not
+ -- apply this transformation to a packed array, where the
+ -- index type is computed for a byte array and is different
+ -- from the source index.
+
+ if Nkind (Parent (N)) = N_Indexed_Component
+ and then
+ not Is_Bit_Packed_Array (Etype (Prefix (Parent (N))))
+ then
+ Indx1 := First (Expressions (Parent (N)));
+ I_Typ := First_Index (Etype (N));
+
+ while Present (Indx1) and then Present (I_Typ) loop
+
+ if not Is_Entity_Name (Indx1) then
+ Set_Etype (Indx1, Base_Type (Etype (I_Typ)));
+ end if;
+
+ Next (Indx1);
+ Next_Index (I_Typ);
+ end loop;
+ end if;
+ end Update_Index_Types;
+
procedure Traverse is new Traverse_Proc;
-- Start of processing for Update_Prival_Subtypes
diff --git a/gcc/ada/exp_code.adb b/gcc/ada/exp_code.adb
index 421fa5d05c1..775a937dd81 100644
--- a/gcc/ada/exp_code.adb
+++ b/gcc/ada/exp_code.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -170,7 +170,7 @@ package body Exp_Code is
return Get_String_Node (Temp);
else
- Error_Msg_N ("asm template argument is not static", Temp);
+ Flag_Non_Static_Expr ("asm template argument is not static!", Temp);
return Empty;
end if;
end Asm_Template;
@@ -242,7 +242,7 @@ package body Exp_Code is
begin
if not Is_OK_Static_Expression (Clob) then
- Error_Msg_N ("asm clobber argument is not static", Clob);
+ Flag_Non_Static_Expr ("asm clobber argument is not static!", Clob);
Clobber_Node := Empty;
else
@@ -399,7 +399,7 @@ package body Exp_Code is
begin
if not Is_OK_Static_Expression (Vol) then
- Error_Msg_N ("asm volatile argument is not static", Vol);
+ Flag_Non_Static_Expr ("asm volatile argument is not static!", Vol);
return False;
else
diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb
index 251ee5fb464..9e7bcc0eeab 100644
--- a/gcc/ada/exp_dbug.adb
+++ b/gcc/ada/exp_dbug.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -28,14 +28,10 @@ with Alloc; use Alloc;
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
-with Exp_Util; use Exp_Util;
-with Freeze; use Freeze;
-with Lib; use Lib;
-with Hostparm; use Hostparm;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
-with Opt; use Opt;
+with Opt;
with Output; use Output;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
@@ -46,8 +42,6 @@ with Stringt; use Stringt;
with Table;
with Urealp; use Urealp;
-with GNAT.HTable;
-
package body Exp_Dbug is
-- The following table is used to queue up the entities passed as
@@ -62,36 +56,6 @@ package body Exp_Dbug is
Table_Increment => Alloc.Name_Qualify_Units_Increment,
Table_Name => "Name_Qualify_Units");
- -- Define hash table for compressed debug names
-
- -- This hash table keeps track of qualification prefix strings
- -- that have been compressed. The element is the corresponding
- -- hash value used in the compressed symbol.
-
- type Hindex is range 0 .. 4096;
- -- Type to define range of headers
-
- function SHash (S : String_Ptr) return Hindex;
- -- Hash function for this table
-
- function SEq (F1, F2 : String_Ptr) return Boolean;
- -- Equality function for this table
-
- type Elmt is record
- W : Word;
- S : String_Ptr;
- end record;
-
- No_Elmt : Elmt := (0, null);
-
- package CDN is new GNAT.HTable.Simple_HTable (
- Header_Num => Hindex,
- Element => Elmt,
- No_Element => No_Elmt,
- Key => String_Ptr,
- Hash => SHash,
- Equal => SEq);
-
--------------------------------
-- Use of Qualification Flags --
--------------------------------
@@ -169,23 +133,6 @@ package body Exp_Dbug is
-- Determine whether the bounds of E match the size of the type. This is
-- used to determine whether encoding is required for a discrete type.
- function CDN_Hash (S : String) return Word;
- -- This is the hash function used to compress debug symbols. The string
- -- S is the prefix which is a list of qualified names separated by double
- -- underscore (no trailing double underscore). The returned value is the
- -- hash value used in the compressed names. It is also used for the hash
- -- table used to keep track of what prefixes have been compressed so far.
-
- procedure Compress_Debug_Name (E : Entity_Id);
- -- If the name of the entity E is too long, or compression is to be
- -- attempted on all names (Compress_Debug_Names set), then an attempt
- -- is made to compress the name of the entity.
-
- function Double_Underscore (S : String; J : Natural) return Boolean;
- -- Returns True if J is the start of a double underscore
- -- sequence in the string S (defined as two underscores
- -- which are preceded and followed by a non-underscore)
-
procedure Output_Homonym_Numbers_Suffix;
-- If homonym numbers are stored, then output them into Name_Buffer.
@@ -196,9 +143,6 @@ package body Exp_Dbug is
procedure Prepend_Uint_To_Buffer (U : Uint);
-- Prepend image of universal integer to Name_Buffer, updating Name_Len
- procedure Put_Hex (W : Word; N : Natural);
- -- Output W as 8 hex digits (0-9, a-f) in Name_Buffer (N .. N + 7)
-
procedure Qualify_Entity_Name (Ent : Entity_Id);
-- If not already done, replaces the Chars field of the given entity
-- with the appropriate fully qualified name.
@@ -273,7 +217,7 @@ package body Exp_Dbug is
begin
while Present (H) loop
- if (Scope (H) = Scope (E)) then
+ if Scope (H) = Scope (E) then
Nr := Nr + 1;
end if;
@@ -345,108 +289,6 @@ package body Exp_Dbug is
end if;
end Bounds_Match_Size;
- --------------
- -- CDN_Hash --
- --------------
-
- function CDN_Hash (S : String) return Word is
- H : Word;
-
- function Rotate_Left (Value : Word; Amount : Natural) return Word;
- pragma Import (Intrinsic, Rotate_Left);
-
- begin
- H := 0;
- for J in S'Range loop
- H := Rotate_Left (H, 3) + Character'Pos (S (J));
- end loop;
-
- return H;
- end CDN_Hash;
-
- -------------------------
- -- Compress_Debug_Name --
- -------------------------
-
- procedure Compress_Debug_Name (E : Entity_Id) is
- Ptr : Natural;
- Sptr : String_Ptr;
- Cod : Word;
-
- begin
- if not Compress_Debug_Names
- and then Length_Of_Name (Chars (E)) <= Max_Debug_Name_Length
- then
- return;
- end if;
-
- Get_Name_String (Chars (E));
-
- -- Find rightmost double underscore
-
- Ptr := Name_Len - 2;
- loop
- exit when Double_Underscore (Name_Buffer, Ptr);
-
- -- Cannot compress if no double underscore anywhere
-
- if Ptr < 2 then
- return;
- end if;
-
- Ptr := Ptr - 1;
- end loop;
-
- -- At this stage we have
-
- -- Name_Buffer (1 .. Ptr - 1) string to compress
- -- Name_Buffer (Ptr) underscore
- -- Name_Buffer (Ptr + 1) underscore
- -- Name_Buffer (Ptr + 2 .. Name_Len) simple name to retain
-
- -- See if we already have an entry for the compression string
-
- -- No point in compressing if it does not make things shorter
-
- if Name_Len <= (2 + 8 + 1) + (Name_Len - (Ptr + 1)) then
- return;
- end if;
-
- -- Do not compress any reference to entity in internal file
-
- if Name_Buffer (1 .. 5) = "ada__"
- or else
- Name_Buffer (1 .. 8) = "system__"
- or else
- Name_Buffer (1 .. 6) = "gnat__"
- or else
- Name_Buffer (1 .. 12) = "interfaces__"
- or else
- (OpenVMS and then Name_Buffer (1 .. 5) = "dec__")
- then
- return;
- end if;
-
- Sptr := Name_Buffer (1 .. Ptr - 1)'Unrestricted_Access;
- Cod := CDN.Get (Sptr).W;
-
- if Cod = 0 then
- Cod := CDN_Hash (Sptr.all);
- Sptr := new String'(Sptr.all);
- CDN.Set (Sptr, (Cod, Sptr));
- end if;
-
- Name_Buffer (1) := 'X';
- Name_Buffer (2) := 'C';
- Put_Hex (Cod, 3);
- Name_Buffer (11) := '_';
- Name_Buffer (12 .. Name_Len - Ptr + 10) :=
- Name_Buffer (Ptr + 2 .. Name_Len);
- Name_Len := Name_Len - Ptr + 10;
-
- Set_Chars (E, Name_Enter);
- end Compress_Debug_Name;
-
--------------------------------
-- Debug_Renaming_Declaration --
--------------------------------
@@ -496,7 +338,9 @@ package body Exp_Dbug is
-- Start of processing for Debug_Renaming_Declaration
begin
- if not Comes_From_Source (N) then
+ if not Comes_From_Source (N)
+ and then not Needs_Debug_Info (Ent)
+ then
return Empty;
end if;
@@ -628,132 +472,6 @@ package body Exp_Dbug is
return Make_Null_Statement (Loc);
end Debug_Renaming_Declaration;
- -----------------------
- -- Double_Underscore --
- -----------------------
-
- function Double_Underscore (S : String; J : Natural) return Boolean is
- begin
- if J = S'First or else J > S'Last - 2 then
- return False;
-
- else
- return S (J) = '_'
- and then S (J + 1) = '_'
- and then S (J - 1) /= '_'
- and then S (J + 2) /= '_';
- end if;
- end Double_Underscore;
-
- ------------------------------
- -- Generate_Auxiliary_Types --
- ------------------------------
-
- -- Note: right now there is only one auxiliary type to be generated,
- -- namely the enumeration type for the compression sequences if used.
-
- procedure Generate_Auxiliary_Types is
- Loc : constant Source_Ptr := Sloc (Cunit (Current_Sem_Unit));
- E : Elmt;
- Code : Entity_Id;
- Lit : Entity_Id;
- Start : Natural;
- Ptr : Natural;
- Discard : List_Id;
-
- Literal_List : List_Id := New_List;
- -- Gathers the list of literals for the declaration
-
- procedure Output_Literal;
- -- Adds suffix of form Xnnn to name in Name_Buffer, where nnn is
- -- a serial number that is one greater on each call, and then
- -- builds an enumeration literal and adds it to the literal list.
-
- Serial : Nat := 0;
- -- Current serial number
-
- procedure Output_Literal is
- begin
- Serial := Serial + 1;
- Add_Char_To_Name_Buffer ('X');
- Add_Nat_To_Name_Buffer (Serial);
-
- Lit :=
- Make_Defining_Identifier (Loc,
- Chars => Name_Find);
- Set_Has_Qualified_Name (Lit, True);
- Append (Lit, Literal_List);
- end Output_Literal;
-
- -- Start of processing for Auxiliary_Types
-
- begin
- E := CDN.Get_First;
- if E.S /= null then
- while E.S /= null loop
-
- -- We have E.S a String_Ptr that contains a string of the form:
-
- -- b__c__d
-
- -- In E.W is a 32-bit word representing the hash value
-
- -- Our mission is to construct a type
-
- -- type XChhhhhhhh is (b,c,d);
-
- -- where hhhhhhhh is the 8 hex digits of the E.W value.
- -- and append this type declaration to the result list
-
- Name_Buffer (1) := 'X';
- Name_Buffer (2) := 'C';
- Put_Hex (E.W, 3);
- Name_Len := 10;
- Output_Literal;
-
- Start := E.S'First;
- Ptr := E.S'First;
- while Ptr <= E.S'Last loop
- if Ptr = E.S'Last
- or else Double_Underscore (E.S.all, Ptr + 1)
- then
- Name_Len := Ptr - Start + 1;
- Name_Buffer (1 .. Name_Len) := E.S (Start .. Ptr);
- Output_Literal;
- Start := Ptr + 3;
- Ptr := Start;
- else
- Ptr := Ptr + 1;
- end if;
- end loop;
-
- E := CDN.Get_Next;
- end loop;
-
- Name_Buffer (1) := 'X';
- Name_Buffer (2) := 'C';
- Name_Len := 2;
-
- Code :=
- Make_Defining_Identifier (Loc,
- Chars => Name_Find);
- Set_Has_Qualified_Name (Code, True);
-
- Insert_Library_Level_Action (
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Code,
- Type_Definition =>
- Make_Enumeration_Type_Definition (Loc,
- Literals => Literal_List)));
-
- -- We have to manually freeze this entity, since it is inserted
- -- very late on into the tree, and otherwise will not be frozen.
- -- No freeze actions are generated, so we can discard the result.
-
- Discard := Freeze_Entity (Code, Loc);
- end if;
- end Generate_Auxiliary_Types;
-
----------------------
-- Get_Encoded_Name --
----------------------
@@ -835,8 +553,8 @@ package body Exp_Dbug is
Lo : constant Node_Id := Type_Low_Bound (E);
Hi : constant Node_Id := Type_High_Bound (E);
- Lo_Stat : constant Boolean := Is_OK_Static_Expression (Lo);
- Hi_Stat : constant Boolean := Is_OK_Static_Expression (Hi);
+ Lo_Con : constant Boolean := Compile_Time_Known_Value (Lo);
+ Hi_Con : constant Boolean := Compile_Time_Known_Value (Hi);
Lo_Discr : constant Boolean :=
Nkind (Lo) = N_Identifier
@@ -848,8 +566,8 @@ package body Exp_Dbug is
and then
Ekind (Entity (Hi)) = E_Discriminant;
- Lo_Encode : constant Boolean := Lo_Stat or Lo_Discr;
- Hi_Encode : constant Boolean := Hi_Stat or Hi_Discr;
+ Lo_Encode : constant Boolean := Lo_Con or Lo_Discr;
+ Hi_Encode : constant Boolean := Hi_Con or Hi_Discr;
begin
if Lo_Encode or Hi_Encode then
@@ -863,7 +581,7 @@ package body Exp_Dbug is
Add_Str_To_Name_Buffer ("U_");
end if;
- if Lo_Stat then
+ if Lo_Con then
Add_Uint_To_Buffer (Expr_Rep_Value (Lo));
elsif Lo_Discr then
Get_Name_String_And_Append (Chars (Entity (Lo)));
@@ -873,7 +591,7 @@ package body Exp_Dbug is
Add_Str_To_Name_Buffer ("__");
end if;
- if Hi_Stat then
+ if Hi_Con then
Add_Uint_To_Buffer (Expr_Rep_Value (Hi));
elsif Hi_Discr then
Get_Name_String_And_Append (Chars (Entity (Hi)));
@@ -963,14 +681,6 @@ package body Exp_Dbug is
and then No (Address_Clause (E))
and then not Has_Suffix
then
- -- The following code needs explanation ???
-
- if Convention (E) = Convention_Stdcall
- and then Ekind (E) = E_Variable
- then
- Add_Str_To_Name_Buffer ("_imp__");
- end if;
-
Add_String_To_Name_Buffer (Strval (Interface_Name (E)));
-- All other cases besides the interface name case
@@ -996,6 +706,10 @@ package body Exp_Dbug is
if Is_Generic_Instance (E)
and then Is_Subprogram (E)
and then not Is_Compilation_Unit (Scope (E))
+ and then (Ekind (Scope (E)) = E_Package
+ or else
+ Ekind (Scope (E)) = E_Package_Body)
+ and then Present (Related_Instance (Scope (E)))
then
E := Related_Instance (Scope (E));
end if;
@@ -1015,7 +729,23 @@ package body Exp_Dbug is
Suffix : String)
is
Has_Suffix : constant Boolean := (Suffix /= "");
+ use type Opt.Operating_Mode_Type;
+
begin
+ if Opt.Operating_Mode /= Opt.Generate_Code then
+
+ -- If we are not in code generation mode, we still may call this
+ -- procedure from Back_End (more specifically - from gigi for doing
+ -- type representation annotation or some representation-specific
+ -- checks). But in this mode there is no need to mess with external
+ -- names. Furthermore, the call causes difficulties in this case
+ -- because the string representing the homonym number is not
+ -- correctly reset as a part of the call to
+ -- Output_Homonym_Numbers_Suffix (which is not called in gigi)
+
+ return;
+ end if;
+
Get_External_Name (Entity, Has_Suffix);
if Has_Suffix then
@@ -1190,7 +920,6 @@ package body Exp_Dbug is
procedure Prepend_String_To_Buffer (S : String) is
N : constant Integer := S'Length;
-
begin
Name_Buffer (1 + N .. Name_Len + N) := Name_Buffer (1 .. Name_Len);
Name_Buffer (1 .. N) := S;
@@ -1212,24 +941,6 @@ package body Exp_Dbug is
end if;
end Prepend_Uint_To_Buffer;
- -------------
- -- Put_Hex --
- -------------
-
- procedure Put_Hex (W : Word; N : Natural) is
- Hex : constant array (Word range 0 .. 15) of Character :=
- "0123456789abcdef";
-
- Cod : Word;
-
- begin
- Cod := W;
- for J in reverse N .. N + 7 loop
- Name_Buffer (J) := Hex (Cod and 16#F#);
- Cod := Cod / 16;
- end loop;
- end Put_Hex;
-
------------------------------
-- Qualify_All_Entity_Names --
------------------------------
@@ -1255,20 +966,6 @@ package body Exp_Dbug is
exit when Ent = E;
end loop;
end loop;
-
- -- Second loop compresses any names that need compressing
-
- for J in Name_Qualify_Units.First .. Name_Qualify_Units.Last loop
- E := Defining_Entity (Name_Qualify_Units.Table (J));
- Compress_Debug_Name (E);
-
- Ent := First_Entity (E);
- while Present (Ent) loop
- Compress_Debug_Name (Ent);
- Next_Entity (Ent);
- exit when Ent = E;
- end loop;
- end loop;
end Qualify_All_Entity_Names;
-------------------------
@@ -1367,11 +1064,26 @@ package body Exp_Dbug is
Get_Name_String (Chars (E));
end if;
- Full_Qualify_Name
- (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
- Name_Buffer (1 .. Name_Len);
- Full_Qualify_Len := Full_Qualify_Len + Name_Len;
- Append_Homonym_Number (E);
+ -- A special check here, we never add internal block or loop
+ -- names, since they intefere with debugging. We identify these
+ -- by the fact that they start with an upper case B or L.
+ -- But do add these if what we are qualifying is a __clean
+ -- procedure since those need to be made unique.
+
+ if (Name_Buffer (1) = 'B' or else Name_Buffer (1) = 'L')
+ and then (not Debug_Flag_VV)
+ and then Full_Qualify_Len > 2
+ and then Chars (Ent) /= Name_uClean
+ then
+ Full_Qualify_Len := Full_Qualify_Len - 2;
+
+ else
+ Full_Qualify_Name
+ (Full_Qualify_Len + 1 .. Full_Qualify_Len + Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
+ Full_Qualify_Len := Full_Qualify_Len + Name_Len;
+ Append_Homonym_Number (E);
+ end if;
end if;
if Is_BNPE (E) then
@@ -1499,7 +1211,7 @@ package body Exp_Dbug is
and then Present (Debug_Renaming_Link (Ent))
then
Name_Len := 0;
- Set_Entity_Name (Debug_Renaming_Link (Ent));
+ Qualify_Entity_Name (Debug_Renaming_Link (Ent));
Get_Name_String (Chars (Ent));
Prepend_String_To_Buffer
(Get_Name_String (Chars (Debug_Renaming_Link (Ent))));
@@ -1566,25 +1278,6 @@ package body Exp_Dbug is
Name_Qualify_Units.Append (N);
end Qualify_Entity_Names;
- ---------
- -- SEq --
- ---------
-
- function SEq (F1, F2 : String_Ptr) return Boolean is
- begin
- return F1.all = F2.all;
- end SEq;
-
- -----------
- -- SHash --
- -----------
-
- function SHash (S : String_Ptr) return Hindex is
- begin
- return Hindex
- (Hindex'First + Hindex (CDN_Hash (S.all) mod Hindex'Range_Length));
- end SHash;
-
--------------------
-- Strip_Suffixes --
--------------------
diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads
index 951ccc33a30..d17f14b0814 100644
--- a/gcc/ada/exp_dbug.ads
+++ b/gcc/ada/exp_dbug.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -30,7 +30,6 @@
with Types; use Types;
with Uintp; use Uintp;
-with Get_Targ; use Get_Targ;
package Exp_Dbug is
@@ -362,28 +361,46 @@ package Exp_Dbug is
-- the type, the string "PT", and a suffix which is P or N, depending on
-- whether this is the protected/non-locking version of the operation.
+ -- Operations generated for protected entries follow the same encoding.
+ -- Each entry results in two suprograms: a procedure that holds the
+ -- entry body, and a function that holds the evaluation of the barrier.
+ -- The names of these subprograms include the prefix 'E' or 'B' res-
+ -- pectively. The names also include a numeric suffix to render them
+ -- unique in the presence of overloaded entries.
+
-- Given the declaration:
- -- protected type lock is
- -- function get return integer;
- -- procedure set (x: integer);
+ -- protected type Lock is
+ -- function Get return Integer;
+ -- procedure Set (X: Integer);
+ -- entry Update (Val : Integer);
-- private
- -- value : integer := 0;
- -- end lock;
+ -- Value : Integer := 0;
+ -- end Lock;
-- the following operations are created:
-- lockPT_getN
-- lockPT_getP,
+
-- lockPT_setN
-- lockPT_setP
+ -- lockPT_update1sE
+ -- lockPT_udpate2sB
+
----------------------------------------------------
-- Conversion between Entities and External Names --
----------------------------------------------------
- No_Dollar_In_Label : constant Boolean := Get_No_Dollar_In_Label;
- -- True iff the target allows dollar signs ("$") in external names
+ No_Dollar_In_Label : constant Boolean := True;
+ -- True iff the target does not allow dollar signs ("$") in external names
+ -- ??? We want to migrate all platforms to use the same convention.
+ -- As a first step, we force this constant to always be True. This
+ -- constant will eventually be deleted after we have verified that
+ -- the migration does not cause any unforseen adverse impact.
+ -- We chose "__" because it is supported on all platforms, which is
+ -- not the case of "$".
procedure Get_External_Name
(Entity : Entity_Id;
@@ -418,55 +435,9 @@ package Exp_Dbug is
-- by homonym suffix, if the entity is an overloaded subprogram
-- or is defined within an overloaded subprogram.
-- - the string "___" followed by Suffix
-
- ----------------------------
- -- Debug Name Compression --
- ----------------------------
-
- -- The full qualification of names can lead to long names, and this
- -- section describes the method used to compress these names. Such
- -- compression is attempted if one of the following holds:
-
- -- The length exceeds a maximum set in hostparm, currently set
- -- to 128, but can be changed as needed.
-
- -- The compiler switch -gnatC is set, setting the Compress_Debug_Names
- -- switch in Opt to True.
-
- -- If either of these conditions holds, name compression is attempted
- -- by replacing the qualifying section as follows.
-
- -- Given a name of the form
-
- -- a__b__c__d
-
- -- where a,b,c,d are arbitrary strings not containing a sequence
- -- of exactly two underscores, the name is rewritten as:
-
- -- XC????????_d
-
- -- where ???????? are 8 hex digits representing a 32-bit checksum
- -- value that identifies the sequence of compressed names. In
- -- addition a dummy type declaration is generated as shown by
- -- the following example. Supposed we have three compression
- -- sequences
-
- -- XC1234abcd corresponding to a__b__c__ prefix
- -- XCabcd1234 corresponding to a__b__ prefix
- -- XCab1234cd corresponding to a__ prefix
-
- -- then an enumeration type declaration is generated:
-
- -- type XC is
- -- (XC1234abcdXnn, aXnn, bXnn, cXnn,
- -- XCabcd1234Xnn, aXnn, bXnn,
- -- XCab1234cdXnn, aXnn);
-
- -- showing the meaning of each compressed prefix, so the debugger
- -- can interpret the exact sequence of names that correspond to the
- -- compressed sequence. The Xnn suffixes in the above are simply
- -- serial numbers that are guaranteed to be different to ensure
- -- that all names are unique, and are otherwise ignored.
+ --
+ -- If this procedure is called in the ASIS mode, it does nothing. See the
+ -- comments in the body for more details.
--------------------------------------------
-- Subprograms for Handling Qualification --
@@ -497,11 +468,6 @@ package Exp_Dbug is
-- are useful to remove qualification from a name qualified by the
-- call to Qualify_All_Entity_Names.
- procedure Generate_Auxiliary_Types;
- -- The process of qualifying names may result in name compression which
- -- requires dummy enumeration types to be generated. This subprogram
- -- ensures that these types are appropriately included in the tree.
-
--------------------------------
-- Handling of Numeric Values --
--------------------------------
@@ -597,13 +563,14 @@ package Exp_Dbug is
-- the case where one or both of the bounds are discriminants or
-- variable.
- -- Note: at the current time, we also encode static bounds if they
- -- do not match the natural machine type bounds, but this may be
- -- removed in the future, since it is redundant for most debugging
- -- formats. However, we do not ever need XD encoding for enumeration
- -- base types, since here it is always clear what the bounds are
- -- from the number of enumeration literals, and of course we do
- -- not need to encode the dummy XR types generated for renamings.
+ -- Note: at the current time, we also encode compile time known
+ -- bounds if they do not match the natural machine type bounds,
+ -- but this may be removed in the future, since it is redundant
+ -- for most debugging formats. However, we do not ever need XD
+ -- encoding for enumeration base types, since here it is always
+ -- clear what the bounds are from the total number of enumeration
+ -- literals, and of course we do not need to encode the dummy XR
+ -- types generated for renamings.
-- typ___XD
-- typ___XDL_lowerbound
@@ -614,7 +581,7 @@ package Exp_Dbug is
-- correspond in a natural manner to its size), then it is left
-- unencoded. The above encoding forms are used when there is a
-- constrained range that does not correspond to the size or that
- -- has discriminant references or other non-static bounds.
+ -- has discriminant references or other compile time known bounds.
-- The first form is used if both bounds are dynamic, in which case
-- two constant objects are present whose names are typ___L and
@@ -632,14 +599,15 @@ package Exp_Dbug is
-- name as either a decimal integer, or as the discriminant name.
-- The third form is similarly used if the lower bound is dynamic,
- -- but the upper bound is static or a discriminant reference, in
- -- which case the lower bound is stored in a constant object of
- -- name typ___L, and the upper bound is encoded directly into the
- -- name as either a decimal integer, or as the discriminant name.
+ -- but the upper bound is compile time known or a discriminant
+ -- reference, in which case the lower bound is stored in a constant
+ -- object of name typ___L, and the upper bound is encoded directly
+ -- into the name as either a decimal integer, or as the discriminant
+ -- name.
-- The fourth form is used if both bounds are discriminant references
- -- or static values, with the encoding first for the lower bound,
- -- then for the upper bound, as previously described.
+ -- or compile time known values, with the encoding first for the lower
+ -- bound, then for the upper bound, as previously described.
-------------------
-- Modular Types --
@@ -668,9 +636,9 @@ package Exp_Dbug is
-- Here lowerbound and upperbound are decimal integers, with the
-- usual (postfix "m") encoding for negative numbers. Biased
- -- types are only possible where the bounds are static, and the
- -- values are represented as unsigned offsets from the lower
- -- bound given. For example:
+ -- types are only possible where the bounds are compile time
+ -- known, and the values are represented as unsigned offsets
+ -- from the lower bound given. For example:
-- type Q is range 10 .. 15;
-- for Q'size use 3;
@@ -692,9 +660,10 @@ package Exp_Dbug is
-- type___XVU
-- The former name is used for a record and the latter for the union
- -- that is made for a variant record (see below) if that union has
- -- variable size. These encodings suffix any other encodings that
- -- might be suffixed to the type name.
+ -- that is made for a variant record (see below) if that record or
+ -- union has a field of variable size or if the record or union itself
+ -- has a variable size. These encodings suffix any other encodings that
+ -- that might be suffixed to the type name.
-- The idea here is to provide all the needed information to interpret
-- objects of the original type in the form of a "fixed up" type, which
@@ -1193,16 +1162,26 @@ package Exp_Dbug is
-- Thin Pointers
- -- Thin pointers are represented as a pointer to the ARRAY field of
- -- a structure with two fields. The name of the structure type is
- -- that of the unconstrained array followed by "___XUT".
-
- -- The field ARRAY contains the array value. This array field is
- -- typically a variable-length array, and consequently the entire
- -- record structure will be encoded as previously described,
- -- resulting in a type with suffix "___XUT___XVE".
-
- -- The field BOUNDS is a struct containing the bounds as above.
+ -- The value of a thin pointer is a pointer to the second field
+ -- of a structure with two fields. The name of this structure's
+ -- type is "arr___XUT", where "arr" is the name of the
+ -- unconstrained array type. Even though it actually points into
+ -- middle of this structure, the thin pointer's type in debugging
+ -- information is pointer-to-arr___XUT.
+
+ -- The first field of arr___XUT is named BOUNDS, and has a type
+ -- named arr___XUB, with the structure described for such types
+ -- in fat pointers, as described above.
+
+ -- The second field of arr___XUT is named ARRAY, and contains
+ -- the actual array. Because this array has a dynamic size,
+ -- determined by the BOUNDS field that precedes it, all of the
+ -- information about arr___XUT is encoded in a parallel type named
+ -- arr___XUT___XVE, with fields BOUNDS and ARRAY___XVL. As for
+ -- previously described ___XVE types, ARRAY___XVL has
+ -- a pointer-to-array type. However, the array type in this case
+ -- is named arr___XUA and only its element type is meaningful,
+ -- just as described for fat pointers.
--------------------------------------
-- Tagged Types and Type Extensions --
@@ -1360,4 +1339,19 @@ package Exp_Dbug is
-- the second enumeration literal would be named QU43 and the
-- value assigned to it would be 1.
+ ----------------------------
+ -- Effect of Optimization --
+ ----------------------------
+
+ -- If the program is compiled with optimization on (e.g. -O1 switch
+ -- specified), then there may be variations in the output from the
+ -- above specification. In particular, objects may disappear from
+ -- the output. This includes not only constants and variables that
+ -- the program declares at the source level, but also the x___L and
+ -- x___U constants created to describe the lower and upper bounds of
+ -- subtypes with dynamic bounds. This means for example, that array
+ -- bounds may disappear if optimization is turned on. The debugger
+ -- is expected to recognize that these constants are missing and
+ -- deal as best as it can with the limited information available.
+
end Exp_Dbug;
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index d1d161e92e0..0d203b6d289 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -166,10 +166,14 @@ package body Exp_Disp is
Eq_Prim_Op : Entity_Id := Empty;
function New_Value (From : Node_Id) return Node_Id;
- -- From is the original Expression. New_Value is equivalent to
- -- Duplicate_Subexpr with an explicit dereference when From is an
+ -- From is the original Expression. New_Value is equivalent to a call
+ -- to Duplicate_Subexpr with an explicit dereference when From is an
-- access parameter
+ ---------------
+ -- New_Value --
+ ---------------
+
function New_Value (From : Node_Id) return Node_Id is
Res : constant Node_Id := Duplicate_Subexpr (From);
@@ -278,7 +282,8 @@ package body Exp_Disp is
-- No tag check with itself
if Param = Ctrl_Arg then
- Append_To (New_Params, Duplicate_Subexpr (Param));
+ Append_To (New_Params,
+ Duplicate_Subexpr_Move_Checks (Param));
-- No tag check for parameter whose type is neither tagged nor
-- access to tagged (for access parameters)
@@ -294,11 +299,13 @@ package body Exp_Disp is
-- "=" is the only dispatching operation allowed to get
-- operands with incompatible tags (it just returns false).
- -- We use Duplicate_subexpr instead of relocate_node because
- -- the value will be duplicated to check the tags.
+ -- We use Duplicate_Subexpr_Move_Checks instead of calling
+ -- Relocate_Node because the value will be duplicated to
+ -- check the tags.
elsif Subp = Eq_Prim_Op then
- Append_To (New_Params, Duplicate_Subexpr (Param));
+ Append_To (New_Params,
+ Duplicate_Subexpr_Move_Checks (Param));
-- No check in presence of suppress flags
@@ -448,7 +455,7 @@ package body Exp_Disp is
-- Vptr
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Ctrl_Arg),
+ Prefix => Duplicate_Subexpr_Move_Checks (Ctrl_Arg),
Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)),
-- Position
@@ -572,6 +579,11 @@ package body Exp_Disp is
Old_TSD : Node_Id;
begin
+ if not RTE_Available (RE_Tag) then
+ Error_Msg_CRT ("tagged types", Typ);
+ return New_List;
+ end if;
+
if Is_CPP_Class (Root_Type (Typ)) then
Generalized_Tag := RTE (RE_Vtable_Ptr);
else
@@ -812,8 +824,13 @@ package body Exp_Disp is
-- for simple types with controlled components
-- Generate: Set_RC_Offset (DT_Ptr, type._record_controller'position);
-- for complex types with controlled components where the position
- -- of the record controller
+ -- of the record controller is not statically computable, if there are
+ -- controlled components at this level
-- Generate: Set_RC_Offset (DT_Ptr, -1);
+ -- to indicate that the _controller field is right after the _parent or
+ -- if there are no controlled components at this level,
+ -- Generate: Set_RC_Offset (DT_Ptr, -2);
+ -- to indicate that we need to get the position from the parent.
declare
Position : Node_Id;
@@ -823,8 +840,11 @@ package body Exp_Disp is
Position := Make_Integer_Literal (Loc, 0);
elsif Etype (Typ) /= Typ and then Has_Discriminants (Etype (Typ)) then
- Position := Make_Integer_Literal (Loc, -1);
-
+ if Has_New_Controlled_Component (Typ) then
+ Position := Make_Integer_Literal (Loc, -1);
+ else
+ Position := Make_Integer_Literal (Loc, -2);
+ end if;
else
Position :=
Make_Attribute_Reference (Loc,
@@ -835,7 +855,7 @@ package body Exp_Disp is
New_Reference_To (Controller_Component (Typ), Loc)),
Attribute_Name => Name_Position);
- -- This is not proper Ada code to use the attribute component
+ -- This is not proper Ada code to use the attribute 'Position
-- on something else than an object but this is supported by
-- the back end (see comment on the Bit_Component attribute in
-- sem_attr). So we avoid semantic checking here.
@@ -846,7 +866,6 @@ package body Exp_Disp is
Set_Etype (Selector_Name (Prefix (Position)),
RTE (RE_Record_Controller));
Set_Etype (Position, RTE (RE_Storage_Offset));
-
end if;
Append_To (Elab_Code,
@@ -899,13 +918,15 @@ package body Exp_Disp is
Attribute_Name => Name_Address))));
-- Generate code to register the Tag in the External_Tag hash
- -- table for the pure Ada type only. We skip this in No_Run_Time
- -- mode where the External_Tag attribute is not allowed anyway.
+ -- table for the pure Ada type only.
-- Register_Tag (Dt_Ptr);
- if Is_RTE (Generalized_Tag, RE_Tag)
- and then not No_Run_Time
+ -- Skip this if routine not available, or in No_Run_Time mode
+
+ if RTE_Available (RE_Register_Tag)
+ and then Is_RTE (Generalized_Tag, RE_Tag)
+ and then not No_Run_Time_Mode
then
Append_To (Elab_Code,
Make_Procedure_Call_Statement (Loc,
@@ -1149,22 +1170,30 @@ package body Exp_Disp is
-- each primitive operation. Perform some sanity checks to avoid
-- to build completely inconsistant dispatch tables.
- else
+ -- Note that the _Size primitive is always set at position 1 in order
+ -- to comply with the needs of Ada.Tags.Parent_Size (see documentation
+ -- in a-tags.ad?)
- Nb_Prim := 0;
+ else
+ Nb_Prim := 1;
Prim_Elmt := First_Prim;
while Present (Prim_Elmt) loop
Nb_Prim := Nb_Prim + 1;
Prim := Node (Prim_Elmt);
Set_DTC_Entity (Prim, The_Tag);
- Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
+
+ if Chars (Prim) = Name_uSize then
+ Set_DT_Position (Prim, Uint_1);
+ Nb_Prim := Nb_Prim - 1;
+ else
+ Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
+ end if;
if Chars (Prim) = Name_Finalize
- and then (Is_Predefined_File_Name
- (Unit_File_Name (Current_Sem_Unit))
- or else
- not Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Prim))))
+ and then
+ (Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
+ or else not Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Prim))))
then
Finalized := True;
end if;
@@ -1178,8 +1207,6 @@ package body Exp_Disp is
-- ridden. For explicit declarations this is checked at the point
-- of declaration, but for inherited operations it must be done
-- when building the dispatch table. Input is excluded because
- -- Limited_Controlled inherits a useless Input stream operation
- -- from Root_Controlled, which cannot be overridden.
if Is_Abstract (Typ)
and then Is_Abstract (Prim)
@@ -1190,10 +1217,21 @@ package body Exp_Disp is
= Private_Declarations
(Specification (Unit_Declaration_Node (Current_Scope)))
and then Original_View_In_Visible_Part (Typ)
- and then Chars (Prim) /= Name_uInput
then
- Error_Msg_NE ("abstract inherited private operation&"
- & " must be overriden", Parent (Typ), Prim);
+ -- We exclude Input and Output stream operations because
+ -- Limited_Controlled inherits useless Input and Output
+ -- stream operations from Root_Controlled, which can
+ -- never be overridden.
+
+ if not Is_TSS (Prim, TSS_Stream_Input)
+ and then
+ not Is_TSS (Prim, TSS_Stream_Output)
+ then
+ Error_Msg_NE
+ ("abstract inherited private operation&" &
+ " must be overridden ('R'M 3.9.3(10))",
+ Parent (Typ), Prim);
+ end if;
end if;
Next_Elmt (Prim_Elmt);
end loop;
@@ -1211,8 +1249,8 @@ package body Exp_Disp is
Set_DT_Entry_Count (The_Tag, UI_From_Int (Nb_Prim));
- -- The derived type must have at least as many components than
- -- its parent (for root types, the etype points back to itself
+ -- The derived type must have at least as many components as its
+ -- parent (for root types, the Etype points back to itself
-- and the test should not fail)
pragma Assert (
@@ -1229,7 +1267,6 @@ package body Exp_Disp is
Loc : Source_Ptr;
Init : Entity_Id;
Param : Entity_Id;
- Decl : Node_Id;
E : Entity_Id;
begin
@@ -1247,25 +1284,26 @@ package body Exp_Disp is
if Present (E) then
Loc := Sloc (E);
- Init := Make_Defining_Identifier (Loc, Name_uInit_Proc);
+ Init := Make_Defining_Identifier (Loc, Make_Init_Proc_Name (Typ));
Param := Make_Defining_Identifier (Loc, Name_X);
- Decl :=
+
+ Discard_Node (
Make_Subprogram_Declaration (Loc,
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Init,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Param,
- Parameter_Type => New_Reference_To (Typ, Loc)))));
+ Parameter_Type => New_Reference_To (Typ, Loc))))));
Set_Init_Proc (Typ, Init);
- Set_Is_Imported (Init);
+ Set_Is_Imported (Init);
Set_Interface_Name (Init, Interface_Name (E));
- Set_Convention (Init, Convention_C);
- Set_Is_Public (Init);
+ Set_Convention (Init, Convention_C);
+ Set_Is_Public (Init);
Set_Has_Completion (Init);
- -- if there are no constructors, mark the type as abstract since we
+ -- If there are no constructors, mark the type as abstract since we
-- won't be able to declare objects of that type.
else
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb
index 4dff14e076e..a5bab92cb04 100644
--- a/gcc/ada/exp_dist.adb
+++ b/gcc/ada/exp_dist.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- --
@@ -27,6 +27,7 @@
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
+with Exp_Strm; use Exp_Strm;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with GNAT.HTable; use GNAT.HTable;
@@ -145,6 +146,14 @@ package body Exp_Dist is
-- class-wide type before doing the real call using any of the RACW type
-- pointing on the designated type.
+ function Build_RPC_Receiver_Specification
+ (RPC_Receiver : Entity_Id;
+ Stream_Parameter : Entity_Id;
+ Result_Parameter : Entity_Id)
+ return Node_Id;
+ -- Make a subprogram specification for an RPC receiver,
+ -- with the given defining unit name and formal parameters.
+
function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
-- Return an ordered parameter list: unconstrained parameters are put
-- at the beginning of the list and constrained ones are put after. If
@@ -177,7 +186,7 @@ package body Exp_Dist is
function Pack_Entity_Into_Stream_Access
(Loc : Source_Ptr;
- Stream : Entity_Id;
+ Stream : Node_Id;
Object : Entity_Id;
Etyp : Entity_Id := Empty)
return Node_Id;
@@ -196,7 +205,7 @@ package body Exp_Dist is
function Pack_Node_Into_Stream_Access
(Loc : Source_Ptr;
- Stream : Entity_Id;
+ Stream : Node_Id;
Object : Node_Id;
Etyp : Entity_Id)
return Node_Id;
@@ -567,7 +576,6 @@ package body Exp_Dist is
Possibly_Asynchronous : Boolean;
begin
-
if not Expander_Active then
return;
end if;
@@ -588,7 +596,8 @@ package body Exp_Dist is
-- ones that are not remotely dispatching.
if Chars (Current_Primitive) /= Name_uSize
- and then Chars (Current_Primitive) /= Name_uDeep_Finalize
+ and then Chars (Current_Primitive) /= Name_uAlignment
+ and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize)
then
-- The first thing to do is build an up-to-date copy of
-- the spec with all the formals referencing Designated_Type
@@ -740,11 +749,6 @@ package body Exp_Dist is
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
- Proc_Spec : Node_Id;
- -- Specification and body of the currently built procedure
-
- Proc_Body_Spec : Node_Id;
-
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
@@ -767,12 +771,6 @@ package body Exp_Dist is
Source_Address : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
- Stream_Parameter : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('S'));
- Result : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('P'));
Stubbed_Result : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
@@ -782,6 +780,22 @@ package body Exp_Dist is
Asynchronous_Node : constant Node_Id :=
New_Occurrence_Of (Standard_False, Loc);
+ -- Functions to create occurrences of the formal
+ -- parameter names.
+
+ function Stream_Parameter return Node_Id;
+ function Result return Node_Id;
+
+ function Stream_Parameter return Node_Id is
+ begin
+ return Make_Identifier (Loc, Name_S);
+ end Stream_Parameter;
+
+ function Result return Node_Id is
+ begin
+ return Make_Identifier (Loc, Name_V);
+ end Result;
+
begin
-- Declare the asynchronous flag. This flag will be changed to True
-- whenever it is known that the RACW type is asynchronous. Also, the
@@ -828,7 +842,7 @@ package body Exp_Dist is
New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
- New_Occurrence_Of (Stream_Parameter, Loc),
+ Stream_Parameter,
New_Occurrence_Of (Source_Partition, Loc))),
Make_Attribute_Reference (Loc,
@@ -837,7 +851,7 @@ package body Exp_Dist is
Attribute_Name =>
Name_Read,
Expressions => New_List (
- New_Occurrence_Of (Stream_Parameter, Loc),
+ Stream_Parameter,
New_Occurrence_Of (Source_Receiver, Loc))),
Make_Attribute_Reference (Loc,
@@ -846,7 +860,7 @@ package body Exp_Dist is
Attribute_Name =>
Name_Read,
Expressions => New_List (
- New_Occurrence_Of (Stream_Parameter, Loc),
+ Stream_Parameter,
New_Occurrence_Of (Source_Address, Loc))));
-- If the Address is Null_Address, then return a null object
@@ -859,7 +873,7 @@ package body Exp_Dist is
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Result, Loc),
+ Name => Result,
Expression => Make_Null (Loc)),
Make_Return_Statement (Loc))));
@@ -868,7 +882,7 @@ package body Exp_Dist is
Local_Statements := New_List (
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Result, Loc),
+ Name => Result,
Expression =>
Unchecked_Convert_To (RACW_Type,
OK_Convert_To (RTE (RE_Address),
@@ -925,7 +939,7 @@ package body Exp_Dist is
Append_To (Remote_Statements,
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Result, Loc),
+ Name => Result,
Expression => Unchecked_Convert_To (RACW_Type,
New_Occurrence_Of (Stubbed_Result, Loc))));
@@ -944,71 +958,22 @@ package body Exp_Dist is
Then_Statements => Local_Statements,
Else_Statements => Remote_Statements));
- Proc_Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Procedure_Name),
+ Build_Stream_Procedure
+ (Loc, RACW_Type, Body_Node,
+ Make_Defining_Identifier (Loc, Procedure_Name),
+ Statements, Outp => True);
+ Set_Declarations (Body_Node, Decls);
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Stream_Parameter,
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc),
- Attribute_Name =>
- Name_Class))),
-
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Result,
- Out_Present => True,
- Parameter_Type =>
- New_Occurrence_Of (RACW_Type, Loc))));
-
- Proc_Body_Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Procedure_Name),
-
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars (Stream_Parameter)),
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc),
- Attribute_Name =>
- Name_Class))),
-
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars (Result)),
- Out_Present => True,
- Parameter_Type =>
- New_Occurrence_Of (RACW_Type, Loc))));
-
- Body_Node :=
- Make_Subprogram_Body (Loc,
- Specification => Proc_Body_Spec,
- Declarations => Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Statements));
-
- Proc_Decl :=
- Make_Subprogram_Declaration (Loc, Specification => Proc_Spec);
+ Proc_Decl := Make_Subprogram_Declaration (Loc,
+ Copy_Specification (Loc, Specification (Body_Node)));
Attr_Decl :=
Make_Attribute_Definition_Clause (Loc,
Name => New_Occurrence_Of (RACW_Type, Loc),
Chars => Name_Read,
Expression =>
- New_Occurrence_Of (Defining_Unit_Name (Proc_Spec), Loc));
+ New_Occurrence_Of (
+ Defining_Unit_Name (Specification (Proc_Decl)), Loc));
Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
Insert_After (Proc_Decl, Attr_Decl);
@@ -1052,16 +1017,11 @@ package body Exp_Dist is
Object_RPC_Receiver : in Entity_Id;
Declarations : in List_Id)
is
- Loc : constant Source_Ptr := Sloc (RACW_Type);
-
- Proc_Spec : Node_Id;
-
- Proc_Body_Spec : Node_Id;
-
- Body_Node : Node_Id;
+ Loc : constant Source_Ptr := Sloc (RACW_Type);
- Proc_Decl : Node_Id;
- Attr_Decl : Node_Id;
+ Body_Node : Node_Id;
+ Proc_Decl : Node_Id;
+ Attr_Decl : Node_Id;
Statements : List_Id;
Local_Statements : List_Id;
@@ -1070,12 +1030,21 @@ package body Exp_Dist is
Procedure_Name : constant Name_Id := New_Internal_Name ('R');
- Stream_Parameter : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('S'));
+ -- Functions to create occurrences of the formal
+ -- parameter names.
- Object : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ function Stream_Parameter return Node_Id;
+ function Object return Node_Id;
+
+ function Stream_Parameter return Node_Id is
+ begin
+ return Make_Identifier (Loc, Name_S);
+ end Stream_Parameter;
+
+ function Object return Node_Id is
+ begin
+ return Make_Identifier (Loc, Name_V);
+ end Object;
begin
-- Build the code fragment corresponding to the marshalling of a
@@ -1101,7 +1070,7 @@ package body Exp_Dist is
Make_Attribute_Reference (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Object, Loc)),
+ Prefix => Object),
Attribute_Name => Name_Address)),
Etyp => RTE (RE_Unsigned_64)));
@@ -1115,7 +1084,7 @@ package body Exp_Dist is
Object =>
Make_Selected_Component (Loc,
Prefix => Unchecked_Convert_To (Stub_Type_Access,
- New_Occurrence_Of (Object, Loc)),
+ Object),
Selector_Name =>
Make_Identifier (Loc, Name_Origin)),
Etyp => RTE (RE_Partition_ID)),
@@ -1125,7 +1094,7 @@ package body Exp_Dist is
Object =>
Make_Selected_Component (Loc,
Prefix => Unchecked_Convert_To (Stub_Type_Access,
- New_Occurrence_Of (Object, Loc)),
+ Object),
Selector_Name =>
Make_Identifier (Loc, Name_Receiver)),
Etyp => RTE (RE_Unsigned_64)),
@@ -1135,7 +1104,7 @@ package body Exp_Dist is
Object =>
Make_Selected_Component (Loc,
Prefix => Unchecked_Convert_To (Stub_Type_Access,
- New_Occurrence_Of (Object, Loc)),
+ Object),
Selector_Name =>
Make_Identifier (Loc, Name_Addr)),
Etyp => RTE (RE_Unsigned_64)));
@@ -1166,7 +1135,7 @@ package body Exp_Dist is
Make_Implicit_If_Statement (RACW_Type,
Condition =>
Make_Op_Eq (Loc,
- Left_Opnd => New_Occurrence_Of (Object, Loc),
+ Left_Opnd => Object,
Right_Opnd => Make_Null (Loc)),
Then_Statements => Null_Statements,
Elsif_Parts => New_List (
@@ -1175,7 +1144,7 @@ package body Exp_Dist is
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Object, Loc),
+ Prefix => Object,
Attribute_Name => Name_Tag),
Right_Opnd =>
Make_Attribute_Reference (Loc,
@@ -1184,71 +1153,21 @@ package body Exp_Dist is
Then_Statements => Remote_Statements)),
Else_Statements => Local_Statements));
- Proc_Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Procedure_Name),
-
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Stream_Parameter,
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc),
- Attribute_Name =>
- Name_Class))),
-
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Object,
- In_Present => True,
- Parameter_Type =>
- New_Occurrence_Of (RACW_Type, Loc))));
+ Build_Stream_Procedure
+ (Loc, RACW_Type, Body_Node,
+ Make_Defining_Identifier (Loc, Procedure_Name),
+ Statements, Outp => False);
- Proc_Decl :=
- Make_Subprogram_Declaration (Loc, Specification => Proc_Spec);
+ Proc_Decl := Make_Subprogram_Declaration (Loc,
+ Copy_Specification (Loc, Specification (Body_Node)));
Attr_Decl :=
Make_Attribute_Definition_Clause (Loc,
Name => New_Occurrence_Of (RACW_Type, Loc),
Chars => Name_Write,
Expression =>
- New_Occurrence_Of (Defining_Unit_Name (Proc_Spec), Loc));
-
- Proc_Body_Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Procedure_Name),
-
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars (Stream_Parameter)),
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc),
- Attribute_Name =>
- Name_Class))),
-
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars (Object)),
- In_Present => True,
- Parameter_Type =>
- New_Occurrence_Of (RACW_Type, Loc))));
-
- Body_Node :=
- Make_Subprogram_Body (Loc,
- Specification => Proc_Body_Spec,
- Declarations => No_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Statements));
+ New_Occurrence_Of (
+ Defining_Unit_Name (Specification (Proc_Decl)), Loc));
Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
Insert_After (Proc_Decl, Attr_Decl);
@@ -1269,7 +1188,6 @@ package body Exp_Dist is
Proc_Statements : constant List_Id := New_List;
Proc_Spec : Node_Id;
- Proc_Body : Node_Id;
Proc : Node_Id;
@@ -1346,7 +1264,9 @@ package body Exp_Dist is
Expression =>
New_Occurrence_Of (Return_Value, Loc)));
- Proc := Make_Defining_Identifier (Loc, Name_uRAS_Access);
+ Proc :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
Proc_Spec :=
Make_Function_Specification (Loc,
@@ -1381,13 +1301,13 @@ package body Exp_Dist is
Set_Ekind (Proc, E_Function);
Set_Etype (Proc, New_Occurrence_Of (Fat_Type, Loc));
- Proc_Body :=
+ Discard_Node (
Make_Subprogram_Body (Loc,
Specification => Proc_Spec,
Declarations => Proc_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Proc_Statements));
+ Statements => Proc_Statements)));
Set_TSS (Fat_Type, Proc);
@@ -1414,11 +1334,8 @@ package body Exp_Dist is
Direct_Statements : constant List_Id := New_List;
- Proc : Node_Id;
-
- Proc_Spec : Node_Id;
- Proc_Body : Node_Id;
-
+ Proc : Node_Id;
+ Proc_Spec : Node_Id;
Param_Specs : constant List_Id := New_List;
Param_Assoc : constant List_Id := New_List;
@@ -1506,14 +1423,14 @@ package body Exp_Dist is
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
- Chars => Chars (Defining_Identifier (Current_Parameter))),
- In_Present => In_Present (Current_Parameter),
- Out_Present => Out_Present (Current_Parameter),
- Parameter_Type =>
- New_Occurrence_Of
- (Etype (Parameter_Type (Current_Parameter)), Loc),
- Expression =>
- New_Copy_Tree (Expression (Current_Parameter))));
+ Chars =>
+ Chars (Defining_Identifier (Current_Parameter))),
+ In_Present => In_Present (Current_Parameter),
+ Out_Present => Out_Present (Current_Parameter),
+ Parameter_Type =>
+ New_Copy_Tree (Parameter_Type (Current_Parameter)),
+ Expression =>
+ New_Copy_Tree (Expression (Current_Parameter))));
Append_To (Param_Assoc,
Make_Identifier (Loc,
@@ -1523,7 +1440,9 @@ package body Exp_Dist is
end loop;
end if;
- Proc := Make_Defining_Identifier (Loc, Name_uRAS_Dereference);
+ Proc :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Dereference));
if Is_Function then
Proc_Spec :=
@@ -1628,13 +1547,13 @@ package body Exp_Dist is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Inner_Statements)))));
- Proc_Body :=
+ Discard_Node (
Make_Subprogram_Body (Loc,
Specification => Proc_Spec,
Declarations => Proc_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Proc_Statements));
+ Statements => Proc_Statements)));
Set_TSS (Fat_Type, Defining_Unit_Name (Proc_Spec));
@@ -1650,8 +1569,8 @@ package body Exp_Dist is
-- be replaced by an assert or this comment removed if we decide
-- that this is normal to be called several times ???
- if Present (TSS (Equivalent_Type (Defining_Identifier
- (Vis_Decl)), Name_uRAS_Access))
+ if Present (TSS (Equivalent_Type (Defining_Identifier (Vis_Decl)),
+ TSS_RAS_Access))
then
return;
end if;
@@ -1675,10 +1594,9 @@ package body Exp_Dist is
Pkg_RPC_Receiver : Node_Id;
Pkg_RPC_Receiver_Spec : Node_Id;
- Pkg_RPC_Receiver_Formals : List_Id;
Pkg_RPC_Receiver_Decls : List_Id;
Pkg_RPC_Receiver_Statements : List_Id;
- Pkg_RPC_Receiver_Cases : List_Id := New_List;
+ Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
Pkg_RPC_Receiver_Body : Node_Id;
-- A Pkg_RPC_Receiver is built to decode the request
@@ -1726,24 +1644,11 @@ package body Exp_Dist is
-- The parameters of the package RPC receiver are made of two
-- streams, an input one and an output one.
- Pkg_RPC_Receiver_Formals := New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Stream_Parameter,
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Result_Parameter,
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))));
-
Pkg_RPC_Receiver_Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Pkg_RPC_Receiver,
- Parameter_Specifications => Pkg_RPC_Receiver_Formals);
+ Build_RPC_Receiver_Specification
+ (RPC_Receiver => Pkg_RPC_Receiver,
+ Stream_Parameter => Stream_Parameter,
+ Result_Parameter => Result_Parameter);
Pkg_RPC_Receiver_Decls := New_List (
Make_Object_Declaration (Loc,
@@ -2024,23 +1929,10 @@ package body Exp_Dist is
Object_RPC_Receiver_Declaration :=
Make_Subprogram_Declaration (Loc,
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Object_RPC_Receiver,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => RPC_Receiver_Stream,
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
-
- Make_Parameter_Specification (Loc,
- Defining_Identifier => RPC_Receiver_Result,
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Params_Stream_Type), Loc))))));
+ Build_RPC_Receiver_Specification (
+ RPC_Receiver => Object_RPC_Receiver,
+ Stream_Parameter => RPC_Receiver_Stream,
+ Result_Parameter => RPC_Receiver_Result));
Append_To (Decls, Object_RPC_Receiver_Declaration);
end Add_Stub_Type;
@@ -2193,33 +2085,54 @@ package body Exp_Dist is
while Current_Parameter /= Empty loop
- if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then
+ declare
+ Typ : constant Node_Id :=
+ Parameter_Type (Current_Parameter);
+ Etyp : Entity_Id;
+ Constrained : Boolean;
+ Value : Node_Id;
+ Extra_Parameter : Entity_Id;
- -- In the case of a controlling formal argument, we marshall
- -- its addr field rather than the local stub.
+ begin
- Append_To (Statements,
- Pack_Node_Into_Stream (Loc,
- Stream => Stream_Parameter,
- Object =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (
- Defining_Identifier (Current_Parameter), Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Addr)),
- Etyp => RTE (RE_Unsigned_64)));
+ if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then
- else
- declare
- Etyp : constant Entity_Id :=
- Etype (Parameter_Type (Current_Parameter));
+ -- In the case of a controlling formal argument, we marshall
+ -- its addr field rather than the local stub.
- Constrained : constant Boolean :=
- Is_Constrained (Etyp)
- or else Is_Elementary_Type (Etyp);
+ Append_To (Statements,
+ Pack_Node_Into_Stream (Loc,
+ Stream => Stream_Parameter,
+ Object =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (
+ Defining_Identifier (Current_Parameter), Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Addr)),
+ Etyp => RTE (RE_Unsigned_64)));
+
+ else
+ Value := New_Occurrence_Of
+ (Defining_Identifier (Current_Parameter), Loc);
+
+ -- Access type parameters are transmitted as in out
+ -- parameters. However, a dereference is needed so that
+ -- we marshall the designated object.
+
+ if Nkind (Typ) = N_Access_Definition then
+ Value := Make_Explicit_Dereference (Loc, Value);
+ Etyp := Etype (Subtype_Mark (Typ));
+ else
+ Etyp := Etype (Typ);
+ end if;
+
+ Constrained :=
+ Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
+
+ -- Any parameter but unconstrained out parameters are
+ -- transmitted to the peer.
- begin
if In_Present (Current_Parameter)
or else not Out_Present (Current_Parameter)
or else not Constrained
@@ -2234,61 +2147,56 @@ package body Exp_Dist is
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
- New_Occurrence_Of (
- Defining_Identifier (Current_Parameter), Loc))));
+ Value)));
end if;
- end;
- end if;
+ end if;
- -- If the current parameter has a dynamic constrained status,
- -- then this status is transmitted as well.
- -- This should be done for accessibility as well ???
+ -- If the current parameter has a dynamic constrained status,
+ -- then this status is transmitted as well.
+ -- This should be done for accessibility as well ???
- if Nkind (Parameter_Type (Current_Parameter)) /= N_Access_Definition
- and then Need_Extra_Constrained (Current_Parameter)
- then
- -- In this block, we do not use the extra formal that has been
- -- created because it does not exist at the time of expansion
- -- when building calling stubs for remote access to subprogram
- -- types. We create an extra variable of this type and push it
- -- in the stream after the regular parameters.
+ if Nkind (Typ) /= N_Access_Definition
+ and then Need_Extra_Constrained (Current_Parameter)
+ then
+ -- In this block, we do not use the extra formal that has been
+ -- created because it does not exist at the time of expansion
+ -- when building calling stubs for remote access to subprogram
+ -- types. We create an extra variable of this type and push it
+ -- in the stream after the regular parameters.
- declare
- Extra_Parameter : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('P'));
+ Extra_Parameter := Make_Defining_Identifier
+ (Loc, New_Internal_Name ('P'));
- begin
Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Extra_Parameter,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (
- Defining_Identifier (Current_Parameter), Loc),
- Attribute_Name => Name_Constrained)));
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Extra_Parameter,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (
+ Defining_Identifier (Current_Parameter), Loc),
+ Attribute_Name => Name_Constrained)));
Append_To (Extra_Formal_Statements,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Standard_Boolean, Loc),
- Attribute_Name =>
- Name_Write,
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Stream_Parameter, Loc),
- Attribute_Name =>
- Name_Access),
- New_Occurrence_Of (Extra_Parameter, Loc))));
- end;
- end if;
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Standard_Boolean, Loc),
+ Attribute_Name =>
+ Name_Write,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Stream_Parameter, Loc),
+ Attribute_Name =>
+ Name_Access),
+ New_Occurrence_Of (Extra_Parameter, Loc))));
+ end if;
- Next (Current_Parameter);
+ Next (Current_Parameter);
+ end;
end loop;
-- Append the formal statements list to the statements
@@ -2397,27 +2305,42 @@ package body Exp_Dist is
while Current_Parameter /= Empty loop
- if Out_Present (Current_Parameter)
- and then
- Etype (Parameter_Type (Current_Parameter)) /= Object_Type
- then
- Append_To (Non_Asynchronous_Statements,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (
- Etype (Parameter_Type (Current_Parameter)), Loc),
+ declare
+ Typ : constant Node_Id :=
+ Parameter_Type (Current_Parameter);
+ Etyp : Entity_Id;
+ Value : Node_Id;
+ begin
+ Value := New_Occurrence_Of
+ (Defining_Identifier (Current_Parameter), Loc);
- Attribute_Name => Name_Read,
+ if Nkind (Typ) = N_Access_Definition then
+ Value := Make_Explicit_Dereference (Loc, Value);
+ Etyp := Etype (Subtype_Mark (Typ));
+ else
+ Etyp := Etype (Typ);
+ end if;
- Expressions => New_List (
+ if (Out_Present (Current_Parameter)
+ or else Nkind (Typ) = N_Access_Definition)
+ and then Etyp /= Object_Type
+ then
+ Append_To (Non_Asynchronous_Statements,
Make_Attribute_Reference (Loc,
Prefix =>
- New_Occurrence_Of (Result_Parameter, Loc),
- Attribute_Name =>
- Name_Access),
- New_Occurrence_Of (
- Defining_Identifier (Current_Parameter), Loc))));
- end if;
+ New_Occurrence_Of (Etyp, Loc),
+
+ Attribute_Name => Name_Read,
+
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Result_Parameter, Loc),
+ Attribute_Name =>
+ Name_Access),
+ Value)));
+ end if;
+ end;
Next (Current_Parameter);
end loop;
@@ -2511,13 +2434,18 @@ package body Exp_Dist is
L : List_Id;
Reg : Node_Id;
Loc : constant Source_Ptr := Sloc (U);
- Dist_OK : Entity_Id;
begin
-- Verify that the implementation supports distribution, by accessing
-- a type defined in the proper version of system.rpc
- Dist_OK := RTE (RE_Params_Stream_Type);
+ declare
+ Dist_OK : Entity_Id;
+ pragma Warnings (Off, Dist_OK);
+
+ begin
+ Dist_OK := RTE (RE_Params_Stream_Type);
+ end;
-- Use body if present, spec otherwise
@@ -2544,6 +2472,39 @@ package body Exp_Dist is
Analyze (Reg);
end Build_Passive_Partition_Stub;
+ --------------------------------------
+ -- Build_RPC_Receiver_Specification --
+ --------------------------------------
+
+ function Build_RPC_Receiver_Specification
+ (RPC_Receiver : Entity_Id;
+ Stream_Parameter : Entity_Id;
+ Result_Parameter : Entity_Id)
+ return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (RPC_Receiver);
+
+ begin
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => RPC_Receiver,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Stream_Parameter,
+ Parameter_Type =>
+ Make_Access_Definition (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Result_Parameter,
+ Parameter_Type =>
+ Make_Access_Definition (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (RTE (RE_Params_Stream_Type), Loc)))));
+ end Build_RPC_Receiver_Specification;
+
------------------------------------
-- Build_Subprogram_Calling_Stubs --
------------------------------------
@@ -2589,9 +2550,12 @@ package body Exp_Dist is
procedure Insert_Partition_Check (Parameter : in Node_Id) is
Parameter_Entity : constant Entity_Id :=
Defining_Identifier (Parameter);
- Designated_Object : Node_Id;
Condition : Node_Id;
+ Designated_Object : Node_Id;
+ pragma Warnings (Off, Designated_Object);
+ -- Is it really right that this is unreferenced ???
+
begin
-- The expression that will be built is of the form:
-- if not (Parameter in Stub_Type and then
@@ -2790,16 +2754,16 @@ package body Exp_Dist is
Result_Parameter : Node_Id;
-- See explanations of those in Build_Subprogram_Calling_Stubs
- Decls : List_Id := New_List;
+ Decls : constant List_Id := New_List;
-- All the parameters will get declared before calling the real
-- subprograms. Also the out parameters will be declared.
- Statements : List_Id := New_List;
+ Statements : constant List_Id := New_List;
- Extra_Formal_Statements : List_Id := New_List;
+ Extra_Formal_Statements : constant List_Id := New_List;
-- Statements concerning extra formal parameters
- After_Statements : List_Id := New_List;
+ After_Statements : constant List_Id := New_List;
-- Statements to be executed after the subprogram call
Inner_Decls : List_Id := No_List;
@@ -2810,13 +2774,14 @@ package body Exp_Dist is
Excep_Choice : Entity_Id;
Excep_Code : List_Id;
- Parameter_List : List_Id := New_List;
+ Parameter_List : constant List_Id := New_List;
-- List of parameters to be passed to the subprogram.
Current_Parameter : Node_Id;
Ordered_Parameters_List : constant List_Id :=
- Build_Ordered_Parameters_List (Specification (Vis_Decl));
+ Build_Ordered_Parameters_List
+ (Specification (Vis_Decl));
Subp_Spec : Node_Id;
-- Subprogram specification
@@ -3238,6 +3203,7 @@ package body Exp_Dist is
Current_Parameter : Node_Id;
Current_Type : Node_Id;
+ Current_Etype : Entity_Id;
Name_For_New_Spec : Name_Id;
@@ -3260,28 +3226,31 @@ package body Exp_Dist is
Current_Type := Parameter_Type (Current_Parameter);
if Nkind (Current_Type) = N_Access_Definition then
+ Current_Etype := Entity (Subtype_Mark (Current_Type));
+
if Object_Type = Empty then
Current_Type :=
Make_Access_Definition (Loc,
Subtype_Mark =>
- New_Occurrence_Of (Etype (
- Subtype_Mark (Current_Type)), Loc));
+ New_Occurrence_Of (Current_Etype, Loc));
else
pragma Assert
- (Root_Type (Etype (Subtype_Mark (Current_Type)))
- = Root_Type (Object_Type));
+ (Root_Type (Current_Etype) = Root_Type (Object_Type));
Current_Type :=
Make_Access_Definition (Loc,
Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
end if;
- elsif Object_Type /= Empty
- and then Etype (Current_Type) = Object_Type
- then
- Current_Type := New_Occurrence_Of (Stub_Type, Loc);
-
else
- Current_Type := New_Occurrence_Of (Etype (Current_Type), Loc);
+ Current_Etype := Entity (Current_Type);
+
+ if Object_Type /= Empty
+ and then Current_Etype = Object_Type
+ then
+ Current_Type := New_Occurrence_Of (Stub_Type, Loc);
+ else
+ Current_Type := New_Occurrence_Of (Current_Etype, Loc);
+ end if;
end if;
New_Identifier := Make_Defining_Identifier (Loc,
@@ -3308,7 +3277,7 @@ package body Exp_Dist is
Chars => Name_For_New_Spec),
Parameter_Specifications => Parameters,
Subtype_Mark =>
- New_Occurrence_Of (Etype (Subtype_Mark (Spec)), Loc));
+ New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
else
return
@@ -3373,7 +3342,7 @@ package body Exp_Dist is
-- is not prematurely removed by the GCC back-end.
declare
- Scop : Entity_Id := Cunit_Entity (Current_Sem_Unit);
+ Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
begin
if Ekind (Scop) = E_Package_Body then
@@ -3462,7 +3431,7 @@ package body Exp_Dist is
----------------------------
function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id is
- Unit_Name_Id : Unit_Name_Type := Get_Unit_Name (Decl_Node);
+ Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
begin
Get_Unit_Name_String (Unit_Name_Id);
@@ -3604,7 +3573,7 @@ package body Exp_Dist is
function Pack_Entity_Into_Stream_Access
(Loc : Source_Ptr;
- Stream : Entity_Id;
+ Stream : Node_Id;
Object : Entity_Id;
Etyp : Entity_Id := Empty)
return Node_Id
@@ -3660,7 +3629,7 @@ package body Exp_Dist is
function Pack_Node_Into_Stream_Access
(Loc : Source_Ptr;
- Stream : Entity_Id;
+ Stream : Node_Id;
Object : Node_Id;
Etyp : Entity_Id)
return Node_Id
@@ -3677,7 +3646,7 @@ package body Exp_Dist is
Prefix => New_Occurrence_Of (Etyp, Loc),
Attribute_Name => Write_Attribute,
Expressions => New_List (
- New_Occurrence_Of (Stream, Loc),
+ Stream,
Object));
end Pack_Node_Into_Stream_Access;
diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb
index 79f43b102a6..41158104beb 100644
--- a/gcc/ada/exp_fixd.adb
+++ b/gcc/ada/exp_fixd.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,7 +30,6 @@ with Einfo; use Einfo;
with Exp_Util; use Exp_Util;
with Nlists; use Nlists;
with Nmake; use Nmake;
-with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
@@ -39,7 +38,6 @@ with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Urealp; use Urealp;
@@ -403,13 +401,6 @@ package body Exp_Fixd is
Expr : Node_Id;
begin
- if Y_Size > System_Word_Size
- or else
- Z_Size > System_Word_Size
- then
- Disallow_In_No_Run_Time_Mode (N);
- end if;
-
-- If denominator fits in 64 bits, we can build the operations directly
-- without causing any intermediate overflow, so that's what we do!
@@ -606,6 +597,8 @@ package body Exp_Fixd is
Loc : constant Source_Ptr := Sloc (N);
Left_Type : constant Entity_Id := Etype (L);
Right_Type : constant Entity_Id := Etype (R);
+ Left_Size : Int;
+ Right_Size : Int;
Rsize : Int;
Result_Type : Entity_Id;
Rnode : Node_Id;
@@ -634,11 +627,54 @@ package body Exp_Fixd is
return R;
end if;
- -- Otherwise we use a type that is at least twice the longer
- -- of the two sizes.
+ -- Otherwise we need to figure out the correct result type size
+ -- First figure out the effective sizes of the operands. Normally
+ -- the effective size of an operand is the RM_Size of the operand.
+ -- But a special case arises with operands whose size is known at
+ -- compile time. In this case, we can use the actual value of the
+ -- operand to get its size if it would fit in 8 or 16 bits.
+
+ -- Note: if both operands are known at compile time (can that
+ -- happen?) and both were equal to the power of 2, then we would
+ -- be one bit off in this test, so for the left operand, we only
+ -- go up to the power of 2 - 1. This ensures that we do not get
+ -- this anomolous case, and in practice the right operand is by
+ -- far the more likely one to be the constant.
+
+ Left_Size := UI_To_Int (RM_Size (Left_Type));
+
+ if Compile_Time_Known_Value (L) then
+ declare
+ Val : constant Uint := Expr_Value (L);
+
+ begin
+ if Val < Int'(2 ** 8) then
+ Left_Size := 8;
+ elsif Val < Int'(2 ** 16) then
+ Left_Size := 16;
+ end if;
+ end;
+ end if;
+
+ Right_Size := UI_To_Int (RM_Size (Right_Type));
+
+ if Compile_Time_Known_Value (R) then
+ declare
+ Val : constant Uint := Expr_Value (R);
+
+ begin
+ if Val <= Int'(2 ** 8) then
+ Right_Size := 8;
+ elsif Val <= Int'(2 ** 16) then
+ Right_Size := 16;
+ end if;
+ end;
+ end if;
+
+ -- Now the result size must be at least twice the longer of
+ -- the two sizes, to accomodate all possible results.
- Rsize := 2 * Int'Max (UI_To_Int (Esize (Left_Type)),
- UI_To_Int (Esize (Right_Type)));
+ Rsize := 2 * Int'Max (Left_Size, Right_Size);
if Rsize <= 8 then
Result_Type := Standard_Integer_8;
@@ -650,10 +686,6 @@ package body Exp_Fixd is
Result_Type := Standard_Integer_32;
else
- if Rsize > System_Word_Size then
- Disallow_In_No_Run_Time_Mode (N);
- end if;
-
Result_Type := Standard_Integer_64;
end if;
@@ -2309,7 +2341,6 @@ package body Exp_Fixd is
Set_Analyzed (L);
return L;
-
end Integer_Literal;
------------------
diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index 0e75acfab95..7f3a8f0858d 100644
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -114,7 +114,7 @@ package body Exp_Imgv is
Eind :=
Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (E), 'I'));
+ Chars => New_External_Name (Chars (E), 'N'));
Set_Lit_Strings (E, Estr);
Set_Lit_Indexes (E, Eind);
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index 1070138347d..f6889090645 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -29,7 +29,6 @@ with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Ch4; use Exp_Ch4;
with Exp_Ch7; use Exp_Ch7;
-with Exp_Ch9; use Exp_Ch9;
with Exp_Ch11; use Exp_Ch11;
with Exp_Code; use Exp_Code;
with Exp_Fixd; use Exp_Fixd;
@@ -84,6 +83,11 @@ package body Exp_Intr is
-- Expand a call to an instantiation of Unchecked_Deallocation into a node
-- N_Free_Statement and appropriate context.
+ procedure Expand_To_Address (N : Node_Id);
+ procedure Expand_To_Pointer (N : Node_Id);
+ -- Expand a call to corresponding function, declared in an instance of
+ -- System.Addess_To_Access_Conversions.
+
procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id);
-- Rewrite the node by the appropriate string or positive constant.
-- Nam can be one of the following:
@@ -267,6 +271,12 @@ package body Exp_Intr is
elsif Nam = Name_Unchecked_Deallocation then
Expand_Unc_Deallocation (N);
+ elsif Nam = Name_To_Address then
+ Expand_To_Address (N);
+
+ elsif Nam = Name_To_Pointer then
+ Expand_To_Pointer (N);
+
elsif Nam = Name_File
or else Nam = Name_Line
or else Nam = Name_Source_Location
@@ -281,7 +291,6 @@ package body Exp_Intr is
pragma Assert (Present (Alias (E)));
Expand_Intrinsic_Call (N, Alias (E));
end if;
-
end Expand_Intrinsic_Call;
------------------------
@@ -318,16 +327,18 @@ package body Exp_Intr is
Make_Conditional_Expression (Loc,
Expressions => New_List (
Make_Op_Gt (Loc,
- Left_Opnd => Duplicate_Subexpr (Opnd),
+ Left_Opnd => Duplicate_Subexpr_No_Checks (Opnd),
Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
New_Occurrence_Of (Standard_False, Loc),
Make_Op_Ne (Loc,
Left_Opnd =>
- Unchecked_Convert_To (RTE (RE_Float_Unsigned),
- Convert_To (Standard_Float,
- Duplicate_Subexpr (Opnd))),
+ Unchecked_Convert_To
+ (RTE (RE_Float_Unsigned),
+ Convert_To
+ (Standard_Float,
+ Duplicate_Subexpr_No_Checks (Opnd))),
Right_Opnd =>
Make_Integer_Literal (Loc, 0)))))));
@@ -380,7 +391,6 @@ package body Exp_Intr is
Rewrite (N, Snode);
Set_Analyzed (N);
-
end Expand_Shift;
------------------------
@@ -511,17 +521,19 @@ package body Exp_Intr is
-- For a task, we also generate a call to Free_Task to ensure that the
-- task itself is freed if it is terminated, ditto for a simple protected
- -- object, with a call to Finalize_Protection
+ -- object, with a call to Finalize_Protection. For composite types that
+ -- have tasks or simple protected objects as components, we traverse the
+ -- structures to find and terminate those components.
procedure Expand_Unc_Deallocation (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Arg : constant Node_Id := First_Actual (N);
Typ : constant Entity_Id := Etype (Arg);
Stmts : constant List_Id := New_List;
- Pool : constant Entity_Id :=
- Associated_Storage_Pool (Underlying_Type (Root_Type (Typ)));
+ Rtyp : constant Entity_Id := Underlying_Type (Root_Type (Typ));
+ Pool : constant Entity_Id := Associated_Storage_Pool (Rtyp);
- Desig_T : Entity_Id := Designated_Type (Typ);
+ Desig_T : constant Entity_Id := Designated_Type (Typ);
Gen_Code : Node_Id;
Free_Node : Node_Id;
Deref : Node_Id;
@@ -530,9 +542,14 @@ package body Exp_Intr is
Blk : Node_Id;
begin
- if Controlled_Type (Desig_T) then
+ if No_Pool_Assigned (Rtyp) then
+ Error_Msg_N ("?deallocation from empty storage pool", N);
+ end if;
- Deref := Make_Explicit_Dereference (Loc, Duplicate_Subexpr (Arg));
+ if Controlled_Type (Desig_T) then
+ Deref :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => Duplicate_Subexpr_No_Checks (Arg));
-- If the type is tagged, then we must force dispatching on the
-- finalization call because the designated type may not be the
@@ -576,10 +593,9 @@ package body Exp_Intr is
end if;
end if;
- -- For a task type, call Free_Task before freeing the ATCB.
+ -- For a task type, call Free_Task before freeing the ATCB
if Is_Task_Type (Desig_T) then
-
declare
Stat : Node_Id := Prev (N);
Nam1 : Node_Id;
@@ -587,8 +603,8 @@ package body Exp_Intr is
begin
-- An Abort followed by a Free will not do what the user
- -- expects, because the abort is not immediate. This is worth
- -- a friendly warning.
+ -- expects, because the abort is not immediate. This is
+ -- worth a friendly warning.
while Present (Stat)
and then not Comes_From_Source (Original_Node (Stat))
@@ -615,27 +631,39 @@ package body Exp_Intr is
end if;
end;
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Free_Task), Loc),
- Parameter_Associations => New_List (
- Concurrent_Ref (Duplicate_Subexpr (Arg)))));
+ Append_To
+ (Stmts, Cleanup_Task (N, Duplicate_Subexpr_No_Checks (Arg)));
+
+ -- For composite types that contain tasks, recurse over the structure
+ -- to build the selectors for the task subcomponents.
+
+ elsif Has_Task (Desig_T) then
+ if Is_Record_Type (Desig_T) then
+ Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T));
+
+ elsif Is_Array_Type (Desig_T) then
+ Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T));
+ end if;
end if;
- -- For a protected type with no entries, call Finalize_Protection
- -- before freeing the PO.
+ -- Same for simple protected types. Eventually call Finalize_Protection
+ -- before freeing the PO for each protected component.
- if Is_Protected_Type (Desig_T) and then not Has_Entries (Desig_T) then
+ if Is_Simple_Protected_Type (Desig_T) then
Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE_Finalize_Protection), Loc),
- Parameter_Associations => New_List (
- Concurrent_Ref (Duplicate_Subexpr (Arg)))));
+ Cleanup_Protected_Object (N, Duplicate_Subexpr_No_Checks (Arg)));
+
+ elsif Has_Simple_Protected_Object (Desig_T) then
+ if Is_Record_Type (Desig_T) then
+ Append_List_To (Stmts, Cleanup_Record (N, Arg, Desig_T));
+ elsif Is_Array_Type (Desig_T) then
+ Append_List_To (Stmts, Cleanup_Array (N, Arg, Desig_T));
+ end if;
end if;
-- Normal processing for non-controlled types
- Free_Arg := Duplicate_Subexpr (Arg);
+ Free_Arg := Duplicate_Subexpr_No_Checks (Arg);
Free_Node := Make_Free_Statement (Loc, Empty);
Append_To (Stmts, Free_Node);
Set_Storage_Pool (Free_Node, Pool);
@@ -701,6 +729,9 @@ package body Exp_Intr is
if Is_RTE (Pool, RE_SS_Pool) then
null;
+ elsif Is_Class_Wide_Type (Etype (Pool)) then
+ Set_Procedure_To_Call (Free_Node,
+ RTE (RE_Deallocate_Any));
else
Set_Procedure_To_Call (Free_Node,
Find_Prim_Op (Etype (Pool), Name_Deallocate));
@@ -715,7 +746,7 @@ package body Exp_Intr is
Create_Itype (E_Access_Type, N);
Deref : constant Node_Id :=
Make_Explicit_Dereference (Loc,
- Duplicate_Subexpr (Arg));
+ Duplicate_Subexpr_No_Checks (Arg));
begin
Set_Etype (Deref, Typ);
@@ -736,7 +767,7 @@ package body Exp_Intr is
Set_Expression (Free_Node, Free_Arg);
declare
- Lhs : Node_Id := Duplicate_Subexpr (Arg);
+ Lhs : constant Node_Id := Duplicate_Subexpr_No_Checks (Arg);
begin
Set_Assignment_OK (Lhs);
@@ -750,4 +781,44 @@ package body Exp_Intr is
Analyze (N);
end Expand_Unc_Deallocation;
+ -----------------------
+ -- Expand_To_Address --
+ -----------------------
+
+ procedure Expand_To_Address (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Arg : constant Node_Id := First_Actual (N);
+ Obj : Node_Id;
+
+ begin
+ Remove_Side_Effects (Arg);
+
+ Obj := Make_Explicit_Dereference (Loc, Relocate_Node (Arg));
+
+ Rewrite (N,
+ Make_Conditional_Expression (Loc,
+ Expressions => New_List (
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Copy_Tree (Arg),
+ Right_Opnd => Make_Null (Loc)),
+ New_Occurrence_Of (RTE (RE_Null_Address), Loc),
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Address,
+ Prefix => Obj))));
+
+ Analyze_And_Resolve (N, RTE (RE_Address));
+ end Expand_To_Address;
+
+ -----------------------
+ -- Expand_To_Pointer --
+ -----------------------
+
+ procedure Expand_To_Pointer (N : Node_Id) is
+ Arg : constant Node_Id := First_Actual (N);
+
+ begin
+ Rewrite (N, Unchecked_Convert_To (Etype (N), Arg));
+ Analyze (N);
+ end Expand_To_Pointer;
+
end Exp_Intr;
diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb
index e8c607adda5..a0440cae4b5 100644
--- a/gcc/ada/exp_pakd.adb
+++ b/gcc/ada/exp_pakd.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- --
@@ -31,9 +31,9 @@ with Exp_Dbug; use Exp_Dbug;
with Exp_Util; use Exp_Util;
with Nlists; use Nlists;
with Nmake; use Nmake;
-with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
@@ -298,7 +298,7 @@ package body Exp_Pakd is
-- a packed array whose component size is N. RE_Null is used as a null
-- entry, for the cases where a library routine is not used.
- Set_Id : E_Array :=
+ Set_Id : constant E_Array :=
(01 => RE_Null,
02 => RE_Null,
03 => RE_Set_03,
@@ -368,7 +368,7 @@ package body Exp_Pakd is
-- not be fully aligned. This only affects the even sizes, since for the
-- odd sizes, we do not get any fixed alignment in any case.
- SetU_Id : E_Array :=
+ SetU_Id : constant E_Array :=
(01 => RE_Null,
02 => RE_Null,
03 => RE_Set_03,
@@ -515,10 +515,10 @@ package body Exp_Pakd is
-- On return:
--
-- Obj is the object containing the desired bit field. It is of type
- -- Unsigned or Long_Long_Unsigned, and is either the entire value,
- -- for the small static case, or the proper selected byte from the
- -- array in the large or dynamic case. This node is analyzed and
- -- resolved on return.
+ -- Unsigned, Long_Unsigned, or Long_Long_Unsigned, and is either the
+ -- entire value, for the small static case, or the proper selected byte
+ -- from the array in the large or dynamic case. This node is analyzed
+ -- and resolved on return.
--
-- Shift is a node representing the shift count to be used in the
-- rotate right instruction that positions the field for access.
@@ -768,7 +768,7 @@ package body Exp_Pakd is
-- Set Esize and RM_Size to the actual size of the packed object
-- Do not reset RM_Size if already set, as happens in the case
- -- of a modular type
+ -- of a modular type.
Set_Esize (PAT, Esiz);
@@ -887,7 +887,7 @@ package body Exp_Pakd is
Set_Packed_Array_Type (Typ, PAT);
declare
- Indexes : List_Id := New_List;
+ Indexes : constant List_Id := New_List;
Indx : Node_Id;
Indx_Typ : Entity_Id;
Enum_Case : Boolean;
@@ -1049,43 +1049,63 @@ package body Exp_Pakd is
-- Temporarily attach the length expression to the tree and analyze
-- and resolve it, so that we can test its value. We assume that the
- -- total length fits in type Integer.
+ -- total length fits in type Integer. This expression may involve
+ -- discriminants, so we treat it as a default/per-object expression.
Set_Parent (Len_Expr, Typ);
- Analyze_And_Resolve (Len_Expr, Standard_Integer);
+ Analyze_Per_Use_Expression (Len_Expr, Standard_Integer);
-- Use a modular type if possible. We can do this if we are we
-- have static bounds, and the length is small enough, and the
-- length is not zero. We exclude the zero length case because the
-- size of things is always at least one, and the zero length object
- -- would have an anomous size
+ -- would have an anomous size.
if Compile_Time_Known_Value (Len_Expr) then
Len_Bits := Expr_Value (Len_Expr) * Csize;
-- We normally consider small enough to mean no larger than the
- -- value of System_Max_Binary_Modulus_Power, except that in
- -- No_Run_Time mode, we use the Word Size on machines for
- -- which double length shifts are not generated in line.
+ -- value of System_Max_Binary_Modulus_Power, checking that in the
+ -- case of values longer than word size, we have long shifts.
if Len_Bits > 0
and then
(Len_Bits <= System_Word_Size
or else (Len_Bits <= System_Max_Binary_Modulus_Power
- and then (not No_Run_Time
- or else
- Long_Shifts_Inlined_On_Target)))
+ and then Support_Long_Shifts_On_Target))
+
+ -- Also test for alignment given. If an alignment is given which
+ -- is smaller than the natural modular alignment, force the array
+ -- of bytes representation to accommodate the alignment.
+
+ and then
+ (No (Alignment_Clause (Typ))
+ or else
+ Alignment (Typ) >= ((Len_Bits + System_Storage_Unit)
+ / System_Storage_Unit))
then
-- We can use the modular type, it has the form:
-- subtype tttPn is btyp
-- range 0 .. 2 ** (Esize (Typ) * Csize) - 1;
- -- Here Siz is 1, 2 or 4, as computed above, and btyp is either
- -- Unsigned or Long_Long_Unsigned depending on the length.
+ -- The bounds are statically known, and btyp is one
+ -- of the unsigned types, depending on the length. If the
+ -- type is its first subtype, i.e. it is a user-defined
+ -- type, no object of the type will be larger, and it is
+ -- worthwhile to use a small unsigned type.
- if Len_Bits <= Standard_Integer_Size then
+ if Len_Bits <= Standard_Short_Integer_Size
+ and then First_Subtype (Typ) = Typ
+ then
+ Btyp := RTE (RE_Short_Unsigned);
+
+ elsif Len_Bits <= Standard_Integer_Size then
Btyp := RTE (RE_Unsigned);
+
+ elsif Len_Bits <= Standard_Long_Integer_Size then
+ Btyp := RTE (RE_Long_Unsigned);
+
else
Btyp := RTE (RE_Long_Long_Unsigned);
end if;
@@ -1187,9 +1207,15 @@ package body Exp_Pakd is
PAT : Entity_Id;
Ctyp : Entity_Id;
Csiz : Int;
- Shift : Node_Id;
Cmask : Uint;
+ Shift : Node_Id;
+ -- The expression for the shift value that is required
+
+ Shift_Used : Boolean := False;
+ -- Set True if Shift has been used in the generated code at least
+ -- once, so that it must be duplicated if used again
+
New_Lhs : Node_Id;
New_Rhs : Node_Id;
@@ -1200,6 +1226,33 @@ package body Exp_Pakd is
-- contains the value. Otherwise Rhs_Val_Known is set False, and
-- the Rhs_Val is undefined.
+ function Get_Shift return Node_Id;
+ -- Function used to get the value of Shift, making sure that it
+ -- gets duplicated if the function is called more than once.
+
+ ---------------
+ -- Get_Shift --
+ ---------------
+
+ function Get_Shift return Node_Id is
+ begin
+ -- If we used the shift value already, then duplicate it. We
+ -- set a temporary parent in case actions have to be inserted.
+
+ if Shift_Used then
+ Set_Parent (Shift, N);
+ return Duplicate_Subexpr_No_Checks (Shift);
+
+ -- If first time, use Shift unchanged, and set flag for first use
+
+ else
+ Shift_Used := True;
+ return Shift;
+ end if;
+ end Get_Shift;
+
+ -- Start of processing for Expand_Bit_Packed_Element_Set
+
begin
pragma Assert (Is_Bit_Packed_Array (Etype (Prefix (Lhs))));
@@ -1290,7 +1343,7 @@ package body Exp_Pakd is
end if;
New_Lhs := Duplicate_Subexpr (Obj, True);
- New_Rhs := Duplicate_Subexpr (Obj);
+ New_Rhs := Duplicate_Subexpr_No_Checks (Obj);
-- First we deal with the "and"
@@ -1304,7 +1357,7 @@ package body Exp_Pakd is
Mask1 :=
Make_Integer_Literal (Loc,
Modulus (Etype (Obj)) - 1 -
- (Cmask * (2 ** Expr_Value (Shift))));
+ (Cmask * (2 ** Expr_Value (Get_Shift))));
Set_Print_In_Hex (Mask1);
else
@@ -1312,7 +1365,7 @@ package body Exp_Pakd is
Set_Print_In_Hex (Lit);
Mask1 :=
Make_Op_Not (Loc,
- Right_Opnd => Make_Shift_Left (Lit, Shift));
+ Right_Opnd => Make_Shift_Left (Lit, Get_Shift));
end if;
New_Rhs :=
@@ -1366,11 +1419,11 @@ package body Exp_Pakd is
begin
if Rhs_Val_Known
- and then Compile_Time_Known_Value (Shift)
+ and then Compile_Time_Known_Value (Get_Shift)
then
Or_Rhs :=
Make_Integer_Literal (Loc,
- Rhs_Val * (2 ** Expr_Value (Shift)));
+ Rhs_Val * (2 ** Expr_Value (Get_Shift)));
Set_Print_In_Hex (Or_Rhs);
else
@@ -1407,7 +1460,7 @@ package body Exp_Pakd is
Fixup_Rhs;
end if;
- Or_Rhs := Make_Shift_Left (Rhs, Shift);
+ Or_Rhs := Make_Shift_Left (Rhs, Get_Shift);
end if;
if Nkind (New_Rhs) = N_Op_And then
@@ -1446,6 +1499,13 @@ package body Exp_Pakd is
Atyp : Entity_Id;
begin
+ if No (Bits_nn) then
+
+ -- Error, most likely High_Integrity_Mode restriction.
+
+ return;
+ end if;
+
-- Acquire proper Set entity. We use the aligned or unaligned
-- case as appropriate.
@@ -1462,11 +1522,18 @@ package body Exp_Pakd is
Atyp := Etype (Obj);
Compute_Linear_Subscript (Atyp, Lhs, Subscr);
+ -- Below we must make the assumption that Obj is
+ -- at least byte aligned, since otherwise its address
+ -- cannot be taken. The assumption holds since the
+ -- only arrays that can be misaligned are small packed
+ -- arrays which are implemented as a modular type, and
+ -- that is not the case here.
+
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Set_nn, Loc),
Parameter_Associations => New_List (
- Make_Byte_Aligned_Attribute_Reference (Loc,
+ Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
Prefix => Obj),
Subscr,
@@ -1652,7 +1719,12 @@ package body Exp_Pakd is
-- convert to the base type, since this would be unconstrained, and
-- hence not have a corresponding packed array type set.
- if Is_Modular_Integer_Type (PAT) then
+ -- Note that both operands must be modular for this code to be used.
+
+ if Is_Modular_Integer_Type (PAT)
+ and then
+ Is_Modular_Integer_Type (Etype (R))
+ then
declare
P : Node_Id;
@@ -1686,6 +1758,11 @@ package body Exp_Pakd is
-- operands in bits. Then we replace the expression by a reference
-- to Result.
+ -- Note that if we are mixing a modular and array operand, everything
+ -- works fine, since we ensure that the modular representation has the
+ -- same physical layout as the array representation (that's what the
+ -- left justified modular stuff in the big-endian case is about).
+
else
declare
Result_Ent : constant Entity_Id :=
@@ -1818,6 +1895,11 @@ package body Exp_Pakd is
Left_Opnd => Make_Shift_Right (Obj, Shift),
Right_Opnd => Lit);
+ -- We neded to analyze this before we do the unchecked convert
+ -- below, but we need it temporarily attached to the tree for
+ -- this analysis (hence the temporary Set_Parent call).
+
+ Set_Parent (Arg, Parent (N));
Analyze_And_Resolve (Arg);
Rewrite (N,
@@ -1850,12 +1932,18 @@ package body Exp_Pakd is
Compute_Linear_Subscript (Atyp, N, Subscr);
+ -- Below we make the assumption that Obj is at least byte
+ -- aligned, since otherwise its address cannot be taken.
+ -- The assumption holds since the only arrays that can be
+ -- misaligned are small packed arrays which are implemented
+ -- as a modular type, and that is not the case here.
+
Rewrite (N,
Unchecked_Convert_To (Ctyp,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Get_nn, Loc),
Parameter_Associations => New_List (
- Make_Byte_Aligned_Attribute_Reference (Loc,
+ Make_Attribute_Reference (Loc,
Attribute_Name => Name_Address,
Prefix => Obj),
Subscr))));
@@ -2220,9 +2308,19 @@ package body Exp_Pakd is
return Known_Aligned_Enough (Prefix (Obj), Csiz);
end if;
- -- If not selected or indexed component, must be aligned
+ elsif Nkind (Obj) = N_Type_Conversion then
+ return Known_Aligned_Enough (Expression (Obj), Csiz);
+ -- For a formal parameter, it is safer to assume that it is not
+ -- aligned, because the formal may be unconstrained while the actual
+ -- is constrained. In this situation, a small constrained packed
+ -- array, represented in modular form, may be unaligned.
+
+ elsif Is_Entity_Name (Obj) then
+ return not Is_Formal (Entity (Obj));
else
+
+ -- If none of the above, must be aligned
return True;
end if;
end Known_Aligned_Enough;
@@ -2288,20 +2386,24 @@ package body Exp_Pakd is
Source_Siz := UI_To_Int (RM_Size (Source_Typ));
Target_Siz := UI_To_Int (RM_Size (Target_Typ));
+ -- First step, if the source type is not a discrete type, then we
+ -- first convert to a modular type of the source length, since
+ -- otherwise, on a big-endian machine, we get left-justification.
+ -- We do it for little-endian machines as well, because there might
+ -- be junk bits that are not cleared if the type is not numeric.
+
+ if Source_Siz /= Target_Siz
+ and then not Is_Discrete_Type (Source_Typ)
+ then
+ Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src);
+ end if;
+
-- In the big endian case, if the lengths of the two types differ,
-- then we must worry about possible left justification in the
-- conversion, and avoiding that is what this is all about.
if Bytes_Big_Endian and then Source_Siz /= Target_Siz then
- -- First step, if the source type is not a discrete type, then we
- -- first convert to a modular type of the source length, since
- -- otherwise, on a big-endian machine, we get left-justification.
-
- if not Is_Discrete_Type (Source_Typ) then
- Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src);
- end if;
-
-- Next step. If the target is not a discrete type, then we first
-- convert to a modular type of the target length, since
-- otherwise, on a big-endian machine, we get left-justification.
@@ -2390,14 +2492,12 @@ package body Exp_Pakd is
Shift : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (N);
- Ctyp : Entity_Id;
PAT : Entity_Id;
Otyp : Entity_Id;
Csiz : Uint;
Osiz : Uint;
begin
- Ctyp := Component_Type (Atyp);
Csiz := Component_Size (Atyp);
Convert_To_PAT_Type (Obj);
@@ -2407,7 +2507,7 @@ package body Exp_Pakd is
if Is_Array_Type (PAT) then
Otyp := Component_Type (PAT);
- Osiz := Esize (Otyp);
+ Osiz := Component_Size (PAT);
else
Otyp := PAT;
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index 7ef21dce758..cce84e8e73b 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -46,6 +46,7 @@ with Sinput; use Sinput;
with Snames; use Snames;
with Stringt; use Stringt;
with Stand; use Stand;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
@@ -312,145 +313,168 @@ package body Exp_Prag is
-- with the unexpanded name of the exception (if not already set).
procedure Expand_Pragma_Import_Export_Exception (N : Node_Id) is
- Id : constant Entity_Id := Entity (Expression (Arg1 (N)));
- Call : constant Node_Id := Register_Exception_Call (Id);
- Loc : constant Source_Ptr := Sloc (N);
begin
- if Present (Call) then
- declare
- Excep_Internal : constant Node_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('V'));
- Export_Pragma : Node_Id;
- Excep_Alias : Node_Id;
- Excep_Object : Node_Id;
- Excep_Image : String_Id;
- Exdata : List_Id;
- Lang1 : Node_Id;
- Lang2 : Node_Id;
- Lang3 : Node_Id;
- Code : Node_Id;
- begin
- if Present (Interface_Name (Id)) then
- Excep_Image := Strval (Interface_Name (Id));
- else
- Get_Name_String (Chars (Id));
- Set_All_Upper_Case;
- Excep_Image := String_From_Name_Buffer;
- end if;
-
- Exdata := Component_Associations (Expression (Parent (Id)));
-
- if Is_VMS_Exception (Id) then
-
- Lang1 := Next (First (Exdata));
- Lang2 := Next (Lang1);
- Lang3 := Next (Lang2);
-
- Rewrite (Expression (Lang1),
- Make_Character_Literal (Loc, Name_uV, Get_Char_Code ('V')));
- Analyze (Expression (Lang1));
-
- Rewrite (Expression (Lang2),
- Make_Character_Literal (Loc, Name_uM, Get_Char_Code ('M')));
- Analyze (Expression (Lang2));
-
- Rewrite (Expression (Lang3),
- Make_Character_Literal (Loc, Name_uS, Get_Char_Code ('S')));
- Analyze (Expression (Lang3));
-
- if Exception_Code (Id) /= No_Uint then
- Code := Make_Integer_Literal (Loc, Exception_Code (Id));
-
- Excep_Object :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Excep_Internal,
- Object_Definition =>
- New_Reference_To (Standard_Integer, Loc));
-
- Insert_Action (N, Excep_Object);
- Analyze (Excep_Object);
-
- Start_String;
- Store_String_Int (UI_To_Int (Exception_Code (Id)) / 8 * 8);
-
- Excep_Alias :=
- Make_Pragma
- (Loc,
- Name_Linker_Alias,
- New_List
- (Make_Pragma_Argument_Association
- (Sloc => Loc,
- Expression =>
- New_Reference_To (Excep_Internal, Loc)),
- Make_Pragma_Argument_Association
- (Sloc => Loc,
- Expression =>
- Make_String_Literal
- (Sloc => Loc,
- Strval => End_String))));
-
- Insert_Action (N, Excep_Alias);
- Analyze (Excep_Alias);
-
- Export_Pragma :=
- Make_Pragma
- (Loc,
- Name_Export,
- New_List
- (Make_Pragma_Argument_Association
- (Sloc => Loc,
- Expression => Make_Identifier (Loc, Name_C)),
- Make_Pragma_Argument_Association
- (Sloc => Loc,
- Expression =>
- New_Reference_To (Excep_Internal, Loc)),
- Make_Pragma_Argument_Association
- (Sloc => Loc,
- Expression =>
- Make_String_Literal
- (Sloc => Loc,
- Strval => Excep_Image)),
- Make_Pragma_Argument_Association
- (Sloc => Loc,
- Expression =>
- Make_String_Literal
- (Sloc => Loc,
- Strval => Excep_Image))));
-
- Insert_Action (N, Export_Pragma);
- Analyze (Export_Pragma);
+ -- This pragma is only effective on OpenVMS systems, it was ignored
+ -- on non-VMS systems, and we need to ignore it here as well.
+ if not OpenVMS_On_Target then
+ return;
+ end if;
+
+ declare
+ Id : constant Entity_Id := Entity (Expression (Arg1 (N)));
+ Call : constant Node_Id := Register_Exception_Call (Id);
+ Loc : constant Source_Ptr := Sloc (N);
+
+ begin
+ if Present (Call) then
+ declare
+ Excep_Internal : constant Node_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('V'));
+ Export_Pragma : Node_Id;
+ Excep_Alias : Node_Id;
+ Excep_Object : Node_Id;
+ Excep_Image : String_Id;
+ Exdata : List_Id;
+ Lang1 : Node_Id;
+ Lang2 : Node_Id;
+ Lang3 : Node_Id;
+ Code : Node_Id;
+
+ begin
+ if Present (Interface_Name (Id)) then
+ Excep_Image := Strval (Interface_Name (Id));
else
- Code :=
- Unchecked_Convert_To (Standard_Integer,
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Import_Value), Loc),
- Parameter_Associations => New_List
- (Make_String_Literal (Loc,
- Strval => Excep_Image))));
+ Get_Name_String (Chars (Id));
+ Set_All_Upper_Case;
+ Excep_Image := String_From_Name_Buffer;
end if;
- Rewrite (Call,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To
- (RTE (RE_Register_VMS_Exception), Loc),
- Parameter_Associations => New_List (Code)));
-
- Analyze_And_Resolve (Code, Standard_Integer);
- Analyze (Call);
-
- end if;
+ Exdata := Component_Associations (Expression (Parent (Id)));
+
+ if Is_VMS_Exception (Id) then
+ Lang1 := Next (First (Exdata));
+ Lang2 := Next (Lang1);
+ Lang3 := Next (Lang2);
+
+ Rewrite (Expression (Lang1),
+ Make_Character_Literal (Loc,
+ Chars => Name_uV,
+ Char_Literal_Value => Get_Char_Code ('V')));
+ Analyze (Expression (Lang1));
+
+ Rewrite (Expression (Lang2),
+ Make_Character_Literal (Loc,
+ Chars => Name_uM,
+ Char_Literal_Value => Get_Char_Code ('M')));
+ Analyze (Expression (Lang2));
+
+ Rewrite (Expression (Lang3),
+ Make_Character_Literal (Loc,
+ Chars => Name_uS,
+ Char_Literal_Value => Get_Char_Code ('S')));
+ Analyze (Expression (Lang3));
+
+ if Exception_Code (Id) /= No_Uint then
+ Code :=
+ Make_Integer_Literal (Loc,
+ Intval => Exception_Code (Id));
+
+ Excep_Object :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Excep_Internal,
+ Object_Definition =>
+ New_Reference_To (Standard_Integer, Loc));
+
+ Insert_Action (N, Excep_Object);
+ Analyze (Excep_Object);
+
+ Start_String;
+ Store_String_Int
+ (UI_To_Int (Exception_Code (Id)) / 8 * 8);
+
+ Excep_Alias :=
+ Make_Pragma
+ (Loc,
+ Name_Linker_Alias,
+ New_List
+ (Make_Pragma_Argument_Association
+ (Sloc => Loc,
+ Expression =>
+ New_Reference_To (Excep_Internal, Loc)),
+
+ Make_Pragma_Argument_Association
+ (Sloc => Loc,
+ Expression =>
+ Make_String_Literal
+ (Sloc => Loc,
+ Strval => End_String))));
+
+ Insert_Action (N, Excep_Alias);
+ Analyze (Excep_Alias);
+
+ Export_Pragma :=
+ Make_Pragma
+ (Loc,
+ Name_Export,
+ New_List
+ (Make_Pragma_Argument_Association
+ (Sloc => Loc,
+ Expression => Make_Identifier (Loc, Name_C)),
+
+ Make_Pragma_Argument_Association
+ (Sloc => Loc,
+ Expression =>
+ New_Reference_To (Excep_Internal, Loc)),
+
+ Make_Pragma_Argument_Association
+ (Sloc => Loc,
+ Expression =>
+ Make_String_Literal
+ (Sloc => Loc,
+ Strval => Excep_Image)),
+
+ Make_Pragma_Argument_Association
+ (Sloc => Loc,
+ Expression =>
+ Make_String_Literal
+ (Sloc => Loc,
+ Strval => Excep_Image))));
+
+ Insert_Action (N, Export_Pragma);
+ Analyze (Export_Pragma);
+
+ else
+ Code :=
+ Unchecked_Convert_To (Standard_Integer,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Import_Value), Loc),
+ Parameter_Associations => New_List
+ (Make_String_Literal (Loc,
+ Strval => Excep_Image))));
+ end if;
+
+ Rewrite (Call,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To
+ (RTE (RE_Register_VMS_Exception), Loc),
+ Parameter_Associations => New_List (Code)));
+
+ Analyze_And_Resolve (Code, Standard_Integer);
+ Analyze (Call);
+ end if;
- if not Present (Interface_Name (Id)) then
- Set_Interface_Name (Id,
- Make_String_Literal
- (Sloc => Loc,
- Strval => Excep_Image));
- end if;
- end;
- end if;
+ if not Present (Interface_Name (Id)) then
+ Set_Interface_Name (Id,
+ Make_String_Literal
+ (Sloc => Loc,
+ Strval => Excep_Image));
+ end if;
+ end;
+ end if;
+ end;
end Expand_Pragma_Import_Export_Exception;
------------------------------------
diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb
index 6cc2e7f23ec..726f713fe3c 100644
--- a/gcc/ada/exp_strm.adb
+++ b/gcc/ada/exp_strm.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- --
@@ -24,20 +24,19 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Einfo; use Einfo;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Rtsfind; use Rtsfind;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Exp_Tss; use Exp_Tss;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Einfo; use Einfo;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Rtsfind; use Rtsfind;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Exp_Tss; use Exp_Tss;
+with Uintp; use Uintp;
package body Exp_Strm is
@@ -80,18 +79,6 @@ package body Exp_Strm is
-- Decls and Stms are the declarations and statements for the body and
-- The parameter Fnam is the name of the constructed function.
- procedure Build_Stream_Procedure
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- Decl : out Node_Id;
- Pnam : Entity_Id;
- Stms : List_Id;
- Outp : Boolean);
- -- Called to build an array or record stream procedure. The first three
- -- arguments are the same as Build_Record_Or_Elementary_Output_Procedure.
- -- Stms is the list of statements for the body (the declaration list is
- -- always null), and Pnam is the name of the constructed procedure.
-
function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean;
-- This function is used to test U_Type, which is a type
-- Returns True if U_Type has a standard representation for stream
@@ -99,6 +86,17 @@ package body Exp_Strm is
-- clause, and the size of the first subtype is the same as the size
-- of the root type.
+ function Make_Stream_Subprogram_Name
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Entity_Id;
+ -- Return the entity that identifies the stream subprogram for type Typ
+ -- that is identified by the given Nam. This procedure deals with the
+ -- difference between tagged types (where a single subprogram associated
+ -- with the type is generated) and all other cases (where a subprogram
+ -- is generated at the point of the stream attribute reference). The
+ -- Loc parameter is used as the Sloc of the created entity.
+
function Stream_Base_Type (E : Entity_Id) return Entity_Id;
-- Stream attributes work on the basis of the base type except for the
-- array case. For the array case, we do not go to the base type, but
@@ -114,7 +112,7 @@ package body Exp_Strm is
-- The function we build looks like
- -- function InputN (S : access RST) return Typ is
+ -- function typSI[_nnn] (S : access RST) return Typ is
-- L1 : constant Index_Type_1 := Index_Type_1'Input (S);
-- H1 : constant Index_Type_1 := Index_Type_1'Input (S);
-- L2 : constant Index_Type_2 := Index_Type_2'Input (S);
@@ -128,7 +126,11 @@ package body Exp_Strm is
-- begin
-- Typ'Read (S, V);
-- return V;
- -- end InputN
+ -- end typSI[_nnn]
+
+ -- Note: the suffix [_nnn] is present for non-tagged types, where we
+ -- generate a local subprogram at the point of the occurrence of the
+ -- attribute reference, so the name must be unique.
procedure Build_Array_Input_Function
(Loc : Source_Ptr;
@@ -221,8 +223,7 @@ package body Exp_Strm is
Fnam :=
Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Name_uInput, ' ', Increment_Serial_Number));
+ Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Input));
Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
end Build_Array_Input_Function;
@@ -288,8 +289,7 @@ package body Exp_Strm is
Pnam :=
Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Name_uOutput, ' ', Increment_Serial_Number));
+ Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Output));
Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
end Build_Array_Output_Procedure;
@@ -309,9 +309,7 @@ package body Exp_Strm is
begin
Pnam :=
Make_Defining_Identifier (Loc,
- New_External_Name
- (Name_uRead, ' ', Increment_Serial_Number));
-
+ Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read);
end Build_Array_Read_Procedure;
@@ -343,8 +341,7 @@ package body Exp_Strm is
Pnam : Entity_Id;
Nam : Name_Id)
is
- Loc : constant Source_Ptr := Sloc (Nod);
-
+ Loc : constant Source_Ptr := Sloc (Nod);
Ndim : constant Pos := Number_Dimensions (Typ);
Ctyp : constant Entity_Id := Component_Type (Typ);
@@ -378,9 +375,9 @@ package body Exp_Strm is
-- generate any additional freezing actions in any case. See 5509-003.
if Nam = Name_Read then
- RW := TSS (Base_Type (Ctyp), Name_uRead);
+ RW := TSS (Base_Type (Ctyp), TSS_Stream_Read);
else
- RW := TSS (Base_Type (Ctyp), Name_uWrite);
+ RW := TSS (Base_Type (Ctyp), TSS_Stream_Write);
end if;
if Present (RW)
@@ -435,9 +432,7 @@ package body Exp_Strm is
begin
Pnam :=
Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Name_uWrite, ' ', Increment_Serial_Number));
-
+ Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write);
end Build_Array_Write_Procedure;
@@ -452,7 +447,9 @@ package body Exp_Strm is
Rt_Type : constant Entity_Id := Root_Type (U_Type);
FST : constant Entity_Id := First_Subtype (U_Type);
P_Size : constant Uint := Esize (FST);
+ Res : Node_Id;
Strm : constant Node_Id := First (Expressions (N));
+ Targ : constant Node_Id := Next (Strm);
Lib_RE : RE_Id;
begin
@@ -580,15 +577,32 @@ package body Exp_Strm is
end if;
-- Call the function, and do an unchecked conversion of the result
- -- to the actual type of the prefix.
+ -- to the actual type of the prefix. If the target is a discriminant,
+ -- set target type to force a constraint check (13.13.2 (35)).
- return
- Unchecked_Convert_To (P_Type,
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
- Parameter_Associations => New_List (
- Relocate_Node (Strm))));
+ if Nkind (Targ) = N_Selected_Component
+ and then Present (Entity (Selector_Name (Targ)))
+ and then Ekind (Entity (Selector_Name (Targ)))
+ = E_Discriminant
+ then
+ Res :=
+ Unchecked_Convert_To (Base_Type (P_Type),
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
+ Parameter_Associations => New_List (
+ Relocate_Node (Strm))));
+
+ Set_Do_Range_Check (Res);
+ return Res;
+ else
+ return
+ Unchecked_Convert_To (P_Type,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
+ Parameter_Associations => New_List (
+ Relocate_Node (Strm))));
+ end if;
end Build_Elementary_Input_Call;
---------------------------------
@@ -746,7 +760,6 @@ package body Exp_Strm is
Relocate_Node (Strm),
Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))),
Relocate_Node (Item))));
-
end Build_Elementary_Write_Call;
-----------------------------------------
@@ -793,9 +806,7 @@ package body Exp_Strm is
Pnam :=
Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Name_uRead, ' ', Increment_Serial_Number));
-
+ Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
-- Read the discriminants before the rest of the components, so
@@ -860,9 +871,7 @@ package body Exp_Strm is
Pnam :=
Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Name_uWrite, ' ', Increment_Serial_Number));
-
+ Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
-- Write the discriminants before the rest of the components, so
@@ -987,18 +996,7 @@ package body Exp_Strm is
Make_Return_Statement (Loc,
Expression => Make_Identifier (Loc, Name_V)));
- -- For tagged types, we use a canonical name so that it matches the
- -- primitive spec. For all other cases, we use a serialized name so
- -- that multiple generations of the same procedure do not clash.
-
- if Is_Tagged_Type (Typ) then
- Fnam := Make_Defining_Identifier (Loc, Name_uInput);
- else
- Fnam :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Name_uInput, ' ', Increment_Serial_Number));
- end if;
+ Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
end Build_Record_Or_Elementary_Input_Function;
@@ -1049,19 +1047,7 @@ package body Exp_Strm is
Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Name_V))));
- -- For tagged types, we use a canonical name so that it matches the
- -- primitive spec. For all other cases, we use a serialized name so
- -- that multiple generations of the same procedure do not clash.
-
- if Is_Tagged_Type (Typ) then
- Pnam := Make_Defining_Identifier (Loc, Name_uOutput);
- else
- Pnam :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name
- (Name_uOutput, ' ', Increment_Serial_Number));
- end if;
+ Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output);
Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
end Build_Record_Or_Elementary_Output_Procedure;
@@ -1077,19 +1063,7 @@ package body Exp_Strm is
Pnam : out Entity_Id)
is
begin
- -- For tagged types, we use a canonical name so that it matches the
- -- primitive spec. For all other cases, we use a serialized name so
- -- that multiple generations of the same procedure do not clash.
-
- if Is_Tagged_Type (Typ) then
- Pnam := Make_Defining_Identifier (Loc, Name_uRead);
- else
- Pnam :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Name_uRead, ' ', Increment_Serial_Number));
- end if;
-
+ Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read);
Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
end Build_Record_Read_Procedure;
@@ -1283,7 +1257,8 @@ package body Exp_Strm is
-- Write do not read or write the discriminant values. All handling
-- of discriminants occurs in the Input and Output subprograms.
- Rdef := Type_Definition (Declaration_Node (Underlying_Type (Typt)));
+ Rdef := Type_Definition
+ (Declaration_Node (Base_Type (Underlying_Type (Typt))));
Stms := Empty_List;
-- In record extension case, the fields we want, including the _Parent
@@ -1302,7 +1277,6 @@ package body Exp_Strm is
Build_Stream_Procedure
(Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read);
-
end Build_Record_Read_Write_Procedure;
----------------------------------
@@ -1316,19 +1290,7 @@ package body Exp_Strm is
Pnam : out Entity_Id)
is
begin
- -- For tagged types, we use a canonical name so that it matches the
- -- primitive spec. For all other cases, we use a serialized name so
- -- that multiple generations of the same procedure do not clash.
-
- if Is_Tagged_Type (Typ) then
- Pnam := Make_Defining_Identifier (Loc, Name_uWrite);
- else
- Pnam :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Name_uWrite, ' ', Increment_Serial_Number));
- end if;
-
+ Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write);
Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
end Build_Record_Write_Procedure;
@@ -1337,27 +1299,26 @@ package body Exp_Strm is
-------------------------------
function Build_Stream_Attr_Profile
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- Nam : Name_Id)
- return List_Id
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Nam : TSS_Name_Type) return List_Id
is
Profile : List_Id;
begin
Profile := New_List (
Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark => New_Reference_To (
Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))));
- if Nam /= Name_uInput then
+ if Nam /= TSS_Stream_Input then
Append_To (Profile,
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
- Out_Present => (Nam = Name_uRead),
+ Out_Present => (Nam = TSS_Stream_Read),
Parameter_Type => New_Reference_To (Typ, Loc)));
end if;
@@ -1402,7 +1363,6 @@ package body Exp_Strm is
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
-
end Build_Stream_Function;
----------------------------
@@ -1446,7 +1406,6 @@ package body Exp_Strm is
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
-
end Build_Stream_Procedure;
-----------------------------
@@ -1457,13 +1416,38 @@ package body Exp_Strm is
begin
if Has_Non_Standard_Rep (U_Type) then
return False;
-
else
return
Esize (First_Subtype (U_Type)) = Esize (Root_Type (U_Type));
end if;
end Has_Stream_Standard_Rep;
+ ---------------------------------
+ -- Make_Stream_Subprogram_Name --
+ ---------------------------------
+
+ function Make_Stream_Subprogram_Name
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Entity_Id
+ is
+ Sname : Name_Id;
+
+ begin
+ -- For tagged types, we are dealing with a TSS associated with the
+ -- declaration, so we use the standard primitive function name. For
+ -- other types, generate a local TSS name since we are generating
+ -- the subprogram at the point of use.
+
+ if Is_Tagged_Type (Typ) then
+ Sname := Make_TSS_Name (Typ, Nam);
+ else
+ Sname := Make_TSS_Name_Local (Typ, Nam);
+ end if;
+
+ return Make_Defining_Identifier (Loc, Sname);
+ end Make_Stream_Subprogram_Name;
+
----------------------
-- Stream_Base_Type --
----------------------
@@ -1474,7 +1458,6 @@ package body Exp_Strm is
and then Is_First_Subtype (E)
then
return E;
-
else
return Base_Type (E);
end if;
diff --git a/gcc/ada/exp_strm.ads b/gcc/ada/exp_strm.ads
index 1e089ca881d..fee12452d74 100644
--- a/gcc/ada/exp_strm.ads
+++ b/gcc/ada/exp_strm.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1999 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- --
@@ -26,7 +26,8 @@
-- Routines to build stream subprograms for composite types
-with Types; use Types;
+with Exp_Tss; use Exp_Tss;
+with Types; use Types;
package Exp_Strm is
@@ -42,14 +43,12 @@ package Exp_Strm is
-- reference node.
function Build_Stream_Attr_Profile
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- Nam : Name_Id)
- return List_Id;
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Nam : TSS_Name_Type) return List_Id;
-- Builds the parameter profile for the stream attribute identified by
- -- the given name (which is the underscore version, e.g. Name_uWrite to
- -- identify the Write attribute). This is used for the tagged case to
- -- build the spec for the primitive operation.
+ -- the given name. This is used for the tagged case to build the spec
+ -- for the primitive operation.
-- The following routines build procedures and functions for stream
-- attributes applied to composite types. For each of these routines,
@@ -140,4 +139,17 @@ package Exp_Strm is
Pnam : out Entity_Id);
-- Build procedure for Write attribute for record type
+ procedure Build_Stream_Procedure
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Decl : out Node_Id;
+ Pnam : Entity_Id;
+ Stms : List_Id;
+ Outp : Boolean);
+ -- Called to build an array or record stream procedure. The first three
+ -- arguments are the same as Build_Record_Or_Elementary_Output_Procedure.
+ -- Stms is the list of statements for the body (the declaration list is
+ -- always null), and Pnam is the name of the constructed procedure.
+ -- Used by Exp_Dist to generate stream-oriented attributes for RACWs.
+
end Exp_Strm;
diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb
index e714a082c1e..5068b242225 100644
--- a/gcc/ada/exp_tss.adb
+++ b/gcc/ada/exp_tss.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -29,9 +29,9 @@ with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
+with Namet; use Namet;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
-with Snames; use Snames;
package body Exp_Tss is
@@ -97,6 +97,31 @@ package body Exp_Tss is
Prepend_Elmt (TSS, TSS_Elist (FN));
end Copy_TSS;
+ -----------------------
+ -- Get_TSS_Name_Type --
+ -----------------------
+
+ function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type is
+ C1 : Character;
+ C2 : Character;
+ Nm : TSS_Name_Type;
+
+ begin
+ Get_Last_Two_Chars (Chars (E), C1, C2);
+
+ if C1 in 'A' .. 'Z' and then C2 in 'A' .. 'Z' then
+ Nm := (C1, C2);
+
+ for J in OK_TSS_Names'Range loop
+ if Nm = OK_TSS_Names (J) then
+ return Nm;
+ end if;
+ end loop;
+ end if;
+
+ return TSS_Null;
+ end Get_TSS_Name;
+
---------------------------------
-- Has_Non_Null_Base_Init_Proc --
---------------------------------
@@ -113,10 +138,131 @@ package body Exp_Tss is
---------------
function Init_Proc (Typ : Entity_Id) return Entity_Id is
+ FN : constant Node_Id := Freeze_Node (Typ);
+ Elmt : Elmt_Id;
+
begin
- return TSS (Typ, Name_uInit_Proc);
+ if No (FN) then
+ return Empty;
+
+ elsif No (TSS_Elist (FN)) then
+ return Empty;
+
+ else
+ Elmt := First_Elmt (TSS_Elist (FN));
+ while Present (Elmt) loop
+ if Is_Init_Proc (Node (Elmt)) then
+ return Node (Elmt);
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end if;
+
+ return Empty;
end Init_Proc;
+ ------------------
+ -- Is_Init_Proc --
+ ------------------
+
+ function Is_Init_Proc (E : Entity_Id) return Boolean is
+ C1 : Character;
+ C2 : Character;
+ begin
+ Get_Last_Two_Chars (Chars (E), C1, C2);
+ return C1 = TSS_Init_Proc (1) and then C2 = TSS_Init_Proc (2);
+ end Is_Init_Proc;
+
+ ------------
+ -- Is_TSS --
+ ------------
+
+ function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean is
+ C1 : Character;
+ C2 : Character;
+ begin
+ Get_Last_Two_Chars (Chars (E), C1, C2);
+ return C1 = Nam (1) and then C2 = Nam (2);
+ end Is_TSS;
+
+ function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean is
+ C1 : Character;
+ C2 : Character;
+ begin
+ Get_Last_Two_Chars (N, C1, C2);
+ return C1 = Nam (1) and then C2 = Nam (2);
+ end Is_TSS;
+
+ -------------------------
+ -- Make_Init_Proc_Name --
+ -------------------------
+
+ function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id is
+ begin
+ Get_Name_String (Chars (Typ));
+ Name_Len := Name_Len + 2;
+ Name_Buffer (Name_Len - 1) := TSS_Init_Proc (1);
+ Name_Buffer (Name_Len) := TSS_Init_Proc (2);
+ return Name_Find;
+ end Make_Init_Proc_Name;
+
+ -------------------------
+ -- Make_TSS_Name_Local --
+ -------------------------
+
+ function Make_TSS_Name_Local
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Name_Id
+ is
+ begin
+ Get_Name_String (Chars (Typ));
+ Add_Char_To_Name_Buffer (Nam (1));
+ Add_Char_To_Name_Buffer (Nam (2));
+ Add_Char_To_Name_Buffer ('_');
+ Add_Nat_To_Name_Buffer (Increment_Serial_Number);
+ return Name_Find;
+ end Make_TSS_Name_Local;
+
+ -------------------
+ -- Make_TSS_Name --
+ -------------------
+
+ function Make_TSS_Name
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Name_Id
+ is
+ begin
+ Get_Name_String (Chars (Typ));
+ Add_Char_To_Name_Buffer (Nam (1));
+ Add_Char_To_Name_Buffer (Nam (2));
+ return Name_Find;
+ end Make_TSS_Name;
+
+ --------------
+ -- Same_TSS --
+ --------------
+
+ function Same_TSS (E1, E2 : Entity_Id) return Boolean is
+ E1C1 : Character;
+ E1C2 : Character;
+ E2C1 : Character;
+ E2C2 : Character;
+
+ begin
+ Get_Last_Two_Chars (Chars (E1), E1C1, E1C2);
+ Get_Last_Two_Chars (Chars (E2), E2C1, E2C2);
+
+ return
+ E1C1 = E2C1
+ and then
+ E1C2 = E2C2
+ and then
+ E1C1 in 'A' .. 'Z'
+ and then
+ E1C2 in 'A' .. 'Z';
+ end Same_TSS;
+
-------------------
-- Set_Init_Proc --
-------------------
@@ -152,7 +298,7 @@ package body Exp_Tss is
-- TSS --
---------
- function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
+ function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id is
FN : constant Node_Id := Freeze_Node (Typ);
Elmt : Elmt_Id;
Subp : Entity_Id;
@@ -166,9 +312,50 @@ package body Exp_Tss is
else
Elmt := First_Elmt (TSS_Elist (FN));
+ while Present (Elmt) loop
+ if Is_TSS (Node (Elmt), Nam) then
+ Subp := Node (Elmt);
+
+ -- For stream subprograms, the TSS entity may be a renaming-
+ -- as-body of an already generated entity. Use that one rather
+ -- the one introduced by the renaming, which is an artifact of
+ -- current stream handling.
+
+ if Nkind (Parent (Parent (Subp))) =
+ N_Subprogram_Renaming_Declaration
+ and then
+ Present (Corresponding_Spec (Parent (Parent (Subp))))
+ then
+ return Corresponding_Spec (Parent (Parent (Subp)));
+ else
+ return Subp;
+ end if;
+ else
+ Next_Elmt (Elmt);
+ end if;
+ end loop;
+ end if;
+
+ return Empty;
+ end TSS;
+
+ function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id is
+ FN : constant Node_Id := Freeze_Node (Typ);
+ Elmt : Elmt_Id;
+ Subp : Entity_Id;
+
+ begin
+ if No (FN) then
+ return Empty;
+
+ elsif No (TSS_Elist (FN)) then
+ return Empty;
+
+ else
+ Elmt := First_Elmt (TSS_Elist (FN));
while Present (Elmt) loop
- if Chars (Node (Elmt)) = Nam then
+ if Chars (Node (Elmt)) = Nam then
Subp := Node (Elmt);
-- For stream subprograms, the TSS entity may be a renaming-
diff --git a/gcc/ada/exp_tss.ads b/gcc/ada/exp_tss.ads
index 2901dbb6b95..c36b821f792 100644
--- a/gcc/ada/exp_tss.ads
+++ b/gcc/ada/exp_tss.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -45,19 +45,116 @@ package Exp_Tss is
-- attributes use the second approach, since it is more likely that they
-- will not be used at all, or will only be used in one client in any case.
- -- A TSS is identified by its Chars name, i.e. for a given TSS type, the
- -- same name is used for all types, e.g. the initialization routine has
- -- the name _init for all types.
+ -------------------------
+ -- Current Limitations --
+ -------------------------
+
+ -- In the current version of this package, only the case of generating a
+ -- TSS at the point of declaration of the type is accomodated. A clear
+ -- improvement would be to follow through with the full implementation
+ -- as described above, and also accomodate the requirement of generating
+ -- only one copy in a given object file.
+
+ -- For now, we deal with the local case by generating duplicate versions
+ -- of the TSS routine, which is clearly rather inefficient in space usage.
+ -- This is done by using Make_TSS_Name_Local to generate unique names
+ -- for the different instances of TSS routines in a given scope.
+
+ ----------------
+ -- TSS Naming --
+ ----------------
+
+ -- A TSS is identified by its Chars name. The name has the form typXY,
+ -- where typ is the type name, and XY are two characters that identify
+ -- the particular TSS routine, using the following codes:
+
+ -- Note: When making additions to this list, update the list in snames.adb
+
+ type TSS_Name_Type is new String (1 .. 2);
+ subtype TNT is TSS_Name_Type;
+
+ TSS_Deep_Adjust : constant TNT := "DA"; -- Deep Adjust
+ TSS_Deep_Finalize : constant TNT := "DF"; -- Deep Finalize
+ TSS_Deep_Initialize : constant TNT := "DI"; -- Deep Initialize
+ TSS_Composite_Equality : constant TNT := "EQ"; -- Composite Equality
+ TSS_Init_Proc : constant TNT := "IP"; -- Initialization Procedure
+ TSS_RAS_Access : constant TNT := "RA"; -- RAs type access
+ TSS_RAS_Dereference : constant TNT := "RD"; -- RAs type deference
+ TSS_Rep_To_Pos : constant TNT := "RP"; -- Rep to Pos conversion
+ TSS_Stream_Input : constant TNT := "SI"; -- Stream Input attribute
+ TSS_Stream_Output : constant TNT := "SO"; -- Stream Output attribute
+ TSS_Stream_Read : constant TNT := "SR"; -- Stream Read attribute
+ TSS_Stream_Write : constant TNT := "SW"; -- Stream Write attribute
+
+ OK_TSS_Names : constant array (Natural range <>) of TSS_Name_Type :=
+ (TSS_Deep_Adjust,
+ TSS_Deep_Finalize,
+ TSS_Deep_Initialize,
+ TSS_Composite_Equality,
+ TSS_Init_Proc,
+ TSS_RAS_Access,
+ TSS_RAS_Dereference,
+ TSS_Rep_To_Pos,
+ TSS_Stream_Input,
+ TSS_Stream_Output,
+ TSS_Stream_Read,
+ TSS_Stream_Write);
+
+ TSS_Null : constant TNT := " ";
+ -- Dummy entry used to indicated that this is not really a TSS
+
+ function Get_TSS_Name (E : Entity_Id) return TSS_Name_Type;
+ -- Given an entity, if it is a TSS, then return the corresponding TSS
+ -- name type, otherwise return TSS_Null.
+
+ function Make_TSS_Name
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Name_Id;
+ -- Construct the name as described above for the given TSS routine
+ -- identified by Nam for the type identified by Typ.
+
+ function Make_TSS_Name_Local
+ (Typ : Entity_Id;
+ Nam : TSS_Name_Type) return Name_Id;
+ -- Similar to the above call, but a string of the form _nnn is appended
+ -- to the name, where nnn is a unique serial number. This is used when
+ -- multiple instances of the same TSS routine may be generated in the
+ -- same scope (see also discussion above of current limitations).
+
+ function Make_Init_Proc_Name (Typ : Entity_Id) return Name_Id;
+ -- Version for init procs, same as Make_TSS_Name (Typ, TSS_Init_Proc)
+
+ function Is_TSS (E : Entity_Id; Nam : TSS_Name_Type) return Boolean;
+ -- Determines if given entity (E) is the name of a TSS identified by Nam
+
+ function Is_TSS (N : Name_Id; Nam : TSS_Name_Type) return Boolean;
+ -- Same test applied directly to a Name_Id value
+
+ function Is_Init_Proc (E : Entity_Id) return Boolean;
+ -- Version for init procs, same as Is_TSS (E, TSS_Init_Proc);
+
+ -----------------------------------------
+ -- TSS Data structures and Subprograms --
+ -----------------------------------------
-- The TSS's for a given type are stored in an element list associated with
-- the type, and referenced from the TSS_Elist field of the N_Freeze_Entity
-- node associated with the type (all types that need TSS's always need to
-- be explicitly frozen, so the N_Freeze_Entity node always exists).
+ function TSS (Typ : Entity_Id; Nam : TSS_Name_Type) return Entity_Id;
+ -- Finds the TSS with the given name associated with the given type
+ -- If no such TSS exists, then Empty is returned;
+
function TSS (Typ : Entity_Id; Nam : Name_Id) return Entity_Id;
-- Finds the TSS with the given name associated with the given type. If
-- no such TSS exists, then Empty is returned.
+ function Same_TSS (E1, E2 : Entity_Id) return Boolean;
+ -- Returns True if E1 and E2 are the same kind of TSS, even if the names
+ -- are different (i.e. if the names of E1 and E2 end with two upper case
+ -- letters that are the same).
+
procedure Set_TSS (Typ : Entity_Id; TSS : Entity_Id);
-- This procedure is used to install a newly created TSS. The second
-- argument is the entity for such a new TSS. This entity is placed in
@@ -85,8 +182,8 @@ package Exp_Tss is
-- objects are always initialized using the initialization procedure for
-- the corresponding base type (see Base_Init_Proc function). A special
-- case arises for concurrent types. Such types do not themselves have an
- -- _init TSS, but initialization is required. The initialization procedure
- -- used is the one fot the corresponding record type (see Base_Init_Proc).
+ -- init proc TSS, but initialization is required. The init proc used is
+ -- the one fot the corresponding record type (see Base_Init_Proc).
function Base_Init_Proc (Typ : Entity_Id) return Entity_Id;
-- Obtains the _Init TSS entry from the base type of the entity, and also
@@ -104,7 +201,7 @@ package Exp_Tss is
-- Returns true if the given type has a defined Base_Init_Proc and
-- this init proc is not a null init proc (null init procs occur as
-- a result of the processing for Initialize_Scalars. This function
- -- is used to test for the presence of an Init_Proc in cases where
- -- a null init proc is considered equivalent to no Init_Proc.
+ -- is used to test for the presence of an init proc in cases where
+ -- a null init proc is considered equivalent to no init proc.
end Exp_Tss;
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 1da64c40e39..7cc74834745 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.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- --
@@ -31,6 +31,7 @@ with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
+with Exp_Tss; use Exp_Tss;
with Hostparm; use Hostparm;
with Inline; use Inline;
with Itypes; use Itypes;
@@ -46,6 +47,7 @@ with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
+with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Targparm; use Targparm;
@@ -99,7 +101,7 @@ package body Exp_Util is
(Loc : Source_Ptr;
Id_Ref : Node_Id;
Dyn : Boolean := False)
- return Node_Id;
+ return Node_Id;
-- Build function to generate the image string for a task that is a
-- record component. Concatenate name of variable with that of selector.
-- The flag Dyn indicates whether this is called for the initialization
@@ -114,6 +116,7 @@ package body Exp_Util is
-- constrains T in case such as: " X: T := E" or "new T'(E)"
-- This function returns the entity of the Equivalent type and inserts
-- on the fly the necessary declaration such as:
+ --
-- type anon is record
-- _parent : Root_Type (T); constrained with E discriminants (if any)
-- Extension : String (1 .. expr to match size of E);
@@ -311,9 +314,16 @@ package body Exp_Util is
function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
begin
- return
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE), Loc));
+ -- If entity is not available, we can skip making the call (this avoids
+ -- junk duplicated error messages in a number of cases).
+
+ if not RTE_Available (RE) then
+ return Make_Null_Statement (Loc);
+ else
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE), Loc));
+ end if;
end Build_Runtime_Call;
-----------------------------
@@ -322,25 +332,25 @@ package body Exp_Util is
-- This function generates the body for a function that constructs the
-- image string for a task that is an array component. The function is
- -- local to the init_proc for the array type, and is called for each one
+ -- local to the init proc for the array type, and is called for each one
-- of the components. The constructed image has the form of an indexed
-- component, whose prefix is the outer variable of the array type.
-- The n-dimensional array type has known indices Index, Index2...
- -- Id_Ref is an indexed component form created by the enclosing init_proc.
+ -- Id_Ref is an indexed component form created by the enclosing init proc.
-- Its successive indices are Val1, Val2,.. which are the loop variables
- -- in the loops that call the individual task init_proc on each component.
+ -- in the loops that call the individual task init proc on each component.
-- The generated function has the following structure:
- -- function F return Task_Image_Type is
- -- Pref : string := Task_Id.all;
- -- T1 : String := Index1'Image (Val1);
+ -- function F return String is
+ -- Pref : string renames Task_Name;
+ -- T1 : String := Index1'Image (Val1);
-- ...
- -- Tn : String := indexn'image (Valn);
- -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
+ -- Tn : String := indexn'image (Valn);
+ -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
-- -- Len includes commas and the end parentheses.
- -- Res : String (1..Len);
- -- Pos : Integer := Pref'Length;
+ -- Res : String (1..Len);
+ -- Pos : Integer := Pref'Length;
--
-- begin
-- Res (1 .. Pos) := Pref;
@@ -355,7 +365,7 @@ package body Exp_Util is
-- Res (Pos .. Pos + Tn'Length - 1) := Tn;
-- Res (Len) := ')';
--
- -- return new String (Res);
+ -- return Res;
-- end F;
--
-- Needless to say, multidimensional arrays of tasks are rare enough
@@ -386,9 +396,6 @@ package body Exp_Util is
Pref : Entity_Id;
-- Name of enclosing variable, prefix of resulting name
- P_Nam : Node_Id;
- -- string expression for Pref.
-
Res : Entity_Id;
-- String to hold result
@@ -408,24 +415,25 @@ package body Exp_Util is
Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
-- For a dynamic task, the name comes from the target variable.
- -- For a static one it is a formal of the enclosing init_proc.
+ -- For a static one it is a formal of the enclosing init proc.
if Dyn then
Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
- P_Nam :=
- Make_String_Literal (Loc, Strval => String_From_Name_Buffer);
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Pref,
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc, Strval => String_From_Name_Buffer)));
+
else
- P_Nam :=
- Make_Explicit_Dereference (Loc,
- Prefix => Make_Identifier (Loc, Name_uTask_Id));
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Pref,
+ Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
+ Name => Make_Identifier (Loc, Name_uTask_Name)));
end if;
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Pref,
- Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression => P_Nam));
-
Indx := First_Index (A_Type);
Val := First (Expressions (Id_Ref));
@@ -582,28 +590,34 @@ package body Exp_Util is
A_Type : Entity_Id)
return List_Id
is
+ Decls : constant List_Id := New_List;
T_Id : Entity_Id := Empty;
Decl : Node_Id;
- Decls : List_Id := New_List;
Expr : Node_Id := Empty;
Fun : Node_Id := Empty;
Is_Dyn : constant Boolean :=
- Nkind (Parent (Id_Ref)) = N_Assignment_Statement
- and then Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
+ Nkind (Parent (Id_Ref)) = N_Assignment_Statement
+ and then
+ Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
begin
- -- If Discard_Names is in effect, generate a dummy declaration only.
+ -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
+ -- generate a dummy declaration only.
- if Global_Discard_Names then
- T_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+ if Restrictions (No_Implicit_Heap_Allocations)
+ or else Global_Discard_Names
+ then
+ T_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
+ Name_Len := 0;
return
New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => T_Id,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc)));
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal
+ (Loc, Strval => String_From_Name_Buffer)));
else
if Nkind (Id_Ref) = N_Identifier
@@ -614,30 +628,23 @@ package body Exp_Util is
T_Id :=
Make_Defining_Identifier (Loc,
- New_External_Name (Chars (Id_Ref), 'I'));
+ New_External_Name (Chars (Id_Ref), 'T'));
Get_Name_String (Chars (Id_Ref));
- Expr :=
- Make_Allocator (Loc,
- Expression =>
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Standard_String, Loc),
- Expression =>
- Make_String_Literal
- (Loc, Strval => String_From_Name_Buffer)));
+ Expr := Make_String_Literal
+ (Loc, Strval => String_From_Name_Buffer);
elsif Nkind (Id_Ref) = N_Selected_Component then
T_Id :=
Make_Defining_Identifier (Loc,
- New_External_Name (Chars (Selector_Name (Id_Ref)), 'I'));
+ New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
elsif Nkind (Id_Ref) = N_Indexed_Component then
T_Id :=
Make_Defining_Identifier (Loc,
- New_External_Name (Chars (A_Type), 'I'));
+ New_External_Name (Chars (A_Type), 'N'));
Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
end if;
@@ -645,17 +652,15 @@ package body Exp_Util is
if Present (Fun) then
Append (Fun, Decls);
-
- Expr :=
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
+ Expr := Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
end if;
Decl := Make_Object_Declaration (Loc,
Defining_Identifier => T_Id,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc),
- Expression => Expr);
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Constant_Present => True,
+ Expression => Expr);
Append (Decl, Decls);
return Decls;
@@ -677,25 +682,23 @@ package body Exp_Util is
begin
Append_To (Stats,
Make_Return_Statement (Loc,
- Expression =>
- Make_Allocator (Loc,
- Expression =>
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Standard_String, Loc),
- Expression => New_Occurrence_Of (Res, Loc)))));
-
- Spec := Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
- Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc));
+ Expression => New_Occurrence_Of (Res, Loc)));
+
+ Spec := Make_Function_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
+ Subtype_Mark => New_Occurrence_Of (Standard_String, Loc));
+
+ -- Calls to 'Image use the secondary stack, which must be cleaned
+ -- up after the task name is built.
+
+ Set_Uses_Sec_Stack (Defining_Unit_Name (Spec));
return Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stats));
+ Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
end Build_Task_Image_Function;
-----------------------------
@@ -800,9 +803,6 @@ package body Exp_Util is
Pref : Entity_Id;
-- Name of enclosing variable, prefix of resulting name
- P_Nam : Node_Id;
- -- string expression for Pref.
-
Sum : Node_Id;
-- Expression to compute total size of string.
@@ -816,24 +816,25 @@ package body Exp_Util is
Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
-- For a dynamic task, the name comes from the target variable.
- -- For a static one it is a formal of the enclosing init_proc.
+ -- For a static one it is a formal of the enclosing init proc.
if Dyn then
Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
- P_Nam :=
- Make_String_Literal (Loc, Strval => String_From_Name_Buffer);
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Pref,
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc, Strval => String_From_Name_Buffer)));
+
else
- P_Nam :=
- Make_Explicit_Dereference (Loc,
- Prefix => Make_Identifier (Loc, Name_uTask_Id));
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Pref,
+ Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
+ Name => Make_Identifier (Loc, Name_uTask_Name)));
end if;
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Pref,
- Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression => P_Nam));
-
Sel := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
Get_Name_String (Chars (Selector_Name (Id_Ref)));
@@ -1244,6 +1245,29 @@ package body Exp_Util is
return Node (Prim);
end Find_Prim_Op;
+ function Find_Prim_Op
+ (T : Entity_Id;
+ Name : TSS_Name_Type) return Entity_Id
+ is
+ Prim : Elmt_Id;
+ Typ : Entity_Id := T;
+
+ begin
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
+ end if;
+
+ Typ := Underlying_Type (Typ);
+
+ Prim := First_Elmt (Primitive_Operations (Typ));
+ while not Is_TSS (Node (Prim), Name) loop
+ Next_Elmt (Prim);
+ pragma Assert (Present (Prim));
+ end loop;
+
+ return Node (Prim);
+ end Find_Prim_Op;
+
----------------------
-- Force_Evaluation --
----------------------
@@ -1273,6 +1297,179 @@ package body Exp_Util is
end if;
end Generate_Poll_Call;
+ ---------------------------------
+ -- Get_Current_Value_Condition --
+ ---------------------------------
+
+ procedure Get_Current_Value_Condition
+ (Var : Node_Id;
+ Op : out Node_Kind;
+ Val : out Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Var);
+ CV : constant Node_Id := Current_Value (Entity (Var));
+ Sens : Boolean;
+ Stm : Node_Id;
+ Cond : Node_Id;
+
+ begin
+ Op := N_Empty;
+ Val := Empty;
+
+ -- If statement. Condition is known true in THEN section, known False
+ -- in any ELSIF or ELSE part, and unknown outside the IF statement.
+
+ if Nkind (CV) = N_If_Statement then
+
+ -- Before start of IF statement
+
+ if Loc < Sloc (CV) then
+ return;
+
+ -- After end of IF statement
+
+ elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
+ return;
+ end if;
+
+ -- At this stage we know that we are within the IF statement, but
+ -- unfortunately, the tree does not record the SLOC of the ELSE so
+ -- we cannot use a simple SLOC comparison to distinguish between
+ -- the then/else statements, so we have to climb the tree.
+
+ declare
+ N : Node_Id;
+
+ begin
+ N := Parent (Var);
+ while Parent (N) /= CV loop
+ N := Parent (N);
+
+ -- If we fall off the top of the tree, then that's odd, but
+ -- perhaps it could occur in some error situation, and the
+ -- safest response is simply to assume that the outcome of
+ -- the condition is unknown. No point in bombing during an
+ -- attempt to optimize things.
+
+ if No (N) then
+ return;
+ end if;
+ end loop;
+
+ -- Now we have N pointing to a node whose parent is the IF
+ -- statement in question, so now we can tell if we are within
+ -- the THEN statements.
+
+ if Is_List_Member (N)
+ and then List_Containing (N) = Then_Statements (CV)
+ then
+ Sens := True;
+
+ -- Otherwise we must be in ELSIF or ELSE part
+
+ else
+ Sens := False;
+ end if;
+ end;
+
+ -- ELSIF part. Condition is known true within the referenced
+ -- ELSIF, known False in any subsequent ELSIF or ELSE part,
+ -- and unknown before the ELSE part or after the IF statement.
+
+ elsif Nkind (CV) = N_Elsif_Part then
+ Stm := Parent (CV);
+
+ -- Before start of ELSIF part
+
+ if Loc < Sloc (CV) then
+ return;
+
+ -- After end of IF statement
+
+ elsif Loc >= Sloc (Stm) +
+ Text_Ptr (UI_To_Int (End_Span (Stm)))
+ then
+ return;
+ end if;
+
+ -- Again we lack the SLOC of the ELSE, so we need to climb the
+ -- tree to see if we are within the ELSIF part in question.
+
+ declare
+ N : Node_Id;
+
+ begin
+ N := Parent (Var);
+ while Parent (N) /= Stm loop
+ N := Parent (N);
+
+ -- If we fall off the top of the tree, then that's odd, but
+ -- perhaps it could occur in some error situation, and the
+ -- safest response is simply to assume that the outcome of
+ -- the condition is unknown. No point in bombing during an
+ -- attempt to optimize things.
+
+ if No (N) then
+ return;
+ end if;
+ end loop;
+
+ -- Now we have N pointing to a node whose parent is the IF
+ -- statement in question, so see if is the ELSIF part we want.
+ -- the THEN statements.
+
+ if N = CV then
+ Sens := True;
+
+ -- Otherwise we must be in susbequent ELSIF or ELSE part
+
+ else
+ Sens := False;
+ end if;
+ end;
+
+ -- All other cases of Current_Value settings
+
+ else
+ return;
+ end if;
+
+ -- If we fall through here, then we have a reportable
+ -- condition, Sens is True if the condition is true and
+ -- False if it needs inverting.
+
+ Cond := Condition (CV);
+
+ -- Deal with NOT operators, inverting sense
+
+ while Nkind (Cond) = N_Op_Not loop
+ Cond := Right_Opnd (Cond);
+ Sens := not Sens;
+ end loop;
+
+ -- Now we must have a relational operator
+
+ pragma Assert (Entity (Var) = Entity (Left_Opnd (Cond)));
+ Val := Right_Opnd (Cond);
+ Op := Nkind (Cond);
+
+ if Sens = False then
+ case Op is
+ when N_Op_Eq => Op := N_Op_Ne;
+ when N_Op_Ne => Op := N_Op_Eq;
+ when N_Op_Lt => Op := N_Op_Ge;
+ when N_Op_Gt => Op := N_Op_Le;
+ when N_Op_Le => Op := N_Op_Gt;
+ when N_Op_Ge => Op := N_Op_Lt;
+
+ -- No other entry should be possible
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end if;
+ end Get_Current_Value_Condition;
+
--------------------
-- Homonym_Number --
--------------------
@@ -1417,7 +1614,7 @@ package body Exp_Util is
not Is_Procedure_Attribute_Name
(Attribute_Name (Assoc_Node)))
then
- P := Assoc_Node; -- ????? does not agree with above!
+ P := Assoc_Node; -- ??? does not agree with above!
N := Parent (Assoc_Node);
-- Non-subexpression case. Note that N is initially Empty in this
@@ -1678,7 +1875,9 @@ package body Exp_Util is
-- If a component association appears within a loop created for
-- an array aggregate, attach the actions to the association so
-- they can be subsequently inserted within the loop. For other
- -- component associations insert outside of the aggregate.
+ -- component associations insert outside of the aggregate. For
+ -- an association that will generate a loop, its Loop_Actions
+ -- attribute is already initialized (see exp_aggr.adb).
-- The list of loop_actions can in turn generate additional ones,
-- that are inserted before the associated node. If the associated
@@ -1689,10 +1888,9 @@ package body Exp_Util is
when
N_Component_Association =>
if Nkind (Parent (P)) = N_Aggregate
- and then Present (Aggregate_Bounds (Parent (P)))
- and then Nkind (First (Choices (P))) = N_Others_Choice
+ and then Present (Loop_Actions (P))
then
- if No (Loop_Actions (P)) then
+ if Is_Empty_List (Loop_Actions (P)) then
Set_Loop_Actions (P, Ins_Actions);
Analyze_List (Ins_Actions);
@@ -1922,7 +2120,7 @@ package body Exp_Util is
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
@@ -1932,12 +2130,12 @@ package body Exp_Util is
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Insert_Actions (Assoc_Node, Ins_Actions);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Insert_Actions;
@@ -2011,8 +2209,10 @@ package body Exp_Util is
begin
S := Current_Scope;
- while S /= Standard_Standard loop
- if Chars (S) = Name_uInit_Proc then
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Is_Init_Proc (S) then
return True;
else
S := Scope (S);
@@ -2022,6 +2222,148 @@ package body Exp_Util is
return False;
end Inside_Init_Proc;
+ ----------------------------
+ -- Is_All_Null_Statements --
+ ----------------------------
+
+ function Is_All_Null_Statements (L : List_Id) return Boolean is
+ Stm : Node_Id;
+
+ begin
+ Stm := First (L);
+ while Present (Stm) loop
+ if Nkind (Stm) /= N_Null_Statement then
+ return False;
+ end if;
+
+ Next (Stm);
+ end loop;
+
+ return True;
+ end Is_All_Null_Statements;
+
+ ----------------------------------
+ -- Is_Possibly_Unaligned_Object --
+ ----------------------------------
+
+ function Is_Possibly_Unaligned_Object (P : Node_Id) return Boolean is
+ begin
+ -- If target does not have strict alignment, result is always
+ -- False, since correctness of code does no depend on alignment.
+
+ if not Target_Strict_Alignment then
+ return False;
+ end if;
+
+ -- If renamed object, apply test to underlying object
+
+ if Is_Entity_Name (P)
+ and then Is_Object (Entity (P))
+ and then Present (Renamed_Object (Entity (P)))
+ then
+ return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (P)));
+ end if;
+
+ -- If this is an element of a packed array, may be unaligned
+
+ if Is_Ref_To_Bit_Packed_Array (P) then
+ return True;
+ end if;
+
+ -- Case of component reference
+
+ if Nkind (P) = N_Selected_Component then
+
+ -- If component reference is for a record that is bit packed
+ -- or has a specified alignment (that might be too small) or
+ -- the component reference has a component clause, then the
+ -- object may be unaligned.
+
+ if Is_Packed (Etype (Prefix (P)))
+ or else Known_Alignment (Etype (Prefix (P)))
+ or else Present (Component_Clause (Entity (Selector_Name (P))))
+ then
+ return True;
+
+ -- Otherwise, for a component reference, test prefix
+
+ else
+ return Is_Possibly_Unaligned_Object (Prefix (P));
+ end if;
+
+ -- If not a component reference, must be aligned
+
+ else
+ return False;
+ end if;
+ end Is_Possibly_Unaligned_Object;
+
+ ---------------------------------
+ -- Is_Possibly_Unaligned_Slice --
+ ---------------------------------
+
+ function Is_Possibly_Unaligned_Slice (P : Node_Id) return Boolean is
+ begin
+ if Is_Entity_Name (P)
+ and then Is_Object (Entity (P))
+ and then Present (Renamed_Object (Entity (P)))
+ then
+ return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (P)));
+ end if;
+
+ -- We only need to worry if the target has strict alignment, unless
+ -- it is a nested record component with a component clause, which
+ -- Gigi does not handle well. This patch should disappear with GCC 3.0
+ -- and it is not clear why it is needed even when the representation
+ -- clause is a confirming one, but in its absence gigi complains that
+ -- the slice is not addressable.???
+
+ if not Target_Strict_Alignment then
+ if Nkind (P) /= N_Slice
+ or else Nkind (Prefix (P)) /= N_Selected_Component
+ or else Nkind (Prefix (Prefix (P))) /= N_Selected_Component
+ then
+ return False;
+ end if;
+ end if;
+
+ -- The reference must be a slice
+
+ if Nkind (P) /= N_Slice then
+ return False;
+ end if;
+
+ -- If it is a slice, then look at the array type being sliced
+
+ declare
+ Pref : constant Node_Id := Prefix (P);
+ Typ : constant Entity_Id := Etype (Prefix (P));
+
+ begin
+ -- The worrisome case is one where we don't know the alignment
+ -- of the array, or we know it and it is greater than 1 (if the
+ -- alignment is one, then obviously it cannot be misaligned).
+
+ if Known_Alignment (Typ) and then Alignment (Typ) = 1 then
+ return False;
+ end if;
+
+ -- The only way we can be unaligned is if the array being sliced
+ -- is a component of a record, and either the record is packed,
+ -- or the component has a component clause, or the record has
+ -- a specified alignment (that might be too small).
+
+ return
+ Nkind (Pref) = N_Selected_Component
+ and then
+ (Is_Packed (Etype (Prefix (Pref)))
+ or else
+ Known_Alignment (Etype (Prefix (Pref)))
+ or else
+ Present (Component_Clause (Entity (Selector_Name (Pref)))));
+ end;
+ end Is_Possibly_Unaligned_Slice;
+
--------------------------------
-- Is_Ref_To_Bit_Packed_Array --
--------------------------------
@@ -2031,6 +2373,13 @@ package body Exp_Util is
Expr : Node_Id;
begin
+ if Is_Entity_Name (P)
+ and then Is_Object (Entity (P))
+ and then Present (Renamed_Object (Entity (P)))
+ then
+ return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (P)));
+ end if;
+
if Nkind (P) = N_Indexed_Component
or else
Nkind (P) = N_Selected_Component
@@ -2058,11 +2407,18 @@ package body Exp_Util is
end Is_Ref_To_Bit_Packed_Array;
--------------------------------
- -- Is_Ref_To_Bit_Packed_Slce --
+ -- Is_Ref_To_Bit_Packed_Slice --
--------------------------------
function Is_Ref_To_Bit_Packed_Slice (P : Node_Id) return Boolean is
begin
+ if Is_Entity_Name (P)
+ and then Is_Object (Entity (P))
+ and then Present (Renamed_Object (Entity (P)))
+ then
+ return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (P)));
+ end if;
+
if Nkind (P) = N_Slice
and then Is_Bit_Packed_Array (Etype (Prefix (P)))
then
@@ -2162,6 +2518,9 @@ package body Exp_Util is
end loop;
end;
+ elsif Nkind (N) = N_Case_Statement_Alternative then
+ Kill_Dead_Code (Statements (N));
+
-- Deal with dead instances caused by deleting instantiations
elsif Nkind (N) in N_Generic_Instantiation then
@@ -2209,88 +2568,75 @@ package body Exp_Util is
end if;
end Known_Non_Negative;
- --------------------------
- -- Target_Has_Fixed_Ops --
- --------------------------
-
- Integer_Sized_Small : Ureal;
- -- Set to 2.0 ** -(Integer'Size - 1) the first time that this
- -- function is called (we don't want to compute it more than once!)
+ --------------------
+ -- Known_Non_Null --
+ --------------------
- Long_Integer_Sized_Small : Ureal;
- -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
- -- functoin is called (we don't want to compute it more than once)
+ function Known_Non_Null (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Is_Access_Type (Underlying_Type (Etype (N))));
- First_Time_For_THFO : Boolean := True;
- -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
+ -- Case of entity for which Is_Known_Non_Null is True
- function Target_Has_Fixed_Ops
- (Left_Typ : Entity_Id;
- Right_Typ : Entity_Id;
- Result_Typ : Entity_Id)
- return Boolean
- is
- function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
- -- Return True if the given type is a fixed-point type with a small
- -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
- -- an absolute value less than 1.0. This is currently limited
- -- to fixed-point types that map to Integer or Long_Integer.
+ if Is_Entity_Name (N) and then Is_Known_Non_Null (Entity (N)) then
- ------------------------
- -- Is_Fractional_Type --
- ------------------------
+ -- If the entity is aliased or volatile, then we decide that
+ -- we don't know it is really non-null even if the sequential
+ -- flow indicates that it is, since such variables can be
+ -- changed without us noticing.
- function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
- begin
- if Esize (Typ) = Standard_Integer_Size then
- return Small_Value (Typ) = Integer_Sized_Small;
+ if Is_Aliased (Entity (N))
+ or else Treat_As_Volatile (Entity (N))
+ then
+ return False;
- elsif Esize (Typ) = Standard_Long_Integer_Size then
- return Small_Value (Typ) = Long_Integer_Sized_Small;
+ -- For all other cases, the flag is decisive
else
- return False;
+ return True;
end if;
- end Is_Fractional_Type;
- -- Start of processing for Target_Has_Fixed_Ops
+ -- True if access attribute
- begin
- -- Return False if Fractional_Fixed_Ops_On_Target is false
+ elsif Nkind (N) = N_Attribute_Reference
+ and then (Attribute_Name (N) = Name_Access
+ or else
+ Attribute_Name (N) = Name_Unchecked_Access
+ or else
+ Attribute_Name (N) = Name_Unrestricted_Access)
+ then
+ return True;
- if not Fractional_Fixed_Ops_On_Target then
- return False;
- end if;
+ -- True if allocator
- -- Here the target has Fractional_Fixed_Ops, if first time, compute
- -- standard constants used by Is_Fractional_Type.
+ elsif Nkind (N) = N_Allocator then
+ return True;
- if First_Time_For_THFO then
- First_Time_For_THFO := False;
+ -- For a conversion, true if expression is known non-null
- Integer_Sized_Small :=
- UR_From_Components
- (Num => Uint_1,
- Den => UI_From_Int (Standard_Integer_Size - 1),
- Rbase => 2);
+ elsif Nkind (N) = N_Type_Conversion then
+ return Known_Non_Null (Expression (N));
- Long_Integer_Sized_Small :=
- UR_From_Components
- (Num => Uint_1,
- Den => UI_From_Int (Standard_Long_Integer_Size - 1),
- Rbase => 2);
- end if;
+ -- One more case is when Current_Value references a condition
+ -- that ensures a non-null value.
- -- Return True if target supports fixed-by-fixed multiply/divide
- -- for fractional fixed-point types (see Is_Fractional_Type) and
- -- the operand and result types are equivalent fractional types.
+ elsif Is_Entity_Name (N) then
+ declare
+ Op : Node_Kind;
+ Val : Node_Id;
- return Is_Fractional_Type (Base_Type (Left_Typ))
- and then Is_Fractional_Type (Base_Type (Right_Typ))
- and then Is_Fractional_Type (Base_Type (Result_Typ))
- and then Esize (Left_Typ) = Esize (Right_Typ)
- and then Esize (Left_Typ) = Esize (Result_Typ);
- end Target_Has_Fixed_Ops;
+ begin
+ Get_Current_Value_Condition (N, Op, Val);
+ return Op = N_Op_Ne and then Nkind (Val) = N_Null;
+ end;
+
+ -- Above are all cases where the value could be determined to be
+ -- non-null. In all other cases, we don't know, so return False.
+
+ else
+ return False;
+ end if;
+ end Known_Non_Null;
-----------------------------
-- Make_CW_Equivalent_Type --
@@ -2303,8 +2649,11 @@ package body Exp_Util is
-- type Equiv_T is record
-- _parent : T (List of discriminant constaints taken from Exp);
- -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'size) / Storage_Unit);
+ -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
-- end Equiv_T;
+ --
+ -- ??? Note that this type does not guarantee same alignment as all
+ -- derived types
function Make_CW_Equivalent_Type
(T : Entity_Id;
@@ -2313,10 +2662,10 @@ package body Exp_Util is
is
Loc : constant Source_Ptr := Sloc (E);
Root_Typ : constant Entity_Id := Root_Type (T);
+ List_Def : constant List_Id := Empty_List;
Equiv_Type : Entity_Id;
Range_Type : Entity_Id;
Str_Type : Entity_Id;
- List_Def : List_Id := Empty_List;
Constr_Root : Entity_Id;
Sizexpr : Node_Id;
@@ -2351,7 +2700,7 @@ package body Exp_Util is
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Constr_Root, Loc),
- Attribute_Name => Name_Size));
+ Attribute_Name => Name_Object_Size));
Set_Paren_Count (Sizexpr, 1);
@@ -2392,9 +2741,17 @@ package body Exp_Util is
Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
- -- Avoid the generation of an init procedure
+ -- When the target requires front-end layout, it's necessary to allow
+ -- the equivalent type to be frozen so that layout can occur (when the
+ -- associated class-wide subtype is frozen, the equivalent type will
+ -- be frozen, see freeze.adb). For other targets, Gigi wants to have
+ -- the equivalent type marked as frozen and deals with this type itself.
+ -- In the Gigi case this will also avoid the generation of an init
+ -- procedure for the type.
- Set_Is_Frozen (Equiv_Type);
+ if not Frontend_Layout_On_Target then
+ Set_Is_Frozen (Equiv_Type);
+ end if;
Set_Ekind (Equiv_Type, E_Record_Type);
Set_Parent_Subtype (Equiv_Type, Constr_Root);
@@ -2432,7 +2789,7 @@ package body Exp_Util is
Literal_Typ : Entity_Id)
return Node_Id
is
- Lo : Node_Id :=
+ Lo : constant Node_Id :=
New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
begin
@@ -2471,7 +2828,7 @@ package body Exp_Util is
return Node_Id
is
Loc : constant Source_Ptr := Sloc (E);
- List_Constr : List_Id := New_List;
+ List_Constr : constant List_Id := New_List;
D : Entity_Id;
Full_Subtyp : Entity_Id;
@@ -2483,9 +2840,10 @@ package body Exp_Util is
if Is_Private_Type (Unc_Typ)
and then Has_Unknown_Discriminants (Unc_Typ)
then
- -- Prepare the subtype completion
+ -- Prepare the subtype completion, Go to base type to
+ -- find underlying type.
- Utyp := Underlying_Type (Unc_Typ);
+ Utyp := Underlying_Type (Base_Type (Unc_Typ));
Full_Subtyp := Make_Defining_Identifier (Loc,
New_Internal_Name ('C'));
Full_Exp :=
@@ -2558,15 +2916,21 @@ package body Exp_Util is
CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
Set_Equivalent_Type (CW_Subtype, EQ_Typ);
+
+ if Present (EQ_Typ) then
+ Set_Is_Class_Wide_Equivalent_Type (EQ_Typ);
+ end if;
+
Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
return New_Occurrence_Of (CW_Subtype, Loc);
end;
+ -- Comment needed (what case is this ???)
+
else
D := First_Discriminant (Unc_Typ);
- while (Present (D)) loop
-
+ while Present (D) loop
Append_To (List_Constr,
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr_No_Checks (E),
@@ -2625,9 +2989,9 @@ package body Exp_Util is
N : Node_Id)
return Entity_Id
is
- Res : Entity_Id := Create_Itype (E_Void, N);
- Res_Name : constant Name_Id := Chars (Res);
- Res_Scope : Entity_Id := Scope (Res);
+ Res : constant Entity_Id := Create_Itype (E_Void, N);
+ Res_Name : constant Name_Id := Chars (Res);
+ Res_Scope : constant Entity_Id := Scope (Res);
begin
Copy_Node (CW_Typ, Res);
@@ -2641,6 +3005,18 @@ package body Exp_Util is
Set_Ekind (Res, E_Class_Wide_Subtype);
Set_Next_Entity (Res, Empty);
Set_Etype (Res, Base_Type (CW_Typ));
+
+ -- For targets where front-end layout is required, reset the Is_Frozen
+ -- status of the subtype to False (it can be implicitly set to true
+ -- from the copy of the class-wide type). For other targets, Gigi
+ -- doesn't want the class-wide subtype to go through the freezing
+ -- process (though it's unclear why that causes problems and it would
+ -- be nice to allow freezing to occur normally for all targets ???).
+
+ if Frontend_Layout_On_Target then
+ Set_Is_Frozen (Res, False);
+ end if;
+
Set_Freeze_Node (Res, Empty);
return (Res);
end New_Class_Wide_Subtype;
@@ -2655,8 +3031,8 @@ package body Exp_Util is
Variable_Ref : Boolean := False)
is
Loc : constant Source_Ptr := Sloc (Exp);
- Exp_Type : constant Entity_Id := Etype (Exp);
- Svg_Suppress : constant Suppress_Record := Scope_Suppress;
+ Exp_Type : constant Entity_Id := Etype (Exp);
+ Svg_Suppress : constant Suppress_Array := Scope_Suppress;
Def_Id : Entity_Id;
Ref_Type : Entity_Id;
Res : Node_Id;
@@ -2671,31 +3047,80 @@ package body Exp_Util is
function Side_Effect_Free (L : List_Id) return Boolean;
-- Determines if all elements of the list L are side effect free
- function Mutable_Dereference (N : Node_Id) return Boolean;
- -- If a selected component involves an implicit dereference and
- -- the type of the prefix is not an_access_to_constant, the node
- -- must be evaluated because it may be affected by a subsequent
- -- assignment.
+ function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
+ -- The argument N is a construct where the Prefix is dereferenced
+ -- if it is a an access type and the result is a variable. The call
+ -- returns True if the construct is side effect free (not considering
+ -- side effects in other than the prefix which are to be tested by the
+ -- caller).
+
+ function Within_In_Parameter (N : Node_Id) return Boolean;
+ -- Determines if N is a subcomponent of a composite in-parameter.
+ -- If so, N is not side-effect free when the actual is global and
+ -- modifiable indirectly from within a subprogram, because it may
+ -- be passed by reference. The front-end must be conservative here
+ -- and assume that this may happen with any array or record type.
+ -- On the other hand, we cannot create temporaries for all expressions
+ -- for which this condition is true, for various reasons that might
+ -- require clearing up ??? For example, descriminant references that
+ -- appear out of place, or spurious type errors with class-wide
+ -- expressions. As a result, we limit the transformation to loop
+ -- bounds, which is so far the only case that requires it.
+
+ -----------------------------
+ -- Safe_Prefixed_Reference --
+ -----------------------------
+
+ function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
+ begin
+ -- If prefix is not side effect free, definitely not safe
- -------------------------
- -- Mutable_Dereference --
- -------------------------
+ if not Side_Effect_Free (Prefix (N)) then
+ return False;
- function Mutable_Dereference (N : Node_Id) return Boolean is
- begin
- return Nkind (N) = N_Selected_Component
- and then Is_Access_Type (Etype (Prefix (N)))
+ -- If the prefix is of an access type that is not access-to-constant,
+ -- then this construct is a variable reference, which means it is to
+ -- be considered to have side effects if Variable_Ref is set True
+ -- Exception is an access to an entity that is a constant or an
+ -- in-parameter which does not come from source, and is the result
+ -- of a previous removal of side-effects.
+
+ elsif Is_Access_Type (Etype (Prefix (N)))
and then not Is_Access_Constant (Etype (Prefix (N)))
- and then Variable_Ref;
- end Mutable_Dereference;
+ and then Variable_Ref
+ then
+ if not Is_Entity_Name (Prefix (N)) then
+ return False;
+ else
+ return Ekind (Entity (Prefix (N))) = E_Constant
+ or else Ekind (Entity (Prefix (N))) = E_In_Parameter;
+ end if;
+
+ -- The following test is the simplest way of solving a complex
+ -- problem uncovered by BB08-010: Side effect on loop bound that
+ -- is a subcomponent of a global variable:
+ -- If a loop bound is a subcomponent of a global variable, a
+ -- modification of that variable within the loop may incorrectly
+ -- affect the execution of the loop.
+
+ elsif not
+ (Nkind (Parent (Parent (N))) /= N_Loop_Parameter_Specification
+ or else not Within_In_Parameter (Prefix (N)))
+ then
+ return False;
+
+ -- All other cases are side effect free
+
+ else
+ return True;
+ end if;
+ end Safe_Prefixed_Reference;
----------------------
-- Side_Effect_Free --
----------------------
function Side_Effect_Free (N : Node_Id) return Boolean is
- K : constant Node_Kind := Nkind (N);
-
begin
-- Note on checks that could raise Constraint_Error. Strictly, if
-- we take advantage of 11.6, these checks do not count as side
@@ -2707,24 +3132,10 @@ package body Exp_Util is
-- code insertions at a point where we do not have a clear model
-- for performing the insertions. See 4908-002/comment for details.
- -- An attribute reference is side effect free if its expressions
- -- are side effect free and its prefix is (could be a dereference
- -- or an indexed retrieval for example).
-
- if K = N_Attribute_Reference then
- return Side_Effect_Free (Expressions (N))
- and then (Is_Entity_Name (Prefix (N))
- or else Side_Effect_Free (Prefix (N)));
+ -- Special handling for entity names
- -- An entity is side effect free unless it is a function call, or
- -- a reference to a volatile variable and Name_Req is False. If
- -- Name_Req is True then we can't help returning a name which
- -- effectively allows multiple references in any case.
+ if Is_Entity_Name (N) then
- elsif Is_Entity_Name (N)
- and then Ekind (Entity (N)) /= E_Function
- and then (not Is_Volatile (Entity (N)) or else Name_Req)
- then
-- If the entity is a constant, it is definitely side effect
-- free. Note that the test of Is_Variable (N) below might
-- be expected to catch this case, but it does not, because
@@ -2732,14 +3143,28 @@ package body Exp_Util is
-- already rewritten a variable node with a constant as
-- a result of an earlier Force_Evaluation call.
- if Ekind (Entity (N)) = E_Constant then
+ if Ekind (Entity (N)) = E_Constant
+ or else Ekind (Entity (N)) = E_In_Parameter
+ then
return True;
- -- If the Variable_Ref flag is set, any variable reference is
- -- is considered a side-effect
+ -- Functions are not side effect free
+
+ elsif Ekind (Entity (N)) = E_Function then
+ return False;
+
+ -- Variables are considered to be a side effect if Variable_Ref
+ -- is set or if we have a volatile variable and Name_Req is off.
+ -- If Name_Req is True then we can't help returning a name which
+ -- effectively allows multiple references in any case.
- elsif Variable_Ref then
- return not Is_Variable (N);
+ elsif Is_Variable (N) then
+ return not Variable_Ref
+ and then (not Treat_As_Volatile (Entity (N))
+ or else Name_Req);
+
+ -- Any other entity (e.g. a subtype name) is definitely side
+ -- effect free.
else
return True;
@@ -2749,91 +3174,129 @@ package body Exp_Util is
elsif Compile_Time_Known_Value (N) then
return True;
+ end if;
- -- Literals are always side-effect free
+ -- For other than entity names and compile time known values,
+ -- check the node kind for special processing.
- elsif (K = N_Integer_Literal
- or else K = N_Real_Literal
- or else K = N_Character_Literal
- or else K = N_String_Literal
- or else K = N_Null)
- and then not Raises_Constraint_Error (N)
- then
- return True;
+ case Nkind (N) is
+
+ -- An attribute reference is side effect free if its expressions
+ -- are side effect free and its prefix is side effect free or
+ -- is an entity reference.
+
+ -- Is this right? what about x'first where x is a variable???
+
+ when N_Attribute_Reference =>
+ return Side_Effect_Free (Expressions (N))
+ and then (Is_Entity_Name (Prefix (N))
+ or else Side_Effect_Free (Prefix (N)));
+
+ -- A binary operator is side effect free if and both operands
+ -- are side effect free. For this purpose binary operators
+ -- include membership tests and short circuit forms
+
+ when N_Binary_Op |
+ N_In |
+ N_Not_In |
+ N_And_Then |
+ N_Or_Else
+ =>
+ return Side_Effect_Free (Left_Opnd (N))
+ and then Side_Effect_Free (Right_Opnd (N));
+
+ -- An explicit dereference is side effect free only if it is
+ -- a side effect free prefixed reference.
+
+ when N_Explicit_Dereference =>
+ return Safe_Prefixed_Reference (N);
+
+ -- A call to _rep_to_pos is side effect free, since we generate
+ -- this pure function call ourselves. Moreover it is critically
+ -- important to make this exception, since otherwise we can
+ -- have discriminants in array components which don't look
+ -- side effect free in the case of an array whose index type
+ -- is an enumeration type with an enumeration rep clause.
+
+ -- All other function calls are not side effect free
+
+ when N_Function_Call =>
+ return Nkind (Name (N)) = N_Identifier
+ and then Is_TSS (Name (N), TSS_Rep_To_Pos)
+ and then
+ Side_Effect_Free (First (Parameter_Associations (N)));
- -- A type conversion or qualification is side effect free if the
- -- expression to be converted is side effect free.
+ -- An indexed component is side effect free if it is a side
+ -- effect free prefixed reference and all the indexing
+ -- expressions are side effect free.
- elsif K = N_Type_Conversion or else K = N_Qualified_Expression then
- return Side_Effect_Free (Expression (N));
+ when N_Indexed_Component =>
+ return Side_Effect_Free (Expressions (N))
+ and then Safe_Prefixed_Reference (N);
- -- An unchecked type conversion is never side effect free since we
- -- need to check whether it is safe.
- -- effect free if its argument is side effect free.
+ -- A type qualification is side effect free if the expression
+ -- is side effect free.
- elsif K = N_Unchecked_Type_Conversion then
- if Safe_Unchecked_Type_Conversion (N) then
+ when N_Qualified_Expression =>
return Side_Effect_Free (Expression (N));
- else
- return False;
- end if;
- -- A unary operator is side effect free if the operand
- -- is side effect free.
+ -- A selected component is side effect free only if it is a
+ -- side effect free prefixed reference.
- elsif K in N_Unary_Op then
- return Side_Effect_Free (Right_Opnd (N));
+ when N_Selected_Component =>
+ return Safe_Prefixed_Reference (N);
- -- A binary operator is side effect free if and both operands
- -- are side effect free.
+ -- A range is side effect free if the bounds are side effect free
- elsif K in N_Binary_Op then
- return Side_Effect_Free (Left_Opnd (N))
- and then Side_Effect_Free (Right_Opnd (N));
+ when N_Range =>
+ return Side_Effect_Free (Low_Bound (N))
+ and then Side_Effect_Free (High_Bound (N));
- -- An explicit dereference or selected component is side effect
- -- free if its prefix is side effect free.
+ -- A slice is side effect free if it is a side effect free
+ -- prefixed reference and the bounds are side effect free.
- elsif K = N_Explicit_Dereference
- or else K = N_Selected_Component
- then
- return Side_Effect_Free (Prefix (N))
- and then not Mutable_Dereference (Prefix (N));
-
- -- An indexed component can be copied if the prefix is copyable
- -- and all the indexing expressions are copyable and there is
- -- no access check and no range checks.
-
- elsif K = N_Indexed_Component then
- return Side_Effect_Free (Prefix (N))
- and then Side_Effect_Free (Expressions (N));
-
- elsif K = N_Unchecked_Expression then
- return Side_Effect_Free (Expression (N));
-
- -- A call to _rep_to_pos is side effect free, since we generate
- -- this pure function call ourselves. Moreover it is critically
- -- important to make this exception, since otherwise we can
- -- have discriminants in array components which don't look
- -- side effect free in the case of an array whose index type
- -- is an enumeration type with an enumeration rep clause.
-
- elsif K = N_Function_Call
- and then Nkind (Name (N)) = N_Identifier
- and then Chars (Name (N)) = Name_uRep_To_Pos
- then
- return True;
+ when N_Slice =>
+ return Side_Effect_Free (Discrete_Range (N))
+ and then Safe_Prefixed_Reference (N);
- -- We consider that anything else has side effects. This is a bit
- -- crude, but we are pretty close for most common cases, and we
- -- are certainly correct (i.e. we never return True when the
- -- answer should be False).
+ -- A type conversion is side effect free if the expression
+ -- to be converted is side effect free.
- else
- return False;
- end if;
+ when N_Type_Conversion =>
+ return Side_Effect_Free (Expression (N));
+
+ -- A unary operator is side effect free if the operand
+ -- is side effect free.
+
+ when N_Unary_Op =>
+ return Side_Effect_Free (Right_Opnd (N));
+
+ -- An unchecked type conversion is side effect free only if it
+ -- is safe and its argument is side effect free.
+
+ when N_Unchecked_Type_Conversion =>
+ return Safe_Unchecked_Type_Conversion (N)
+ and then Side_Effect_Free (Expression (N));
+
+ -- An unchecked expression is side effect free if its expression
+ -- is side effect free.
+
+ when N_Unchecked_Expression =>
+ return Side_Effect_Free (Expression (N));
+
+ -- We consider that anything else has side effects. This is a bit
+ -- crude, but we are pretty close for most common cases, and we
+ -- are certainly correct (i.e. we never return True when the
+ -- answer should be False).
+
+ when others =>
+ return False;
+ end case;
end Side_Effect_Free;
+ -- A list is side effect free if all elements of the list are
+ -- side effect free.
+
function Side_Effect_Free (L : List_Id) return Boolean is
N : Node_Id;
@@ -2856,6 +3319,29 @@ package body Exp_Util is
end if;
end Side_Effect_Free;
+ -------------------------
+ -- Within_In_Parameter --
+ -------------------------
+
+ function Within_In_Parameter (N : Node_Id) return Boolean is
+ begin
+ if not Comes_From_Source (N) then
+ return False;
+
+ elsif Is_Entity_Name (N) then
+ return
+ Ekind (Entity (N)) = E_In_Parameter;
+
+ elsif Nkind (N) = N_Indexed_Component
+ or else Nkind (N) = N_Selected_Component
+ then
+ return Within_In_Parameter (Prefix (N));
+ else
+
+ return False;
+ end if;
+ end Within_In_Parameter;
+
-- Start of processing for Remove_Side_Effects
begin
@@ -2866,7 +3352,7 @@ package body Exp_Util is
return;
end if;
- -- All the must not have any checks
+ -- All this must not have any checks
Scope_Suppress := (others => True);
@@ -2887,6 +3373,16 @@ package body Exp_Util is
Constant_Present => True,
Expression => Relocate_Node (Prefix (Exp))));
+ -- Similar processing for an unchecked conversion of an expression
+ -- of the form v.all, where we want the same kind of treatment.
+
+ elsif Nkind (Exp) = N_Unchecked_Type_Conversion
+ and then Nkind (Expression (Exp)) = N_Explicit_Dereference
+ then
+ Remove_Side_Effects (Expression (Exp), Variable_Ref);
+ Scope_Suppress := Svg_Suppress;
+ return;
+
-- If this is a type conversion, leave the type conversion and remove
-- the side effects in the expression. This is important in several
-- circumstances: for change of representations, and also when this
@@ -2909,16 +3405,21 @@ package body Exp_Util is
-- We skip using this if we have a volatile variable and we do not
-- have Nam_Req set true (see comments above for Side_Effect_Free).
-- We also skip this scheme for class-wide expressions in order to
- -- avoid recursive expension (see Expand_N_Object_Renaming_Declaration)
+ -- avoid recursive expansion (see Expand_N_Object_Renaming_Declaration)
-- If the object is a function call, we need to create a temporary and
-- not a renaming.
+ -- Note that we could use ordinary object declarations in the case of
+ -- expressions not appearing as lvalues. That is left as a possible
+ -- optimization in the future but we prefer to generate renamings
+ -- right now, since we may indeed be transforming an lvalue.
+
elsif Is_Object_Reference (Exp)
and then Nkind (Exp) /= N_Function_Call
and then not Variable_Ref
and then (Name_Req
or else not Is_Entity_Name (Exp)
- or else not Is_Volatile (Entity (Exp)))
+ or else not Treat_As_Volatile (Entity (Exp)))
and then not Is_Class_Wide_Type (Exp_Type)
then
Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
@@ -2943,6 +3444,13 @@ package body Exp_Util is
Subtype_Mark =>
New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
Name => Relocate_Node (Prefix (Exp))));
+
+ -- The temporary must be elaborated by gigi, and is of course
+ -- not to be replaced in-line by the expression it renames,
+ -- which would defeat the purpose of removing the side-effect.
+
+ Set_Is_Renaming_Of_Object (Def_Id, False);
+
else
Res := New_Reference_To (Def_Id, Loc);
@@ -2951,6 +3459,8 @@ package body Exp_Util is
Defining_Identifier => Def_Id,
Subtype_Mark => New_Reference_To (Exp_Type, Loc),
Name => Relocate_Node (Exp)));
+
+ Set_Is_Renaming_Of_Object (Def_Id, False);
end if;
-- If it is a scalar type, just make a copy.
@@ -2970,13 +3480,15 @@ package body Exp_Util is
Set_Assignment_OK (E);
Insert_Action (Exp, E);
+ -- Always use a renaming for an unchecked conversion
-- If this is an unchecked conversion that Gigi can't handle, make
-- a copy or a use a renaming to capture the value.
- elsif (Nkind (Exp) = N_Unchecked_Type_Conversion
- and then not Safe_Unchecked_Type_Conversion (Exp))
+ elsif Nkind (Exp) = N_Unchecked_Type_Conversion
+ and then not Safe_Unchecked_Type_Conversion (Exp)
then
if Controlled_Type (Etype (Exp)) then
+
-- Use a renaming to capture the expression, rather than create
-- a controlled temporary.
@@ -3244,10 +3756,11 @@ package body Exp_Util is
procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
Asn : Node_Id;
begin
- if Present (Elaboration_Entity (Spec_Id)) then
+ if Present (Ent) then
-- Nothing to do if at the compilation unit level, because in this
-- case the flag is set by the binder generated elaboration routine.
@@ -3261,7 +3774,7 @@ package body Exp_Util is
Check_Restriction (No_Elaboration_Code, N);
Asn :=
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Elaboration_Entity (Spec_Id), Loc),
+ Name => New_Occurrence_Of (Ent, Loc),
Expression => New_Occurrence_Of (Standard_True, Loc));
if Nkind (Parent (N)) = N_Subunit then
@@ -3271,10 +3784,99 @@ package body Exp_Util is
end if;
Analyze (Asn);
+
+ -- Kill current value indication. This is necessary because
+ -- the tests of this flag are inserted out of sequence and must
+ -- not pick up bogus indications of the wrong constant value.
+
+ Set_Current_Value (Ent, Empty);
end if;
end if;
end Set_Elaboration_Flag;
+ --------------------------
+ -- Target_Has_Fixed_Ops --
+ --------------------------
+
+ Integer_Sized_Small : Ureal;
+ -- Set to 2.0 ** -(Integer'Size - 1) the first time that this
+ -- function is called (we don't want to compute it more than once!)
+
+ Long_Integer_Sized_Small : Ureal;
+ -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
+ -- functoin is called (we don't want to compute it more than once)
+
+ First_Time_For_THFO : Boolean := True;
+ -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
+
+ function Target_Has_Fixed_Ops
+ (Left_Typ : Entity_Id;
+ Right_Typ : Entity_Id;
+ Result_Typ : Entity_Id)
+ return Boolean
+ is
+ function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
+ -- Return True if the given type is a fixed-point type with a small
+ -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
+ -- an absolute value less than 1.0. This is currently limited
+ -- to fixed-point types that map to Integer or Long_Integer.
+
+ ------------------------
+ -- Is_Fractional_Type --
+ ------------------------
+
+ function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
+ begin
+ if Esize (Typ) = Standard_Integer_Size then
+ return Small_Value (Typ) = Integer_Sized_Small;
+
+ elsif Esize (Typ) = Standard_Long_Integer_Size then
+ return Small_Value (Typ) = Long_Integer_Sized_Small;
+
+ else
+ return False;
+ end if;
+ end Is_Fractional_Type;
+
+ -- Start of processing for Target_Has_Fixed_Ops
+
+ begin
+ -- Return False if Fractional_Fixed_Ops_On_Target is false
+
+ if not Fractional_Fixed_Ops_On_Target then
+ return False;
+ end if;
+
+ -- Here the target has Fractional_Fixed_Ops, if first time, compute
+ -- standard constants used by Is_Fractional_Type.
+
+ if First_Time_For_THFO then
+ First_Time_For_THFO := False;
+
+ Integer_Sized_Small :=
+ UR_From_Components
+ (Num => Uint_1,
+ Den => UI_From_Int (Standard_Integer_Size - 1),
+ Rbase => 2);
+
+ Long_Integer_Sized_Small :=
+ UR_From_Components
+ (Num => Uint_1,
+ Den => UI_From_Int (Standard_Long_Integer_Size - 1),
+ Rbase => 2);
+ end if;
+
+ -- Return True if target supports fixed-by-fixed multiply/divide
+ -- for fractional fixed-point types (see Is_Fractional_Type) and
+ -- the operand and result types are equivalent fractional types.
+
+ return Is_Fractional_Type (Base_Type (Left_Typ))
+ and then Is_Fractional_Type (Base_Type (Right_Typ))
+ and then Is_Fractional_Type (Base_Type (Result_Typ))
+ and then Esize (Left_Typ) = Esize (Right_Typ)
+ and then Esize (Left_Typ) = Esize (Result_Typ);
+ end Target_Has_Fixed_Ops;
+
----------------------------
-- Wrap_Cleanup_Procedure --
----------------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index bc3e6f75f88..e45930d5732 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -26,8 +26,9 @@
-- Package containing utility procedures used throughout the expander
-with Snames; use Snames;
+with Exp_Tss; use Exp_Tss;
with Rtsfind; use Rtsfind;
+with Sinfo; use Sinfo;
with Types; use Types;
package Exp_Util is
@@ -302,8 +303,18 @@ package Exp_Util is
function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id;
-- Find the first primitive operation of type T whose name is 'Name'.
- -- this function allows the use of a primitive operation which is not
- -- directly visible
+ -- This function allows the use of a primitive operation which is not
+ -- directly visible. If T is a class wide type, then the reference is
+ -- to an operation of the corresponding root type.
+
+ function Find_Prim_Op
+ (T : Entity_Id;
+ Name : TSS_Name_Type) return Entity_Id;
+ -- Find the first primitive operation of type T whose name has the form
+ -- indicated by the name parameter (i.e. is a type support subprogram
+ -- with the indicated suffix). This function allows use of a primitive
+ -- operation which is not directly visible. If T is a class wide type,
+ -- then the reference is to an operation of the corresponding root type.
procedure Force_Evaluation
(Exp : Node_Id;
@@ -320,6 +331,43 @@ package Exp_Util is
-- If polling is active, then a call to the Poll routine is built,
-- and then inserted before the given node N and analyzed.
+ procedure Get_Current_Value_Condition
+ (Var : Node_Id;
+ Op : out Node_Kind;
+ Val : out Node_Id);
+ -- This routine processes the Current_Value field of the variable Var.
+ -- If the Current_Value field is null or if it represents a known value,
+ -- then on return Cond is set to N_Empty, and Val is set to Empty.
+ --
+ -- The other case is when Current_Value points to an N_If_Statement
+ -- or an N_Elsif_Part (while statement). Such a setting only occurs
+ -- if the condition of an IF or ELSIF is of the form X op Y, where X
+ -- is the variable in question, Y is a compile-time known value, and
+ -- op is one of the six possible relational operators.
+ --
+ -- In this case, Get_Current_Condition digs out the condition, and
+ -- then checks if the condition is known false, known true, or not
+ -- known at all. In the first two cases, Get_Current_Condition will
+ -- return with Op set to the appropriate conditional operator (inverted
+ -- if the condition is known false), and Val set to the constant value.
+ -- If the condition is not known, then Cond and Val are set for the
+ -- empty case (N_Empty and Empty).
+ --
+ -- The check for whether the condition is true/false unknown depends
+ -- on the case:
+ --
+ -- For an IF, the condition is known true in the THEN part, known
+ -- false in any ELSIF or ELSE part, and not known outside the IF
+ -- statement in question.
+ --
+ -- For an ELSIF, the condition is known true in the ELSIF part,
+ -- known FALSE in any subsequent ELSIF, or ELSE part, and not
+ -- known before the ELSIF, or after the end of the IF statement.
+ --
+ -- The caller can use this result to determine the value (for the
+ -- case of N_Op_Eq), or to determine the result of some other test
+ -- in other cases (e.g. no access check required if N_Op_Ne Null).
+
function Homonym_Number (Subp : Entity_Id) return Nat;
-- Here subp is the entity for a subprogram. This routine returns the
-- homonym number used to disambiguate overloaded subprograms in the
@@ -329,7 +377,7 @@ package Exp_Util is
-- an entity is not overloaded, the returned number will be one.
function Inside_Init_Proc return Boolean;
- -- Returns True if current scope is within an Init_Proc
+ -- Returns True if current scope is within an init proc
function In_Unconditional_Context (Node : Node_Id) return Boolean;
-- Node is the node for a statement or a component of a statement.
@@ -337,6 +385,11 @@ package Exp_Util is
-- that is unconditionally executed, i.e. it is not within a loop
-- or a conditional or a case statement etc.
+ function Is_All_Null_Statements (L : List_Id) return Boolean;
+ -- Return True if all the items of the list are N_Null_Statement
+ -- nodes. False otherwise. True for an empty list. It is an error
+ -- to call this routine with No_List as the argument.
+
function Is_Ref_To_Bit_Packed_Array (P : Node_Id) return Boolean;
-- Determine whether the node P is a reference to a bit packed
-- array, i.e. whether the designated object is a component of
@@ -350,6 +403,18 @@ package Exp_Util is
-- slice, i.e. whether the designated object is bit packed slice
-- or a component of a bit packed slice. Return True if so.
+ function Is_Possibly_Unaligned_Slice (P : Node_Id) return Boolean;
+ -- Determine whether the node P is a slice of an array where the slice
+ -- result may cause alignment problems because it has an alignment that
+ -- is not compatible with the type. Return True if so.
+
+ function Is_Possibly_Unaligned_Object (P : Node_Id) return Boolean;
+ -- Node P is an object reference. This function returns True if it
+ -- is possible that the object may not be aligned according to the
+ -- normal default alignment requirement for its type (e.g. if it
+ -- appears in a packed record, or as part of a component that has
+ -- a component clause.
+
function Is_Renamed_Object (N : Node_Id) return Boolean;
-- Returns True if the node N is a renamed object. An expression
-- is considered to be a renamed object if either it is the Name
@@ -379,6 +444,12 @@ package Exp_Util is
-- that cannot possibly be negative, and if so returns True. A value of
-- False means that it is not known if the value is positive or negative.
+ function Known_Non_Null (N : Node_Id) return Boolean;
+ -- Given a node N for a subexpression of an access type, determines if
+ -- this subexpression yields a value that is known at compile time to
+ -- be non-null and returns True if so. Returns False otherwise. It is
+ -- an error to call this function if N is not of an access type.
+
function Make_Subtype_From_Expr
(E : Node_Id;
Unc_Typ : Entity_Id)
diff --git a/gcc/ada/exp_vfpt.adb b/gcc/ada/exp_vfpt.adb
index 0f03e874393..5bb73438229 100644
--- a/gcc/ada/exp_vfpt.adb
+++ b/gcc/ada/exp_vfpt.adb
@@ -31,7 +31,6 @@ with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sem_Res; use Sem_Res;
with Sinfo; use Sinfo;
-with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
with Ttypef; use Ttypef;
diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb
index 83a04a28014..b2d6e3ee9a2 100644
--- a/gcc/ada/expander.adb
+++ b/gcc/ada/expander.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,6 +42,7 @@ with Exp_Ch12; use Exp_Ch12;
with Exp_Ch13; use Exp_Ch13;
with Exp_Prag; use Exp_Prag;
with Opt; use Opt;
+with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
with Sem_Util; use Sem_Util;
@@ -131,307 +132,313 @@ package body Expander is
-- activity required in each case, see bodies of corresponding
-- expand routines
- case Nkind (N) is
+ begin
+ case Nkind (N) is
+
+ when N_Abort_Statement =>
+ Expand_N_Abort_Statement (N);
- when N_Abort_Statement =>
- Expand_N_Abort_Statement (N);
+ when N_Accept_Statement =>
+ Expand_N_Accept_Statement (N);
- when N_Accept_Statement =>
- Expand_N_Accept_Statement (N);
+ when N_Aggregate =>
+ Expand_N_Aggregate (N);
- when N_Aggregate =>
- Expand_N_Aggregate (N);
+ when N_Allocator =>
+ Expand_N_Allocator (N);
- when N_Allocator =>
- Expand_N_Allocator (N);
+ when N_And_Then =>
+ Expand_N_And_Then (N);
- when N_And_Then =>
- Expand_N_And_Then (N);
+ when N_Assignment_Statement =>
+ Expand_N_Assignment_Statement (N);
- when N_Assignment_Statement =>
- Expand_N_Assignment_Statement (N);
+ when N_Asynchronous_Select =>
+ Expand_N_Asynchronous_Select (N);
- when N_Asynchronous_Select =>
- Expand_N_Asynchronous_Select (N);
+ when N_Attribute_Definition_Clause =>
+ Expand_N_Attribute_Definition_Clause (N);
- when N_Attribute_Definition_Clause =>
- Expand_N_Attribute_Definition_Clause (N);
+ when N_Attribute_Reference =>
+ Expand_N_Attribute_Reference (N);
- when N_Attribute_Reference =>
- Expand_N_Attribute_Reference (N);
+ when N_Block_Statement =>
+ Expand_N_Block_Statement (N);
- when N_Block_Statement =>
- Expand_N_Block_Statement (N);
+ when N_Case_Statement =>
+ Expand_N_Case_Statement (N);
- when N_Case_Statement =>
- Expand_N_Case_Statement (N);
+ when N_Conditional_Entry_Call =>
+ Expand_N_Conditional_Entry_Call (N);
- when N_Conditional_Entry_Call =>
- Expand_N_Conditional_Entry_Call (N);
+ when N_Conditional_Expression =>
+ Expand_N_Conditional_Expression (N);
- when N_Conditional_Expression =>
- Expand_N_Conditional_Expression (N);
+ when N_Delay_Relative_Statement =>
+ Expand_N_Delay_Relative_Statement (N);
- when N_Delay_Relative_Statement =>
- Expand_N_Delay_Relative_Statement (N);
+ when N_Delay_Until_Statement =>
+ Expand_N_Delay_Until_Statement (N);
- when N_Delay_Until_Statement =>
- Expand_N_Delay_Until_Statement (N);
+ when N_Entry_Body =>
+ Expand_N_Entry_Body (N);
- when N_Entry_Body =>
- Expand_N_Entry_Body (N);
+ when N_Entry_Call_Statement =>
+ Expand_N_Entry_Call_Statement (N);
- when N_Entry_Call_Statement =>
- Expand_N_Entry_Call_Statement (N);
+ when N_Entry_Declaration =>
+ Expand_N_Entry_Declaration (N);
- when N_Entry_Declaration =>
- Expand_N_Entry_Declaration (N);
+ when N_Exception_Declaration =>
+ Expand_N_Exception_Declaration (N);
- when N_Exception_Declaration =>
- Expand_N_Exception_Declaration (N);
+ when N_Exception_Renaming_Declaration =>
+ Expand_N_Exception_Renaming_Declaration (N);
- when N_Exception_Renaming_Declaration =>
- Expand_N_Exception_Renaming_Declaration (N);
+ when N_Exit_Statement =>
+ Expand_N_Exit_Statement (N);
- when N_Exit_Statement =>
- Expand_N_Exit_Statement (N);
+ when N_Expanded_Name =>
+ Expand_N_Expanded_Name (N);
- when N_Expanded_Name =>
- Expand_N_Expanded_Name (N);
+ when N_Explicit_Dereference =>
+ Expand_N_Explicit_Dereference (N);
- when N_Explicit_Dereference =>
- Expand_N_Explicit_Dereference (N);
+ when N_Extension_Aggregate =>
+ Expand_N_Extension_Aggregate (N);
- when N_Extension_Aggregate =>
- Expand_N_Extension_Aggregate (N);
+ when N_Freeze_Entity =>
+ Expand_N_Freeze_Entity (N);
- when N_Freeze_Entity =>
- Expand_N_Freeze_Entity (N);
+ when N_Full_Type_Declaration =>
+ Expand_N_Full_Type_Declaration (N);
- when N_Full_Type_Declaration =>
- Expand_N_Full_Type_Declaration (N);
+ when N_Function_Call =>
+ Expand_N_Function_Call (N);
- when N_Function_Call =>
- Expand_N_Function_Call (N);
+ when N_Generic_Instantiation =>
+ Expand_N_Generic_Instantiation (N);
- when N_Generic_Instantiation =>
- Expand_N_Generic_Instantiation (N);
+ when N_Goto_Statement =>
+ Expand_N_Goto_Statement (N);
- when N_Goto_Statement =>
- Expand_N_Goto_Statement (N);
+ when N_Handled_Sequence_Of_Statements =>
+ Expand_N_Handled_Sequence_Of_Statements (N);
- when N_Handled_Sequence_Of_Statements =>
- Expand_N_Handled_Sequence_Of_Statements (N);
+ when N_Identifier =>
+ Expand_N_Identifier (N);
- when N_Identifier =>
- Expand_N_Identifier (N);
+ when N_Indexed_Component =>
+ Expand_N_Indexed_Component (N);
- when N_Indexed_Component =>
- Expand_N_Indexed_Component (N);
+ when N_If_Statement =>
+ Expand_N_If_Statement (N);
- when N_If_Statement =>
- Expand_N_If_Statement (N);
+ when N_In =>
+ Expand_N_In (N);
- when N_In =>
- Expand_N_In (N);
+ when N_Loop_Statement =>
+ Expand_N_Loop_Statement (N);
- when N_Loop_Statement =>
- Expand_N_Loop_Statement (N);
+ when N_Not_In =>
+ Expand_N_Not_In (N);
- when N_Not_In =>
- Expand_N_Not_In (N);
+ when N_Null =>
+ Expand_N_Null (N);
- when N_Null =>
- Expand_N_Null (N);
+ when N_Object_Declaration =>
+ Expand_N_Object_Declaration (N);
- when N_Object_Declaration =>
- Expand_N_Object_Declaration (N);
+ when N_Object_Renaming_Declaration =>
+ Expand_N_Object_Renaming_Declaration (N);
- when N_Object_Renaming_Declaration =>
- Expand_N_Object_Renaming_Declaration (N);
+ when N_Op_Add =>
+ Expand_N_Op_Add (N);
- when N_Op_Add =>
- Expand_N_Op_Add (N);
+ when N_Op_Abs =>
+ Expand_N_Op_Abs (N);
- when N_Op_Abs =>
- Expand_N_Op_Abs (N);
+ when N_Op_And =>
+ Expand_N_Op_And (N);
- when N_Op_And =>
- Expand_N_Op_And (N);
+ when N_Op_Concat =>
+ Expand_N_Op_Concat (N);
- when N_Op_Concat =>
- Expand_N_Op_Concat (N);
+ when N_Op_Divide =>
+ Expand_N_Op_Divide (N);
- when N_Op_Divide =>
- Expand_N_Op_Divide (N);
+ when N_Op_Eq =>
+ Expand_N_Op_Eq (N);
- when N_Op_Eq =>
- Expand_N_Op_Eq (N);
+ when N_Op_Expon =>
+ Expand_N_Op_Expon (N);
- when N_Op_Expon =>
- Expand_N_Op_Expon (N);
+ when N_Op_Ge =>
+ Expand_N_Op_Ge (N);
- when N_Op_Ge =>
- Expand_N_Op_Ge (N);
+ when N_Op_Gt =>
+ Expand_N_Op_Gt (N);
- when N_Op_Gt =>
- Expand_N_Op_Gt (N);
+ when N_Op_Le =>
+ Expand_N_Op_Le (N);
- when N_Op_Le =>
- Expand_N_Op_Le (N);
+ when N_Op_Lt =>
+ Expand_N_Op_Lt (N);
- when N_Op_Lt =>
- Expand_N_Op_Lt (N);
+ when N_Op_Minus =>
+ Expand_N_Op_Minus (N);
- when N_Op_Minus =>
- Expand_N_Op_Minus (N);
+ when N_Op_Mod =>
+ Expand_N_Op_Mod (N);
- when N_Op_Mod =>
- Expand_N_Op_Mod (N);
+ when N_Op_Multiply =>
+ Expand_N_Op_Multiply (N);
- when N_Op_Multiply =>
- Expand_N_Op_Multiply (N);
+ when N_Op_Ne =>
+ Expand_N_Op_Ne (N);
- when N_Op_Ne =>
- Expand_N_Op_Ne (N);
+ when N_Op_Not =>
+ Expand_N_Op_Not (N);
- when N_Op_Not =>
- Expand_N_Op_Not (N);
+ when N_Op_Or =>
+ Expand_N_Op_Or (N);
- when N_Op_Or =>
- Expand_N_Op_Or (N);
+ when N_Op_Plus =>
+ Expand_N_Op_Plus (N);
- when N_Op_Plus =>
- Expand_N_Op_Plus (N);
+ when N_Op_Rem =>
+ Expand_N_Op_Rem (N);
- when N_Op_Rem =>
- Expand_N_Op_Rem (N);
+ when N_Op_Rotate_Left =>
+ Expand_N_Op_Rotate_Left (N);
- when N_Op_Rotate_Left =>
- Expand_N_Op_Rotate_Left (N);
+ when N_Op_Rotate_Right =>
+ Expand_N_Op_Rotate_Right (N);
- when N_Op_Rotate_Right =>
- Expand_N_Op_Rotate_Right (N);
+ when N_Op_Shift_Left =>
+ Expand_N_Op_Shift_Left (N);
- when N_Op_Shift_Left =>
- Expand_N_Op_Shift_Left (N);
+ when N_Op_Shift_Right =>
+ Expand_N_Op_Shift_Right (N);
- when N_Op_Shift_Right =>
- Expand_N_Op_Shift_Right (N);
+ when N_Op_Shift_Right_Arithmetic =>
+ Expand_N_Op_Shift_Right_Arithmetic (N);
- when N_Op_Shift_Right_Arithmetic =>
- Expand_N_Op_Shift_Right_Arithmetic (N);
+ when N_Op_Subtract =>
+ Expand_N_Op_Subtract (N);
- when N_Op_Subtract =>
- Expand_N_Op_Subtract (N);
+ when N_Op_Xor =>
+ Expand_N_Op_Xor (N);
- when N_Op_Xor =>
- Expand_N_Op_Xor (N);
+ when N_Or_Else =>
+ Expand_N_Or_Else (N);
- when N_Or_Else =>
- Expand_N_Or_Else (N);
+ when N_Package_Body =>
+ Expand_N_Package_Body (N);
- when N_Package_Body =>
- Expand_N_Package_Body (N);
+ when N_Package_Declaration =>
+ Expand_N_Package_Declaration (N);
- when N_Package_Declaration =>
- Expand_N_Package_Declaration (N);
+ when N_Package_Renaming_Declaration =>
+ Expand_N_Package_Renaming_Declaration (N);
- when N_Package_Renaming_Declaration =>
- Expand_N_Package_Renaming_Declaration (N);
+ when N_Pragma =>
+ Expand_N_Pragma (N);
- when N_Pragma =>
- Expand_N_Pragma (N);
+ when N_Procedure_Call_Statement =>
+ Expand_N_Procedure_Call_Statement (N);
- when N_Procedure_Call_Statement =>
- Expand_N_Procedure_Call_Statement (N);
+ when N_Protected_Type_Declaration =>
+ Expand_N_Protected_Type_Declaration (N);
- when N_Protected_Type_Declaration =>
- Expand_N_Protected_Type_Declaration (N);
+ when N_Protected_Body =>
+ Expand_N_Protected_Body (N);
- when N_Protected_Body =>
- Expand_N_Protected_Body (N);
+ when N_Qualified_Expression =>
+ Expand_N_Qualified_Expression (N);
- when N_Qualified_Expression =>
- Expand_N_Qualified_Expression (N);
+ when N_Raise_Statement =>
+ Expand_N_Raise_Statement (N);
- when N_Raise_Statement =>
- Expand_N_Raise_Statement (N);
+ when N_Raise_Constraint_Error =>
+ Expand_N_Raise_Constraint_Error (N);
- when N_Raise_Constraint_Error =>
- Expand_N_Raise_Constraint_Error (N);
+ when N_Raise_Program_Error =>
+ Expand_N_Raise_Program_Error (N);
- when N_Raise_Program_Error =>
- Expand_N_Raise_Program_Error (N);
+ when N_Raise_Storage_Error =>
+ Expand_N_Raise_Storage_Error (N);
- when N_Raise_Storage_Error =>
- Expand_N_Raise_Storage_Error (N);
+ when N_Real_Literal =>
+ Expand_N_Real_Literal (N);
- when N_Real_Literal =>
- Expand_N_Real_Literal (N);
+ when N_Record_Representation_Clause =>
+ Expand_N_Record_Representation_Clause (N);
- when N_Record_Representation_Clause =>
- Expand_N_Record_Representation_Clause (N);
+ when N_Requeue_Statement =>
+ Expand_N_Requeue_Statement (N);
- when N_Requeue_Statement =>
- Expand_N_Requeue_Statement (N);
+ when N_Return_Statement =>
+ Expand_N_Return_Statement (N);
- when N_Return_Statement =>
- Expand_N_Return_Statement (N);
+ when N_Selected_Component =>
+ Expand_N_Selected_Component (N);
- when N_Selected_Component =>
- Expand_N_Selected_Component (N);
+ when N_Selective_Accept =>
+ Expand_N_Selective_Accept (N);
- when N_Selective_Accept =>
- Expand_N_Selective_Accept (N);
+ when N_Single_Task_Declaration =>
+ Expand_N_Single_Task_Declaration (N);
- when N_Single_Task_Declaration =>
- Expand_N_Single_Task_Declaration (N);
+ when N_Slice =>
+ Expand_N_Slice (N);
- when N_Slice =>
- Expand_N_Slice (N);
+ when N_Subtype_Indication =>
+ Expand_N_Subtype_Indication (N);
- when N_Subtype_Indication =>
- Expand_N_Subtype_Indication (N);
+ when N_Subprogram_Body =>
+ Expand_N_Subprogram_Body (N);
- when N_Subprogram_Body =>
- Expand_N_Subprogram_Body (N);
+ when N_Subprogram_Body_Stub =>
+ Expand_N_Subprogram_Body_Stub (N);
- when N_Subprogram_Body_Stub =>
- Expand_N_Subprogram_Body_Stub (N);
+ when N_Subprogram_Declaration =>
+ Expand_N_Subprogram_Declaration (N);
- when N_Subprogram_Declaration =>
- Expand_N_Subprogram_Declaration (N);
+ when N_Subprogram_Info =>
+ Expand_N_Subprogram_Info (N);
- when N_Subprogram_Info =>
- Expand_N_Subprogram_Info (N);
+ when N_Task_Body =>
+ Expand_N_Task_Body (N);
- when N_Task_Body =>
- Expand_N_Task_Body (N);
+ when N_Task_Type_Declaration =>
+ Expand_N_Task_Type_Declaration (N);
- when N_Task_Type_Declaration =>
- Expand_N_Task_Type_Declaration (N);
+ when N_Timed_Entry_Call =>
+ Expand_N_Timed_Entry_Call (N);
- when N_Timed_Entry_Call =>
- Expand_N_Timed_Entry_Call (N);
+ when N_Type_Conversion =>
+ Expand_N_Type_Conversion (N);
- when N_Type_Conversion =>
- Expand_N_Type_Conversion (N);
+ when N_Unchecked_Expression =>
+ Expand_N_Unchecked_Expression (N);
- when N_Unchecked_Expression =>
- Expand_N_Unchecked_Expression (N);
+ when N_Unchecked_Type_Conversion =>
+ Expand_N_Unchecked_Type_Conversion (N);
- when N_Unchecked_Type_Conversion =>
- Expand_N_Unchecked_Type_Conversion (N);
+ when N_Variant_Part =>
+ Expand_N_Variant_Part (N);
- when N_Variant_Part =>
- Expand_N_Variant_Part (N);
+ -- For all other node kinds, no expansion activity is required
- -- For all other node kinds, no expansion activity is required
+ when others => null;
- when others => null;
+ end case;
- end case;
+ exception
+ when RE_Not_Available =>
+ return;
+ end;
-- Set result as analyzed and then do a possible transient wrap. The
-- transient wrap must be done after the Analyzed flag is set on, so
@@ -459,6 +466,7 @@ package body Expander is
Debug_A_Exit ("expanding ", N, " (done)");
end if;
+
end Expand;
---------------------------
@@ -467,9 +475,22 @@ package body Expander is
procedure Expander_Mode_Restore is
begin
+ -- Not active (has no effect) in ASIS mode (see comments in spec of
+ -- Expander_Mode_Save_And_Set).
+
+ if ASIS_Mode then
+ return;
+ end if;
+
+ -- Otherwise restore the flag
+
Expander_Active := Expander_Flags.Table (Expander_Flags.Last);
Expander_Flags.Decrement_Last;
+ -- Keep expander off if serious errors detected. In this case we do
+ -- not need expansion, and continued expansion may cause cascaded
+ -- errors or compiler bombs.
+
if Serious_Errors_Detected /= 0 then
Expander_Active := False;
end if;
@@ -481,6 +502,15 @@ package body Expander is
procedure Expander_Mode_Save_And_Set (Status : Boolean) is
begin
+ -- Not active (has no effect) in ASIS mode (see comments in spec of
+ -- Expander_Mode_Save_And_Set).
+
+ if ASIS_Mode then
+ return;
+ end if;
+
+ -- Otherwise save and set the flag
+
Expander_Flags.Increment_Last;
Expander_Flags.Table (Expander_Flags.Last) := Expander_Active;
Expander_Active := Status;
diff --git a/gcc/ada/expander.ads b/gcc/ada/expander.ads
index 28fef078c3c..d469405c48d 100644
--- a/gcc/ada/expander.ads
+++ b/gcc/ada/expander.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -150,11 +150,19 @@ package Expander is
procedure Expander_Mode_Save_And_Set (Status : Boolean);
-- Saves the current setting of the Expander_Active flag on an internal
-- stack and then sets the flag to the given value.
+ --
+ -- Note: this routine has no effect in ASIS_Mode. In ASIS_Mode, all
+ -- expansion activity is always off, since we want the original semantic
+ -- tree for ASIS purposes without any expansion. This is achieved by
+ -- setting Expander_Active False in ASIS_Mode. In situations such as
+ -- the call to Instantiate_Bodies in Frontend, Expander_Mode_Save_And_Set
+ -- may be called to temporarily turn the expander on, but this will have
+ -- no effect in ASIS mode.
procedure Expander_Mode_Restore;
-- Restores the setting of the Expander_Active flag using the top entry
-- pushed onto the stack by Expander_Mode_Save_And_Reset, popping the
-- stack, except that if any errors have been detected, then the state
- -- of the flag is left set to False.
+ -- of the flag is left set to False. Disabled for ASIS_Mode (see above).
end Expander;
diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c
index 175a7e057c6..3a86ffdf87c 100644
--- a/gcc/ada/expect.c
+++ b/gcc/ada/expect.c
@@ -6,8 +6,7 @@
* *
* C Implementation File *
* *
- * *
- * Copyright (C) 2001-2002 Ada Core Technologies, Inc. *
+ * Copyright (C) 2001-2003 Ada Core Technologies, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -27,7 +26,7 @@
* file might be covered by the GNU Public License. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
- * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ * Extensive contributions were provided by Ada Core Technologies Inc. *
* *
****************************************************************************/
@@ -59,11 +58,17 @@
#include <windows.h>
#include <process.h>
-/* ??? Provide a no-op for now */
-
void
-kill ()
+__gnat_kill (int pid, int sig)
{
+ HANDLE process_handle;
+
+ if (sig == 9)
+ {
+ process_handle = OpenProcess (PROCESS_TERMINATE, FALSE, pid);
+ if (process_handle != NULL)
+ TerminateProcess (process_handle, 0);
+ }
}
int
@@ -73,34 +78,28 @@ __gnat_expect_fork ()
}
void
-__gnat_expect_portable_execvp (pid, cmd, argv)
- int *pid;
- char *cmd;
- char *argv[];
+__gnat_expect_portable_execvp (int *pid, char *cmd, char *argv[])
{
*pid = (int) spawnve (_P_NOWAIT, cmd, argv, NULL);
}
int
-__gnat_pipe (fd)
- int *fd;
+__gnat_pipe (int *fd)
{
HANDLE read, write;
CreatePipe (&read, &write, NULL, 0);
- fd[0]=_open_osfhandle (read, 0);
- fd[1]=_open_osfhandle (write, 0);
+ fd[0]=_open_osfhandle ((long)read, 0);
+ fd[1]=_open_osfhandle ((long)write, 0);
return 0; /* always success */
}
int
-__gnat_expect_poll (fd, num_fd, timeout, is_set)
- int *fd;
- int num_fd;
- int timeout;
- int *is_set;
+__gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set)
{
- int i, num;
+#define MAX_DELAY 100
+
+ int i, delay, infinite = 0;
DWORD avail;
HANDLE handles[num_fd];
@@ -108,29 +107,37 @@ __gnat_expect_poll (fd, num_fd, timeout, is_set)
is_set[i] = 0;
for (i = 0; i < num_fd; i++)
- handles[i] = (HANDLE) _get_osfhandle (fd[i]);
+ handles[i] = (HANDLE) _get_osfhandle (fd [i]);
+
+ /* Start with small delays, and then increase them, to avoid polling too
+ much when waiting a long time */
+ delay = 5;
- num = timeout / 50;
+ if (timeout < 0)
+ infinite = 1;
while (1)
{
for (i = 0; i < num_fd; i++)
- {
- if (!PeekNamedPipe (handles[i], NULL, 0, NULL, &avail, NULL))
- return -1;
+ {
+ if (!PeekNamedPipe (handles [i], NULL, 0, NULL, &avail, NULL))
+ return -1;
- if (avail > 0)
- {
- is_set[i] = 1;
- return 1;
- }
- }
+ if (avail > 0)
+ {
+ is_set[i] = 1;
+ return 1;
+ }
+ }
- if (timeout >= 0 && num == 0)
- return 0;
+ if (!infinite && timeout <= 0)
+ return 0;
- Sleep (50);
- num--;
+ Sleep (delay);
+ timeout -= delay;
+
+ if (delay < MAX_DELAY)
+ delay += 10;
}
}
@@ -146,8 +153,7 @@ __gnat_expect_poll (fd, num_fd, timeout, is_set)
#include <iodef.h>
int
-__gnat_pipe (fd)
- int *fd;
+__gnat_pipe (int *fd)
{
return pipe (fd);
}
@@ -159,22 +165,16 @@ __gnat_expect_fork ()
}
void
-__gnat_expect_portable_execvp (pid, cmd, argv)
- int *pid;
- char *cmd;
- char *argv[];
+__gnat_expect_portable_execvp (int *pid, char *cmd, char *argv[])
{
- *pid = (int) getpid();
- /* Since cmd is fully qualified, it is incorrect to to call execvp */
+ *pid = (int) getpid ();
+ /* Since cmd is fully qualified, it is incorrect to call execvp */
execv (cmd, argv);
+ _exit (1);
}
int
-__gnat_expect_poll (fd, num_fd, timeout, is_set)
- int *fd;
- int num_fd;
- int timeout;
- int *is_set;
+__gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set)
{
int i, num, ready = 0;
unsigned int status;
@@ -205,6 +205,12 @@ __gnat_expect_poll (fd, num_fd, timeout, is_set)
mbxname.dsc$a_pointer = buf;
status = SYS$ASSIGN (&mbxname, &mbxchans[i], 0, 0, 0);
+
+ if ((status & 1) != 1)
+ {
+ ready = -1;
+ return ready;
+ }
}
}
@@ -222,6 +228,12 @@ __gnat_expect_poll (fd, num_fd, timeout, is_set)
(0, mbxchans[i], IO$_SENSEMODE|IO$M_READERCHECK,
&iosb, 0, 0, 0, 0, 0, 0, 0, 0);
+ if ((status & 1) != 1)
+ {
+ ready = -1;
+ goto deassign;
+ }
+
if (iosb.count > 0)
{
is_set[i] = 1;
@@ -231,7 +243,7 @@ __gnat_expect_poll (fd, num_fd, timeout, is_set)
}
}
- if (timeout >= 0 && num == 0)
+ if (timeout > 0 && num == 0)
{
ready = 0;
goto deassign;
@@ -255,6 +267,10 @@ __gnat_expect_poll (fd, num_fd, timeout, is_set)
#elif defined (unix)
+#ifdef hpux
+#include <sys/ptyio.h>
+#endif
+
#include <sys/time.h>
#ifndef NO_FD_SET
@@ -270,9 +286,14 @@ typedef long fd_mask;
#endif /* !_IBMR2 */
#endif /* !NO_FD_SET */
+void
+__gnat_kill (int pid, int sig)
+{
+ kill (pid, sig);
+}
+
int
-__gnat_pipe (fd)
- int *fd;
+__gnat_pipe (int *fd)
{
return pipe (fd);
}
@@ -284,54 +305,102 @@ __gnat_expect_fork ()
}
void
-__gnat_expect_portable_execvp (pid, cmd, argv)
- int *pid;
- char *cmd;
- char *argv[];
+__gnat_expect_portable_execvp (int *pid, char *cmd, char *argv[])
{
- *pid = (int) getpid();
- execvp (cmd, argv);
+ *pid = (int) getpid ();
+ /* Since cmd is fully qualified, it is incorrect to call execvp */
+ execv (cmd, argv);
+ _exit (1);
}
int
-__gnat_expect_poll (fd, num_fd, timeout, is_set)
- int *fd;
- int num_fd;
- int timeout;
- int *is_set;
+__gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set)
{
struct timeval tv;
SELECT_MASK rset;
+ SELECT_MASK eset;
+
int max_fd = 0;
int ready;
int i;
-
- FD_ZERO (&rset);
-
- for (i = 0; i < num_fd; i++)
- {
- FD_SET (fd[i], &rset);
- if (fd[i] > max_fd)
- max_fd = fd[i];
- }
+ int received;
tv.tv_sec = timeout / 1000;
tv.tv_usec = (timeout % 1000) * 1000;
- ready = select (max_fd + 1, &rset, NULL, NULL, timeout == -1 ? NULL : &tv);
+ do {
+ FD_ZERO (&rset);
+ FD_ZERO (&eset);
- if (ready > 0)
for (i = 0; i < num_fd; i++)
- is_set[i] = (FD_ISSET (fd[i], &rset) ? 1 : 0);
+ {
+ FD_SET (fd[i], &rset);
+ FD_SET (fd[i], &eset);
+
+ if (fd[i] > max_fd)
+ max_fd = fd[i];
+ }
+
+ ready =
+ select (max_fd + 1, &rset, NULL, &eset, timeout == -1 ? NULL : &tv);
+
+ if (ready > 0)
+ {
+ received = 0;
+
+ for (i = 0; i < num_fd; i++)
+ {
+ if (FD_ISSET (fd[i], &rset))
+ {
+ is_set[i] = 1;
+ received = 1;
+ }
+ else
+ is_set[i] = 0;
+ }
+
+#ifdef hpux
+ for (i = 0; i < num_fd; i++)
+ {
+ if (FD_ISSET (fd[i], &eset))
+ {
+ struct request_info ei;
+
+ /* Only query and reset error state if no file descriptor
+ is ready to be read, otherwise we will be signalling a
+ died process too early */
+
+ if (!received)
+ {
+ ioctl (fd[i], TIOCREQCHECK, &ei);
+
+ if (ei.request == TIOCCLOSE)
+ {
+ ioctl (fd[i], TIOCREQSET, &ei);
+ return -1;
+ }
+
+ ioctl (fd[i], TIOCREQSET, &ei);
+ }
+ ready--;
+ }
+ }
+#endif
+ }
+ } while (timeout == -1 && ready == 0);
return ready;
}
#else
+void
+__gnat_kill (int pid, int sig)
+{
+}
+
int
-__gnat_pipe (fd)
- int *fd;
+__gnat_pipe (int *fd)
{
return -1;
}
@@ -343,20 +412,13 @@ __gnat_expect_fork ()
}
void
-__gnat_expect_portable_execvp (pid, cmd, argv)
- int *pid;
- char *cmd;
- char *argv[];
+__gnat_expect_portable_execvp (int *pid, char *cmd, char *argv[])
{
*pid = 0;
}
int
-__gnat_expect_poll (fd, num_fd, timeout, is_set)
- int *fd;
- int num_fd;
- int timeout;
- int *is_set;
+__gnat_expect_poll (int *fd, int num_fd, int timeout, int *is_set)
{
return -1;
}
diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h
index 9c2837cf6e0..181d58b3e03 100644
--- a/gcc/ada/fe.h
+++ b/gcc/ada/fe.h
@@ -6,8 +6,7 @@
* *
* C Header File *
* *
- * *
- * 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- *
@@ -34,21 +33,12 @@
/* This file contains definitions to access front-end functions and
variables used by gigi. */
-/* atree: */
-
-#define Is_Rewrite_Substitution atree__is_rewrite_substitution
-#define Original_Node atree__original_node
-
-extern Boolean Is_Rewrite_Subsitution PARAMS ((Node_Id));
-extern Node_Id Original_Node PARAMS ((Node_Id));
-
/* comperr: */
#define Compiler_Abort comperr__compiler_abort
-extern int Compiler_Abort PARAMS ((Fat_Pointer, int)) ATTRIBUTE_NORETURN;
+extern int Compiler_Abort (Fat_Pointer, int) ATTRIBUTE_NORETURN;
-/* csets: Definitions to access the front-end's character translation
- tables. */
+/* csets: */
#define Fold_Lower(C) csets__fold_lower[C]
#define Fold_Upper(C) csets__fold_upper[C]
@@ -73,37 +63,44 @@ extern Boolean Debug_Flag_NN;
#define Set_Component_Size einfo__set_component_size
#define Set_Present_Expr sinfo__set_present_expr
-extern void Set_Alignment PARAMS ((Entity_Id, Uint));
-extern void Set_Component_Size PARAMS ((Entity_Id, Uint));
-extern void Set_Esize PARAMS ((Entity_Id, Uint));
-extern void Set_RM_Size PARAMS ((Entity_Id, Uint));
-extern void Set_Component_Bit_Offset PARAMS ((Entity_Id, Uint));
-extern void Set_Present_Expr PARAMS ((Node_Id, Uint));
+extern void Set_Alignment (Entity_Id, Uint);
+extern void Set_Component_Size (Entity_Id, Uint);
+extern void Set_Esize (Entity_Id, Uint);
+extern void Set_RM_Size (Entity_Id, Uint);
+extern void Set_Component_Bit_Offset (Entity_Id, Uint);
+extern void Set_Present_Expr (Node_Id, Uint);
/* Test if the node N is the name of an entity (i.e. is an identifier,
expanded name, or an attribute reference that returns an entity). */
#define Is_Entity_Name einfo__is_entity_name
-extern Boolean Is_Entity_Name PARAMS ((Node_Id));
+extern Boolean Is_Entity_Name (Node_Id);
#define Get_Attribute_Definition_Clause einfo__get_attribute_definition_clause
-extern Node_Id Get_Attribute_Definition_Clause PARAMS ((Entity_Id, char));
+extern Node_Id Get_Attribute_Definition_Clause (Entity_Id, char);
/* errout: */
-#define Error_Msg_N errout__error_msg_n
-#define Error_Msg_NE errout__error_msg_ne
-#define Error_Msg_Node_2 errout__error_msg_node_2
-#define Error_Msg_Uint_1 errout__error_msg_uint_1
-#define Error_Msg_Uint_2 errout__error_msg_uint_2
+#define Error_Msg_N errout__error_msg_n
+#define Error_Msg_NE errout__error_msg_ne
+#define Set_Identifier_Casing errout__set_identifier_casing
+
+extern void Error_Msg_N (Fat_Pointer, Node_Id);
+extern void Error_Msg_NE (Fat_Pointer, Node_Id, Entity_Id);
+extern void Set_Identifier_Casing (Char, Char);
-extern void Error_Msg_N PARAMS ((Fat_Pointer, Node_Id));
-extern void Error_Msg_NE PARAMS ((Fat_Pointer, Node_Id, Entity_Id));
+/* err_vars: */
+
+#define Error_Msg_Node_2 err_vars__error_msg_node_2
+#define Error_Msg_Uint_1 err_vars__error_msg_uint_1
+#define Error_Msg_Uint_2 err_vars__error_msg_uint_2
+
+extern Entity_Id Error_Msg_Node_2;
+extern Uint Error_Msg_Uint_1;
+extern Uint Error_Msg_Uint_2;
-extern Entity_Id Error_Msg_Node_2;
-extern Uint Error_Msg_Uint_1;
-extern Uint Error_Msg_Uint_2;
/* exp_code: */
+
#define Asm_Input_Constraint exp_code__asm_input_constraint
#define Asm_Input_Value exp_code__asm_input_value
#define Asm_Output_Constraint exp_code__asm_output_constraint
@@ -117,26 +114,26 @@ extern Uint Error_Msg_Uint_2;
#define Setup_Asm_Inputs exp_code__setup_asm_inputs
#define Setup_Asm_Outputs exp_code__setup_asm_outputs
-extern Node_Id Asm_Input_Constraint PARAMS ((void));
-extern Node_Id Asm_Input_Value PARAMS ((void));
-extern Node_Id Asm_Output_Constraint PARAMS ((void));
-extern Node_Id Asm_Output_Variable PARAMS ((void));
-extern Node_Id Asm_Template PARAMS ((Node_Id));
-extern char *Clobber_Get_Next PARAMS ((void));
-extern void Clobber_Setup PARAMS ((Node_Id));
-extern Boolean Is_Asm_Volatile PARAMS ((Node_Id));
-extern void Next_Asm_Input PARAMS ((void));
-extern void Next_Asm_Output PARAMS ((void));
-extern void Setup_Asm_Inputs PARAMS ((Node_Id));
-extern void Setup_Asm_Outputs PARAMS ((Node_Id));
+extern Node_Id Asm_Input_Constraint (void);
+extern Node_Id Asm_Input_Value (void);
+extern Node_Id Asm_Output_Constraint (void);
+extern Node_Id Asm_Output_Variable (void);
+extern Node_Id Asm_Template (Node_Id);
+extern char *Clobber_Get_Next (void);
+extern void Clobber_Setup (Node_Id);
+extern Boolean Is_Asm_Volatile (Node_Id);
+extern void Next_Asm_Input (void);
+extern void Next_Asm_Output (void);
+extern void Setup_Asm_Inputs (Node_Id);
+extern void Setup_Asm_Outputs (Node_Id);
/* exp_dbug: */
#define Get_Encoded_Name exp_dbug__get_encoded_name
#define Get_External_Name_With_Suffix exp_dbug__get_external_name_with_suffix
-extern void Get_Encoded_Name PARAMS ((Entity_Id));
-extern void Get_External_Name_With_Suffix PARAMS ((Entity_Id, Fat_Pointer));
+extern void Get_Encoded_Name (Entity_Id);
+extern void Get_External_Name_With_Suffix (Entity_Id, Fat_Pointer);
/* lib: */
@@ -144,27 +141,33 @@ extern void Get_External_Name_With_Suffix PARAMS ((Entity_Id, Fat_Pointer));
#define Ident_String lib__ident_string
#define In_Extended_Main_Code_Unit lib__in_extended_main_code_unit
-extern Node_Id Cunit PARAMS ((Unit_Number_Type));
-extern Node_Id Ident_String PARAMS ((Unit_Number_Type));
-extern Boolean In_Extended_Main_Code_Unit PARAMS ((Entity_Id));
+extern Node_Id Cunit (Unit_Number_Type);
+extern Node_Id Ident_String (Unit_Number_Type);
+extern Boolean In_Extended_Main_Code_Unit (Entity_Id);
/* opt: */
-#define Global_Discard_Names opt__global_discard_names
-#define Exception_Mechanism opt__exception_mechanism
+#define Global_Discard_Names opt__global_discard_names
+#define Exception_Mechanism opt__exception_mechanism
+#define Back_Annotate_Rep_Info opt__back_annotate_rep_info
typedef enum {Setjmp_Longjmp, Front_End_ZCX, GCC_ZCX} Exception_Mechanism_Type;
extern Boolean Global_Discard_Names;
extern Exception_Mechanism_Type Exception_Mechanism;
+extern Boolean Back_Annotate_Rep_Info;
/* restrict: */
+#define No_Exception_Handlers_Set restrict__no_exception_handlers_set
+#define Check_No_Implicit_Heap_Alloc restrict__check_no_implicit_heap_alloc
#define Check_Elaboration_Code_Allowed restrict__check_elaboration_code_allowed
-#define No_Exception_Handlers_Set restrict__no_exception_handlers_set
+#define Check_No_Implicit_Heap_Alloc restrict__check_no_implicit_heap_alloc
-extern void Check_Elaboration_Code_Allowed PARAMS ((Node_Id));
-extern Boolean No_Exception_Handlers_Set PARAMS ((void));
+extern Boolean No_Exception_Handlers_Set (void);
+extern void Check_No_Implicit_Heap_Alloc (Node_Id);
+extern void Check_Elaboration_Code_Allowed (Node_Id);
+extern void Check_No_Implicit_Heap_Alloc (Node_Id);
/* sem_eval: */
@@ -172,11 +175,13 @@ extern Boolean No_Exception_Handlers_Set PARAMS ((void));
#define Expr_Value sem_eval__expr_value
#define Expr_Value_S sem_eval__expr_value_s
#define Is_OK_Static_Expression sem_eval__is_ok_static_expression
+#define Is_OK_Static_Subtype sem_eval__is_ok_static_subtype
-extern Uint Expr_Value PARAMS ((Node_Id));
-extern Node_Id Expr_Value_S PARAMS ((Node_Id));
-extern Boolean Compile_Time_Known_Value PARAMS((Node_Id));
-extern Boolean Is_OK_Static_Expression PARAMS((Node_Id));
+extern Uint Expr_Value (Node_Id);
+extern Node_Id Expr_Value_S (Node_Id);
+extern Boolean Compile_Time_Known_Value (Node_Id);
+extern Boolean Is_OK_Static_Expression (Node_Id);
+extern Boolean Is_OK_Static_Subtype (Entity_Id);
/* sem_util: */
@@ -185,15 +190,16 @@ extern Boolean Is_OK_Static_Expression PARAMS((Node_Id));
#define Next_Actual sem_util__next_actual
#define Requires_Transient_Scope sem_util__requires_transient_scope
-extern Entity_Id Defining_Entity PARAMS ((Node_Id));
-extern Node_Id First_Actual PARAMS ((Node_Id));
-extern Node_Id Next_Actual PARAMS ((Node_Id));
-extern Boolean Requires_Transient_Scope PARAMS ((Entity_Id));
+extern Entity_Id Defining_Entity (Node_Id);
+extern Node_Id First_Actual (Node_Id);
+extern Node_Id Next_Actual (Node_Id);
+extern Boolean Requires_Transient_Scope (Entity_Id);
/* sinfo: These functions aren't in sinfo.h since we don't make the
setting functions, just the retrieval functions. */
+
#define Set_Has_No_Elaboration_Code sinfo__set_has_no_elaboration_code
-extern void Set_Has_No_Elaboration_Code PARAMS ((Node_Id, Boolean));
+extern void Set_Has_No_Elaboration_Code (Node_Id, Boolean);
/* targparm: */
diff --git a/gcc/ada/adafinal.c b/gcc/ada/final.c
index 06e1f462a46..0fda97b98ee 100644
--- a/gcc/ada/adafinal.c
+++ b/gcc/ada/final.c
@@ -2,12 +2,11 @@
* *
* GNAT COMPILER COMPONENTS *
* *
- * A D A F I N A L *
- * *
+ * F I N A L *
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2001 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- *
@@ -31,19 +30,7 @@
* *
****************************************************************************/
-#ifdef __alpha_vxworks
-#include "vxWorks.h"
-#endif
-
-#ifdef IN_RTS
-#include "tconfig.h"
-#include "tsystem.h"
-#else
-#include "config.h"
-#include "system.h"
-#endif
-
-#include "raise.h"
+extern void __gnat_finalize (void);
/* This routine is called at the extreme end of execution of an Ada program
(the call is generated by the binder). The standard routine does nothing
diff --git a/gcc/ada/fmap.adb b/gcc/ada/fmap.adb
index 9fdfda04b01..f65d88781a0 100644
--- a/gcc/ada/fmap.adb
+++ b/gcc/ada/fmap.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -43,6 +43,13 @@ package body Fmap is
function To_Big_String_Ptr is new Unchecked_Conversion
(Source_Buffer_Ptr, Big_String_Ptr);
+ Max_Buffer : constant := 1_500;
+ Buffer : String (1 .. Max_Buffer);
+ -- Used to bufferize output when writing to a new mapping file
+
+ Buffer_Last : Natural := 0;
+ -- Index of last valid character in Buffer
+
type Mapping is record
Uname : Unit_Name_Type;
Fname : File_Name_Type;
@@ -96,6 +103,23 @@ package body Fmap is
Last_In_Table : Int := 0;
+ package Forbidden_Names is new GNAT.HTable.Simple_HTable (
+ Header_Num => Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => File_Name_Type,
+ Hash => Hash,
+ Equal => "=");
+
+ -----------------------------
+ -- Add_Forbidden_File_Name --
+ -----------------------------
+
+ procedure Add_Forbidden_File_Name (Name : Name_Id) is
+ begin
+ Forbidden_Names.Set (Name, True);
+ end Add_Forbidden_File_Name;
+
---------------------
-- Add_To_File_Map --
---------------------
@@ -144,9 +168,12 @@ package body Fmap is
The_Mapping : Mapping;
- procedure Empty_Tables;
+ procedure Empty_Tables (Warning : Boolean := True);
-- Remove all entries in case of incorrect mapping file
+ function Find_Name return Name_Id;
+ -- Return Error_Name for "/", otherwise call Name_Find
+
procedure Get_Line;
-- Get a line from the mapping file
@@ -158,8 +185,14 @@ package body Fmap is
-- Empty_Tables --
------------------
- procedure Empty_Tables is
+ procedure Empty_Tables (Warning : Boolean := True) is
begin
+ if Warning then
+ Write_Str ("mapping file """);
+ Write_Str (File_Name);
+ Write_Line (""" is not taken into account");
+ end if;
+
Unit_Hash_Table.Reset;
File_Hash_Table.Reset;
Path_Mapping.Set_Last (0);
@@ -203,33 +236,43 @@ package body Fmap is
end if;
end Get_Line;
+ ---------------
+ -- Find_Name --
+ ---------------
+
+ function Find_Name return Name_Id is
+ begin
+ if Name_Buffer (1 .. Name_Len) = "/" then
+ return Error_Name;
+
+ else
+ return Name_Find;
+ end if;
+ end Find_Name;
+
----------------------
-- Report_Truncated --
----------------------
procedure Report_Truncated is
begin
- if not Quiet_Output then
- Write_Str ("warning: mapping file """);
- Write_Str (File_Name);
- Write_Line (""" is truncated");
- end if;
+ Write_Str ("warning: mapping file """);
+ Write_Str (File_Name);
+ Write_Line (""" is truncated");
end Report_Truncated;
-- Start of procedure Initialize
begin
- Empty_Tables;
+ Empty_Tables (Warning => False);
Name_Len := File_Name'Length;
Name_Buffer (1 .. Name_Len) := File_Name;
Read_Source_File (Name_Enter, 0, Hi, Src, Config);
if Src = null then
- if not Quiet_Output then
- Write_Str ("warning: could not read mapping file """);
- Write_Str (File_Name);
- Write_Line ("""");
- end if;
+ Write_Str ("warning: could not read mapping file """);
+ Write_Str (File_Name);
+ Write_Line ("""");
else
BS := To_Big_String_Ptr (Src);
@@ -244,13 +287,20 @@ package body Fmap is
exit when First > Last;
- pragma Assert (Last >= First + 2);
- pragma Assert (SP (Last - 1) = '%');
- pragma Assert (SP (Last) = 's' or else SP (Last) = 'b');
+ if (Last < First + 2) or else (SP (Last - 1) /= '%')
+ or else (SP (Last) /= 's' and then SP (Last) /= 'b')
+ then
+ Write_Str ("warning: mapping file """);
+ Write_Str (File_Name);
+ Write_Line (""" is incorrectly formated");
+ Empty_Tables;
+ return;
+ end if;
+
Name_Len := Last - First + 1;
Name_Buffer (1 .. Name_Len) := SP (First .. Last);
- Uname := Name_Find;
+ Uname := Find_Name;
-- Get the file name
@@ -266,7 +316,8 @@ package body Fmap is
Name_Len := Last - First + 1;
Name_Buffer (1 .. Name_Len) := SP (First .. Last);
- Fname := Name_Find;
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Fname := Find_Name;
-- Get the path name
@@ -282,40 +333,32 @@ package body Fmap is
Name_Len := Last - First + 1;
Name_Buffer (1 .. Name_Len) := SP (First .. Last);
- Pname := Name_Find;
+ Pname := Find_Name;
-- Check for duplicate entries
if Unit_Hash_Table.Get (Uname) /= No_Entry then
- if not Quiet_Output then
- Write_Str ("warning: duplicate entry """);
- Write_Str (Get_Name_String (Uname));
- Write_Str (""" in mapping file """);
- Write_Str (File_Name);
- Write_Line ("""");
- The_Mapping :=
- File_Mapping.Table (Unit_Hash_Table.Get (Uname));
- Write_Line (Get_Name_String (The_Mapping.Uname));
- Write_Line (Get_Name_String (The_Mapping.Fname));
- end if;
-
+ Write_Str ("warning: duplicate entry """);
+ Write_Str (Get_Name_String (Uname));
+ Write_Str (""" in mapping file """);
+ Write_Str (File_Name);
+ Write_Line ("""");
+ The_Mapping := File_Mapping.Table (Unit_Hash_Table.Get (Uname));
+ Write_Line (Get_Name_String (The_Mapping.Uname));
+ Write_Line (Get_Name_String (The_Mapping.Fname));
Empty_Tables;
return;
end if;
if File_Hash_Table.Get (Fname) /= No_Entry then
- if not Quiet_Output then
- Write_Str ("warning: duplicate entry """);
- Write_Str (Get_Name_String (Fname));
- Write_Str (""" in mapping file """);
- Write_Str (File_Name);
- Write_Line ("""");
- The_Mapping :=
- Path_Mapping.Table (File_Hash_Table.Get (Fname));
- Write_Line (Get_Name_String (The_Mapping.Uname));
- Write_Line (Get_Name_String (The_Mapping.Fname));
- end if;
-
+ Write_Str ("warning: duplicate entry """);
+ Write_Str (Get_Name_String (Fname));
+ Write_Str (""" in mapping file """);
+ Write_Str (File_Name);
+ Write_Line ("""");
+ The_Mapping := Path_Mapping.Table (File_Hash_Table.Get (Fname));
+ Write_Line (Get_Name_String (The_Mapping.Uname));
+ Write_Line (Get_Name_String (The_Mapping.Fname));
Empty_Tables;
return;
end if;
@@ -355,6 +398,10 @@ package body Fmap is
Index : Int := No_Entry;
begin
+ if Forbidden_Names.Get (File) then
+ return Error_Name;
+ end if;
+
Index := File_Hash_Table.Get (File);
if Index = No_Entry then
@@ -364,12 +411,39 @@ package body Fmap is
end if;
end Mapped_Path_Name;
+ --------------------------------
+ -- Remove_Forbidden_File_Name --
+ --------------------------------
+
+ procedure Remove_Forbidden_File_Name (Name : Name_Id) is
+ begin
+ Forbidden_Names.Set (Name, False);
+ end Remove_Forbidden_File_Name;
+
+ ------------------
+ -- Reset_Tables --
+ ------------------
+
+ procedure Reset_Tables is
+ begin
+ File_Mapping.Init;
+ Path_Mapping.Init;
+ Unit_Hash_Table.Reset;
+ File_Hash_Table.Reset;
+ Forbidden_Names.Reset;
+ Last_In_Table := 0;
+ end Reset_Tables;
+
-------------------------
-- Update_Mapping_File --
-------------------------
procedure Update_Mapping_File (File_Name : String) is
- File : File_Descriptor;
+ File : File_Descriptor;
+ N_Bytes : Integer;
+
+ Status : Boolean;
+ -- For the call to Close
procedure Put_Line (Name : Name_Id);
-- Put Name as a line in the Mapping File
@@ -379,17 +453,27 @@ package body Fmap is
--------------
procedure Put_Line (Name : Name_Id) is
- N_Bytes : Integer;
begin
Get_Name_String (Name);
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := ASCII.LF;
- N_Bytes := Write (File, Name_Buffer (1)'Address, Name_Len);
- if N_Bytes < Name_Len then
- Fail ("disk full");
+ -- If the Buffer is full, write it to the file
+
+ if Buffer_Last + Name_Len + 1 > Buffer'Last then
+ N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
+
+ if N_Bytes < Buffer_Last then
+ Fail ("disk full");
+ end if;
+
+ Buffer_Last := 0;
end if;
+ -- Add the line to the Buffer
+
+ Buffer (Buffer_Last + 1 .. Buffer_Last + Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
+ Buffer_Last := Buffer_Last + Name_Len + 1;
+ Buffer (Buffer_Last) := ASCII.LF;
end Put_Line;
-- Start of Update_Mapping_File
@@ -428,7 +512,22 @@ package body Fmap is
Put_Line (Path_Mapping.Table (Unit).Fname);
end loop;
- Close (File);
+ -- Before closing the file, write the buffer to the file.
+ -- It is guaranteed that the Buffer is not empty, because
+ -- Put_Line has been called at least 3 times, and after
+ -- a call to Put_Line, the Buffer is not empty.
+
+ N_Bytes := Write (File, Buffer (1)'Address, Buffer_Last);
+
+ if N_Bytes < Buffer_Last then
+ Fail ("disk full");
+ end if;
+
+ Close (File, Status);
+
+ if not Status then
+ Fail ("disk full");
+ end if;
elsif not Quiet_Output then
Write_Str ("warning: could not open mapping file """);
diff --git a/gcc/ada/fmap.ads b/gcc/ada/fmap.ads
index 5b1d51e606d..35429568373 100644
--- a/gcc/ada/fmap.ads
+++ b/gcc/ada/fmap.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -45,6 +45,7 @@ package Fmap is
function Mapped_File_Name (Unit : Unit_Name_Type) return File_Name_Type;
-- Return the file name mapped to the unit name Unit.
-- Return No_File if Unit is not mapped.
+ -- Return Error_Name if it is forbidden.
procedure Add_To_File_Map
(Unit_Name : Unit_Name_Type;
@@ -55,7 +56,22 @@ package Fmap is
procedure Update_Mapping_File (File_Name : String);
-- If Add_To_File_Map has been called (after Initialize or any time
-- if Initialize has not been called), append the new entries to the
- -- to the mapping file.
- -- What is the significance of the parameter File_Name ???
+ -- mapping file whose file name is File_Name.
+
+ procedure Reset_Tables;
+ -- Initialize all the internal data structures. This procedure is used
+ -- when several compilations are performed by the same process (by GNSA
+ -- for ASIS, for example) to remove any existing mappings from a previous
+ -- compilation.
+
+ procedure Add_Forbidden_File_Name (Name : Name_Id);
+ -- Indicate that a source file name is forbidden.
+ -- This is used by gnatmake when there are Locally_Removed_Files in
+ -- extending projects.
+
+ procedure Remove_Forbidden_File_Name (Name : Name_Id);
+ -- Indicate that a source file name that was forbidden is no longer
+ -- forbidden. Used by gnatmake when a locally removed file is redefined
+ -- in another extending project.
end Fmap;
diff --git a/gcc/ada/fname-uf.adb b/gcc/ada/fname-uf.adb
index bd545950d6a..8f65c7d76de 100644
--- a/gcc/ada/fname-uf.adb
+++ b/gcc/ada/fname-uf.adb
@@ -124,8 +124,7 @@ package body Fname.UF is
function Get_File_Name
(Uname : Unit_Name_Type;
- Subunit : Boolean)
- return File_Name_Type
+ Subunit : Boolean) return File_Name_Type
is
Unit_Char : Character;
-- Set to 's' or 'b' for spec or body or to 'u' for a subunit
@@ -221,6 +220,9 @@ package body Fname.UF is
Dot : String_Ptr;
Dotl : Natural;
+ Is_Predef : Boolean;
+ -- Set True for predefined file
+
function C (N : Natural) return Character;
-- Return N'th character of pattern
@@ -251,11 +253,25 @@ package body Fname.UF is
if SFN_Patterns.Table (Pent).Typ = Unit_Char_Search then
Name_Len := 0;
+ -- Determine if we have a predefined file name
+
+ Name_Len := Uname'Length;
+ Name_Buffer (1 .. Name_Len) := Uname;
+ Is_Predef :=
+ Is_Predefined_File_Name (Renamings_Included => True);
+
-- Found a match, execute the pattern
Name_Len := Uname'Length;
Name_Buffer (1 .. Name_Len) := Uname;
- Set_Casing (SFN_Patterns.Table (Pent).Cas);
+
+ -- Apply casing, except that we do not do this for the case
+ -- of a predefined library file. For the latter, we always
+ -- use the all lower case name, regardless of the setting.
+
+ if not Is_Predef then
+ Set_Casing (SFN_Patterns.Table (Pent).Cas);
+ end if;
-- If dot translation required do it
diff --git a/gcc/ada/fname-uf.ads b/gcc/ada/fname-uf.ads
index 6eef86e9ee7..50c15bf33d5 100644
--- a/gcc/ada/fname-uf.ads
+++ b/gcc/ada/fname-uf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 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- --
@@ -45,8 +45,7 @@ package Fname.UF is
function Get_File_Name
(Uname : Unit_Name_Type;
- Subunit : Boolean)
- return File_Name_Type;
+ Subunit : Boolean) return File_Name_Type;
-- This function returns the file name that corresponds to a given unit
-- name, Uname. The Subunit parameter is set True for subunits, and
-- false for all other kinds of units. The caller is responsible for
diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb
index 195010b072d..b771772556a 100644
--- a/gcc/ada/fname.adb
+++ b/gcc/ada/fname.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- --
@@ -135,6 +135,15 @@ package body Fname is
Renamings_Included : Boolean := True)
return Boolean
is
+ begin
+ Get_Name_String (Fname);
+ return Is_Predefined_File_Name (Renamings_Included);
+ end Is_Predefined_File_Name;
+
+ function Is_Predefined_File_Name
+ (Renamings_Included : Boolean := True)
+ return Boolean
+ is
subtype Str8 is String (1 .. 8);
Predef_Names : constant array (1 .. 11) of Str8 :=
@@ -157,9 +166,7 @@ package body Fname is
7 + 4 * Boolean'Pos (Renamings_Included);
begin
- -- Get file name, removing the extension (if any)
-
- Get_Name_String (Fname);
+ -- Remove extension (if present)
if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then
Name_Len := Name_Len - 4;
diff --git a/gcc/ada/fname.ads b/gcc/ada/fname.ads
index d4bf4cf3cd4..380b617f780 100644
--- a/gcc/ada/fname.ads
+++ b/gcc/ada/fname.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 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- --
@@ -77,8 +77,7 @@ package Fname is
function Is_Predefined_File_Name
(Fname : File_Name_Type;
- Renamings_Included : Boolean := True)
- return Boolean;
+ Renamings_Included : Boolean := True) return Boolean;
-- This function determines if the given file name (which must be a simple
-- file name with no directory information) is the file name for one of
-- the predefined library units. On return, Name_Buffer contains the
@@ -87,6 +86,10 @@ package Fname is
-- Renamings_Included is True, then Text_IO will return True, otherwise
-- only children of Ada, Interfaces and System return True.
+ function Is_Predefined_File_Name
+ (Renamings_Included : Boolean := True) return Boolean;
+ -- This version is called with the file name already in Name_Buffer
+
function Is_Internal_File_Name
(Fname : File_Name_Type;
Renamings_Included : Boolean := True)
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 579c5ff5090..18f77f04283 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.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- --
@@ -33,6 +33,7 @@ with Exp_Ch7; use Exp_Ch7;
with Exp_Ch11; use Exp_Ch11;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
+with Exp_Tss; use Exp_Tss;
with Layout; use Layout;
with Lib.Xref; use Lib.Xref;
with Nlists; use Nlists;
@@ -78,6 +79,10 @@ package body Freeze is
After : in out Node_Id);
-- Build body for a renaming declaration, insert in tree and analyze.
+ procedure Check_Address_Clause (E : Entity_Id);
+ -- Apply legality checks to address clauses for object declarations,
+ -- at the point the object is frozen.
+
procedure Check_Strict_Alignment (E : Entity_Id);
-- E is a base type. If E is tagged or has a component that is aliased
-- or tagged or contains something this is aliased or tagged, set
@@ -153,6 +158,16 @@ package body Freeze is
-- needed -- see body for details). Never has any effect on T if the
-- Debug_Info_Off flag is set.
+ procedure Warn_Overlay
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Nam : Node_Id);
+ -- Expr is the expression for an address clause for entity Nam whose type
+ -- is Typ. If Typ has a default initialization, and there is no explicit
+ -- initialization in the source declaration, check whether the address
+ -- clause might cause overlaying of an entity, and emit a warning on the
+ -- side effect that the initialization will cause.
+
-------------------------------
-- Adjust_Esize_For_Alignment --
-------------------------------
@@ -196,8 +211,7 @@ package body Freeze is
function Build_Renamed_Body
(Decl : Node_Id;
- New_S : Entity_Id)
- return Node_Id
+ New_S : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (New_S);
-- We use for the source location of the renamed body, the location
@@ -232,7 +246,6 @@ package body Freeze is
Old_S := Etype (Nam);
elsif Nkind (Nam) = N_Indexed_Component then
-
if Is_Entity_Name (Prefix (Nam)) then
Old_S := Entity (Prefix (Nam));
else
@@ -412,6 +425,75 @@ package body Freeze is
return Body_Node;
end Build_Renamed_Body;
+ --------------------------
+ -- Check_Address_Clause --
+ --------------------------
+
+ procedure Check_Address_Clause (E : Entity_Id) is
+ Addr : constant Node_Id := Address_Clause (E);
+ Expr : Node_Id;
+ Decl : constant Node_Id := Declaration_Node (E);
+ Typ : constant Entity_Id := Etype (E);
+
+ begin
+ if Present (Addr) then
+ Expr := Expression (Addr);
+
+ -- If we have no initialization of any kind, then we don't
+ -- need to place any restrictions on the address clause, because
+ -- the object will be elaborated after the address clause is
+ -- evaluated. This happens if the declaration has no initial
+ -- expression, or the type has no implicit initialization, or
+ -- the object is imported.
+
+ -- The same holds for all initialized scalar types and all
+ -- access types. Packed bit arrays of size up to 64 are
+ -- represented using a modular type with an initialization
+ -- (to zero) and can be processed like other initialized
+ -- scalar types.
+
+ -- If the type is controlled, code to attach the object to a
+ -- finalization chain is generated at the point of declaration,
+ -- and therefore the elaboration of the object cannot be delayed:
+ -- the address expression must be a constant.
+
+ if (No (Expression (Decl))
+ and then not Controlled_Type (Typ)
+ and then
+ (not Has_Non_Null_Base_Init_Proc (Typ)
+ or else Is_Imported (E)))
+
+ or else
+ (Present (Expression (Decl))
+ and then Is_Scalar_Type (Typ))
+
+ or else
+ Is_Access_Type (Typ)
+
+ or else
+ (Is_Bit_Packed_Array (Typ)
+ and then
+ Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
+ then
+ null;
+
+ -- Otherwise, we require the address clause to be constant
+ -- because the call to the initialization procedure (or the
+ -- attach code) has to happen at the point of the declaration.
+
+ else
+ Check_Constant_Address_Clause (Expr, E);
+ Set_Has_Delayed_Freeze (E, False);
+ end if;
+
+ if not Error_Posted (Expr)
+ and then not Controlled_Type (Typ)
+ then
+ Warn_Overlay (Expr, Typ, Name (Addr));
+ end if;
+ end if;
+ end Check_Address_Clause;
+
-----------------------------
-- Check_Compile_Time_Size --
-----------------------------
@@ -429,7 +511,7 @@ package body Freeze is
function Static_Discriminated_Components (T : Entity_Id) return Boolean;
-- If T is a constrained subtype, its size is not known if any of its
-- discriminant constraints is not static and it is not a null record.
- -- The test is conservative and doesn't check that the components are
+ -- The test is conservative and doesn't check that the components are
-- in fact constrained by non-static discriminant values. Could be made
-- more precise ???
@@ -487,7 +569,6 @@ package body Freeze is
return not Is_Generic_Type (T);
elsif Is_Array_Type (T) then
-
if Ekind (T) = E_String_Literal_Subtype then
Set_Small_Size (Component_Size (T) * String_Literal_Length (T));
return True;
@@ -567,74 +648,179 @@ package body Freeze is
end if;
elsif Is_Record_Type (T) then
+
+ -- A class-wide type is never considered to have a known size
+
if Is_Class_Wide_Type (T) then
return False;
- elsif T /= Base_Type (T) then
- return Size_Known_At_Compile_Time (Base_Type (T))
- and then Static_Discriminated_Components (T);
+ -- A subtype of a variant record must not have non-static
+ -- discriminanted components.
+
+ elsif T /= Base_Type (T)
+ and then not Static_Discriminated_Components (T)
+ then
+ return False;
-- Don't do any recursion on type with error posted, since
-- we may have a malformed type that leads us into a loop
elsif Error_Posted (T) then
return False;
+ end if;
- else
- declare
- Packed_Size_Known : Boolean := Is_Packed (T);
- Packed_Size : Uint := Uint_0;
+ -- Now look at the components of the record
- begin
- -- Test for variant part present
-
- if Has_Discriminants (T)
- and then Present (Parent (T))
- and then Nkind (Parent (T)) = N_Full_Type_Declaration
- and then Nkind (Type_Definition (Parent (T))) =
- N_Record_Definition
- and then not Null_Present (Type_Definition (Parent (T)))
- and then Present (Variant_Part
- (Component_List (Type_Definition (Parent (T)))))
+ declare
+ -- The following two variables are used to keep track of
+ -- the size of packed records if we can tell the size of
+ -- the packed record in the front end. Packed_Size_Known
+ -- is True if so far we can figure out the size. It is
+ -- initialized to True for a packed record, unless the
+ -- record has discriminants. The reason we eliminate the
+ -- discriminated case is that we don't know the way the
+ -- back end lays out discriminated packed records. If
+ -- Packed_Size_Known is True, then Packed_Size is the
+ -- size in bits so far.
+
+ Packed_Size_Known : Boolean :=
+ Is_Packed (T)
+ and then not Has_Discriminants (T);
+
+ Packed_Size : Uint := Uint_0;
+
+ begin
+ -- Test for variant part present
+
+ if Has_Discriminants (T)
+ and then Present (Parent (T))
+ and then Nkind (Parent (T)) = N_Full_Type_Declaration
+ and then Nkind (Type_Definition (Parent (T))) =
+ N_Record_Definition
+ and then not Null_Present (Type_Definition (Parent (T)))
+ and then Present (Variant_Part
+ (Component_List (Type_Definition (Parent (T)))))
+ then
+ -- If variant part is present, and type is unconstrained,
+ -- then we must have defaulted discriminants, or a size
+ -- clause must be present for the type, or else the size
+ -- is definitely not known at compile time.
+
+ if not Is_Constrained (T)
+ and then
+ No (Discriminant_Default_Value
+ (First_Discriminant (T)))
+ and then Unknown_Esize (T)
then
- -- If variant part is present, and type is unconstrained,
- -- then we must have defaulted discriminants, or a size
- -- clause must be present for the type, or else the size
- -- is definitely not known at compile time.
-
- if not Is_Constrained (T)
- and then
- No (Discriminant_Default_Value
- (First_Discriminant (T)))
- and then Unknown_Esize (T)
- then
- return False;
- else
- -- We do not know the packed size, it is too much
- -- trouble to figure it out.
+ return False;
+ end if;
+ end if;
+ -- Loop through components
+
+ Comp := First_Entity (T);
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component
+ or else
+ Ekind (Comp) = E_Discriminant
+ then
+ Ctyp := Etype (Comp);
+
+ -- We do not know the packed size if there is a
+ -- component clause present (we possibly could,
+ -- but this would only help in the case of a record
+ -- with partial rep clauses. That's because in the
+ -- case of full rep clauses, the size gets figured
+ -- out anyway by a different circuit).
+
+ if Present (Component_Clause (Comp)) then
Packed_Size_Known := False;
end if;
- end if;
- Comp := First_Entity (T);
-
- while Present (Comp) loop
- if Ekind (Comp) = E_Component
- or else
- Ekind (Comp) = E_Discriminant
+ -- We need to identify a component that is an array
+ -- where the index type is an enumeration type with
+ -- non-standard representation, and some bound of the
+ -- type depends on a discriminant.
+
+ -- This is because gigi computes the size by doing a
+ -- substituation of the appropriate discriminant value
+ -- in the size expression for the base type, and gigi
+ -- is not clever enough to evaluate the resulting
+ -- expression (which involves a call to rep_to_pos)
+ -- at compile time.
+
+ -- It would be nice if gigi would either recognize that
+ -- this expression can be computed at compile time, or
+ -- alternatively figured out the size from the subtype
+ -- directly, where all the information is at hand ???
+
+ if Is_Array_Type (Etype (Comp))
+ and then Present (Packed_Array_Type (Etype (Comp)))
then
- Ctyp := Etype (Comp);
+ declare
+ Ocomp : constant Entity_Id :=
+ Original_Record_Component (Comp);
+ OCtyp : constant Entity_Id := Etype (Ocomp);
+ Ind : Node_Id;
+ Indtyp : Entity_Id;
+ Lo, Hi : Node_Id;
- if Present (Component_Clause (Comp)) then
- Packed_Size_Known := False;
- end if;
+ begin
+ Ind := First_Index (OCtyp);
+ while Present (Ind) loop
+ Indtyp := Etype (Ind);
+
+ if Is_Enumeration_Type (Indtyp)
+ and then Has_Non_Standard_Rep (Indtyp)
+ then
+ Lo := Type_Low_Bound (Indtyp);
+ Hi := Type_High_Bound (Indtyp);
+
+ if Is_Entity_Name (Lo)
+ and then
+ Ekind (Entity (Lo)) = E_Discriminant
+ then
+ return False;
+
+ elsif Is_Entity_Name (Hi)
+ and then
+ Ekind (Entity (Hi)) = E_Discriminant
+ then
+ return False;
+ end if;
+ end if;
+
+ Next_Index (Ind);
+ end loop;
+ end;
+ end if;
- if not Size_Known (Ctyp) then
- return False;
+ -- Clearly size of record is not known if the size of
+ -- one of the components is not known.
- elsif Packed_Size_Known then
+ if not Size_Known (Ctyp) then
+ return False;
+ end if;
+
+ -- Accumulate packed size if possible
+
+ if Packed_Size_Known then
+
+ -- We can only deal with elementary types, since for
+ -- non-elementary components, alignment enters into
+ -- the picture, and we don't know enough to handle
+ -- proper alignment in this context. Packed arrays
+ -- count as elementary if the representation is a
+ -- modular type.
+ if Is_Elementary_Type (Ctyp)
+ or else (Is_Array_Type (Ctyp)
+ and then
+ Present (Packed_Array_Type (Ctyp))
+ and then
+ Is_Modular_Integer_Type
+ (Packed_Array_Type (Ctyp)))
+ then
-- If RM_Size is known and static, then we can
-- keep accumulating the packed size.
@@ -645,10 +831,13 @@ package body Freeze is
if RM_Size (Ctyp) = Uint_0 then
Packed_Size_Known := False;
- end if;
- Packed_Size :=
- Packed_Size + RM_Size (Ctyp);
+ -- Normal case where we can keep accumulating
+ -- the packed array size.
+
+ else
+ Packed_Size := Packed_Size + RM_Size (Ctyp);
+ end if;
-- If we have a field whose RM_Size is not known
-- then we can't figure out the packed size here.
@@ -656,19 +845,25 @@ package body Freeze is
else
Packed_Size_Known := False;
end if;
+
+ -- If we have a non-elementary type we can't figure
+ -- out the packed array size (alignment issues).
+
+ else
+ Packed_Size_Known := False;
end if;
end if;
+ end if;
- Next_Entity (Comp);
- end loop;
+ Next_Entity (Comp);
+ end loop;
- if Packed_Size_Known then
- Set_Small_Size (Packed_Size);
- end if;
+ if Packed_Size_Known then
+ Set_Small_Size (Packed_Size);
+ end if;
- return True;
- end;
- end if;
+ return True;
+ end;
else
return False;
@@ -691,7 +886,6 @@ package body Freeze is
and then Present (First_Component (T))
then
Constraint := First_Elmt (Discriminant_Constraint (T));
-
while Present (Constraint) loop
if not Compile_Time_Known_Value (Node (Constraint)) then
return False;
@@ -752,7 +946,7 @@ package body Freeze is
while Present (Comp) loop
if not Is_Type (Comp)
and then (Strict_Alignment (Etype (Comp))
- or else Is_Aliased (Comp))
+ or else Is_Aliased (Comp))
then
Set_Strict_Alignment (E);
return;
@@ -838,12 +1032,51 @@ package body Freeze is
end if;
return;
-
end if;
end if;
end loop;
end Check_Unsigned_Type;
+ -----------------------------
+ -- Expand_Atomic_Aggregate --
+ -----------------------------
+
+ procedure Expand_Atomic_Aggregate (E : Entity_Id; Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (E);
+ New_N : Node_Id;
+ Temp : Entity_Id;
+
+ begin
+ if (Nkind (Parent (E)) = N_Object_Declaration
+ or else Nkind (Parent (E)) = N_Assignment_Statement)
+ and then Comes_From_Source (Parent (E))
+ and then Nkind (E) = N_Aggregate
+ then
+ Temp :=
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('T'));
+
+ New_N :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_definition => New_Occurrence_Of (Typ, Loc),
+ Expression => Relocate_Node (E));
+ Insert_Before (Parent (E), New_N);
+ Analyze (New_N);
+
+ Set_Expression (Parent (E), New_Occurrence_Of (Temp, Loc));
+
+ -- To prevent the temporary from being constant-folded (which
+ -- would lead to the same piecemeal assignment on the original
+ -- target) indicate to the back-end that the temporary is a
+ -- variable with real storage. See description of this flag
+ -- in Einfo, and the notes on N_Assignment_Statement and
+ -- N_Object_Declaration in Sinfo.
+
+ Set_Is_True_Constant (Temp, False);
+ end if;
+ end Expand_Atomic_Aggregate;
+
----------------
-- Freeze_All --
----------------
@@ -866,6 +1099,10 @@ package body Freeze is
-- should not be recursive, we don't want to analyze those till
-- we are sure that ALL the types are frozen).
+ --------------------
+ -- Freeze_All_Ent --
+ --------------------
+
procedure Freeze_All_Ent
(From : Entity_Id;
After : in out Node_Id)
@@ -878,6 +1115,10 @@ package body Freeze is
-- If freeze nodes are present, insert and analyze, and reset
-- cursor for next insertion.
+ -------------------
+ -- Process_Flist --
+ -------------------
+
procedure Process_Flist is
begin
if Is_Non_Empty_List (Flist) then
@@ -892,6 +1133,8 @@ package body Freeze is
end if;
end Process_Flist;
+ -- Start or processing for Freeze_All_Ent
+
begin
E := From;
while Present (E) loop
@@ -920,7 +1163,7 @@ package body Freeze is
elsif Ekind (E) in Task_Kind
and then
(Nkind (Parent (E)) = N_Task_Type_Declaration
- or else
+ or else
Nkind (Parent (E)) = N_Single_Task_Declaration)
then
New_Scope (E);
@@ -940,8 +1183,9 @@ package body Freeze is
declare
Prim_List : constant Elist_Id :=
Primitive_Operations (Etype (E));
- Prim : Elmt_Id;
- Subp : Entity_Id;
+
+ Prim : Elmt_Id;
+ Subp : Entity_Id;
begin
Prim := First_Elmt (Prim_List);
@@ -966,6 +1210,38 @@ package body Freeze is
Process_Flist;
end if;
+ -- If an incomplete type is still not frozen, this may be
+ -- a premature freezing because of a body declaration that
+ -- follows. Indicate where the freezing took place.
+
+ -- If the freezing is caused by the end of the current
+ -- declarative part, it is a Taft Amendment type, and there
+ -- is no error.
+
+ if not Is_Frozen (E)
+ and then Ekind (E) = E_Incomplete_Type
+ then
+ declare
+ Bod : constant Node_Id := Next (After);
+
+ begin
+ if (Nkind (Bod) = N_Subprogram_Body
+ or else Nkind (Bod) = N_Entry_Body
+ or else Nkind (Bod) = N_Package_Body
+ or else Nkind (Bod) = N_Protected_Body
+ or else Nkind (Bod) = N_Task_Body
+ or else Nkind (Bod) in N_Body_Stub)
+ and then
+ List_Containing (After) = List_Containing (Parent (E))
+ then
+ Error_Msg_Sloc := Sloc (Next (After));
+ Error_Msg_NE
+ ("type& is frozen# before its full declaration",
+ Parent (E), E);
+ end if;
+ end;
+ end if;
+
Next_Entity (E);
end loop;
end Freeze_All_Ent;
@@ -979,6 +1255,7 @@ package body Freeze is
-- that require us to build a default expression functions. This is the
-- point at which such functions are constructed (after all types that
-- might be used in such expressions have been frozen).
+
-- We also add finalization chains to access types whose designated
-- types are controlled. This is normally done when freezing the type,
-- but this misses recursive type definitions where the later members
@@ -988,7 +1265,6 @@ package body Freeze is
E := From;
while Present (E) loop
-
if Is_Subprogram (E) then
if not Default_Expressions_Processed (E) then
@@ -1005,7 +1281,7 @@ package body Freeze is
and then Present (Corresponding_Body (Decl))
and then
Nkind (Unit_Declaration_Node (Corresponding_Body (Decl)))
- = N_Subprogram_Renaming_Declaration
+ = N_Subprogram_Renaming_Declaration
then
Build_And_Analyze_Renamed_Body
(Decl, Corresponding_Body (Decl), After);
@@ -1015,12 +1291,11 @@ package body Freeze is
elsif Ekind (E) in Task_Kind
and then
(Nkind (Parent (E)) = N_Task_Type_Declaration
- or else
+ or else
Nkind (Parent (E)) = N_Single_Task_Declaration)
then
declare
Ent : Entity_Id;
-
begin
Ent := First_Entity (E);
@@ -1047,7 +1322,6 @@ package body Freeze is
Next_Entity (E);
end loop;
-
end Freeze_All;
-----------------------
@@ -1077,15 +1351,10 @@ package body Freeze is
procedure Freeze_Before (N : Node_Id; T : Entity_Id) is
Freeze_Nodes : constant List_Id := Freeze_Entity (T, Sloc (N));
- F : Node_Id;
begin
if Is_Non_Empty_List (Freeze_Nodes) then
- F := First (Freeze_Nodes);
-
- if Present (F) then
- Insert_Actions (N, Freeze_Nodes);
- end if;
+ Insert_Actions (N, Freeze_Nodes);
end if;
end Freeze_Before;
@@ -1119,7 +1388,7 @@ package body Freeze is
----------------------------
function After_Last_Declaration return Boolean is
- Spec : Node_Id := Parent (Current_Scope);
+ Spec : constant Node_Id := Parent (Current_Scope);
begin
if Nkind (Spec) = N_Package_Specification then
@@ -1146,6 +1415,10 @@ package body Freeze is
function Process (N : Node_Id) return Traverse_Result;
-- Process routine to apply check to given node.
+ -------------
+ -- Process --
+ -------------
+
function Process (N : Node_Id) return Traverse_Result is
begin
case Nkind (N) is
@@ -1182,6 +1455,7 @@ package body Freeze is
procedure Freeze_Record_Type (Rec : Entity_Id) is
Comp : Entity_Id;
+ IR : Node_Id;
Junk : Boolean;
ADC : Node_Id;
@@ -1194,12 +1468,39 @@ package body Freeze is
-- clause (used to warn about useless Bit_Order pragmas).
begin
+ -- If this is a subtype of a controlled type, declared without
+ -- a constraint, the _controller may not appear in the component
+ -- list if the parent was not frozen at the point of subtype
+ -- declaration. Inherit the _controller component now.
+
+ if Rec /= Base_Type (Rec)
+ and then Has_Controlled_Component (Rec)
+ then
+ if Nkind (Parent (Rec)) = N_Subtype_Declaration
+ and then Is_Entity_Name (Subtype_Indication (Parent (Rec)))
+ then
+ Set_First_Entity (Rec, First_Entity (Base_Type (Rec)));
+
+ -- If this is an internal type without a declaration, as for
+ -- a record component, the base type may not yet be frozen,
+ -- and its controller has not been created. Add an explicit
+ -- freeze node for the itype, so it will be frozen after the
+ -- base type.
+
+ elsif Is_Itype (Rec)
+ and then Has_Delayed_Freeze (Base_Type (Rec))
+ and then
+ Nkind (Associated_Node_For_Itype (Rec)) =
+ N_Component_Declaration
+ then
+ Ensure_Freeze_Node (Rec);
+ end if;
+ end if;
+
-- Freeze components and embedded subtypes
Comp := First_Entity (Rec);
-
while Present (Comp) loop
-
if not Is_Type (Comp) then
Freeze_And_Append (Etype (Comp), Loc, Result);
end if;
@@ -1230,7 +1531,6 @@ package body Freeze is
-- case freeze the subtype mark.
if Is_Class_Wide_Type (Designated_Type (Etype (Comp))) then
-
if Is_Entity_Name (Expression (Alloc)) then
Freeze_And_Append
(Entity (Expression (Alloc)), Loc, Result);
@@ -1241,6 +1541,7 @@ package body Freeze is
(Entity (Subtype_Mark (Expression (Alloc))),
Loc, Result);
end if;
+
else
Freeze_And_Append
(Designated_Type (Etype (Comp)), Loc, Result);
@@ -1258,6 +1559,24 @@ package body Freeze is
then
Set_Is_Frozen (Designated_Type (Etype (Comp)));
+ -- In addition, add an Itype_Reference to ensure that the
+ -- access subtype is elaborated early enough. This cannot
+ -- be done if the subtype may depend on discriminants.
+
+ if Ekind (Comp) = E_Component
+ and then Is_Itype (Etype (Comp))
+ and then not Has_Discriminants (Rec)
+ then
+ IR := Make_Itype_Reference (Sloc (Comp));
+ Set_Itype (IR, Designated_Type (Etype (Comp)));
+
+ if No (Result) then
+ Result := New_List (IR);
+ else
+ Append (IR, Result);
+ end if;
+ end if;
+
elsif Is_Array_Type (Etype (Comp))
and then Is_Access_Type (Component_Type (Etype (Comp)))
and then Present (Parent (Comp))
@@ -1441,22 +1760,20 @@ package body Freeze is
-- If this is the record corresponding to a remote type,
-- freeze the remote type here since that is what we are
- -- semantically freeing. This prevents having the freeze node
- -- for that type in an inner scope.
+ -- semantically freezing. This prevents having the freeze
+ -- node for that type in an inner scope.
-- Also, Check for controlled components and unchecked unions.
-- Finally, enforce the restriction that access attributes with
-- a current instance prefix can only apply to limited types.
if Ekind (Rec) = E_Record_Type then
-
if Present (Corresponding_Remote_Type (Rec)) then
Freeze_And_Append
(Corresponding_Remote_Type (Rec), Loc, Result);
end if;
Comp := First_Component (Rec);
-
while Present (Comp) loop
if Has_Controlled_Component (Etype (Comp))
or else (Chars (Comp) /= Name_uParent
@@ -1518,7 +1835,7 @@ package body Freeze is
-- Start of processing for Freeze_Entity
begin
- -- Do not freeze if already frozen since we only need one freeze node.
+ -- Do not freeze if already frozen since we only need one freeze node
if Is_Frozen (E) then
return No_List;
@@ -1588,18 +1905,50 @@ package body Freeze is
then
Set_Encoded_Interface_Name
(E, Get_Default_External_Name (E));
+
+ -- Special processing for atomic objects appearing in object decls
+
+ elsif Is_Atomic (E)
+ and then Nkind (Parent (E)) = N_Object_Declaration
+ and then Present (Expression (Parent (E)))
+ then
+ declare
+ Expr : constant Node_Id := Expression (Parent (E));
+
+ begin
+ -- If expression is an aggregate, assign to a temporary to
+ -- ensure that the actual assignment is done atomically rather
+ -- than component-wise (the assignment to the temp may be done
+ -- component-wise, but that is harmless.
+
+ if Nkind (Expr) = N_Aggregate then
+ Expand_Atomic_Aggregate (Expr, Etype (E));
+
+ -- If the expression is a reference to a record or array
+ -- object entity, then reset Is_True_Constant to False so
+ -- that the compiler will not optimize away the intermediate
+ -- object, which we need in this case for the same reason
+ -- (to ensure that the actual assignment is atomic, rather
+ -- than component-wise).
+
+ elsif Is_Entity_Name (Expr)
+ and then (Is_Record_Type (Etype (Expr))
+ or else
+ Is_Array_Type (Etype (Expr)))
+ then
+ Set_Is_True_Constant (Entity (Expr), False);
+ end if;
+ end;
end if;
-- For a subprogram, freeze all parameter types and also the return
- -- type (RM 13.14(13)). However skip this for internal subprograms.
+ -- type (RM 13.14(14)). However skip this for internal subprograms.
-- This is also the point where any extra formal parameters are
-- created since we now know whether the subprogram will use
-- a foreign convention.
if Is_Subprogram (E) then
-
if not Is_Internal (E) then
-
declare
F_Type : Entity_Id;
@@ -1627,7 +1976,6 @@ package body Freeze is
Formal := First_Formal (E);
while Present (Formal) loop
-
F_Type := Etype (Formal);
Freeze_And_Append (F_Type, Loc, Result);
@@ -1643,6 +1991,7 @@ package body Freeze is
-- an artifact of our need to regard the end of an
-- instantiation as a freeze point. Otherwise it is
-- a definite error.
+
-- and then not Is_Wrapper_Package (Current_Scope) ???
if In_Instance then
@@ -1659,7 +2008,9 @@ package body Freeze is
-- Check bad use of fat C pointer
- if Is_Fat_C_Ptr_Type (F_Type) then
+ if Warn_On_Export_Import and then
+ Is_Fat_C_Ptr_Type (F_Type)
+ then
Error_Msg_Qual_Level := 1;
Error_Msg_N
("?type of & does not correspond to C pointer",
@@ -1674,6 +2025,7 @@ package body Freeze is
and then not Is_Imported (E)
and then Is_Array_Type (F_Type)
and then not Is_Constrained (F_Type)
+ and then Warn_On_Export_Import
then
Error_Msg_Qual_Level := 1;
Error_Msg_N
@@ -1693,7 +2045,9 @@ package body Freeze is
if Ekind (E) = E_Function then
Freeze_And_Append (Etype (E), Loc, Result);
- if Is_Fat_C_Ptr_Type (Etype (E)) then
+ if Warn_On_Export_Import
+ and then Is_Fat_C_Ptr_Type (Etype (E))
+ then
Error_Msg_N
("?return type of& does not correspond to C pointer",
E);
@@ -1702,9 +2056,10 @@ package body Freeze is
and then not Is_Constrained (Etype (E))
and then not Is_Imported (E)
and then Convention (E) in Foreign_Convention
+ and then Warn_On_Export_Import
then
Error_Msg_N
- ("foreign convention function may not " &
+ ("?foreign convention function& should not " &
"return unconstrained array", E);
end if;
end if;
@@ -1751,6 +2106,7 @@ package body Freeze is
if Nkind (Declaration_Node (E)) = N_Object_Declaration then
Validate_Object_Declaration (Declaration_Node (E));
+ Check_Address_Clause (E);
end if;
-- Check that a constant which has a pragma Volatile[_Components]
@@ -1829,13 +2185,13 @@ package body Freeze is
Freeze_And_Append (Atype, Loc, Result);
-- Otherwise freeze the base type of the entity before
- -- freezing the entity itself, (RM 13.14(14)).
+ -- freezing the entity itself, (RM 13.14(15)).
elsif E /= Base_Type (E) then
Freeze_And_Append (Base_Type (E), Loc, Result);
end if;
- -- For a derived type, freeze its parent type first (RM 13.14(14))
+ -- For a derived type, freeze its parent type first (RM 13.14(15))
elsif Is_Derived_Type (E) then
Freeze_And_Append (Etype (E), Loc, Result);
@@ -1843,11 +2199,12 @@ package body Freeze is
end if;
-- For array type, freeze index types and component type first
- -- before freezing the array (RM 13.14(14)).
+ -- before freezing the array (RM 13.14(15)).
if Is_Array_Type (E) then
declare
- Ctyp : constant Entity_Id := Component_Type (E);
+ Ctyp : constant Entity_Id := Component_Type (E);
+ Pnod : Node_Id;
Non_Standard_Enum : Boolean := False;
-- Set true if any of the index types is an enumeration
@@ -1949,6 +2306,33 @@ package body Freeze is
Set_Component_Size (Base_Type (E), Csiz);
+ -- Check for base type of 8,16,32 bits, where the
+ -- subtype has a length one less than the base type
+ -- and is unsigned (e.g. Natural subtype of Integer)
+
+ -- In such cases, if a component size was not set
+ -- explicitly, then generate a warning.
+
+ if Has_Pragma_Pack (E)
+ and then not Has_Component_Size_Clause (E)
+ and then
+ (Csiz = 7 or else Csiz = 15 or else Csiz = 31)
+ and then Esize (Base_Type (Ctyp)) = Csiz + 1
+ then
+ Error_Msg_Uint_1 := Csiz;
+ Pnod :=
+ Get_Rep_Pragma (First_Subtype (E), Name_Pack);
+
+ if Present (Pnod) then
+ Error_Msg_N
+ ("pragma Pack causes component size to be ^?",
+ Pnod);
+ Error_Msg_N
+ ("\use Component_Size to set desired value",
+ Pnod);
+ end if;
+ end if;
+
-- Actual packing is not needed for 8,16,32,64
-- Also not needed for 24 if alignment is 1
@@ -2000,18 +2384,19 @@ package body Freeze is
-- we can give a better error message in those cases that
-- we do catch with the circuitry here.
- if Present (Size_Clause (E))
- and then Known_Static_Esize (E)
- and then not Has_Pragma_Pack (E)
- and then Number_Dimensions (E) = 1
- and then not Has_Component_Size_Clause (E)
- and then Known_Static_Component_Size (E)
- then
- declare
- Lo, Hi : Node_Id;
- Ctyp : constant Entity_Id := Component_Type (E);
+ declare
+ Lo, Hi : Node_Id;
+ Ctyp : constant Entity_Id := Component_Type (E);
- begin
+ begin
+ if Present (Size_Clause (E))
+ and then Known_Static_Esize (E)
+ and then not Is_Bit_Packed_Array (E)
+ and then not Has_Pragma_Pack (E)
+ and then Number_Dimensions (E) = 1
+ and then not Has_Component_Size_Clause (E)
+ and then Known_Static_Esize (Ctyp)
+ then
Get_Index_Bounds (First_Index (E), Lo, Hi);
if Compile_Time_Known_Value (Lo)
@@ -2020,14 +2405,22 @@ package body Freeze is
and then RM_Size (Ctyp) < 64
then
declare
- Lov : constant Uint := Expr_Value (Lo);
- Hiv : constant Uint := Expr_Value (Hi);
- Len : constant Uint :=
- UI_Max (Uint_0, Hiv - Lov + 1);
+ Lov : constant Uint := Expr_Value (Lo);
+ Hiv : constant Uint := Expr_Value (Hi);
+ Len : constant Uint :=
+ UI_Max (Uint_0, Hiv - Lov + 1);
+ Rsiz : constant Uint := RM_Size (Ctyp);
+
+ -- What we are looking for here is the situation
+ -- where the Esize given would be exactly right
+ -- if there was a pragma Pack (resulting in the
+ -- component size being the same as the RM_Size).
+ -- Furthermore, the component type size must be
+ -- an odd size (not a multiple of storage unit)
begin
- if Esize (E) < Len * Component_Size (E)
- and then Esize (E) = Len * RM_Size (Ctyp)
+ if Esize (E) = Len * Rsiz
+ and then Rsiz mod System_Storage_Unit /= 0
then
Error_Msg_NE
("size given for& too small",
@@ -2038,8 +2431,8 @@ package body Freeze is
end if;
end;
end if;
- end;
- end if;
+ end if;
+ end;
-- If any of the index types was an enumeration type with
-- a non-standard rep clause, then we indicate that the
@@ -2071,8 +2464,8 @@ package body Freeze is
Set_RM_Size (E, RM_Size (Packed_Array_Type (E)));
end if;
- -- For a class wide type, the corresponding specific type is
- -- frozen as well (RM 13.14(14))
+ -- For a class-wide type, the corresponding specific type is
+ -- frozen as well (RM 13.14(15))
elsif Is_Class_Wide_Type (E) then
Freeze_And_Append (Root_Type (E), Loc, Result);
@@ -2086,9 +2479,8 @@ package body Freeze is
if Is_Itype (E)
and then Is_Compilation_Unit (Scope (E))
then
-
declare
- Ref : Node_Id := Make_Itype_Reference (Loc);
+ Ref : constant Node_Id := Make_Itype_Reference (Loc);
begin
Set_Itype (Ref, E);
@@ -2100,8 +2492,20 @@ package body Freeze is
end;
end if;
- -- For record (sub)type, freeze all the component types (RM
- -- 13.14(14). We test for E_Record_(sub)Type here, rather than
+ -- The equivalent type associated with a class-wide subtype
+ -- needs to be frozen to ensure that its layout is done.
+ -- Class-wide subtypes are currently only frozen on targets
+ -- requiring front-end layout (see New_Class_Wide_Subtype
+ -- and Make_CW_Equivalent_Type in exp_util.adb).
+
+ if Ekind (E) = E_Class_Wide_Subtype
+ and then Present (Equivalent_Type (E))
+ then
+ Freeze_And_Append (Equivalent_Type (E), Loc, Result);
+ end if;
+
+ -- For a record (sub)type, freeze all the component types (RM
+ -- 13.14(15). We test for E_Record_(sub)Type here, rather than
-- using Is_Record_Type, because we don't want to attempt the
-- freeze for the case of a private type with record extension
-- (we will do that later when the full type is frozen).
@@ -2146,7 +2550,7 @@ package body Freeze is
-- end of a scope (or within the scope of the private type),
-- the partial and full views will have been swapped, the
-- full view appears first in the entity chain and the swapping
- -- mechanism enusres that the pointers are properly set (on
+ -- mechanism ensures that the pointers are properly set (on
-- scope exit).
-- If we encounter the partial view before the full view
@@ -2172,31 +2576,39 @@ package body Freeze is
Check_Debug_Info_Needed (E);
-- Otherwise freeze full view and patch the pointers
+ -- so that the freeze node will elaborate both views
+ -- in the back-end.
else
- if Is_Private_Type (Full_View (E))
- and then Present (Underlying_Full_View (Full_View (E)))
- then
- Freeze_And_Append
- (Underlying_Full_View (Full_View (E)), Loc, Result);
- end if;
+ declare
+ Full : constant Entity_Id := Full_View (E);
- Freeze_And_Append (Full_View (E), Loc, Result);
+ begin
+ if Is_Private_Type (Full)
+ and then Present (Underlying_Full_View (Full))
+ then
+ Freeze_And_Append
+ (Underlying_Full_View (Full), Loc, Result);
+ end if;
- if Has_Delayed_Freeze (E) then
- F_Node := Freeze_Node (Full_View (E));
+ Freeze_And_Append (Full, Loc, Result);
- if Present (F_Node) then
- Set_Freeze_Node (E, F_Node);
- Set_Entity (F_Node, E);
- else
- -- {Incomplete,Private}_Subtypes
- -- with Full_Views constrained by discriminants
+ if Has_Delayed_Freeze (E) then
+ F_Node := Freeze_Node (Full);
- Set_Has_Delayed_Freeze (E, False);
- Set_Freeze_Node (E, Empty);
+ if Present (F_Node) then
+ Set_Freeze_Node (E, F_Node);
+ Set_Entity (F_Node, E);
+
+ else
+ -- {Incomplete,Private}_Subtypes
+ -- with Full_Views constrained by discriminants
+
+ Set_Has_Delayed_Freeze (E, False);
+ Set_Freeze_Node (E, Empty);
+ end if;
end if;
- end if;
+ end;
Check_Debug_Info_Needed (E);
end if;
@@ -2290,6 +2702,37 @@ package body Freeze is
if Is_Fixed_Point_Type (E) then
Freeze_Fixed_Point_Type (E);
+ -- Some error checks required for ordinary fixed-point type.
+ -- Defer these till the freeze-point since we need the small
+ -- and range values. We only do these checks for base types
+
+ if Is_Ordinary_Fixed_Point_Type (E)
+ and then E = Base_Type (E)
+ then
+ if Small_Value (E) < Ureal_2_M_80 then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` is too small, minimum is 2.0'*'*(-80)", E);
+
+ elsif Small_Value (E) > Ureal_2_80 then
+ Error_Msg_Name_1 := Name_Small;
+ Error_Msg_N
+ ("`&''%` is too large, maximum is 2.0'*'*80", E);
+ end if;
+
+ if Expr_Value_R (Type_Low_Bound (E)) < Ureal_M_10_36 then
+ Error_Msg_Name_1 := Name_First;
+ Error_Msg_N
+ ("`&''%` is too small, minimum is -10.0'*'*36", E);
+ end if;
+
+ if Expr_Value_R (Type_High_Bound (E)) > Ureal_10_36 then
+ Error_Msg_Name_1 := Name_Last;
+ Error_Msg_N
+ ("`&''%` is too large, maximum is 10.0'*'*36", E);
+ end if;
+ end if;
+
elsif Is_Enumeration_Type (E) then
Freeze_Enumeration_Type (E);
@@ -2309,7 +2752,6 @@ package body Freeze is
if Is_Composite_Type (E) then
if Is_Array_Type (E) then
-
declare
Index : Node_Id := First_Index (E);
Expr1 : Node_Id;
@@ -2347,9 +2789,7 @@ package body Freeze is
begin
Constraint := First_Elmt (Discriminant_Constraint (E));
-
while Present (Constraint) loop
-
Expr := Node (Constraint);
if Nkind (Expr) = N_Identifier
and then Ekind (Entity (Expr)) = E_Discriminant
@@ -2363,7 +2803,6 @@ package body Freeze is
Next_Elmt (Constraint);
end loop;
end;
-
end if;
-- AI-117 requires that all new primitives of a tagged type
@@ -2386,7 +2825,6 @@ package body Freeze is
declare
Prim_List : constant Elist_Id := Primitive_Operations (E);
Prim : Elmt_Id;
-
begin
Prim := First_Elmt (Prim_List);
while Present (Prim) loop
@@ -2512,7 +2950,6 @@ package body Freeze is
else
Append (F_Node, Result);
end if;
-
end if;
-- When a type is frozen, the first subtype of the type is frozen as
@@ -2565,7 +3002,6 @@ package body Freeze is
Generate_Subprogram_Descriptor_For_Imported_Subprogram
(E, Result);
end if;
-
end if;
return Result;
@@ -2582,7 +3018,6 @@ package body Freeze is
and then Esize (Typ) < Standard_Integer_Size
then
Init_Esize (Typ, Standard_Integer_Size);
-
else
Adjust_Esize_For_Alignment (Typ);
end if;
@@ -2614,6 +3049,10 @@ package body Freeze is
-- subprogram (init proc, or stream subprogram). If so, it returns
-- True, otherwise False.
+ -----------------
+ -- In_Exp_Body --
+ -----------------
+
function In_Exp_Body (N : Node_Id) return Boolean is
P : Node_Id;
@@ -2631,18 +3070,17 @@ package body Freeze is
P := Defining_Unit_Name (Specification (P));
if Nkind (P) = N_Defining_Identifier
- and then (Chars (P) = Name_uInit_Proc or else
- Chars (P) = Name_uInput or else
- Chars (P) = Name_uOutput or else
- Chars (P) = Name_uRead or else
- Chars (P) = Name_uWrite)
+ and then (Is_Init_Proc (P) or else
+ Is_TSS (P, TSS_Stream_Input) or else
+ Is_TSS (P, TSS_Stream_Output) or else
+ Is_TSS (P, TSS_Stream_Read) or else
+ Is_TSS (P, TSS_Stream_Write))
then
return True;
else
return False;
end if;
end if;
-
end In_Exp_Body;
-- Start of processing for Freeze_Expression
@@ -2672,12 +3110,18 @@ package body Freeze is
-- Freeze type of expression if not frozen already
- if Nkind (N) in N_Has_Etype
- and then not Is_Frozen (Etype (N))
- then
- Typ := Etype (N);
- else
- Typ := Empty;
+ Typ := Empty;
+
+ if Nkind (N) in N_Has_Etype then
+ if not Is_Frozen (Etype (N)) then
+ Typ := Etype (N);
+
+ -- Base type may be an derived numeric type that is frozen at
+ -- the point of declaration, but first_subtype is still unfrozen.
+
+ elsif not Is_Frozen (First_Subtype (Etype (N))) then
+ Typ := First_Subtype (Etype (N));
+ end if;
end if;
-- For entity name, freeze entity if not frozen already. A special
@@ -2695,7 +3139,6 @@ package body Freeze is
or else not Comes_From_Source (Entity (N)))
then
Nam := Entity (N);
-
else
Nam := Empty;
end if;
@@ -2709,8 +3152,8 @@ package body Freeze is
-- expression cannot contain an allocator, so the type is not frozen.
Desig_Typ := Empty;
- case Nkind (N) is
+ case Nkind (N) is
when N_Allocator =>
Desig_Typ := Designated_Type (Etype (N));
@@ -2731,7 +3174,6 @@ package body Freeze is
when others =>
null;
-
end case;
if Desig_Typ /= Empty
@@ -2813,7 +3255,7 @@ package body Freeze is
-- If we have an enumeration literal that appears as the
-- choice in the aggregate of an enumeration representation
- -- clause, then freezing does not occur (RM 13.14(9)).
+ -- clause, then freezing does not occur (RM 13.14(10)).
when N_Enumeration_Representation_Clause =>
@@ -3002,7 +3444,6 @@ package body Freeze is
end if;
if Is_Non_Empty_List (Freeze_Nodes) then
-
if No (Scope_Stack.Table
(Scope_Stack.Last).Pending_Freeze_Actions)
then
@@ -3031,20 +3472,20 @@ package body Freeze is
In_Default_Expression := False;
- -- Freeze the designated type of an allocator (RM 13.14(12))
+ -- Freeze the designated type of an allocator (RM 13.14(13))
if Present (Desig_Typ) then
Freeze_Before (P, Desig_Typ);
end if;
- -- Freeze type of expression (RM 13.14(9)). Note that we took care of
+ -- Freeze type of expression (RM 13.14(10)). Note that we took care of
-- the enumeration representation clause exception in the loop above.
if Present (Typ) then
Freeze_Before (P, Typ);
end if;
- -- Freeze name if one is present (RM 13.14(10))
+ -- Freeze name if one is present (RM 13.14(11))
if Present (Nam) then
Freeze_Before (P, Nam);
@@ -3102,9 +3543,9 @@ package body Freeze is
Atype := Ancestor_Subtype (Typ);
if Present (Atype) then
- Set_Size_Info (Typ, Atype);
+ Set_Esize (Typ, Esize (Atype));
else
- Set_Size_Info (Typ, Base_Type (Typ));
+ Set_Esize (Typ, Esize (Base_Type (Typ)));
end if;
end if;
@@ -3462,9 +3903,11 @@ package body Freeze is
Set_Etype (Rng, Etype (Lo));
- -- Set Esize to calculated size and also set RM_Size
+ -- Set Esize to calculated size if not set already
- Init_Esize (Typ, Actual_Size);
+ if Unknown_Esize (Typ) then
+ Init_Esize (Typ, Actual_Size);
+ end if;
-- Set RM_Size if not already set. If already set, check value
@@ -3485,7 +3928,6 @@ package body Freeze is
Set_RM_Size (Typ, Minsiz);
end if;
end;
-
end Freeze_Fixed_Point_Type;
------------------
@@ -3652,6 +4094,14 @@ package body Freeze is
begin
Ensure_Type_Is_SA (Etype (E));
+ -- Reset True_Constant flag, since something strange is going on
+ -- with the scoping here, and our simple value traceing may not
+ -- be sufficient for this indication to be reliable. We kill the
+ -- Constant_Value indication for the same reason.
+
+ Set_Is_True_Constant (E, False);
+ Set_Current_Value (E, Empty);
+
exception
when Cannot_Be_Static =>
@@ -3706,6 +4156,7 @@ package body Freeze is
if Ekind (E) = E_Procedure
and then Is_Valued_Procedure (E)
and then Convention (E) = Convention_Ada
+ and then Warn_On_Export_Import
then
Error_Msg_N
("?Valued_Procedure has no effect for convention Ada", E);
@@ -3717,7 +4168,7 @@ package body Freeze is
else
Set_Mechanisms (E);
- -- For foreign conventions, do not permit return of an
+ -- For foreign conventions, warn about return of an
-- unconstrained array.
-- Note: we *do* allow a return by descriptor for the VMS case,
@@ -3742,10 +4193,11 @@ package body Freeze is
elsif Is_Array_Type (Retype)
and then not Is_Constrained (Retype)
and then Mechanism (E) not in Descriptor_Codes
+ and then Warn_On_Export_Import
then
- Error_Msg_NE
- ("convention for& does not permit returning " &
- "unconstrained array type", E, E);
+ Error_Msg_N
+ ("?foreign convention function& should not return " &
+ "unconstrained array", E);
return;
end if;
end if;
@@ -3757,7 +4209,9 @@ package body Freeze is
if Is_Exported (E) then
F := First_Formal (E);
while Present (F) loop
- if Present (Default_Value (F)) then
+ if Warn_On_Export_Import
+ and then Present (Default_Value (F))
+ then
Error_Msg_N
("?parameter cannot be defaulted in non-Ada call",
Default_Value (F));
@@ -3786,7 +4240,6 @@ package body Freeze is
end loop;
end if;
end if;
-
end Freeze_Subprogram;
-----------------------
@@ -3862,7 +4315,6 @@ package body Freeze is
or else (Nkind (Dcopy) = N_Attribute_Reference
and then
Attribute_Name (Dcopy) = Name_Null_Parameter)
-
then
-- If there is no default function, we must still do a full
@@ -3884,7 +4336,7 @@ package body Freeze is
-- context is generic, to avoid anomalies with private types.
if Ekind (Scope (E)) = E_Generic_Package then
- Resolve (Dcopy, Etype (Dcopy));
+ Resolve (Dcopy);
else
Resolve (Dcopy, Etype (Formal));
end if;
@@ -4035,7 +4487,134 @@ package body Freeze is
Set_Debug_Info_Needed (Corresponding_Record_Type (T));
end if;
end if;
-
end Set_Debug_Info_Needed;
+ ------------------
+ -- Warn_Overlay --
+ ------------------
+
+ procedure Warn_Overlay
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Nam : Entity_Id)
+ is
+ Ent : constant Entity_Id := Entity (Nam);
+ -- The object to which the address clause applies.
+
+ Init : Node_Id;
+ Old : Entity_Id := Empty;
+ Decl : Node_Id;
+
+ begin
+ -- No warning if address clause overlay warnings are off
+
+ if not Address_Clause_Overlay_Warnings then
+ return;
+ end if;
+
+ -- No warning if there is an explicit initialization
+
+ Init := Original_Node (Expression (Declaration_Node (Ent)));
+
+ if Present (Init) and then Comes_From_Source (Init) then
+ return;
+ end if;
+
+ -- We only give the warning for non-imported entities of a type
+ -- for which a non-null base init proc is defined (or for access
+ -- types which have implicit null initialization).
+
+ if Present (Expr)
+ and then (Has_Non_Null_Base_Init_Proc (Typ)
+ or else Is_Access_Type (Typ))
+ and then not Is_Imported (Ent)
+ then
+ if Nkind (Expr) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (Expr))
+ then
+ Old := Entity (Prefix (Expr));
+
+ elsif Is_Entity_Name (Expr)
+ and then Ekind (Entity (Expr)) = E_Constant
+ then
+ Decl := Declaration_Node (Entity (Expr));
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Present (Expression (Decl))
+ and then Nkind (Expression (Decl)) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (Expression (Decl)))
+ then
+ Old := Entity (Prefix (Expression (Decl)));
+
+ elsif Nkind (Expr) = N_Function_Call then
+ return;
+ end if;
+
+ -- A function call (most likely to To_Address) is probably not
+ -- an overlay, so skip warning. Ditto if the function call was
+ -- inlined and transformed into an entity.
+
+ elsif Nkind (Original_Node (Expr)) = N_Function_Call then
+ return;
+ end if;
+
+ Decl := Next (Parent (Expr));
+
+ -- If a pragma Import follows, we assume that it is for the current
+ -- target of the address clause, and skip the warning.
+
+ if Present (Decl)
+ and then Nkind (Decl) = N_Pragma
+ and then Chars (Decl) = Name_Import
+ then
+ return;
+ end if;
+
+ if Present (Old) then
+ Error_Msg_Node_2 := Old;
+ Error_Msg_N
+ ("default initialization of & may modify &?",
+ Nam);
+ else
+ Error_Msg_N
+ ("default initialization of & may modify overlaid storage?",
+ Nam);
+ end if;
+
+ -- Add friendly warning if initialization comes from a packed array
+ -- component.
+
+ if Is_Record_Type (Typ) then
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (Typ);
+
+ while Present (Comp) loop
+ if Nkind (Parent (Comp)) = N_Component_Declaration
+ and then Present (Expression (Parent (Comp)))
+ then
+ exit;
+ elsif Is_Array_Type (Etype (Comp))
+ and then Present (Packed_Array_Type (Etype (Comp)))
+ then
+ Error_Msg_NE
+ ("packed array component& will be initialized to zero?",
+ Nam, Comp);
+ exit;
+ else
+ Next_Component (Comp);
+ end if;
+ end loop;
+ end;
+ end if;
+
+ Error_Msg_N
+ ("use pragma Import for & to " &
+ "suppress initialization ('R'M B.1(24))?",
+ Nam);
+ end if;
+ end Warn_Overlay;
+
end Freeze;
diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads
index 247fbc4e9cb..aaa7b009d52 100644
--- a/gcc/ada/freeze.ads
+++ b/gcc/ada/freeze.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -127,8 +127,7 @@ package Freeze is
function Build_Renamed_Body
(Decl : Node_Id;
- New_S : Entity_Id)
- return Node_Id;
+ New_S : Entity_Id) return Node_Id;
-- Rewrite renaming declaration as a subprogram body, whose single
-- statement is a call to the renamed entity. New_S is the entity that
-- appears in the renaming declaration. If this is a Renaming_As_Body,
@@ -170,6 +169,13 @@ package Freeze is
-- do not allow a size clause if the size would not otherwise be known at
-- compile time in any case.
+ procedure Expand_Atomic_Aggregate (E : Entity_Id; Typ : Entity_Id);
+ -- If an atomic object is initialized with an aggregate or is assigned
+ -- an aggregate, we have to prevent a piecemeal access or assignment
+ -- to the object, even if the aggregate is to be expanded. we create
+ -- a temporary for the aggregate, and assign the temporary instead,
+ -- so that the back end can generate an atomic move for it.
+
function Freeze_Entity (E : Entity_Id; Loc : Source_Ptr) return List_Id;
-- Freeze an entity, and return Freeze nodes, to be inserted at the
-- point of call. Loc is a source location which corresponds to the
diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb
index 758513eb180..f4f36f56aaf 100644
--- a/gcc/ada/frontend.adb
+++ b/gcc/ada/frontend.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- --
@@ -24,6 +24,8 @@
-- --
------------------------------------------------------------------------------
+with GNAT.Strings; use GNAT.Strings;
+
with Atree; use Atree;
with Checks;
with CStand;
@@ -44,6 +46,7 @@ with Opt; use Opt;
with Osint;
with Output; use Output;
with Par;
+with Prepcomp;
with Rtsfind;
with Sprint;
with Scn; use Scn;
@@ -55,14 +58,12 @@ with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Sinput.L; use Sinput.L;
+with Tbuild; use Tbuild;
with Types; use Types;
procedure Frontend is
- Pragmas : List_Id;
- Prag : Node_Id;
-
- Save_Style_Check : constant Boolean := Opt.Style_Check;
- -- Save style check mode so it can be restored later
+ Config_Pragmas : List_Id;
+ -- Gather configuration pragmas
begin
-- Carry out package initializations. These are initializations which
@@ -86,102 +87,115 @@ begin
CStand.Create_Standard;
- -- Read and process gnat.adc file if one is present
+ -- Check possible symbol definitions specified by -gnateD switches
- if Opt.Config_File then
+ Prepcomp.Process_Command_Line_Symbol_Definitions;
- -- We always analyze the gnat.adc file with style checks off,
- -- since we don't want a miscellaneous gnat.adc that is around
- -- to discombobulate intended -gnatg compilations.
+ -- If -gnatep= was specified, parse the preprocessing data file
- Opt.Style_Check := False;
+ if Preprocessing_Data_File /= null then
+ Name_Len := Preprocessing_Data_File'Length;
+ Name_Buffer (1 .. Name_Len) := Preprocessing_Data_File.all;
+ Prepcomp.Parse_Preprocessing_Data_File (Name_Find);
- -- Capture current suppress options, which may get modified
+ -- Otherwise, check if there were preprocessing symbols on the command
+ -- line and set preprocessing if there are.
- Scope_Suppress := Opt.Suppress_Options;
+ else
+ Prepcomp.Check_Symbols;
+ end if;
- Name_Buffer (1 .. 8) := "gnat.adc";
- Name_Len := 8;
- Source_gnat_adc := Load_Config_File (Name_Enter);
+ -- Now that the preprocessing situation is established, we are able to
+ -- load the main source (this is no longer done by Lib.Load.Initalize).
- if Source_gnat_adc /= No_Source_File then
- Initialize_Scanner (No_Unit, Source_gnat_adc);
- Pragmas := Par (Configuration_Pragmas => True);
+ Lib.Load.Load_Main_Source;
- if Pragmas /= Error_List
- and then Operating_Mode /= Check_Syntax
- then
- Prag := First (Pragmas);
- while Present (Prag) loop
- Analyze_Pragma (Prag);
- Next (Prag);
- end loop;
- end if;
- end if;
+ -- Read and process configuration pragma files if present
- -- Restore style check, but if gnat.adc turned on checks, leave on!
+ declare
+ Save_Style_Check : constant Boolean := Opt.Style_Check;
+ -- Save style check mode so it can be restored later
- Opt.Style_Check := Save_Style_Check or Style_Check;
+ Source_Config_File : Source_File_Index;
+ -- Source reference for -gnatec configuration file
- -- Capture any modifications to suppress options from config pragmas
+ Prag : Node_Id;
- Opt.Suppress_Options := Scope_Suppress;
- end if;
+ begin
+ -- We always analyze config files with style checks off, since
+ -- we don't want a miscellaneous gnat.adc that is around to
+ -- discombobulate intended -gnatg or -gnaty compilations.
- -- Read and process the configuration pragmas file if one is present
+ Opt.Style_Check := False;
+ Style_Check := False;
- if Config_File_Name /= null then
+ -- Capture current suppress options, which may get modified
- declare
- New_Pragmas : List_Id;
- Style_Check_Saved : constant Boolean := Opt.Style_Check;
- Source_Config_File : Source_File_Index := No_Source_File;
+ Scope_Suppress := Opt.Suppress_Options;
- begin
- -- We always analyze the config pragmas file with style checks off,
- -- since we don't want it to discombobulate intended
- -- -gnatg compilations.
+ -- First deal with gnat.adc file
+
+ if Opt.Config_File then
+ Name_Buffer (1 .. 8) := "gnat.adc";
+ Name_Len := 8;
+ Source_gnat_adc := Load_Config_File (Name_Enter);
+
+ if Source_gnat_adc /= No_Source_File then
+ Initialize_Scanner (No_Unit, Source_gnat_adc);
+ Config_Pragmas := Par (Configuration_Pragmas => True);
+
+ else
+ Config_Pragmas := Empty_List;
+ end if;
- Opt.Style_Check := False;
+ else
+ Config_Pragmas := Empty_List;
+ end if;
- -- Capture current suppress options, which may get modified
+ -- Now deal with specified config pragmas files if there are any
- Scope_Suppress := Opt.Suppress_Options;
+ if Opt.Config_File_Names /= null then
+ for Index in Opt.Config_File_Names'Range loop
+ Name_Len := Config_File_Names (Index)'Length;
+ Name_Buffer (1 .. Name_Len) := Config_File_Names (Index).all;
+ Source_Config_File := Load_Config_File (Name_Enter);
- Name_Buffer (1 .. Config_File_Name'Length) := Config_File_Name.all;
- Name_Len := Config_File_Name'Length;
- Source_Config_File := Load_Config_File (Name_Enter);
+ if Source_Config_File = No_Source_File then
+ Osint.Fail
+ ("cannot find configuration pragmas file ",
+ Config_File_Names (Index).all);
+ end if;
- if Source_Config_File = No_Source_File then
- Osint.Fail
- ("cannot find configuration pragmas file ",
- Config_File_Name.all);
- end if;
+ Initialize_Scanner (No_Unit, Source_Config_File);
+ Append_List_To
+ (Config_Pragmas, Par (Configuration_Pragmas => True));
+ end loop;
+ end if;
- Initialize_Scanner (No_Unit, Source_Config_File);
- New_Pragmas := Par (Configuration_Pragmas => True);
+ -- Now analyze all pragmas except those whose analysis must be
+ -- deferred till after the main unit is analyzed.
- if New_Pragmas /= Error_List
- and then Operating_Mode /= Check_Syntax
- then
- Prag := First (New_Pragmas);
- while Present (Prag) loop
+ if Config_Pragmas /= Error_List
+ and then Operating_Mode /= Check_Syntax
+ then
+ Prag := First (Config_Pragmas);
+ while Present (Prag) loop
+ if not Delay_Config_Pragma_Analyze (Prag) then
Analyze_Pragma (Prag);
- Next (Prag);
- end loop;
- end if;
+ end if;
- -- Restore style check, but if the config pragmas file
- -- turned on checks, leave on!
+ Next (Prag);
+ end loop;
+ end if;
- Opt.Style_Check := Style_Check_Saved or Style_Check;
+ -- Restore style check, but if config file turned on checks, leave on!
- -- Capture any modifications to suppress options from config pragmas
+ Opt.Style_Check := Save_Style_Check or Style_Check;
- Opt.Suppress_Options := Scope_Suppress;
- end;
+ -- Capture any modifications to suppress options from config pragmas
- end if;
+ Opt.Suppress_Options := Scope_Suppress;
+ end;
-- If there was a -gnatem switch, initialize the mappings of unit names to
-- file names and of file names to path names from the mapping file.
@@ -228,90 +242,117 @@ begin
-- the check syntax mode, but in that case we won't go on to the
-- semantics in any case).
- declare
- Discard : List_Id;
-
- begin
- Discard := Par (Configuration_Pragmas => False);
- end;
+ Discard_List (Par (Configuration_Pragmas => False));
-- The main unit is now loaded, and subunits of it can be loaded,
-- without reporting spurious loading circularities.
Set_Loading (Main_Unit, False);
- -- Now on to the semantics. We skip the semantics if we are in syntax
- -- only mode, or if we encountered a fatal error during the parsing.
+ -- Now that the main unit is installed, we can complete the analysis
+ -- of the pragmas in gnat.adc and the configuration file, that require
+ -- a context for their semantic processing.
- if Operating_Mode /= Check_Syntax
- and then not Fatal_Error (Main_Unit)
+ if Config_Pragmas /= Error_List
+ and then Operating_Mode /= Check_Syntax
then
- -- Reset Operating_Mode to Check_Semantics for subunits. We cannot
- -- actually generate code for subunits, so we suppress expansion.
- -- This also corrects certain problems that occur if we try to
- -- incorporate subunits at a lower level.
+ -- Pragmas that require some semantic activity, such as
+ -- Interrupt_State, cannot be processed until the main unit
+ -- is installed, because they require a compilation unit on
+ -- which to attach with_clauses, etc. So analyze them now.
- if Operating_Mode = Generate_Code
- and then Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
- then
- Operating_Mode := Check_Semantics;
- end if;
+ declare
+ Prag : Node_Id;
- -- Analyze (and possibly expand) main unit
+ begin
+ Prag := First (Config_Pragmas);
+ while Present (Prag) loop
+ if Delay_Config_Pragma_Analyze (Prag) then
+ Analyze_Pragma (Prag);
+ end if;
- Scope_Suppress := Suppress_Options;
- Semantics (Cunit (Main_Unit));
+ Next (Prag);
+ end loop;
+ end;
+ end if;
- -- Cleanup processing after completing main analysis
+ -- Now on to the semantics. Skip if in syntax only mode
- if Operating_Mode = Generate_Code
- or else (Operating_Mode = Check_Semantics
- and then Tree_Output)
- then
- Instantiate_Bodies;
- end if;
+ if Operating_Mode /= Check_Syntax then
- if Operating_Mode = Generate_Code then
+ -- Install the configuration pragmas in the tree
+
+ Set_Config_Pragmas (Aux_Decls_Node (Cunit (Main_Unit)), Config_Pragmas);
+
+ -- Following steps are skipped if we had a fatal error during parsing
+
+ if not Fatal_Error (Main_Unit) then
- if Inline_Processing_Required then
- Analyze_Inlined_Bodies;
+ -- Reset Operating_Mode to Check_Semantics for subunits. We cannot
+ -- actually generate code for subunits, so we suppress expansion.
+ -- This also corrects certain problems that occur if we try to
+ -- incorporate subunits at a lower level.
+
+ if Operating_Mode = Generate_Code
+ and then Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
+ then
+ Operating_Mode := Check_Semantics;
end if;
- -- Remove entities from program that do not have any
- -- execution time references.
+ -- Analyze (and possibly expand) main unit
+
+ Scope_Suppress := Suppress_Options;
+ Semantics (Cunit (Main_Unit));
+
+ -- Cleanup processing after completing main analysis
- if Debug_Flag_UU then
- Collect_Garbage_Entities;
+ if Operating_Mode = Generate_Code
+ or else (Operating_Mode = Check_Semantics
+ and then ASIS_Mode)
+ then
+ Instantiate_Bodies;
end if;
- Check_Elab_Calls;
+ if Operating_Mode = Generate_Code then
+ if Inline_Processing_Required then
+ Analyze_Inlined_Bodies;
+ end if;
- -- Build unit exception table. We leave this up to the end to
- -- make sure that all the necessary information is at hand.
+ -- Remove entities from program that do not have any
+ -- execution time references.
- Exp_Ch11.Generate_Unit_Exception_Table;
- end if;
+ if Debug_Flag_UU then
+ Collect_Garbage_Entities;
+ end if;
- -- List library units if requested
+ Check_Elab_Calls;
- if List_Units then
- Lib.List;
- end if;
+ -- Build unit exception table. We leave this up to the end to
+ -- make sure that all the necessary information is at hand.
+
+ Exp_Ch11.Generate_Unit_Exception_Table;
+ end if;
- -- Output any messages for unreferenced entities
+ -- List library units if requested
- Output_Unreferenced_Messages;
- Sem_Warn.Check_Unused_Withs;
+ if List_Units then
+ Lib.List;
+ end if;
+
+ -- Output any messages for unreferenced entities
+
+ Output_Unreferenced_Messages;
+ Sem_Warn.Check_Unused_Withs;
+ end if;
end if;
-- Qualify all entity names in inner packages, package bodies, etc.,
-- except when compiling for the JVM back end, which depends on
- -- having unqualified names in certain cases and handles the generation
- -- of qualified names when needed.
+ -- having unqualified names in certain cases and handles the
+ -- generation of qualified names when needed.
if not Java_VM then
Exp_Dbug.Qualify_All_Entity_Names;
- Exp_Dbug.Generate_Auxiliary_Types;
end if;
-- Dump the source now. Note that we do this as soon as the analysis
@@ -320,11 +361,12 @@ begin
Sprint.Source_Dump;
- -- If a mapping file has been specified by a -gnatem switch,
- -- update it if there has been some sourcs that were not in the mappings.
+ -- If a mapping file has been specified by a -gnatem switch, update
+ -- it if there has been some sourcs that were not in the mappings.
if Mapping_File_Name /= null then
Fmap.Update_Mapping_File (Mapping_File_Name.all);
end if;
+ return;
end Frontend;
diff --git a/gcc/ada/g-arrspl.adb b/gcc/ada/g-arrspl.adb
new file mode 100644
index 00000000000..78fa8c46081
--- /dev/null
+++ b/gcc/ada/g-arrspl.adb
@@ -0,0 +1,309 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . A R R A Y _ S P I T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+package body GNAT.Array_Split is
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Slices_Indexes, Slices_Access);
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Separators_Indexes, Indexes_Access);
+
+ function Count
+ (Source : Element_Sequence;
+ Pattern : Element_Set)
+ return Natural;
+ -- Returns the number of occurences of Pattern elements in Source, 0 is
+ -- returned if no occurence is found in Source.
+
+ ------------
+ -- Adjust --
+ ------------
+
+ procedure Adjust (S : in out Slice_Set) is
+ begin
+ S.Ref_Counter.all := S.Ref_Counter.all + 1;
+ end Adjust;
+
+ ------------
+ -- Create --
+ ------------
+
+ procedure Create
+ (S : out Slice_Set;
+ From : Element_Sequence;
+ Separators : Element_Sequence;
+ Mode : Separator_Mode := Single)
+ is
+ begin
+ Create (S, From, To_Set (Separators), Mode);
+ end Create;
+
+ ------------
+ -- Create --
+ ------------
+
+ procedure Create
+ (S : out Slice_Set;
+ From : Element_Sequence;
+ Separators : Element_Set;
+ Mode : Separator_Mode := Single)
+ is
+ begin
+ S.Source := new Element_Sequence'(From);
+ Set (S, Separators, Mode);
+ end Create;
+
+ -----------
+ -- Count --
+ -----------
+
+ function Count
+ (Source : Element_Sequence;
+ Pattern : Element_Set)
+ return Natural
+ is
+ C : Natural := 0;
+ begin
+ for K in Source'Range loop
+ if Is_In (Source (K), Pattern) then
+ C := C + 1;
+ end if;
+ end loop;
+
+ return C;
+ end Count;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize (S : in out Slice_Set) is
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Element_Sequence, Element_Access);
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Natural, Counter);
+
+ begin
+ S.Ref_Counter.all := S.Ref_Counter.all - 1;
+
+ if S.Ref_Counter.all = 0 then
+ Free (S.Source);
+ Free (S.Indexes);
+ Free (S.Slices);
+ Free (S.Ref_Counter);
+ end if;
+ end Finalize;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (S : in out Slice_Set) is
+ begin
+ S.Ref_Counter := new Natural'(1);
+ end Initialize;
+
+ ----------------
+ -- Separators --
+ ----------------
+
+ function Separators
+ (S : Slice_Set;
+ Index : Slice_Number)
+ return Slice_Separators
+ is
+ begin
+ if Index > S.N_Slice then
+ raise Index_Error;
+
+ elsif Index = 0
+ or else (Index = 1 and then S.N_Slice = 1)
+ then
+ -- Whole string, or no separator used.
+
+ return (Before => Array_End,
+ After => Array_End);
+
+ elsif Index = 1 then
+ return (Before => Array_End,
+ After => S.Source (S.Slices (Index).Stop + 1));
+
+ elsif Index = S.N_Slice then
+ return (Before => S.Source (S.Slices (Index).Start - 1),
+ After => Array_End);
+
+ else
+ return (Before => S.Source (S.Slices (Index).Start - 1),
+ After => S.Source (S.Slices (Index).Stop + 1));
+ end if;
+ end Separators;
+
+ ----------------
+ -- Separators --
+ ----------------
+
+ function Separators (S : Slice_Set) return Separators_Indexes is
+ begin
+ return S.Indexes.all;
+ end Separators;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set
+ (S : in out Slice_Set;
+ Separators : Element_Sequence;
+ Mode : Separator_Mode := Single)
+ is
+ begin
+ Set (S, To_Set (Separators), Mode);
+ end Set;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set
+ (S : in out Slice_Set;
+ Separators : Element_Set;
+ Mode : Separator_Mode := Single)
+ is
+ Count_Sep : constant Natural := Count (S.Source.all, Separators);
+ J : Positive;
+ begin
+ -- Free old structure
+ Free (S.Indexes);
+ Free (S.Slices);
+
+ -- Compute all separator's indexes
+
+ S.Indexes := new Separators_Indexes (1 .. Count_Sep);
+ J := S.Indexes'First;
+
+ for K in S.Source'Range loop
+ if Is_In (S.Source (K), Separators) then
+ S.Indexes (J) := K;
+ J := J + 1;
+ end if;
+ end loop;
+
+ -- Compute slice info for fast slice access
+
+ declare
+ S_Info : Slices_Indexes (1 .. Slice_Number (Count_Sep) + 1);
+ K : Natural := 1;
+ Start, Stop : Natural;
+
+ begin
+ S.N_Slice := 0;
+
+ Start := S.Source'First;
+ Stop := 0;
+
+ loop
+ if K > Count_Sep then
+ -- No more separator, last slice end at the end of the source
+ -- string.
+ Stop := S.Source'Last;
+ else
+ Stop := S.Indexes (K) - 1;
+ end if;
+
+ -- Add slice to the table
+
+ S.N_Slice := S.N_Slice + 1;
+ S_Info (S.N_Slice) := (Start, Stop);
+
+ exit when K > Count_Sep;
+
+ case Mode is
+
+ when Single =>
+ -- In this mode just set start to character next to the
+ -- current separator, advance the separator index.
+ Start := S.Indexes (K) + 1;
+ K := K + 1;
+
+ when Multiple =>
+ -- In this mode skip separators following each others
+ loop
+ Start := S.Indexes (K) + 1;
+ K := K + 1;
+ exit when K > Count_Sep
+ or else S.Indexes (K) > S.Indexes (K - 1) + 1;
+ end loop;
+
+ end case;
+ end loop;
+
+ S.Slices := new Slices_Indexes'(S_Info (1 .. S.N_Slice));
+ end;
+ end Set;
+
+ -----------
+ -- Slice --
+ -----------
+
+ function Slice
+ (S : Slice_Set;
+ Index : Slice_Number)
+ return Element_Sequence
+ is
+ begin
+ if Index = 0 then
+ return S.Source.all;
+
+ elsif Index > S.N_Slice then
+ raise Index_Error;
+
+ else
+ return S.Source (S.Slices (Index).Start .. S.Slices (Index).Stop);
+ end if;
+ end Slice;
+
+ -----------------
+ -- Slice_Count --
+ -----------------
+
+ function Slice_Count (S : Slice_Set) return Slice_Number is
+ begin
+ return S.N_Slice;
+ end Slice_Count;
+
+end GNAT.Array_Split;
diff --git a/gcc/ada/g-arrspl.ads b/gcc/ada/g-arrspl.ads
new file mode 100644
index 00000000000..f01210267d8
--- /dev/null
+++ b/gcc/ada/g-arrspl.ads
@@ -0,0 +1,187 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . A R R A Y _ S P L T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Useful array-manipulation routines: given a set of separators, split
+-- an array wherever the separators appear, and provide direct access
+-- to the resulting slices.
+
+with Ada.Finalization;
+
+generic
+ type Element is (<>);
+ -- Element of the array, this must be a discrete type
+
+ type Element_Sequence is array (Positive range <>) of Element;
+ -- The array which is a sequence of element.
+
+ type Element_Set is private;
+ -- This type represent a set of elements. This set does not defined a
+ -- specific order of the elements. The conversion of a sequence to a
+ -- set and membership tests in the set is performed using the routines
+ -- To_Set and Is_In defined below.
+
+ with function To_Set (Sequence : Element_Sequence) return Element_Set;
+ -- Returns an Element_Set given an Element_Sequence. Duplicate elements
+ -- can be ignored during this conversion.
+
+ with function Is_In (Item : Element; Set : Element_Set) return Boolean;
+ -- Returns True if Item is found in Set, False otherwise
+
+package GNAT.Array_Split is
+
+ Index_Error : exception;
+ -- Raised by all operations below if Index > Field_Count (S)
+
+ type Separator_Mode is
+ (Single,
+ -- In this mode the array is cut at each element in the separator
+ -- set. If two separators are contiguous the result at that position
+ -- is an empty slice.
+
+ Multiple
+ -- In this mode contiguous separators are handled as a single
+ -- separator and no empty slice is created.
+ );
+
+ type Slice_Set is private;
+ -- This type uses by-reference semantics. This is a set of slices as
+ -- returned by Create or Set routines below. The abstraction represents
+ -- a set of items. Each item is a part of the original string named a
+ -- Slice. It is possible to access individual slices by using the Slice
+ -- routine below. The first slice in the Set is at the position/index
+ -- 1. The total number of slices in the set is returned by Slice_Count.
+
+ procedure Create
+ (S : out Slice_Set;
+ From : Element_Sequence;
+ Separators : Element_Sequence;
+ Mode : Separator_Mode := Single);
+ -- Create a cut array object. From is the source array, and Separators
+ -- is a sequence of Element along which to split the array. The source
+ -- array is sliced at separator boundaries. The separators are not
+ -- included as part of the resulting slices.
+
+ procedure Create
+ (S : out Slice_Set;
+ From : Element_Sequence;
+ Separators : Element_Set;
+ Mode : Separator_Mode := Single);
+ -- Same as above but using a Element_Set
+
+ procedure Set
+ (S : in out Slice_Set;
+ Separators : Element_Sequence;
+ Mode : Separator_Mode := Single);
+ -- Change the set of separators. The source array will be split according
+ -- to this new set of separators.
+
+ procedure Set
+ (S : in out Slice_Set;
+ Separators : Element_Set;
+ Mode : Separator_Mode := Single);
+ -- Same as above but using a Element_Set
+
+ type Slice_Number is new Natural;
+ -- Type used to count number of slices
+
+ function Slice_Count (S : Slice_Set) return Slice_Number;
+ pragma Inline (Slice_Count);
+ -- Returns the number of slices (fields) in S
+
+ function Slice
+ (S : Slice_Set;
+ Index : Slice_Number)
+ return Element_Sequence;
+ pragma Inline (Slice);
+ -- Returns the slice at position Index. First slice is 1. If Index is 0
+ -- the whole array is returned including the separators (this is the
+ -- original source array).
+
+ type Position is (Before, After);
+ -- Used to designate position of separator
+
+ type Slice_Separators is array (Position) of Element;
+ -- Separators found before and after the slice
+
+ Array_End : constant Element;
+ -- This is the separator returned for the start or the end of the array
+
+ function Separators
+ (S : Slice_Set;
+ Index : Slice_Number)
+ return Slice_Separators;
+ -- Returns the separators used to slice (front and back) the slice at
+ -- position Index. For slices at start and end of the original array, the
+ -- Array_End value is returned for the corresponding outer bound. In
+ -- Multiple mode only the element closest to the slice is returned.
+ -- if Index = 0, returns (Array_End, Array_End).
+
+ type Separators_Indexes is array (Positive range <>) of Positive;
+
+ function Separators (S : Slice_Set) return Separators_Indexes;
+ -- Returns indexes of all separators used to slice original source array S
+
+private
+
+ Array_End : constant Element := Element'First;
+
+ type Element_Access is access Element_Sequence;
+
+ type Counter is access Natural;
+
+ type Indexes_Access is access Separators_Indexes;
+
+ type Slice_Info is record
+ Start : Positive;
+ Stop : Natural;
+ end record;
+ -- Starting/Ending position of a slice. This does not include separators.
+
+ type Slices_Indexes is array (Slice_Number range <>) of Slice_Info;
+ type Slices_Access is access Slices_Indexes;
+ -- All indexes for fast access to slices. In the Slice_Set we keep only
+ -- the original array and the indexes where each slice start and stop.
+
+ type Slice_Set is new Ada.Finalization.Controlled with record
+ Ref_Counter : Counter; -- Reference counter, by-address sem
+ Source : Element_Access;
+ N_Slice : Slice_Number := 0; -- Number of slices found
+ Indexes : Indexes_Access;
+ Slices : Slices_Access;
+ end record;
+
+ procedure Initialize (S : in out Slice_Set);
+ procedure Adjust (S : in out Slice_Set);
+ procedure Finalize (S : in out Slice_Set);
+
+end GNAT.Array_Split;
diff --git a/gcc/ada/g-awk.adb b/gcc/ada/g-awk.adb
index 40de600ffd7..3396daac0e1 100644
--- a/gcc/ada/g-awk.adb
+++ b/gcc/ada/g-awk.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -381,7 +382,7 @@ package body GNAT.AWK is
(A : Simple_Action;
Session : Session_Type)
is
- pragma Warnings (Off, Session);
+ pragma Unreferenced (Session);
begin
A.Proc.all;
@@ -446,7 +447,7 @@ package body GNAT.AWK is
Session : Session_Type)
return Boolean
is
- pragma Warnings (Off, Session);
+ pragma Unreferenced (Session);
begin
return P.Pattern.all;
@@ -457,7 +458,7 @@ package body GNAT.AWK is
-------------
procedure Release (P : in out Pattern) is
- pragma Warnings (Off, P);
+ pragma Unreferenced (P);
begin
null;
@@ -493,10 +494,10 @@ package body GNAT.AWK is
Line : constant String := To_String (Session.Data.Current_Line);
Fields : Field_Table.Instance renames Session.Data.Fields;
- Start : Positive;
+ Start : Natural;
Stop : Natural;
- Seps : Maps.Character_Set := Maps.To_Set (S.Separators);
+ Seps : constant Maps.Character_Set := Maps.To_Set (S.Separators);
begin
-- First field start here
@@ -520,7 +521,7 @@ package body GNAT.AWK is
Fields.Table (Field_Table.Last (Fields)).Last := Stop - 1;
- -- if separators are set to the default (space and tab) we skip
+ -- If separators are set to the default (space and tab) we skip
-- all spaces and tabs following current field.
if S.Separators = Default_Separators then
@@ -529,6 +530,10 @@ package body GNAT.AWK is
Maps.To_Set (Default_Separators),
Outside,
Strings.Forward);
+
+ if Start = 0 then
+ Start := Stop + 1;
+ end if;
else
Start := Stop + 1;
end if;
@@ -1046,6 +1051,8 @@ package body GNAT.AWK is
Session : Session_Type := Current_Session)
is
Filter_Active : Boolean;
+ pragma Unreferenced (Filter_Active);
+
begin
Open (Separators, Filename, Session);
@@ -1178,7 +1185,7 @@ package body GNAT.AWK is
is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
- A_Pattern : Patterns.Pattern_Matcher_Access :=
+ A_Pattern : constant Patterns.Pattern_Matcher_Access :=
new Regpat.Pattern_Matcher'(Pattern);
begin
Pattern_Action_Table.Increment_Last (Filters);
@@ -1196,7 +1203,7 @@ package body GNAT.AWK is
is
Filters : Pattern_Action_Table.Instance renames Session.Data.Filters;
- A_Pattern : Patterns.Pattern_Matcher_Access :=
+ A_Pattern : constant Patterns.Pattern_Matcher_Access :=
new Regpat.Pattern_Matcher'(Pattern);
begin
Pattern_Action_Table.Increment_Last (Filters);
diff --git a/gcc/ada/g-awk.ads b/gcc/ada/g-awk.ads
index 7af1cb3ec5e..577f04e3435 100644
--- a/gcc/ada/g-awk.ads
+++ b/gcc/ada/g-awk.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,10 +26,11 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
---
+
-- This is an AWK-like unit. It provides an easy interface for parsing one
-- or more files containing formatted data. The file can be viewed seen as
-- a database where each record is a line and a field is a data element in
diff --git a/gcc/ada/g-boubuf.adb b/gcc/ada/g-boubuf.adb
new file mode 100644
index 00000000000..5b6a9a830c5
--- /dev/null
+++ b/gcc/ada/g-boubuf.adb
@@ -0,0 +1,93 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . B O U N D E D _ B U F F E R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body GNAT.Bounded_Buffers is
+
+ --------------------
+ -- Bounded_Buffer --
+ --------------------
+
+ protected body Bounded_Buffer is
+
+ ------------
+ -- Insert --
+ ------------
+
+ entry Insert (Item : in Element) when Count /= Capacity is
+ begin
+ Values (Next_In) := Item;
+ Next_In := (Next_In mod Capacity) + 1;
+ Count := Count + 1;
+ end Insert;
+
+ ------------
+ -- Remove --
+ ------------
+
+ entry Remove (Item : out Element) when Count > 0 is
+ begin
+ Item := Values (Next_Out);
+ Next_Out := (Next_Out mod Capacity) + 1;
+ Count := Count - 1;
+ end Remove;
+
+ -----------
+ -- Empty --
+ -----------
+
+ function Empty return Boolean is
+ begin
+ return Count = 0;
+ end Empty;
+
+ ----------
+ -- Full --
+ ----------
+
+ function Full return Boolean is
+ begin
+ return Count = Capacity;
+ end Full;
+
+ ------------
+ -- Extent --
+ ------------
+
+ function Extent return Natural is
+ begin
+ return Count;
+ end Extent;
+
+ end Bounded_Buffer;
+
+
+end GNAT.Bounded_Buffers;
diff --git a/gcc/ada/g-boubuf.ads b/gcc/ada/g-boubuf.ads
new file mode 100644
index 00000000000..8eb478bd3e4
--- /dev/null
+++ b/gcc/ada/g-boubuf.ads
@@ -0,0 +1,101 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- G N A T . B O U N D E D _ B U F F E R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a thread-safe generic bounded buffer abstraction.
+-- Instances are useful directly or as parts of the implementations of other
+-- abstractions, such as mailboxes.
+
+-- Bounded_Buffer is declared explicitly as a protected type, rather than as
+-- a simple limited private type completed as a protected type, so that
+-- clients may make calls accordingly (i.e., conditional/timed entry calls).
+
+with System;
+
+generic
+ type Element is private;
+ -- The type of the values contained within buffer objects
+package GNAT.Bounded_Buffers is
+ pragma Pure;
+
+ type Content is array (Positive range <>) of Element;
+ -- Content is an internal artefact that cannot be hidden
+ -- because protected types cannot contain type declarations.
+
+ Default_Ceiling : constant System.Priority := System.Default_Priority;
+ -- A convenience value for the Ceiling discriminant.
+
+ protected type Bounded_Buffer
+ (Capacity : Positive;
+ -- Objects of type Bounded_Buffer specify the maximum
+ -- number of Element values they can hold via the
+ -- discriminant Capacity.
+ Ceiling : System.Priority)
+ -- Users must specify the ceiling priority for the object.
+ -- If the Real-Time Systems Annex is not in use this value
+ -- is not important.
+ is
+ pragma Priority (Ceiling);
+
+ entry Insert (Item : in Element);
+ -- Insert Item into the buffer. Blocks caller
+ -- until space is available.
+
+ entry Remove (Item : out Element);
+ -- Remove next available Element from buffer.
+ -- Blocks caller until an Element is available.
+
+ function Empty return Boolean;
+ -- Returns whether the instance contains any Elements.
+ -- Note: State may change immediately after call returns.
+
+ function Full return Boolean;
+ -- Returns whether any space remains within the instance.
+ -- Note: State may change immediately after call returns.
+
+ function Extent return Natural;
+ -- Returns the number of Element values currently held
+ -- within the instance.
+ -- Note: State may change immediately after call returns.
+
+ private
+ Values : Content (1 .. Capacity);
+ -- The container for the values held by the buffer instance.
+ Next_In : Positive := 1;
+ -- The index of the next Element inserted. Wraps around.
+ Next_Out : Positive := 1;
+ -- The index of the next Element removed. Wraps around.
+ Count : Natural := 0;
+ -- The number of Elements currently held.
+ end Bounded_Buffer;
+
+end GNAT.Bounded_Buffers;
diff --git a/gcc/ada/g-boumai.ads b/gcc/ada/g-boumai.ads
new file mode 100644
index 00000000000..a6dbf75337b
--- /dev/null
+++ b/gcc/ada/g-boumai.ads
@@ -0,0 +1,98 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- G N A T . B O U N D E D _ M A I L B O X E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a thread-safe asynchronous communication facility
+-- in the form of mailboxes. Individual mailbox objects are bounded in size
+-- to a value specified by their Capacity discriminants.
+
+-- Mailboxes actually hold references to messages, not the message values
+-- themselves.
+
+-- Type Mailbox is defined explicitly as a protected type (via derivation
+-- from a protected type) so that clients may treat them accordingly (for
+-- example, by making conditional/timed entry calls).
+
+with System;
+with GNAT.Bounded_Buffers;
+
+generic
+ type Message (<>) is limited private;
+ type Message_Reference is access all Message;
+ -- Mailboxes hold references to Message values, of this type
+
+package GNAT.Bounded_Mailboxes is
+ pragma Preelaborate;
+
+ package Message_Refs is
+ new GNAT.Bounded_Buffers (Message_Reference);
+
+ type Mailbox is new Message_Refs.Bounded_Buffer;
+
+ -- Type Mailbox has two inherited discriminants:
+
+ -- Capacity : Positive;
+ -- Capacity is the maximum number of Message references
+ -- possibly contained at any given instant.
+
+ -- Ceiling : System.Priority;
+ -- Users must specify the ceiling priority for the object.
+ -- If the Real-Time Systems Annex is not in use this value
+ -- is not important.
+
+ -- Protected type Mailbox has the following inherited interface:
+
+ -- entry Insert (Item : in Message_Reference);
+ -- Insert Item into the Mailbox. Blocks caller
+ -- until space is available.
+
+ -- entry Remove (Item : out Message_Reference);
+ -- Remove next available Message_Reference from Mailbox.
+ -- Blocks caller until a Message_Reference is available.
+
+ -- function Empty return Boolean;
+ -- Returns whether the Mailbox contains any Message_References.
+ -- Note: State may change immediately after call returns.
+
+ -- function Full return Boolean;
+ -- Returns whether any space remains within the Mailbox.
+ -- Note: State may change immediately after call returns.
+
+ -- function Extent return Natural;
+ -- Returns the number of Message_Reference values currently held
+ -- within the Mailbox.
+ -- Note: State may change immediately after call returns.
+
+ Default_Ceiling : constant System.Priority := Message_Refs.Default_Ceiling;
+ -- A convenience value for the Ceiling discriminant
+
+end GNAT.Bounded_Mailboxes;
diff --git a/gcc/ada/s-exnflt.ads b/gcc/ada/g-bubsor.adb
index 968dac48545..5c0b7c722c8 100644
--- a/gcc/ada/s-exnflt.ads
+++ b/gcc/ada/g-bubsor.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
--- S Y S T E M . E X N _ F L T --
+-- G N A T . B U B B L E _ S O R T _ A --
-- --
--- S p e c --
+-- B o d y --
-- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,14 +31,28 @@
-- --
------------------------------------------------------------------------------
--- Float exponentiation (checks off)
+package body GNAT.Bubble_Sort is
-with System.Exn_Gen;
+ ----------
+ -- Sort --
+ ----------
-package System.Exn_Flt is
-pragma Pure (Exn_Flt);
+ procedure Sort (N : Natural; Xchg : Xchg_Procedure; Lt : Lt_Function) is
+ Switched : Boolean;
- function Exn_Float is
- new System.Exn_Gen.Exn_Float_Type (Float);
+ begin
+ loop
+ Switched := False;
-end System.Exn_Flt;
+ for J in 1 .. N - 1 loop
+ if Lt (J + 1, J) then
+ Xchg (J, J + 1);
+ Switched := True;
+ end if;
+ end loop;
+
+ exit when not Switched;
+ end loop;
+ end Sort;
+
+end GNAT.Bubble_Sort;
diff --git a/gcc/ada/g-bubsor.ads b/gcc/ada/g-bubsor.ads
new file mode 100644
index 00000000000..2294e009286
--- /dev/null
+++ b/gcc/ada/g-bubsor.ads
@@ -0,0 +1,68 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- G N A T . B U B B L E _ S O R T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Sort Utility (Using Bubblesort Algorithm)
+
+-- This package provides a bubblesort routine that works with access to
+-- subprogram parameters, so that it can be used with different types with
+-- shared sorting code.
+
+-- See also GNAT.Bubble_Sort_G and GNAT.Bubble_Sort_A. These are older
+-- versions of this routine. In some cases GNAT.Bubble_Sort_G may be a
+-- little faster than GNAT.Bubble_Sort, at the expense of generic code
+-- duplication and a less convenient interface. The generic version also
+-- has the advantage of being Pure, while this unit can only be Preelaborate.
+
+package GNAT.Bubble_Sort is
+pragma Preelaborate (Bubble_Sort);
+
+ -- The data to be sorted is assumed to be indexed by integer values from
+ -- 1 to N, where N is the number of items to be sorted.
+
+ type Xchg_Procedure is access procedure (Op1, Op2 : Natural);
+ -- A pointer to a procedure that exchanges the two data items whose
+ -- index values are Op1 and Op2.
+
+ type Lt_Function is access function (Op1, Op2 : Natural) return Boolean;
+ -- A pointer to a function that compares two items and returns True if
+ -- the item with index value Op1 is less than the item with Index value
+ -- Op2, and False if the Op1 item is greater than or equal to the Op2
+ -- item.
+
+ procedure Sort (N : Natural; Xchg : Xchg_Procedure; Lt : Lt_Function);
+ -- This procedures sorts items in the range from 1 to N into ascending
+ -- order making calls to Lt to do required comparisons, and calls to
+ -- Xchg to exchange items. The sort is stable, that is the order of
+ -- equal items in the input is preserved.
+
+end GNAT.Bubble_Sort;
diff --git a/gcc/ada/g-busora.adb b/gcc/ada/g-busora.adb
index 9a469192785..733d5a006c2 100644
--- a/gcc/ada/g-busora.adb
+++ b/gcc/ada/g-busora.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-busora.ads b/gcc/ada/g-busora.ads
index 7fbc6fc8d6e..bb6432e8e5b 100644
--- a/gcc/ada/g-busora.ads
+++ b/gcc/ada/g-busora.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2000 Ada Core Technologies, Inc. --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,18 +26,17 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Bubblesort using access to procedure parameters
--- This package provides a bubblesort routine that works with access to
+-- This package provides a bubble sort routine that works with access to
-- subprogram parameters, so that it can be used with different types with
--- shared sorting code. See also GNAT.Bubble_Sort_G, the generic version
--- which is a little more efficient, but does not allow code sharing.
--- The generic version is also Pure, while the access version can
--- only be Preelaborate.
+-- shared sorting code. It is considered obsoleted by GNAT.Bubble_Sort which
+-- offers a similar routine with a more convenient interface.
package GNAT.Bubble_Sort_A is
pragma Preelaborate (Bubble_Sort_A);
diff --git a/gcc/ada/g-busorg.adb b/gcc/ada/g-busorg.adb
index 62cbd4275dd..5c5e6656ddc 100644
--- a/gcc/ada/g-busorg.adb
+++ b/gcc/ada/g-busorg.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-busorg.ads b/gcc/ada/g-busorg.ads
index 76ccda75122..e8f7648b7b5 100644
--- a/gcc/ada/g-busorg.ads
+++ b/gcc/ada/g-busorg.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2000 Ada Core Technologies, Inc. --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,17 +26,25 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Bubblesort generic package using formal procedures
-- This package provides a generic bubble sort routine that can be used with
--- different types of data. See also GNAT.Bubble_Sort_A, a version that works
--- with subprogram parameters, allowing code sharing. The generic version
--- is slightly more efficient but does not allow code sharing. The generic
--- version is also Pure, while the access version can only be Preelaborate.
+-- different types of data.
+
+-- See also GNAT.Bubble_Sort, a version that works with subprogram access
+-- parameters, allowing code sharing. The generic version is slightly more
+-- efficient but does not allow code sharing and has an interface that is
+-- more awkward to use. The generic version is also Pure, while the access
+-- subprograqm version can only be Preelaborate.
+
+-- There is also GNAT.Bubble_Sort_A, which is now considered obsolete, but
+-- was an older version working with subprogram parameters. This version
+-- is retained for bacwards compatibility with old versions of GNAT.
generic
-- The data to be sorted is assumed to be indexed by integer values from
@@ -44,9 +52,10 @@ generic
-- index value zero is used for a temporary location used during the sort.
with procedure Move (From : Natural; To : Natural);
- -- A procedure that moves the data item with index From to the data item
- -- with Index To. An index value of zero is used for moves from and to a
- -- single temporary location used by the sort.
+ -- A procedure that moves the data item with index value From to the data
+ -- item with index value To (the old value in To being lost). An index
+ -- value of zero is used for moves from and to a single temporary location
+ -- used by the sort.
with function Lt (Op1, Op2 : Natural) return Boolean;
-- A function that compares two items and returns True if the item with
@@ -60,7 +69,7 @@ pragma Pure (Bubble_Sort_G);
-- This procedures sorts items in the range from 1 to N into ascending
-- order making calls to Lt to do required comparisons, and Move to move
-- items around. Note that, as described above, both Move and Lt use a
- -- single temporary location with index value zero. This sort is not
- -- stable, i.e. the order of equal elements in the input is not preserved.
+ -- single temporary location with index value zero. This sort is stable,
+ -- that is the order of equal elements in the input is preserved.
end GNAT.Bubble_Sort_G;
diff --git a/gcc/ada/g-casuti.adb b/gcc/ada/g-casuti.adb
index a8624915799..606449d0212 100644
--- a/gcc/ada/g-casuti.adb
+++ b/gcc/ada/g-casuti.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-1999 Ada Core Technologies, Inc. --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,79 +26,15 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-package body GNAT.Case_Util is
-
- --------------
- -- To_Lower --
- --------------
-
- function To_Lower (A : Character) return Character is
- A_Val : constant Natural := Character'Pos (A);
-
- begin
- if A in 'A' .. 'Z'
- or else A_Val in 16#C0# .. 16#D6#
- or else A_Val in 16#D8# .. 16#DE#
- then
- return Character'Val (A_Val + 16#20#);
- else
- return A;
- end if;
- end To_Lower;
-
- procedure To_Lower (A : in out String) is
- begin
- for J in A'Range loop
- A (J) := To_Lower (A (J));
- end loop;
- end To_Lower;
-
- --------------
- -- To_Mixed --
- --------------
-
- procedure To_Mixed (A : in out String) is
- Ucase : Boolean := True;
-
- begin
- for J in A'Range loop
- if Ucase then
- A (J) := To_Upper (A (J));
- else
- A (J) := To_Lower (A (J));
- end if;
-
- Ucase := A (J) = '_';
- end loop;
- end To_Mixed;
-
- --------------
- -- To_Upper --
- --------------
-
- function To_Upper (A : Character) return Character is
- A_Val : constant Natural := Character'Pos (A);
-
- begin
- if A in 'a' .. 'z'
- or else A_Val in 16#E0# .. 16#F6#
- or else A_Val in 16#F8# .. 16#FE#
- then
- return Character'Val (A_Val - 16#20#);
- else
- return A;
- end if;
- end To_Upper;
-
- procedure To_Upper (A : in out String) is
- begin
- for J in A'Range loop
- A (J) := To_Upper (A (J));
- end loop;
- end To_Upper;
+-- This is a dummy body, required because if we remove the body we have
+-- bootstrap path problems (this unit used to have a body, and if we do not
+-- supply a dummy body, the old incorrect body is picked up during the
+-- bootstrap process.
+package body GNAT.Case_Util is
end GNAT.Case_Util;
diff --git a/gcc/ada/g-casuti.ads b/gcc/ada/g-casuti.ads
index db22ec52df6..2ef0b1ed129 100644
--- a/gcc/ada/g-casuti.ads
+++ b/gcc/ada/g-casuti.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-1998 Ada Core Technologies, Inc. --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -35,26 +36,43 @@
-- This package provides simple casing functions that do not require the
-- overhead of the full casing tables found in Ada.Characters.Handling.
+-- Note: actual code is found in System.Case_Util, which is used internally
+-- by the GNAT run time. Applications programs should always use this package
+-- rather than using System.Case_Util directly.
+
+with System.Case_Util;
+
package GNAT.Case_Util is
pragma Pure (Case_Util);
+pragma Elaborate_Body;
+-- The elaborate body is because we have a dummy body to deal with bootstrap
+-- path problems (we used to have a real body, and now we don't need it any
+-- more, but the bootstrap requires that we have a dummy body, since otherwise
+-- the old body gets picked up.
+
-- Note: all the following functions handle the full Latin-1 set
- function To_Upper (A : Character) return Character;
+ function To_Upper (A : Character) return Character
+ renames System.Case_Util.To_Upper;
-- Converts A to upper case if it is a lower case letter, otherwise
-- returns the input argument unchanged.
- procedure To_Upper (A : in out String);
+ procedure To_Upper (A : in out String)
+ renames System.Case_Util.To_Upper;
-- Folds all characters of string A to upper csae
- function To_Lower (A : Character) return Character;
+ function To_Lower (A : Character) return Character
+ renames System.Case_Util.To_Lower;
-- Converts A to lower case if it is an upper case letter, otherwise
-- returns the input argument unchanged.
- procedure To_Lower (A : in out String);
+ procedure To_Lower (A : in out String)
+ renames System.Case_Util.To_Lower;
-- Folds all characters of string A to lower case
- procedure To_Mixed (A : in out String);
+ procedure To_Mixed (A : in out String)
+ renames System.Case_Util.To_Mixed;
-- Converts A to mixed case (i.e. lower case, except for initial
-- character and any character after an underscore, which are
-- converted to upper case.
diff --git a/gcc/ada/g-catiio.adb b/gcc/ada/g-catiio.adb
index e3f45f815fe..02ddc9be5a9 100644
--- a/gcc/ada/g-catiio.adb
+++ b/gcc/ada/g-catiio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2003 Ada Core Technologies, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -31,7 +31,7 @@
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -126,7 +126,8 @@ package body GNAT.Calendar.Time_IO is
return String
is
use Ada.Characters.Handling;
- Local : String := To_Upper (Str (1)) & To_Lower (Str (2 .. Str'Last));
+ Local : constant String :=
+ To_Upper (Str (1)) & To_Lower (Str (2 .. Str'Last));
begin
if Length = 0 then
@@ -158,6 +159,10 @@ package body GNAT.Calendar.Time_IO is
is
function Pad_Char return String;
+ --------------
+ -- Pad_Char --
+ --------------
+
function Pad_Char return String is
begin
case Padding is
@@ -309,6 +314,39 @@ package body GNAT.Calendar.Time_IO is
when 'S' =>
Result := Result & Image (Second, Padding, Length => 2);
+ -- Milliseconds (3 digits)
+ -- Microseconds (6 digits)
+ -- Nanoseconds (9 digits)
+
+ when 'i' | 'e' | 'o' =>
+ declare
+ Sub_Sec : constant Long_Integer :=
+ Long_Integer (Sub_Second * 1_000_000_000);
+
+ Img1 : constant String := Sub_Sec'Img;
+ Img2 : constant String :=
+ "00000000" & Img1 (Img1'First + 1 .. Img1'Last);
+ Nanos : constant String :=
+ Img2 (Img2'Last - 8 .. Img2'Last);
+
+ begin
+ case Picture (P + 1) is
+ when 'i' =>
+ Result := Result &
+ Nanos (Nanos'First .. Nanos'First + 2);
+
+ when 'e' =>
+ Result := Result &
+ Nanos (Nanos'First .. Nanos'First + 5);
+
+ when 'o' =>
+ Result := Result & Nanos;
+
+ when others =>
+ null;
+ end case;
+ end;
+
-- Time, 24-hour (hh:mm:ss)
when 'T' =>
@@ -364,9 +402,9 @@ package body GNAT.Calendar.Time_IO is
when 'D' | 'x' =>
Result := Result &
- Image (Month, Padding, 2) & '/' &
- Image (Day, Padding, 2) & '/' &
- Image (Year, Padding, 2);
+ Image (Month, Padding, 2) & '/' &
+ Image (Day, Padding, 2) & '/' &
+ Image (Year, Padding, 2);
-- Day of year (001..366)
@@ -420,7 +458,6 @@ package body GNAT.Calendar.Time_IO is
when 'y' =>
declare
Y : constant Natural := Year - (Year / 100) * 100;
-
begin
Result := Result & Image (Y, Padding, 2);
end;
diff --git a/gcc/ada/g-catiio.ads b/gcc/ada/g-catiio.ads
index 9f3188cdf1b..abaa5f34e8b 100644
--- a/gcc/ada/g-catiio.ads
+++ b/gcc/ada/g-catiio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2003 Ada Core Technologies, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -41,9 +41,9 @@
package GNAT.Calendar.Time_IO is
Picture_Error : exception;
+ -- Exception raised for incorrect picture
type Picture_String is new String;
-
-- This is a string to describe date and time output format. The string is
-- a set of standard character and special tag that are replaced by the
-- corresponding values. It follows the GNU Date specification. Here are
@@ -95,12 +95,18 @@ package GNAT.Calendar.Time_IO is
--
-- - (hyphen) do not pad the field
-- _ (underscore) pad the field with spaces
+ --
+ -- Here are some GNAT extensions to the GNU Date specification:
+ --
+ -- %i milliseconds (3 digits)
+ -- %e microseconds (6 digits)
+ -- %o nanoseconds (9 digits)
- ISO_Date : constant Picture_String;
+ ISO_Date : constant Picture_String;
-- This format follow the ISO 8601 standard. The format is "YYYY-MM-DD",
-- four digits year, month and day number separated by minus.
- US_Date : constant Picture_String;
+ US_Date : constant Picture_String;
-- This format is the common US date format: "MM/DD/YY",
-- month and day number, two digits year separated by slashes.
diff --git a/gcc/ada/g-cgi.adb b/gcc/ada/g-cgi.adb
index 3d5970dbe22..647c61fb9d9 100644
--- a/gcc/ada/g-cgi.adb
+++ b/gcc/ada/g-cgi.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-cgi.ads b/gcc/ada/g-cgi.ads
index 4929989b2c1..6b5e1806344 100644
--- a/gcc/ada/g-cgi.ads
+++ b/gcc/ada/g-cgi.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-cgicoo.adb b/gcc/ada/g-cgicoo.adb
index 6827a9e45cb..ffc8edc249c 100644
--- a/gcc/ada/g-cgicoo.adb
+++ b/gcc/ada/g-cgicoo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2001 Ada Core Technologies, Inc.
+-- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-cgicoo.ads b/gcc/ada/g-cgicoo.ads
index 3af1fd8188f..e06c5f72e1b 100644
--- a/gcc/ada/g-cgicoo.ads
+++ b/gcc/ada/g-cgicoo.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-cgideb.adb b/gcc/ada/g-cgideb.adb
index 0f913fc46d0..b782cf6b43d 100644
--- a/gcc/ada/g-cgideb.adb
+++ b/gcc/ada/g-cgideb.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-cgideb.ads b/gcc/ada/g-cgideb.ads
index 082cebeeaac..4c05bce951c 100644
--- a/gcc/ada/g-cgideb.ads
+++ b/gcc/ada/g-cgideb.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb
index abaa24cd53b..8a4f19b0419 100644
--- a/gcc/ada/g-comlin.adb
+++ b/gcc/ada/g-comlin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-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- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -330,8 +331,12 @@ package body GNAT.Command_Line is
-- Getopt --
------------
- function Getopt (Switches : String) return Character is
+ function Getopt
+ (Switches : String;
+ Concatenate : Boolean := True) return Character
+ is
Dummy : Boolean;
+ pragma Unreferenced (Dummy);
begin
-- If we have finished parsing the current command line item (there
@@ -441,11 +446,20 @@ package body GNAT.Command_Line is
return '*';
end if;
+ -- Depending on the value of Concatenate, the full switch is
+ -- a single character (True) or the rest of the argument (False).
+
+ if Concatenate then
+ End_Index := Current_Index;
+ else
+ End_Index := Arg'Last;
+ end if;
+
Set_Parameter (The_Switch,
Arg_Num => Current_Argument,
First => Current_Index,
- Last => Current_Index);
- Current_Index := Current_Index + 1;
+ Last => End_Index);
+ Current_Index := End_Index + 1;
raise Invalid_Switch;
end if;
@@ -552,12 +566,35 @@ package body GNAT.Command_Line is
Dummy := Goto_Next_Argument_In_Section;
when others =>
+ if Concatenate or else End_Index = Arg'Last then
+ Current_Index := End_Index + 1;
- Current_Index := End_Index + 1;
+ else
+ -- If Concatenate is False and the full argument is not
+ -- recognized as a switch, this is an invalid switch.
+ Set_Parameter (The_Switch,
+ Arg_Num => Current_Argument,
+ First => Current_Index,
+ Last => Arg'Last);
+ Current_Index := Arg'Last + 1;
+ raise Invalid_Switch;
+ end if;
end case;
- else
+
+ elsif Concatenate or else End_Index = Arg'Last then
Current_Index := End_Index + 1;
+
+ else
+ -- If Concatenate is False and the full argument is not
+ -- recognized as a switch, this is an invalid switch.
+
+ Set_Parameter (The_Switch,
+ Arg_Num => Current_Argument,
+ First => Current_Index,
+ Last => Arg'Last);
+ Current_Index := Arg'Last + 1;
+ raise Invalid_Switch;
end if;
return Switches (Index_Switches);
diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads
index 1e421e4cd3e..d5ff4e99005 100644
--- a/gcc/ada/g-comlin.ads
+++ b/gcc/ada/g-comlin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -143,15 +144,17 @@ package GNAT.Command_Line is
-- Returns the full name of the last switch found (Getopt only returns
-- the first character)
- function Getopt (Switches : String) return Character;
+ function Getopt
+ (Switches : String;
+ Concatenate : Boolean := True) return Character;
-- This function moves to the next switch on the command line (defined
-- as a switch character followed by a character within Switches,
-- casing being significant). The result returned is the first
-- character of the particular switch located. If there are no more
- -- switches in the current section, returns ASCII.NUL. The switches
- -- need not be separated by spaces (they can be concatenated if they do
- -- not require an argument, e.g. -ab is the same as two separate
- -- arguments -a -b).
+ -- switches in the current section, returns ASCII.NUL. If Concatenate is
+ -- True (by default), the switches need not be separated by spaces (they
+ -- can be concatenated if they do not require an argument, e.g. -ab is the
+ -- same as two separate arguments -a -b).
--
-- Switches is a string of all the possible switches, separated by a
-- space. A switch can be followed by one of the following characters :
@@ -162,7 +165,7 @@ package GNAT.Command_Line is
-- space on the command line between the switch and its parameter
-- '!' The switch requires a parameter, but there can be no space on the
-- command line between the switch and its parameter
- -- '?' The switch may have an optional parameter. There can no space
+ -- '?' The switch may have an optional parameter. There can be no space
-- between the switch and its argument
-- ex/ if Switches has the following value : "a? b"
-- The command line can be :
@@ -208,6 +211,14 @@ package GNAT.Command_Line is
-- Arbitrary characters are allowed for switches, although it is
-- strongly recommanded to use only letters and digits for portability
-- reasons.
+ --
+ -- When Concatenate is False, individual switches need to be separated by
+ -- spaces.
+ --
+ -- Example
+ -- Getopt ("a b", Concatenate => False)
+ -- If the command line is '-ab', exception Invalid_Switch will be
+ -- raised and Full_Switch will return "ab".
function Get_Argument (Do_Expansion : Boolean := False) return String;
-- Returns the next element in the command line which is not a switch.
diff --git a/gcc/ada/g-comver.adb b/gcc/ada/g-comver.adb
new file mode 100644
index 00000000000..4b70b7b1394
--- /dev/null
+++ b/gcc/ada/g-comver.adb
@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . C O M P I L E R _ V E R S I O N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002 Ada Core Technologies --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a routine for obtaining the version number of the
+-- GNAT compiler used to compile the program. It relies on the generated
+-- constant in the binder generated package that records this information.
+
+package body GNAT.Compiler_Version is
+
+ Ver_Len_Max : constant := 32;
+ -- This is logically a reference to Gnatvsn.Ver_Len_Max but we cannot
+ -- import this directly since run-time units cannot WITH compiler units.
+
+ Ver_Prefix : constant String := "GNAT Version: ";
+ -- Prefix generated by binder
+
+ GNAT_Version : constant String (1 .. Ver_Len_Max + Ver_Prefix'Length);
+ pragma Import (C, GNAT_Version, "__gnat_version");
+
+ -------------
+ -- Version --
+ -------------
+
+ function Version return String is
+ begin
+ -- Search for terminating right paren
+
+ for J in Ver_Prefix'Length + 1 .. GNAT_Version'Last loop
+ if GNAT_Version (J) = ')' then
+ return GNAT_Version (Ver_Prefix'Length + 1 .. J);
+ end if;
+ end loop;
+
+ -- This should not happen (no right paren found)
+
+ return GNAT_Version;
+ end Version;
+
+end GNAT.Compiler_Version;
diff --git a/gcc/ada/g-comver.ads b/gcc/ada/g-comver.ads
new file mode 100644
index 00000000000..4792b0fd9a8
--- /dev/null
+++ b/gcc/ada/g-comver.ads
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . C O M P I L E R _ V E R S I O N --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Ada Core Technologies --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a routine for obtaining the version number of the
+-- GNAT compiler used to compile the program. It relies on the generated
+-- constant in the binder generated package that records this information.
+
+-- Note: to use this package you must first instantiate it, e.g.
+
+-- package CVer is new GNAT.Compiler_Version;
+
+-- and then you use the function in the instantiated package (Cver.Version).
+-- The reason that this unit is generic is that otherwise the direct attempt
+-- to import the necessary variable from the binder file causes trouble when
+-- building a shared library, since the symbol is not available.
+
+-- Note: this unit is only useable if the main program is written
+-- in Ada. It cannot be used if the main program is written in a
+-- foreign language.
+
+generic
+package GNAT.Compiler_Version is
+pragma Pure (Compiler_Version);
+
+ function Version return String;
+ -- This function returns the version in the form "v.vvx (yyyyddmm)".
+ -- Here v.vv is the main version number (e.g. 3.16), x is the version
+ -- designator (e.g. a1 in 3.16a1), and yyyyddmm is the date in ISO form.
+ -- An example of the returned value would be "3.16w (20021029)". The
+ -- version is actually that of the binder used to bind the program,
+ -- which will be the same as the compiler version if a consistent
+ -- set of tools is used to build the program.
+
+end GNAT.Compiler_Version;
diff --git a/gcc/ada/g-crc32.adb b/gcc/ada/g-crc32.adb
index 18ae76dc0b4..5571ff1f06c 100644
--- a/gcc/ada/g-crc32.adb
+++ b/gcc/ada/g-crc32.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-crc32.ads b/gcc/ada/g-crc32.ads
index 00f050ef471..e6a89e9825d 100644
--- a/gcc/ada/g-crc32.ads
+++ b/gcc/ada/g-crc32.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-ctrl_c.ads b/gcc/ada/g-ctrl_c.ads
new file mode 100644
index 00000000000..445653f8e9a
--- /dev/null
+++ b/gcc/ada/g-ctrl_c.ads
@@ -0,0 +1,67 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- G N A T . C T R L _ C --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package may be used to intercept the interruption of a running
+-- program by the operator typing Control-C, without having to use an Ada
+-- interrupt handler protected object.
+--
+-- This package is currently implemented under Windows and Unix platforms.
+--
+-- Note concerning Unix systems:
+
+-- The behavior of this package when using tasking depends on the interaction
+-- between sigaction() and the thread library.
+
+-- On most implementations, the interaction will be no different whether
+-- tasking is involved or not. An exception is GNU/Linux systems where
+-- each task/thread is considered as a separate process by the kernel,
+-- meaning in particular that a Ctrl-C from the keyboard will be sent to
+-- all tasks instead of only one, resulting in multiple calls to the handler.
+
+package GNAT.Ctrl_C is
+
+ type Handler_Type is access procedure;
+ -- Any parameterless library level procedure can be used as a handler.
+ -- Handler_Type should not propagate exceptions.
+
+ procedure Install_Handler (Handler : Handler_Type);
+ -- Set up Handler to be called if the operator hits Ctrl-C.
+
+ procedure Uninstall_Handler;
+ -- Reinstall the standard Control-C handler.
+ -- If Install_Handler has never been called, this procedure has no effect.
+
+private
+ pragma Import (C, Install_Handler, "__gnat_install_int_handler");
+ pragma Import (C, Uninstall_Handler, "__gnat_uninstall_int_handler");
+end GNAT.Ctrl_C;
diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb
index 83c8ba54785..ef853da04e9 100644
--- a/gcc/ada/g-debpoo.adb
+++ b/gcc/ada/g-debpoo.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- G N A T . D E B U G _ P O O L S --
+-- G N A T . D E B U G _ P O O L S --
-- --
--- B o d y --
+-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -31,32 +31,630 @@
-- --
------------------------------------------------------------------------------
-with Unchecked_Conversion;
+with Ada.Exceptions.Traceback;
+with GNAT.IO; use GNAT.IO;
+
+with System.Address_Image;
+with System.Memory; use System.Memory;
+with System.Soft_Links; use System.Soft_Links;
+
+with System.Traceback_Entries; use System.Traceback_Entries;
+
with GNAT.HTable;
-with System.Memory;
+with GNAT.Traceback; use GNAT.Traceback;
-pragma Elaborate_All (GNAT.HTable);
+with Ada.Unchecked_Conversion;
package body GNAT.Debug_Pools is
use System;
- use System.Memory;
use System.Storage_Elements;
- -- Definition of a H-table storing the status of each storage chunck
- -- used by this pool
+ Default_Alignment : constant Storage_Offset := Standard'Maximum_Alignment;
+ -- Alignment used for the memory chunks returned by Allocate. Using this
+ -- value garantees that this alignment will be compatible with all types
+ -- and at the same time makes it easy to find the location of the extra
+ -- header allocated for each chunk.
+
+ Initial_Memory_Size : constant Storage_Offset := 2 ** 26; -- 64 Mb
+ -- Initial size of memory that the debug pool can handle. This is used to
+ -- compute the size of the htable used to monitor the blocks, but this is
+ -- dynamic and will grow as needed. Having a bigger size here means a
+ -- longer setup time, but less time spent later on to grow the array.
+
+ Max_Ignored_Levels : constant Natural := 10;
+ -- Maximum number of levels that will be ignored in backtraces. This is so
+ -- that we still have enough significant levels in the tracebacks returned
+ -- to the user.
+ -- The value 10 is chosen as being greater than the maximum callgraph
+ -- in this package. Its actual value is not really relevant, as long as it
+ -- is high enough to make sure we still have enough frames to return to
+ -- the user after we have hidden the frames internal to this package.
+
+ -----------------------
+ -- Tracebacks_Htable --
+ -----------------------
- type State is (Not_Allocated, Deallocated, Allocated);
+ -- This package needs to store one set of tracebacks for each allocation
+ -- point (when was it allocated or deallocated). This would use too much
+ -- memory, so the tracebacks are actually stored in a hash table, and
+ -- we reference elements in this hash table instead.
+
+ -- This hash-table will remain empty if the discriminant Stack_Trace_Depth
+ -- for the pools is set to 0.
+
+ -- This table is a global table, that can be shared among all debug pools
+ -- with no problems.
type Header is range 1 .. 1023;
- function H (F : Address) return Header;
+ -- Number of elements in the hash-table
+
+ type Tracebacks_Array_Access
+ is access GNAT.Traceback.Tracebacks_Array;
+
+ type Traceback_Kind is (Alloc, Dealloc, Indirect_Alloc, Indirect_Dealloc);
+
+ type Traceback_Htable_Elem;
+ type Traceback_Htable_Elem_Ptr
+ is access Traceback_Htable_Elem;
+
+ type Traceback_Htable_Elem is record
+ Traceback : Tracebacks_Array_Access;
+ Kind : Traceback_Kind;
+ Count : Natural;
+ Total : Byte_Count;
+ Next : Traceback_Htable_Elem_Ptr;
+ end record;
+
+ procedure Set_Next
+ (E : Traceback_Htable_Elem_Ptr;
+ Next : Traceback_Htable_Elem_Ptr);
+ function Next
+ (E : Traceback_Htable_Elem_Ptr)
+ return Traceback_Htable_Elem_Ptr;
+ function Get_Key
+ (E : Traceback_Htable_Elem_Ptr)
+ return Tracebacks_Array_Access;
+ function Hash (T : Tracebacks_Array_Access) return Header;
+ function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean;
+ pragma Inline (Set_Next, Next, Get_Key, Equal, Hash);
+ -- Subprograms required for instantiation of the htable. See GNAT.HTable.
+
+ package Backtrace_Htable is new GNAT.HTable.Static_HTable
+ (Header_Num => Header,
+ Element => Traceback_Htable_Elem,
+ Elmt_Ptr => Traceback_Htable_Elem_Ptr,
+ Null_Ptr => null,
+ Set_Next => Set_Next,
+ Next => Next,
+ Key => Tracebacks_Array_Access,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => Equal);
+
+ -----------------------
+ -- Allocations table --
+ -----------------------
+
+ type Allocation_Header;
+ type Allocation_Header_Access is access Allocation_Header;
+
+ -- The following record stores extra information that needs to be
+ -- memorized for each block allocated with the special debug pool.
+
+ type Traceback_Ptr_Or_Address is new System.Address;
+ -- A type that acts as a C union, and is either a System.Address or a
+ -- Traceback_Htable_Elem_Ptr.
+
+ type Allocation_Header is record
+ Block_Size : Storage_Offset;
+ -- Needed only for advanced freeing algorithms (traverse all allocated
+ -- blocks for potential references). This value is negated when the
+ -- chunk of memory has been logically freed by the application. This
+ -- chunk has not been physically released yet.
+
+ Alloc_Traceback : Traceback_Htable_Elem_Ptr;
+ Dealloc_Traceback : Traceback_Ptr_Or_Address;
+ -- Pointer to the traceback for the allocation (if the memory chunck is
+ -- still valid), or to the first deallocation otherwise. Make sure this
+ -- is a thin pointer to save space.
+ --
+ -- Dealloc_Traceback is also for blocks that are still allocated to
+ -- point to the previous block in the list. This saves space in this
+ -- header, and make manipulation of the lists of allocated pointers
+ -- faster.
+
+ Next : System.Address;
+ -- Point to the next block of the same type (either allocated or
+ -- logically freed) in memory. This points to the beginning of the user
+ -- data, and does not include the header of that block.
+ end record;
+
+ function Header_Of (Address : System.Address)
+ return Allocation_Header_Access;
+ pragma Inline (Header_Of);
+ -- Return the header corresponding to a previously allocated address
+
+ function To_Address is new Ada.Unchecked_Conversion
+ (Traceback_Ptr_Or_Address, System.Address);
+ function To_Address is new Ada.Unchecked_Conversion
+ (System.Address, Traceback_Ptr_Or_Address);
+ function To_Traceback is new Ada.Unchecked_Conversion
+ (Traceback_Ptr_Or_Address, Traceback_Htable_Elem_Ptr);
+ function To_Traceback is new Ada.Unchecked_Conversion
+ (Traceback_Htable_Elem_Ptr, Traceback_Ptr_Or_Address);
+
+ Minimum_Allocation : constant Storage_Count :=
+ Default_Alignment *
+ (Allocation_Header'Size /
+ System.Storage_Unit /
+ Default_Alignment) +
+ Default_Alignment;
+ -- Extra bytes to allocate to store the header. The header needs to be
+ -- correctly aligned as well, so we have to allocate multiples of the
+ -- alignment.
+
+ -----------------------
+ -- Allocations table --
+ -----------------------
+
+ -- This table is indexed on addresses modulo Minimum_Allocation, and
+ -- for each index it indicates whether that memory block is valid.
+ -- Its behavior is similar to GNAT.Table, except that we need to pack
+ -- the table to save space, so we cannot reuse GNAT.Table as is.
+
+ -- This table is the reason why all alignments have to be forced to a
+ -- common value (Default_Alignment), so that this table can be
+ -- kept to a reasonnable size.
+
+ type Byte is mod 2 ** System.Storage_Unit;
+
+ Big_Table_Size : constant Storage_Offset :=
+ (Storage_Offset'Last - 1) / Default_Alignment;
+ type Big_Table is array (0 .. Big_Table_Size) of Byte;
+ -- A simple, flat-array type used to access memory bytes (see the comment
+ -- for Valid_Blocks below).
+ --
+ -- It would be cleaner to represent this as a packed array of Boolean.
+ -- However, we cannot specify pragma Pack for such an array, since the
+ -- total size on a 64 bit machine would be too big (> Integer'Last).
+ --
+ -- Given an address, we know if it is under control of the debug pool if
+ -- the byte at index:
+ -- ((Address - Edata'Address) / Default_Alignment)
+ -- / Storage_unit
+ -- has the bit
+ -- ((Address - Edata'Address) / Default_Alignment)
+ -- mod Storage_Unit
+ -- set to 1.
+ --
+ -- See the subprograms Is_Valid and Set_Valid for proper manipulation of
+ -- this array.
+
+ type Table_Ptr is access Big_Table;
+ function To_Pointer is new Ada.Unchecked_Conversion
+ (System.Address, Table_Ptr);
+
+ Valid_Blocks : Table_Ptr := null;
+ Valid_Blocks_Size : Storage_Offset := 0;
+ -- These two variables represents a mapping of the currently allocated
+ -- memory. Every time the pool works on an address, we first check that the
+ -- index Address / Default_Alignment is True. If not, this means that this
+ -- address is not under control of the debug pool, and thus this is
+ -- probably an invalid memory access (it could also be a general access
+ -- type).
+ --
+ -- Note that in fact we never allocate the full size of Big_Table, only a
+ -- slice big enough to manage the currently allocated memory.
+
+ Edata : System.Address := System.Null_Address;
+ -- Address in memory that matches the index 0 in Valid_Blocks. It is named
+ -- after the symbol _edata, which, on most systems, indicate the lowest
+ -- possible address returned by malloc (). Unfortunately, this symbol
+ -- doesn't exist on windows, so we cannot use it instead of this variable.
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ function Find_Or_Create_Traceback
+ (Pool : Debug_Pool;
+ Kind : Traceback_Kind;
+ Size : Storage_Count;
+ Ignored_Frame_Start : System.Address;
+ Ignored_Frame_End : System.Address)
+ return Traceback_Htable_Elem_Ptr;
+ -- Return an element matching the current traceback (omitting the frames
+ -- that are in the current package). If this traceback already existed in
+ -- the htable, a pointer to this is returned to spare memory. Null is
+ -- returned if the pool is set not to store tracebacks. If the traceback
+ -- already existed in the table, the count is incremented so that
+ -- Dump_Tracebacks returns useful results.
+ -- All addresses up to, and including, an address between
+ -- Ignored_Frame_Start .. Ignored_Frame_End are ignored.
+
+ procedure Put_Line
+ (Depth : Natural;
+ Traceback : Tracebacks_Array_Access;
+ Ignored_Frame_Start : System.Address := System.Null_Address;
+ Ignored_Frame_End : System.Address := System.Null_Address);
+ -- Print Traceback to Standard_Output. If Traceback is null, print the
+ -- call_chain at the current location, up to Depth levels, ignoring all
+ -- addresses up to the first one in the range
+ -- Ignored_Frame_Start .. Ignored_Frame_End
+
+ function Is_Valid (Storage : System.Address) return Boolean;
+ pragma Inline (Is_Valid);
+ -- Return True if Storage is an address that the debug pool has under its
+ -- control.
+
+ procedure Set_Valid (Storage : System.Address; Value : Boolean);
+ pragma Inline (Set_Valid);
+ -- Mark the address Storage as being under control of the memory pool (if
+ -- Value is True), or not (if Value is False). This procedure will
+ -- reallocate the table Valid_Blocks as needed.
+
+ procedure Set_Dead_Beef
+ (Storage_Address : System.Address;
+ Size_In_Storage_Elements : Storage_Count);
+ -- Set the contents of the memory block pointed to by Storage_Address to
+ -- the 16#DEADBEEF# pattern. If Size_In_Storage_Elements is not a multiple
+ -- of the length of this pattern, the last instance may be partial.
+
+ procedure Free_Physically (Pool : in out Debug_Pool);
+ -- Start to physically release some memory to the system, until the amount
+ -- of logically (but not physically) freed memory is lower than the
+ -- expected amount in Pool.
+
+ procedure Allocate_End;
+ procedure Deallocate_End;
+ procedure Dereference_End;
+ -- These procedures are used as markers when computing the stacktraces,
+ -- so that addresses in the debug pool itself are not reported to the user.
+
+ Code_Address_For_Allocate_End : System.Address;
+ Code_Address_For_Deallocate_End : System.Address;
+ Code_Address_For_Dereference_End : System.Address;
+ -- Taking the address of the above procedures will not work on some
+ -- architectures (HPUX and VMS for instance). Thus we do the same thing
+ -- that is done in a-except.adb, and get the address of labels instead
+
+ procedure Skip_Levels
+ (Depth : Natural;
+ Trace : Tracebacks_Array;
+ Start : out Natural;
+ Len : in out Natural;
+ Ignored_Frame_Start : System.Address;
+ Ignored_Frame_End : System.Address);
+ -- Set Start .. Len to the range of values from Trace that should be output
+ -- to the user. This range of values exludes any address prior to the first
+ -- one in Ignored_Frame_Start .. Ignored_Frame_End (basically addresses
+ -- internal to this package). Depth is the number of levels that the user
+ -- is interested in.
+
+ ---------------
+ -- Header_Of --
+ ---------------
+
+ function Header_Of (Address : System.Address)
+ return Allocation_Header_Access
+ is
+ function Convert is new Ada.Unchecked_Conversion
+ (System.Address, Allocation_Header_Access);
+ begin
+ return Convert (Address - Minimum_Allocation);
+ end Header_Of;
+
+ --------------
+ -- Set_Next --
+ --------------
+
+ procedure Set_Next
+ (E : Traceback_Htable_Elem_Ptr;
+ Next : Traceback_Htable_Elem_Ptr)
+ is
+ begin
+ E.Next := Next;
+ end Set_Next;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next
+ (E : Traceback_Htable_Elem_Ptr)
+ return Traceback_Htable_Elem_Ptr
+ is
+ begin
+ return E.Next;
+ end Next;
+
+ -----------
+ -- Equal --
+ -----------
+
+ function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean is
+ use Ada.Exceptions.Traceback;
+
+ begin
+ return K1.all = K2.all;
+ end Equal;
+
+ -------------
+ -- Get_Key --
+ -------------
+
+ function Get_Key
+ (E : Traceback_Htable_Elem_Ptr)
+ return Tracebacks_Array_Access
+ is
+ begin
+ return E.Traceback;
+ end Get_Key;
+
+ ----------
+ -- Hash --
+ ----------
- package Table is new GNAT.HTable.Simple_HTable (
- Header_Num => Header,
- Element => State,
- No_Element => Not_Allocated,
- Key => Address,
- Hash => H,
- Equal => "=");
+ function Hash (T : Tracebacks_Array_Access) return Header is
+ Result : Integer_Address := 0;
+ begin
+ for X in T'Range loop
+ Result := Result + To_Integer (PC_For (T (X)));
+ end loop;
+ return Header (1 + Result mod Integer_Address (Header'Last));
+ end Hash;
+
+ --------------
+ -- Put_Line --
+ --------------
+
+ procedure Put_Line
+ (Depth : Natural;
+ Traceback : Tracebacks_Array_Access;
+ Ignored_Frame_Start : System.Address := System.Null_Address;
+ Ignored_Frame_End : System.Address := System.Null_Address)
+ is
+ procedure Print (Tr : Tracebacks_Array);
+ -- Print the traceback to standard_output
+
+ -----------
+ -- Print --
+ -----------
+
+ procedure Print (Tr : Tracebacks_Array) is
+ begin
+ for J in Tr'Range loop
+ Put ("0x" & Address_Image (PC_For (Tr (J))) & ' ');
+ end loop;
+ Put (ASCII.LF);
+ end Print;
+
+ -- Start of processing for Put_Line
+
+ begin
+ if Traceback = null then
+ declare
+ Tr : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels);
+ Start, Len : Natural;
+
+ begin
+ Call_Chain (Tr, Len);
+ Skip_Levels (Depth, Tr, Start, Len,
+ Ignored_Frame_Start, Ignored_Frame_End);
+ Print (Tr (Start .. Len));
+ end;
+
+ else
+ Print (Traceback.all);
+ end if;
+ end Put_Line;
+
+ -----------------
+ -- Skip_Levels --
+ -----------------
+
+ procedure Skip_Levels
+ (Depth : Natural;
+ Trace : Tracebacks_Array;
+ Start : out Natural;
+ Len : in out Natural;
+ Ignored_Frame_Start : System.Address;
+ Ignored_Frame_End : System.Address)
+ is
+ begin
+ Start := Trace'First;
+
+ while Start <= Len
+ and then (PC_For (Trace (Start)) < Ignored_Frame_Start
+ or else PC_For (Trace (Start)) > Ignored_Frame_End)
+ loop
+ Start := Start + 1;
+ end loop;
+
+ Start := Start + 1;
+
+ -- Just in case: make sure we have a traceback even if Ignore_Till
+ -- wasn't found.
+
+ if Start > Len then
+ Start := 1;
+ end if;
+
+ if Len - Start + 1 > Depth then
+ Len := Depth + Start - 1;
+ end if;
+ end Skip_Levels;
+
+ ------------------------------
+ -- Find_Or_Create_Traceback --
+ ------------------------------
+
+ function Find_Or_Create_Traceback
+ (Pool : Debug_Pool;
+ Kind : Traceback_Kind;
+ Size : Storage_Count;
+ Ignored_Frame_Start : System.Address;
+ Ignored_Frame_End : System.Address)
+ return Traceback_Htable_Elem_Ptr
+ is
+ begin
+ if Pool.Stack_Trace_Depth = 0 then
+ return null;
+ end if;
+
+ declare
+ Trace : aliased Tracebacks_Array
+ (1 .. Integer (Pool.Stack_Trace_Depth) + Max_Ignored_Levels);
+ Len, Start : Natural;
+ Elem : Traceback_Htable_Elem_Ptr;
+
+ begin
+ Call_Chain (Trace, Len);
+ Skip_Levels (Pool.Stack_Trace_Depth, Trace, Start, Len,
+ Ignored_Frame_Start, Ignored_Frame_End);
+
+ -- Check if the traceback is already in the table.
+
+ Elem :=
+ Backtrace_Htable.Get (Trace (Start .. Len)'Unrestricted_Access);
+
+ -- If not, insert it
+
+ if Elem = null then
+ Elem := new Traceback_Htable_Elem'
+ (Traceback => new Tracebacks_Array'(Trace (Start .. Len)),
+ Count => 1,
+ Kind => Kind,
+ Total => Byte_Count (Size),
+ Next => null);
+ Backtrace_Htable.Set (Elem);
+
+ else
+ Elem.Count := Elem.Count + 1;
+ Elem.Total := Elem.Total + Byte_Count (Size);
+ end if;
+
+ return Elem;
+ end;
+ end Find_Or_Create_Traceback;
+
+ --------------
+ -- Is_Valid --
+ --------------
+
+ function Is_Valid (Storage : System.Address) return Boolean is
+ Offset : constant Storage_Offset :=
+ (Storage - Edata) / Default_Alignment;
+
+ Bit : constant Byte := 2 ** Natural (Offset mod System.Storage_Unit);
+
+ begin
+ return (Storage mod Default_Alignment) = 0
+ and then Offset >= 0
+ and then Offset < Valid_Blocks_Size * Storage_Unit
+ and then (Valid_Blocks (Offset / Storage_Unit) and Bit) /= 0;
+ end Is_Valid;
+
+ ---------------
+ -- Set_Valid --
+ ---------------
+
+ procedure Set_Valid (Storage : System.Address; Value : Boolean) is
+ Offset : Storage_Offset;
+ Bit : Byte;
+ Bytes : Storage_Offset;
+ Tmp : constant Table_Ptr := Valid_Blocks;
+
+ Edata_Align : constant Storage_Offset :=
+ Default_Alignment * Storage_Unit;
+
+ procedure Memset (A : Address; C : Integer; N : size_t);
+ pragma Import (C, Memset, "memset");
+
+ procedure Memmove (Dest, Src : Address; N : size_t);
+ pragma Import (C, Memmove, "memmove");
+
+ begin
+ -- Allocate, or reallocate, the valid blocks table as needed. We start
+ -- with a size big enough to handle Initial_Memory_Size bytes of memory,
+ -- to avoid too many reallocations. The table will typically be around
+ -- 16Mb in that case, which is still small enough.
+
+ if Valid_Blocks_Size = 0 then
+ Valid_Blocks_Size := (Initial_Memory_Size / Default_Alignment)
+ / Storage_Unit;
+ Valid_Blocks := To_Pointer (Alloc (size_t (Valid_Blocks_Size)));
+ Edata := Storage;
+
+ -- Reset the memory using memset, which is much faster than the
+ -- standard Ada code with "when others"
+
+ Memset (Valid_Blocks.all'Address, 0, size_t (Valid_Blocks_Size));
+ end if;
+
+ -- First case : the new address is outside of the current scope of
+ -- Valid_Blocks, before the current start address. We need to reallocate
+ -- the table accordingly. This should be a rare occurence, since in most
+ -- cases, the first allocation will also have the lowest address. But
+ -- there is no garantee...
+
+ if Storage < Edata then
+
+ -- The difference between the new Edata and the current one must be
+ -- a multiple of Default_Alignment * Storage_Unit, so that the bit
+ -- representing an address in Valid_Blocks are kept the same.
+
+ Offset := ((Edata - Storage) / Edata_Align + 1) * Edata_Align;
+ Offset := Offset / Default_Alignment;
+ Bytes := Offset / Storage_Unit;
+ Valid_Blocks :=
+ To_Pointer (Alloc (Size => size_t (Valid_Blocks_Size + Bytes)));
+ Memmove (Dest => Valid_Blocks.all'Address + Bytes,
+ Src => Tmp.all'Address,
+ N => size_t (Valid_Blocks_Size));
+ Memset (A => Valid_Blocks.all'Address,
+ C => 0,
+ N => size_t (Bytes));
+ Free (Tmp.all'Address);
+ Valid_Blocks_Size := Valid_Blocks_Size + Bytes;
+
+ -- Take into the account the new start address
+ Edata := Storage - Edata_Align + (Edata - Storage) mod Edata_Align;
+ end if;
+
+ -- Second case : the new address is outside of the current scope of
+ -- Valid_Blocks, so we have to grow the table as appropriate
+
+ Offset := (Storage - Edata) / Default_Alignment;
+
+ if Offset >= Valid_Blocks_Size * System.Storage_Unit then
+ Bytes := Valid_Blocks_Size;
+ loop
+ Bytes := 2 * Bytes;
+ exit when Offset <= Bytes * System.Storage_Unit;
+ end loop;
+
+ Valid_Blocks := To_Pointer
+ (Realloc (Ptr => Valid_Blocks.all'Address,
+ Size => size_t (Bytes)));
+ Memset
+ (Valid_Blocks.all'Address + Valid_Blocks_Size,
+ 0,
+ size_t (Bytes - Valid_Blocks_Size));
+ Valid_Blocks_Size := Bytes;
+ end if;
+
+ Bit := 2 ** Natural (Offset mod System.Storage_Unit);
+ Bytes := Offset / Storage_Unit;
+
+ -- Then set the value as valid
+
+ if Value then
+ Valid_Blocks (Bytes) := Valid_Blocks (Bytes) or Bit;
+ else
+ Valid_Blocks (Bytes) := Valid_Blocks (Bytes) and (not Bit);
+ end if;
+ end Set_Valid;
--------------
-- Allocate --
@@ -68,23 +666,399 @@ package body GNAT.Debug_Pools is
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
- pragma Warnings (Off, Alignment);
+ pragma Unreferenced (Alignment);
+ -- Ignored, we always force 'Default_Alignment
+
+ type Local_Storage_Array is new Storage_Array
+ (1 .. Size_In_Storage_Elements + Minimum_Allocation);
+ for Local_Storage_Array'Alignment use Standard'Maximum_Alignment;
+ -- For performance reasons, make sure the alignment is maximized.
+
+ type Ptr is access Local_Storage_Array;
+ -- On some systems, we might want to physically protect pages
+ -- against writing when they have been freed (of course, this is
+ -- expensive in terms of wasted memory). To do that, all we should
+ -- have to do it to set the size of this array to the page size.
+ -- See mprotect().
+
+ P : Ptr;
+
+ Current : Byte_Count;
+ Trace : Traceback_Htable_Elem_Ptr;
begin
- Storage_Address := Alloc (size_t (Size_In_Storage_Elements));
+ <<Allocate_Label>>
+ Lock_Task.all;
- if Storage_Address = Null_Address then
- raise Storage_Error;
- else
- Table.Set (Storage_Address, Allocated);
- Pool.Allocated := Pool.Allocated + Size_In_Storage_Elements;
+ -- If necessary, start physically releasing memory. The reason this is
+ -- done here, although Pool.Logically_Deallocated has not changed above,
+ -- is so that we do this only after a series of deallocations (e.g a
+ -- loop that deallocates a big array). If we were doing that in
+ -- Deallocate, we might be physically freeing memory several times
+ -- during the loop, which is expensive.
- if Pool.Allocated - Pool.Deallocated > Pool.High_Water then
- Pool.High_Water := Pool.Allocated - Pool.Deallocated;
- end if;
+ if Pool.Logically_Deallocated >
+ Byte_Count (Pool.Maximum_Logically_Freed_Memory)
+ then
+ Free_Physically (Pool);
+ end if;
+
+ -- Use standard (ie through malloc) allocations. This automatically
+ -- raises Storage_Error if needed. We also try once more to physically
+ -- release memory, so that even marked blocks, in the advanced scanning,
+ -- are freed.
+
+ begin
+ P := new Local_Storage_Array;
+
+ exception
+ when Storage_Error =>
+ Free_Physically (Pool);
+ P := new Local_Storage_Array;
+ end;
+
+ Storage_Address := P.all'Address + Minimum_Allocation;
+
+ Trace := Find_Or_Create_Traceback
+ (Pool, Alloc, Size_In_Storage_Elements,
+ Allocate_Label'Address, Code_Address_For_Allocate_End);
+
+ pragma Warnings (Off);
+ -- Turn warning on alignment for convert call off. We know that in
+ -- fact this conversion is safe since P itself is always aligned on
+ -- Default_Alignment.
+
+ Header_Of (Storage_Address).all :=
+ (Alloc_Traceback => Trace,
+ Dealloc_Traceback => To_Traceback (null),
+ Next => Pool.First_Used_Block,
+ Block_Size => Size_In_Storage_Elements);
+
+ pragma Warnings (On);
+
+ -- Link this block in the list of used blocks. This will be used to list
+ -- memory leaks in Print_Info, and for the advanced schemes of
+ -- Physical_Free, where we want to traverse all allocated blocks and
+ -- search for possible references.
+
+ -- We insert in front, since most likely we'll be freeing the most
+ -- recently allocated blocks first (the older one might stay allocated
+ -- for the whole life of the application).
+
+ if Pool.First_Used_Block /= System.Null_Address then
+ Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=
+ To_Address (Storage_Address);
+ end if;
+
+ Pool.First_Used_Block := Storage_Address;
+
+ -- Mark the new address as valid
+
+ Set_Valid (Storage_Address, True);
+
+ -- Update internal data
+
+ Pool.Allocated :=
+ Pool.Allocated + Byte_Count (Size_In_Storage_Elements);
+
+ Current := Pool.Allocated -
+ Pool.Logically_Deallocated -
+ Pool.Physically_Deallocated;
+
+ if Current > Pool.High_Water then
+ Pool.High_Water := Current;
end if;
+
+ Unlock_Task.all;
end Allocate;
+ ------------------
+ -- Allocate_End --
+ ------------------
+
+ -- DO NOT MOVE, this must be right after Allocate. This is similar to
+ -- what is done in a-except, so that we can hide the traceback frames
+ -- internal to this package
+
+ procedure Allocate_End is
+ begin
+ <<Allocate_End_Label>>
+ Code_Address_For_Allocate_End := Allocate_End_Label'Address;
+ end Allocate_End;
+
+ -------------------
+ -- Set_Dead_Beef --
+ -------------------
+
+ procedure Set_Dead_Beef
+ (Storage_Address : System.Address;
+ Size_In_Storage_Elements : Storage_Count)
+ is
+ Dead_Bytes : constant := 4;
+
+ type Data is mod 2 ** (Dead_Bytes * 8);
+ for Data'Size use Dead_Bytes * 8;
+
+ Dead : constant Data := 16#DEAD_BEEF#;
+
+ type Dead_Memory is array
+ (1 .. Size_In_Storage_Elements / Dead_Bytes) of Data;
+ type Mem_Ptr is access Dead_Memory;
+
+ type Byte is mod 2 ** 8;
+ for Byte'Size use 8;
+
+ type Dead_Memory_Bytes is array (0 .. 2) of Byte;
+ type Dead_Memory_Bytes_Ptr is access Dead_Memory_Bytes;
+
+ function From_Ptr is new Ada.Unchecked_Conversion
+ (System.Address, Mem_Ptr);
+
+ function From_Ptr is new Ada.Unchecked_Conversion
+ (System.Address, Dead_Memory_Bytes_Ptr);
+
+ M : constant Mem_Ptr := From_Ptr (Storage_Address);
+ M2 : Dead_Memory_Bytes_Ptr;
+ Modulo : constant Storage_Count :=
+ Size_In_Storage_Elements mod Dead_Bytes;
+ begin
+ M.all := (others => Dead);
+
+ -- Any bytes left (up to three of them)
+
+ if Modulo /= 0 then
+ M2 := From_Ptr (Storage_Address + M'Length * Dead_Bytes);
+
+ M2 (0) := 16#DE#;
+ if Modulo >= 2 then
+ M2 (1) := 16#AD#;
+
+ if Modulo >= 3 then
+ M2 (2) := 16#BE#;
+ end if;
+ end if;
+ end if;
+ end Set_Dead_Beef;
+
+ ---------------------
+ -- Free_Physically --
+ ---------------------
+
+ procedure Free_Physically (Pool : in out Debug_Pool) is
+ type Byte is mod 256;
+ type Byte_Access is access Byte;
+
+ function To_Byte is new Ada.Unchecked_Conversion
+ (System.Address, Byte_Access);
+
+ type Address_Access is access System.Address;
+
+ function To_Address_Access is new Ada.Unchecked_Conversion
+ (System.Address, Address_Access);
+
+ In_Use_Mark : constant Byte := 16#D#;
+ Free_Mark : constant Byte := 16#F#;
+
+ Total_Freed : Storage_Count := 0;
+
+ procedure Reset_Marks;
+ -- Unmark all the logically freed blocks, so that they are considered
+ -- for physical deallocation
+
+ procedure Mark
+ (H : Allocation_Header_Access; A : System.Address; In_Use : Boolean);
+ -- Mark the user data block starting at A. For a block of size zero,
+ -- nothing is done. For a block with a different size, the first byte
+ -- is set to either "D" (in use) or "F" (free).
+
+ function Marked (A : System.Address) return Boolean;
+ -- Return true if the user data block starting at A might be in use
+ -- somewhere else
+
+ procedure Mark_Blocks;
+ -- Traverse all allocated blocks, and search for possible references
+ -- to logically freed blocks. Mark them appropriately
+
+ procedure Free_Blocks (Ignore_Marks : Boolean);
+ -- Physically release blocks. Only the blocks that haven't been marked
+ -- will be released, unless Ignore_Marks is true.
+
+ -----------------
+ -- Free_Blocks --
+ -----------------
+
+ procedure Free_Blocks (Ignore_Marks : Boolean) is
+ Header : Allocation_Header_Access;
+ Tmp : System.Address := Pool.First_Free_Block;
+ Next : System.Address;
+ Previous : System.Address := System.Null_Address;
+
+ begin
+ while Tmp /= System.Null_Address
+ and then Total_Freed < Pool.Minimum_To_Free
+ loop
+ Header := Header_Of (Tmp);
+
+ -- If we know, or at least assume, the block is no longer
+ -- reference anywhere, we can free it physically.
+
+ if Ignore_Marks or else not Marked (Tmp) then
+
+ declare
+ pragma Suppress (All_Checks);
+ -- Suppress the checks on this section. If they are overflow
+ -- errors, it isn't critical, and we'd rather avoid a
+ -- Constraint_Error in that case.
+ begin
+ -- Note that block_size < zero for freed blocks
+
+ Pool.Physically_Deallocated :=
+ Pool.Physically_Deallocated -
+ Byte_Count (Header.Block_Size);
+
+ Pool.Logically_Deallocated :=
+ Pool.Logically_Deallocated +
+ Byte_Count (Header.Block_Size);
+
+ Total_Freed := Total_Freed - Header.Block_Size;
+ end;
+
+ Next := Header.Next;
+ System.Memory.Free (Header.all'Address);
+ Set_Valid (Tmp, False);
+
+ -- Remove this block from the list.
+
+ if Previous = System.Null_Address then
+ Pool.First_Free_Block := Next;
+ else
+ Header_Of (Previous).Next := Next;
+ end if;
+
+ Tmp := Next;
+
+ else
+ Previous := Tmp;
+ Tmp := Header.Next;
+ end if;
+ end loop;
+ end Free_Blocks;
+
+ ----------
+ -- Mark --
+ ----------
+
+ procedure Mark
+ (H : Allocation_Header_Access;
+ A : System.Address;
+ In_Use : Boolean)
+ is
+ begin
+ if H.Block_Size /= 0 then
+ if In_Use then
+ To_Byte (A).all := In_Use_Mark;
+ else
+ To_Byte (A).all := Free_Mark;
+ end if;
+ end if;
+ end Mark;
+
+ -----------------
+ -- Mark_Blocks --
+ -----------------
+
+ procedure Mark_Blocks is
+ Tmp : System.Address := Pool.First_Used_Block;
+ Previous : System.Address;
+ Last : System.Address;
+ Pointed : System.Address;
+ Header : Allocation_Header_Access;
+
+ begin
+ -- For each allocated block, check its contents. Things that look
+ -- like a possible address are used to mark the blocks so that we try
+ -- and keep them, for better detection in case of invalid access.
+ -- This mechanism is far from being fool-proof: it doesn't check the
+ -- stacks of the threads, doesn't check possible memory allocated not
+ -- under control of this debug pool. But it should allow us to catch
+ -- more cases.
+
+ while Tmp /= System.Null_Address loop
+ Previous := Tmp;
+ Last := Tmp + Header_Of (Tmp).Block_Size;
+ while Previous < Last loop
+ -- ??? Should we move byte-per-byte, or consider that addresses
+ -- are always aligned on 4-bytes boundaries ? Let's use the
+ -- fastest for now.
+
+ Pointed := To_Address_Access (Previous).all;
+ if Is_Valid (Pointed) then
+ Header := Header_Of (Pointed);
+
+ -- Do not even attempt to mark blocks in use. That would
+ -- screw up the whole application, of course.
+ if Header.Block_Size < 0 then
+ Mark (Header, Pointed, In_Use => True);
+ end if;
+ end if;
+
+ Previous := Previous + System.Address'Size;
+ end loop;
+
+ Tmp := Header_Of (Tmp).Next;
+ end loop;
+ end Mark_Blocks;
+
+ ------------
+ -- Marked --
+ ------------
+
+ function Marked (A : System.Address) return Boolean is
+ begin
+ return To_Byte (A).all = In_Use_Mark;
+ end Marked;
+
+ -----------------
+ -- Reset_Marks --
+ -----------------
+
+ procedure Reset_Marks is
+ Current : System.Address := Pool.First_Free_Block;
+ Header : Allocation_Header_Access;
+
+ begin
+ while Current /= System.Null_Address loop
+ Header := Header_Of (Current);
+ Mark (Header, Current, False);
+ Current := Header.Next;
+ end loop;
+ end Reset_Marks;
+
+ -- Start of processing for Free_Physically
+
+ begin
+ Lock_Task.all;
+
+ if Pool.Advanced_Scanning then
+ Reset_Marks; -- Reset the mark for each freed block
+ Mark_Blocks;
+ end if;
+
+ Free_Blocks (Ignore_Marks => not Pool.Advanced_Scanning);
+
+ -- The contract is that we need to free at least Minimum_To_Free bytes,
+ -- even if this means freeing marked blocks in the advanced scheme
+
+ if Total_Freed < Pool.Minimum_To_Free
+ and then Pool.Advanced_Scanning
+ then
+ Pool.Marked_Blocks_Deallocated := True;
+ Free_Blocks (Ignore_Marks => True);
+ end if;
+
+ Unlock_Task.all;
+ end Free_Physically;
+
----------------
-- Deallocate --
----------------
@@ -95,55 +1069,119 @@ package body GNAT.Debug_Pools is
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
- pragma Warnings (Off, Alignment);
+ pragma Unreferenced (Alignment);
+
+ Header : constant Allocation_Header_Access :=
+ Header_Of (Storage_Address);
+ Valid : Boolean;
+ Previous : System.Address;
+
+ begin
+ <<Deallocate_Label>>
+ Lock_Task.all;
+ Valid := Is_Valid (Storage_Address);
+
+ if not Valid then
+ Unlock_Task.all;
+ if Pool.Raise_Exceptions then
+ raise Freeing_Not_Allocated_Storage;
+ else
+ Put ("Freeing not allocated storage, at ");
+ Put_Line (Pool.Stack_Trace_Depth, null,
+ Deallocate_Label'Address,
+ Code_Address_For_Deallocate_End);
+ end if;
- procedure Free (Address : System.Address; Siz : Storage_Count);
- -- Fake free, that resets all the deallocated storage to "DEADBEEF"
+ elsif Header.Block_Size < 0 then
+ Unlock_Task.all;
+ if Pool.Raise_Exceptions then
+ raise Freeing_Deallocated_Storage;
+ else
+ Put ("Freeing already deallocated storage, at ");
+ Put_Line (Pool.Stack_Trace_Depth, null,
+ Deallocate_Label'Address,
+ Code_Address_For_Deallocate_End);
+ Put (" Memory already deallocated at ");
+ Put_Line (0, To_Traceback (Header.Dealloc_Traceback).Traceback);
+ end if;
- procedure Free (Address : System.Address; Siz : Storage_Count) is
- DB1 : constant Integer := 16#DEAD#;
- DB2 : constant Integer := 16#BEEF#;
+ else
+ -- Remove this block from the list of used blocks.
- type Dead_Memory is array (1 .. Siz / 4) of Integer;
- type Mem_Ptr is access all Dead_Memory;
+ Previous :=
+ To_Address (Header_Of (Storage_Address).Dealloc_Traceback);
- function From_Ptr is
- new Unchecked_Conversion (System.Address, Mem_Ptr);
+ if Previous = System.Null_Address then
+ Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next;
- J : Storage_Offset;
+ if Pool.First_Used_Block /= System.Null_Address then
+ Header_Of (Pool.First_Used_Block).Dealloc_Traceback :=
+ To_Traceback (null);
+ end if;
- begin
- J := Dead_Memory'First;
- while J < Dead_Memory'Last loop
- From_Ptr (Address) (J) := DB1;
- From_Ptr (Address) (J + 1) := DB2;
- J := J + 2;
- end loop;
+ else
+ Header_Of (Previous).Next := Header_Of (Storage_Address).Next;
- if J = Dead_Memory'Last then
- From_Ptr (Address) (J) := DB1;
+ if Header_Of (Storage_Address).Next /= System.Null_Address then
+ Header_Of
+ (Header_Of (Storage_Address).Next).Dealloc_Traceback :=
+ To_Address (Previous);
+ end if;
end if;
- end Free;
- S : State := Table.Get (Storage_Address);
+ -- Update the header
- -- Start of processing for Deallocate
+ Header.all :=
+ (Alloc_Traceback => Header.Alloc_Traceback,
+ Dealloc_Traceback => To_Traceback
+ (Find_Or_Create_Traceback
+ (Pool, Dealloc,
+ Size_In_Storage_Elements,
+ Deallocate_Label'Address,
+ Code_Address_For_Deallocate_End)),
+ Next => System.Null_Address,
+ Block_Size => -Size_In_Storage_Elements);
- begin
- case S is
- when Not_Allocated =>
- raise Freeing_Not_Allocated_Storage;
+ if Pool.Reset_Content_On_Free then
+ Set_Dead_Beef (Storage_Address, Size_In_Storage_Elements);
+ end if;
- when Deallocated =>
- raise Freeing_Deallocated_Storage;
+ Pool.Logically_Deallocated :=
+ Pool.Logically_Deallocated +
+ Byte_Count (Size_In_Storage_Elements);
- when Allocated =>
- Free (Storage_Address, Size_In_Storage_Elements);
- Table.Set (Storage_Address, Deallocated);
- Pool.Deallocated := Pool.Deallocated + Size_In_Storage_Elements;
- end case;
+ -- Link this free block with the others (at the end of the list, so
+ -- that we can start releasing the older blocks first later on).
+
+ if Pool.First_Free_Block = System.Null_Address then
+ Pool.First_Free_Block := Storage_Address;
+ Pool.Last_Free_Block := Storage_Address;
+
+ else
+ Header_Of (Pool.Last_Free_Block).Next := Storage_Address;
+ Pool.Last_Free_Block := Storage_Address;
+ end if;
+
+ -- Do not physically release the memory here, but in Alloc.
+ -- See comment there for details.
+
+ Unlock_Task.all;
+ end if;
end Deallocate;
+ --------------------
+ -- Deallocate_End --
+ --------------------
+
+ -- DO NOT MOVE, this must be right after Deallocate
+ -- See Allocate_End
+
+ procedure Deallocate_End is
+ begin
+ <<Deallocate_End_Label>>
+ Code_Address_For_Deallocate_End := Deallocate_End_Label'Address;
+ end Deallocate_End;
+
-----------------
-- Dereference --
-----------------
@@ -154,68 +1192,238 @@ package body GNAT.Debug_Pools is
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count)
is
- pragma Warnings (Off, Pool);
- pragma Warnings (Off, Size_In_Storage_Elements);
- pragma Warnings (Off, Alignment);
+ pragma Unreferenced (Alignment, Size_In_Storage_Elements);
- S : State := Table.Get (Storage_Address);
- Max_Dim : constant := 3;
- Dim : Integer := 1;
+ Valid : constant Boolean := Is_Valid (Storage_Address);
+ Header : Allocation_Header_Access;
begin
+ -- Locking policy: we do not do any locking in this procedure. The
+ -- tables are only read, not written to, and although a problem might
+ -- appear if someone else is modifying the tables at the same time, this
+ -- race condition is not intended to be detected by this storage_pool (a
+ -- now invalid pointer would appear as valid). Instead, we prefer
+ -- optimum performance for dereferences.
- -- If this is not a known address, maybe it is because is is an
- -- unconstained array. In which case, the bounds have used the
- -- 2 first words (per dimension) of the allocated spot.
-
- while S = Not_Allocated and then Dim <= Max_Dim loop
- S := Table.Get (Storage_Address - Storage_Offset (Dim * 2 * 4));
- Dim := Dim + 1;
- end loop;
+ <<Dereference_Label>>
- case S is
- when Not_Allocated =>
+ if not Valid then
+ if Pool.Raise_Exceptions then
raise Accessing_Not_Allocated_Storage;
+ else
+ Put ("Accessing not allocated storage, at ");
+ Put_Line (Pool.Stack_Trace_Depth, null,
+ Dereference_Label'Address,
+ Code_Address_For_Dereference_End);
+ end if;
- when Deallocated =>
- raise Accessing_Deallocated_Storage;
+ else
+ Header := Header_Of (Storage_Address);
- when Allocated =>
- null;
- end case;
+ if Header.Block_Size < 0 then
+ if Pool.Raise_Exceptions then
+ raise Accessing_Deallocated_Storage;
+ else
+ Put ("Accessing deallocated storage, at ");
+ Put_Line
+ (Pool.Stack_Trace_Depth, null,
+ Dereference_Label'Address,
+ Code_Address_For_Dereference_End);
+ Put (" First deallocation at ");
+ Put_Line (0, To_Traceback (Header.Dealloc_Traceback).Traceback);
+ end if;
+ end if;
+ end if;
end Dereference;
- -------
- -- H --
- -------
+ ---------------------
+ -- Dereference_End --
+ ---------------------
+
+ -- DO NOT MOVE: this must be right after Dereference
+ -- See Allocate_End
- function H (F : Address) return Header is
+ procedure Dereference_End is
begin
- return
- Header (1 + (To_Integer (F) mod Integer_Address (Header'Last)));
- end H;
+ <<Dereference_End_Label>>
+ Code_Address_For_Dereference_End := Dereference_End_Label'Address;
+ end Dereference_End;
----------------
-- Print_Info --
----------------
- procedure Print_Info (Pool : Debug_Pool) is
+ procedure Print_Info
+ (Pool : Debug_Pool;
+ Cumulate : Boolean := False;
+ Display_Slots : Boolean := False;
+ Display_Leaks : Boolean := False)
+ is
use System.Storage_Elements;
+ package Backtrace_Htable_Cumulate is new GNAT.HTable.Static_HTable
+ (Header_Num => Header,
+ Element => Traceback_Htable_Elem,
+ Elmt_Ptr => Traceback_Htable_Elem_Ptr,
+ Null_Ptr => null,
+ Set_Next => Set_Next,
+ Next => Next,
+ Key => Tracebacks_Array_Access,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => Equal);
+ -- This needs a comment ??? probably some of the ones below do too???
+
+ Data : Traceback_Htable_Elem_Ptr;
+ Elem : Traceback_Htable_Elem_Ptr;
+ Current : System.Address;
+ Header : Allocation_Header_Access;
+ K : Traceback_Kind;
+
begin
- Put_Line ("Debug Pool info:");
- Put_Line (" Total allocated bytes : "
- & Storage_Offset'Image (Pool.Allocated));
+ Put_Line
+ ("Total allocated bytes : " &
+ Byte_Count'Image (Pool.Allocated));
- Put_Line (" Total deallocated bytes : "
- & Storage_Offset'Image (Pool.Deallocated));
+ Put_Line
+ ("Total logically deallocated bytes : " &
+ Byte_Count'Image (Pool.Logically_Deallocated));
- Put_Line (" Current Water Mark: "
- & Storage_Offset'Image (Pool.Allocated - Pool.Deallocated));
+ Put_Line
+ ("Total physically deallocated bytes : " &
+ Byte_Count'Image (Pool.Physically_Deallocated));
+
+ if Pool.Marked_Blocks_Deallocated then
+ Put_Line ("Marked blocks were physically deallocated. This is");
+ Put_Line ("potentially dangereous, and you might want to run");
+ Put_Line ("again with a lower value of Minimum_To_Free");
+ end if;
+
+ Put_Line
+ ("Current Water Mark: " &
+ Byte_Count'Image
+ (Pool.Allocated - Pool.Logically_Deallocated
+ - Pool.Physically_Deallocated));
+
+ Put_Line
+ ("High Water Mark: " &
+ Byte_Count'Image (Pool.High_Water));
- Put_Line (" High Water Mark: "
- & Storage_Offset'Image (Pool.High_Water));
Put_Line ("");
+
+ Data := Backtrace_Htable.Get_First;
+ while Data /= null loop
+ if Data.Kind in Alloc .. Dealloc then
+ Elem :=
+ new Traceback_Htable_Elem'
+ (Traceback => new Tracebacks_Array'(Data.Traceback.all),
+ Count => Data.Count,
+ Kind => Data.Kind,
+ Total => Data.Total,
+ Next => null);
+ Backtrace_Htable_Cumulate.Set (Elem);
+
+ if Cumulate then
+ if Data.Kind = Alloc then
+ K := Indirect_Alloc;
+ else
+ K := Indirect_Dealloc;
+ end if;
+
+ -- Propagate the direct call to all its parents
+
+ for T in Data.Traceback'First + 1 .. Data.Traceback'Last loop
+ Elem := Backtrace_Htable_Cumulate.Get
+ (Data.Traceback
+ (T .. Data.Traceback'Last)'Unrestricted_Access);
+
+ -- If not, insert it
+
+ if Elem = null then
+ Elem := new Traceback_Htable_Elem'
+ (Traceback => new Tracebacks_Array'
+ (Data.Traceback (T .. Data.Traceback'Last)),
+ Count => Data.Count,
+ Kind => K,
+ Total => Data.Total,
+ Next => null);
+ Backtrace_Htable_Cumulate.Set (Elem);
+
+ -- Properly take into account that the subprograms
+ -- indirectly called might be doing either allocations
+ -- or deallocations. This needs to be reflected in the
+ -- counts.
+
+ else
+ Elem.Count := Elem.Count + Data.Count;
+
+ if K = Elem.Kind then
+ Elem.Total := Elem.Total + Data.Total;
+
+ elsif Elem.Total > Data.Total then
+ Elem.Total := Elem.Total - Data.Total;
+
+ else
+ Elem.Kind := K;
+ Elem.Total := Data.Total - Elem.Total;
+ end if;
+ end if;
+ end loop;
+ end if;
+
+ Data := Backtrace_Htable.Get_Next;
+ end if;
+ end loop;
+
+ if Display_Slots then
+ Put_Line ("List of allocations/deallocations: ");
+
+ Data := Backtrace_Htable_Cumulate.Get_First;
+ while Data /= null loop
+ case Data.Kind is
+ when Alloc => Put ("alloc (count:");
+ when Indirect_Alloc => Put ("indirect alloc (count:");
+ when Dealloc => Put ("free (count:");
+ when Indirect_Dealloc => Put ("indirect free (count:");
+ end case;
+
+ Put (Natural'Image (Data.Count) & ", total:" &
+ Byte_Count'Image (Data.Total) & ") ");
+
+ for T in Data.Traceback'Range loop
+ Put ("0x" & Address_Image (PC_For (Data.Traceback (T))) & ' ');
+ end loop;
+
+ Put_Line ("");
+
+ Data := Backtrace_Htable_Cumulate.Get_Next;
+ end loop;
+ end if;
+
+ if Display_Leaks then
+ Put_Line ("");
+ Put_Line ("List of not deallocated blocks:");
+
+ -- Do not try to group the blocks with the same stack traces
+ -- together. This is done by the gnatmem output.
+
+ Current := Pool.First_Used_Block;
+ while Current /= System.Null_Address loop
+ Header := Header_Of (Current);
+
+ Put ("Size: " & Storage_Count'Image (Header.Block_Size) & " at: ");
+
+ for T in Header.Alloc_Traceback.Traceback'Range loop
+ Put ("0x" & Address_Image
+ (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' ');
+ end loop;
+
+ Put_Line ("");
+ Current := Header.Next;
+ end loop;
+ end if;
+
+ Backtrace_Htable_Cumulate.Reset;
end Print_Info;
------------------
@@ -223,10 +1431,170 @@ package body GNAT.Debug_Pools is
------------------
function Storage_Size (Pool : Debug_Pool) return Storage_Count is
- pragma Warnings (Off, Pool);
+ pragma Unreferenced (Pool);
begin
return Storage_Count'Last;
end Storage_Size;
+ ---------------
+ -- Configure --
+ ---------------
+
+ procedure Configure
+ (Pool : in out Debug_Pool;
+ Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth;
+ Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed;
+ Minimum_To_Free : SSC := Default_Min_Freed;
+ Reset_Content_On_Free : Boolean := Default_Reset_Content;
+ Raise_Exceptions : Boolean := Default_Raise_Exceptions;
+ Advanced_Scanning : Boolean := Default_Advanced_Scanning)
+ is
+ begin
+ Pool.Stack_Trace_Depth := Stack_Trace_Depth;
+ Pool.Maximum_Logically_Freed_Memory := Maximum_Logically_Freed_Memory;
+ Pool.Reset_Content_On_Free := Reset_Content_On_Free;
+ Pool.Raise_Exceptions := Raise_Exceptions;
+ Pool.Minimum_To_Free := Minimum_To_Free;
+ Pool.Advanced_Scanning := Advanced_Scanning;
+ end Configure;
+
+ ----------------
+ -- Print_Pool --
+ ----------------
+
+ procedure Print_Pool (A : System.Address) is
+ Storage : constant Address := A;
+ Valid : constant Boolean := Is_Valid (Storage);
+ Header : Allocation_Header_Access;
+
+ begin
+ -- We might get Null_Address if the call from gdb was done
+ -- incorrectly. For instance, doing a "print_pool(my_var)" passes 0x0,
+ -- instead of passing the value of my_var
+
+ if A = System.Null_Address then
+ Put_Line ("Memory not under control of the storage pool");
+ return;
+ end if;
+
+ if not Valid then
+ Put_Line ("Memory not under control of the storage pool");
+
+ else
+ Header := Header_Of (Storage);
+ Put_Line ("0x" & Address_Image (A)
+ & " allocated at:");
+ Put_Line (0, Header.Alloc_Traceback.Traceback);
+
+ if To_Traceback (Header.Dealloc_Traceback) /= null then
+ Put_Line ("0x" & Address_Image (A)
+ & " logically freed memory, deallocated at:");
+ Put_Line (0, To_Traceback (Header.Dealloc_Traceback).Traceback);
+ end if;
+ end if;
+ end Print_Pool;
+
+ -----------------------
+ -- Print_Info_Stdout --
+ -----------------------
+
+ procedure Print_Info_Stdout
+ (Pool : Debug_Pool;
+ Cumulate : Boolean := False;
+ Display_Slots : Boolean := False;
+ Display_Leaks : Boolean := False)
+ is
+ procedure Internal is new Print_Info
+ (Put_Line => GNAT.IO.Put_Line,
+ Put => GNAT.IO.Put);
+
+ begin
+ Internal (Pool, Cumulate, Display_Slots, Display_Leaks);
+ end Print_Info_Stdout;
+
+ ------------------
+ -- Dump_Gnatmem --
+ ------------------
+
+ procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String) is
+ type File_Ptr is new System.Address;
+
+ function fopen (Path : String; Mode : String) return File_Ptr;
+ pragma Import (C, fopen);
+
+ procedure fwrite
+ (Ptr : System.Address;
+ Size : size_t;
+ Nmemb : size_t;
+ Stream : File_Ptr);
+
+ procedure fwrite
+ (Str : String;
+ Size : size_t;
+ Nmemb : size_t;
+ Stream : File_Ptr);
+ pragma Import (C, fwrite);
+
+ procedure fputc (C : Integer; Stream : File_Ptr);
+ pragma Import (C, fputc);
+
+ procedure fclose (Stream : File_Ptr);
+ pragma Import (C, fclose);
+
+ Address_Size : constant size_t :=
+ System.Address'Max_Size_In_Storage_Elements;
+ -- Size in bytes of a pointer
+
+ File : File_Ptr;
+ Current : System.Address;
+ Header : Allocation_Header_Access;
+ Actual_Size : size_t;
+ Num_Calls : Integer;
+ Tracebk : Tracebacks_Array_Access;
+
+ begin
+ File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL);
+ fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File);
+
+ -- List of not deallocated blocks (see Print_Info)
+
+ Current := Pool.First_Used_Block;
+ while Current /= System.Null_Address loop
+ Header := Header_Of (Current);
+
+ Actual_Size := size_t (Header.Block_Size);
+ Tracebk := Header.Alloc_Traceback.Traceback;
+ Num_Calls := Tracebk'Length;
+
+ -- Code taken from memtrack.adb in GNAT's sources
+ -- Logs allocation call
+ -- format is:
+ -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
+
+ fputc (Character'Pos ('A'), File);
+ fwrite (Current'Address, Address_Size, 1, File);
+ fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
+ File);
+ fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
+ File);
+
+ for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
+ declare
+ Ptr : System.Address := PC_For (Tracebk (J));
+ begin
+ fwrite (Ptr'Address, Address_Size, 1, File);
+ end;
+ end loop;
+
+ Current := Header.Next;
+ end loop;
+
+ fclose (File);
+ end Dump_Gnatmem;
+
+begin
+ Allocate_End;
+ Deallocate_End;
+ Dereference_End;
end GNAT.Debug_Pools;
diff --git a/gcc/ada/g-debpoo.ads b/gcc/ada/g-debpoo.ads
index 0da981d8b77..3cfe1bc270a 100644
--- a/gcc/ada/g-debpoo.ads
+++ b/gcc/ada/g-debpoo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -31,34 +31,218 @@
-- --
------------------------------------------------------------------------------
+-- This packages provides a special implementation of the Ada95 storage pools.
+--
+-- The goal of this debug pool is to detect incorrect uses of memory
+-- (multiple deallocations, access to invalid memory,...). Errors are reported
+-- in one of two ways: either by immediately raising an exception, or by
+-- printing a message on standard output.
+--
+-- You need to instrument your code to use this package: for each access type
+-- you want to monitor, you need to add a clause similar to:
+--
+-- type Integer_Access is access Integer;
+-- for Integer_Access'Storage_Pool use Pool;
+
+-- where Pool is a tagged object declared with
+--
+-- Pool : GNAT.Debug_Pools.Debug_Pool;
+--
+-- This package was designed to be as efficient as possible, but still has an
+-- impact on the performance of your code, which depends on the number of
+-- allocations, deallocations and, somewhat less, dereferences that your
+-- application performs.
+--
+-- For each faulty memory use, this debug pool will print several lines
+-- of information, including things like the location where the memory
+-- was initially allocated, the location where it was freed etc.
+--
+-- Physical allocations and deallocations are done through the usual system
+-- calls. However, in order to provide proper checks, the debug pool will not
+-- release the memory immediately. It keeps released memory around (the amount
+-- kept around is configurable) so that it can distinguish between memory that
+-- has not been allocated and memory that has been allocated but freed. This
+-- also means that this memory cannot be reallocated, preventing what would
+-- otherwise be a false indication that freed memory is now allocated.
+--
+-- In addition, this package presents several subprograms that help analyze
+-- the behavior of your program, by reporting memory leaks, the total amount
+-- of memory that was allocated. The pool is also designed to work correctly
+-- in conjunction with gnatmem.
+--
+-- Finally, a subprogram Print_Pool is provided for use from the debugger.
+--
+-- Limitations
+-- ===========
+--
+-- Current limitation of this debug pool: if you use this debug pool for a
+-- general access type ("access all"), the pool might report invalid
+-- dereferences if the access object is pointing to another object on the
+-- stack which was not allocated through a call to "new".
+--
+-- This debug pool will respect all alignments specified in your code, but
+-- it does that by aligning all objects using Standard'Maximum_Alignment.
+-- This allows faster checks, and limits the performance impact of using
+-- this pool.
+--
+
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;
with System.Checked_Pools;
package GNAT.Debug_Pools is
- -- The debug pool is used to track down memory corruption due to use of
- -- deallocated memory or incorrect unchecked conversions. Allocation
- -- strategy :
+ type Debug_Pool is new System.Checked_Pools.Checked_Pool with private;
+ -- The new debug pool
- -- - allocation: . memory is normally allocated with malloc
- -- . the allocated address is noted in a table
+ subtype SSC is System.Storage_Elements.Storage_Count;
- -- - deallocation: . memory is filled with "DEAD_BEEF" patterns
- -- . memory is not freed
- -- . exceptions are raised if the memory was not
- -- allocated or was already deallocated
+ Default_Max_Freed : constant SSC := 50_000_000;
+ Default_Stack_Trace_Depth : constant Natural := 20;
+ Default_Reset_Content : constant Boolean := False;
+ Default_Raise_Exceptions : constant Boolean := True;
+ Default_Advanced_Scanning : constant Boolean := False;
+ Default_Min_Freed : constant SSC := 0;
+ -- The above values are constants used for the parameters to Configure
+ -- if not overridden in the call. See description of Configure for full
+ -- details on these parameters. If these defaults are not satisfactory,
+ -- then you need to call Configure to change the default values.
- -- - dereference: . exceptions are raised if the memory was not
- -- allocated or was already deallocated
+ procedure Configure
+ (Pool : in out Debug_Pool;
+ Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth;
+ Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed;
+ Minimum_To_Free : SSC := Default_Min_Freed;
+ Reset_Content_On_Free : Boolean := Default_Reset_Content;
+ Raise_Exceptions : Boolean := Default_Raise_Exceptions;
+ Advanced_Scanning : Boolean := Default_Advanced_Scanning);
+ -- Subprogram used to configure the debug pool.
+ --
+ -- Stack_Trace_Depth. This parameter controls the maximum depth of stack
+ -- traces that are output to indicate locations of actions for error
+ -- conditions such as bad allocations. If set to zero, the debug pool
+ -- will not try to compute backtraces. This is more efficient but gives
+ -- less information on problem locations
+ --
+ -- Maximum_Logically_Freed_Memory: maximum amount of memory (bytes)
+ -- that should be kept before starting to physically deallocate some.
+ -- This value should be non-zero, since having memory that is logically
+ -- but not physically freed helps to detect invalid memory accesses.
+ --
+ -- Minimum_To_Free is the minimum amount of memory that should be freed
+ -- every time the pool starts physically releasing memory. The algorithm
+ -- to compute which block should be physically released needs some
+ -- expensive initialization (see Advanced_Scanning below), and this
+ -- parameter can be used to limit the performance impact by ensuring
+ -- that a reasonable amount of memory is freed each time. Even in the
+ -- advanced scanning mode, marked blocks may be released to match this
+ -- Minimum_To_Free parameter.
+ --
+ -- Reset_Content_On_Free: If true, then the contents of the freed memory
+ -- is reset to the pattern 16#DEADBEEF#, following an old IBM convention.
+ -- This helps in detecting invalid memory references from the debugger.
+ --
+ -- Raise_Exceptions: If true, the exceptions below will be raised every
+ -- time an error is detected. If you set this to False, then the action
+ -- is to generate output on standard error, noting the errors, but to
+ -- keep running if possible (of course if storage is badly damaged, this
+ -- attempt may fail. This helps to detect more than one error in a run.
+ --
+ -- Advanced_Scanning: If true, the pool will check the contents of all
+ -- allocated blocks before physically releasing memory. Any possible
+ -- reference to a logically free block will prevent its deallocation.
+ -- Note that this algorithm is approximate, and it is recommended
+ -- that you set Minimum_To_Free to a non-zero value to save time.
+ --
+ -- All instantiations of this pool use the same internal tables. However,
+ -- they do not store the same amount of information for the tracebacks,
+ -- and they have different counters for maximum logically freed memory.
Accessing_Not_Allocated_Storage : exception;
- Accessing_Deallocated_Storage : exception;
- Freeing_Not_Allocated_Storage : exception;
- Freeing_Deallocated_Storage : exception;
+ -- Exception raised if Raise_Exception is True, and an attempt is made
+ -- to access storage that was never allocated.
+
+ Accessing_Deallocated_Storage : exception;
+ -- Exception raised if Raise_Exception is True, and an attempt is made
+ -- to access storage that was allocated but has been deallocated.
+
+ Freeing_Not_Allocated_Storage : exception;
+ -- Exception raised if Raise_Exception is True, and an attempt is made
+ -- to free storage that had not been previously allocated.
+
+ Freeing_Deallocated_Storage : exception;
+ -- Exception raised if Raise_Exception is True, and an attempt is made
+ -- to free storage that had already been freed.
+
+ -- Note on the above exceptions. The distinction between not allocated
+ -- and deallocated storage is not guaranteed to be accurate in the case
+ -- where storage is allocated, and then physically freed. Larger values
+ -- of the parameter Maximum_Logically_Freed_Memory will help to guarantee
+ -- that this distinction is made more accurately.
+
+ generic
+ with procedure Put_Line (S : String) is <>;
+ with procedure Put (S : String) is <>;
+ procedure Print_Info
+ (Pool : Debug_Pool;
+ Cumulate : Boolean := False;
+ Display_Slots : Boolean := False;
+ Display_Leaks : Boolean := False);
+ -- Print out information about the High Water Mark, the current and
+ -- total number of bytes allocated and the total number of bytes
+ -- deallocated.
+ --
+ -- If Display_Slots is true, this subprogram prints a list of all the
+ -- locations in the application that have done at least one allocation or
+ -- deallocation. The result might be used to detect places in the program
+ -- where lots of allocations are taking place. This output is not in any
+ -- defined order.
+ --
+ -- If Cumulate if True, then each stack trace will display the number of
+ -- allocations that were done either directly, or by the subprograms called
+ -- at that location (e.g: if there were two physical allocations at a->b->c
+ -- and a->b->d, then a->b would be reported as performing two allocations).
+ --
+ -- If Display_Leaks is true, then each block that has not been deallocated
+ -- (often called a "memory leak") will be listed, along with the traceback
+ -- showing where it was allocated. Not that no grouping of the blocks is
+ -- done, you should use the Dump_Gnatmem procedure below in conjunction
+ -- with the gnatmem utility.
+
+ procedure Print_Info_Stdout
+ (Pool : Debug_Pool;
+ Cumulate : Boolean := False;
+ Display_Slots : Boolean := False;
+ Display_Leaks : Boolean := False);
+ -- Standard instantiation of Print_Info to print on standard_output. More
+ -- convenient to use where this is the intended location, and in particular
+ -- easier to use from the debugger.
+
+ procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String);
+ -- Create an external file on the disk, which can be processed by gnatmem
+ -- to display the location of memory leaks.
+ --
+ -- This provides a nicer output that Print_Info above, and groups similar
+ -- stack traces together. This also provides an easy way to save the memory
+ -- status of your program for post-mortem analysis.
+ --
+ -- To use this file, use the following command line:
+ -- gnatmem 5 -i <File_Name> <Executable_Name>
+ -- If you want all the stack traces to be displayed with 5 levels.
- type Debug_Pool is
- new System.Checked_Pools.Checked_Pool with private;
+ procedure Print_Pool (A : System.Address);
+ pragma Export (C, Print_Pool, "print_pool");
+ -- This subprogram is meant to be used from a debugger. Given an address in
+ -- memory, it will print on standard output the known information about
+ -- this address (provided, of course, the matching pointer is handled by
+ -- the Debug_Pool).
+ --
+ -- The information includes the stacktrace for the allocation or
+ -- deallocation of that memory chunck, its current status (allocated or
+ -- logically freed), etc.
+
+private
+ -- The following are the standard primitive subprograms for a pool
procedure Allocate
(Pool : in out Debug_Pool;
@@ -72,9 +256,7 @@ package GNAT.Debug_Pools is
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
- function Storage_Size
- (Pool : Debug_Pool)
- return System.Storage_Elements.Storage_Count;
+ function Storage_Size (Pool : Debug_Pool) return SSC;
procedure Dereference
(Pool : in out Debug_Pool;
@@ -82,22 +264,48 @@ package GNAT.Debug_Pools is
Size_In_Storage_Elements : Storage_Count;
Alignment : Storage_Count);
- generic
- with procedure Put_Line (S : String);
- procedure Print_Info (Pool : Debug_Pool);
- -- Print out information about the High Water Mark, the current and
- -- total number of bytes allocated and the total number of bytes
- -- deallocated.
+ type Byte_Count is mod System.Max_Binary_Modulus;
+ -- Type used for maintaining byte counts, needs to be large enough
+ -- to accomodate counts allowing for repeated use of the same memory.
-private
type Debug_Pool is new System.Checked_Pools.Checked_Pool with record
- Allocated : Storage_Count := 0;
+ Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth;
+ Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed;
+ Reset_Content_On_Free : Boolean := Default_Reset_Content;
+ Raise_Exceptions : Boolean := Default_Raise_Exceptions;
+ Minimum_To_Free : SSC := Default_Min_Freed;
+ Advanced_Scanning : Boolean := Default_Advanced_Scanning;
+
+ Allocated : Byte_Count := 0;
-- Total number of bytes allocated in this pool
- Deallocated : Storage_Count := 0;
- -- Total number of bytes deallocated in this pool
+ Logically_Deallocated : Byte_Count := 0;
+ -- Total number of bytes logically deallocated in this pool. This is the
+ -- memory that the application has released, but that the pool has not
+ -- yet physically released through a call to free(), to detect later
+ -- accesed to deallocated memory.
+
+ Physically_Deallocated : Byte_Count := 0;
+ -- Total number of bytes that were free()-ed.
+
+ Marked_Blocks_Deallocated : Boolean := False;
+ -- Set to true if some mark blocks had to be deallocated in the advanced
+ -- scanning scheme. Since this is potentially dangereous, this is
+ -- reported to the user, who might want to rerun his program with a
+ -- lower Minimum_To_Free value.
+
+ High_Water : Byte_Count := 0;
+ -- Maximum of Allocated - Logically_Deallocated - Physically_Deallocated
+
+ First_Free_Block : System.Address := System.Null_Address;
+ Last_Free_Block : System.Address := System.Null_Address;
+ -- Pointers to the first and last logically freed blocks.
- High_Water : Storage_Count := 0;
- -- Maximum of during the time of Allocated - Deallocated
+ First_Used_Block : System.Address := System.Null_Address;
+ -- Pointer to the list of currently allocated blocks. This list is
+ -- used to list the memory leaks in the application on exit, as well as
+ -- for the advanced freeing algorithms that needs to traverse all these
+ -- blocks to find possible references to the block being physically
+ -- freed.
end record;
end GNAT.Debug_Pools;
diff --git a/gcc/ada/g-debuti.adb b/gcc/ada/g-debuti.adb
index 9266c0cf1cc..1c1e29d7304 100644
--- a/gcc/ada/g-debuti.adb
+++ b/gcc/ada/g-debuti.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 1997-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -35,19 +36,19 @@ with System.Storage_Elements; use System.Storage_Elements;
package body GNAT.Debug_Utilities is
+ H : constant array (0 .. 15) of Character := "0123456789ABCDEF";
+ -- Table of hex digits
+
--------------------------
-- Image (address case) --
--------------------------
- function Image (A : Address) return String is
- S : String (1 .. Address_Image_Length);
- P : Natural := S'Last - 1;
+ function Image (A : Address) return Image_String is
+ S : Image_String;
+ P : Natural := Address_Image_Length - 1;
N : Integer_Address := To_Integer (A);
U : Natural := 0;
- H : constant array (Integer range 0 .. 15) of Character :=
- "0123456789ABCDEF";
-
begin
S (S'Last) := '#';
@@ -96,15 +97,89 @@ package body GNAT.Debug_Utilities is
return W (1 .. P);
end Image;
+ -------------
+ -- Image_C --
+ -------------
+
+ function Image_C (A : Address) return Image_C_String is
+ S : Image_C_String;
+ N : Integer_Address := To_Integer (A);
+
+ begin
+ for P in reverse 3 .. S'Last loop
+ S (P) := H (Integer (N mod 16));
+ N := N / 16;
+ end loop;
+
+ S (1 .. 2) := "0x";
+ return S;
+ end Image_C;
+
-----------
-- Value --
-----------
function Value (S : String) return System.Address is
- N : constant Integer_Address := Integer_Address'Value (S);
+ Base : Integer_Address := 10;
+ Res : Integer_Address := 0;
+ Last : Natural := S'Last;
+ C : Character;
+ N : Integer_Address;
begin
- return To_Address (N);
+ -- Skip final Ada 95 base character
+
+ if S (Last) = '#' or else S (Last) = ':' then
+ Last := Last - 1;
+ end if;
+
+ -- Loop through characters
+
+ for J in S'First .. Last loop
+ C := S (J);
+
+ -- C format hex constant
+
+ if C = 'x' then
+ if Res /= 0 then
+ raise Constraint_Error;
+ end if;
+
+ Base := 16;
+
+ -- Ada form based literal
+
+ elsif C = '#' or C = ':' then
+ Base := Res;
+ Res := 0;
+
+ -- Ignore all underlines
+
+ elsif C = '_' then
+ null;
+
+ -- Otherwise must have digit
+
+ else
+ if C in '0' .. '9' then
+ N := Character'Pos (C) - Character'Pos ('0');
+ elsif C in 'A' .. 'F' then
+ N := Character'Pos (C) - (Character'Pos ('A') - 10);
+ elsif C in 'a' .. 'f' then
+ N := Character'Pos (C) - (Character'Pos ('a') - 10);
+ else
+ raise Constraint_Error;
+ end if;
+
+ if N >= Base then
+ raise Constraint_Error;
+ else
+ Res := Res * Base + N;
+ end if;
+ end if;
+ end loop;
+
+ return To_Address (Res);
end Value;
end GNAT.Debug_Utilities;
diff --git a/gcc/ada/g-debuti.ads b/gcc/ada/g-debuti.ads
index 334b103d43f..470c2867f59 100644
--- a/gcc/ada/g-debuti.ads
+++ b/gcc/ada/g-debuti.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-1998 Ada Core Technologies, Inc. --
+-- Copyright (C) 1995-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -40,22 +41,43 @@ with System;
package GNAT.Debug_Utilities is
pragma Pure (Debug_Utilities);
+ Address_64 : constant Boolean := Standard'Address_Size = 64;
+ -- Set true if 64 bit addresses (assumes only 32 and 64 are possible)
+
+ Address_Image_Length : constant := 13 + 10 * Boolean'Pos (Address_64);
+ -- Length of string returned by Image function for an address
+
+ subtype Image_String is String (1 .. Address_Image_Length);
+ -- Subtype returned by Image function for an address
+
+ Address_Image_C_Length : constant := 10 + 8 * Boolean'Pos (Address_64);
+ -- Length of string returned by Image_C function
+
+ subtype Image_C_String is String (1 .. Address_Image_C_Length);
+ -- Subtype returned by Image_C function
+
function Image (S : String) return String;
-- Returns a string image of S, obtained by prepending and appending
-- quote (") characters and doubling any quote characters in the string.
-- The maximum length of the result is thus 2 ** S'Length + 2.
- Address_Image_Length : constant :=
- 13 + 10 * Boolean'Pos (Standard'Address_Size > 32);
- -- Length of string returned by Image function
-
- function Image (A : System.Address) return String;
- -- Returns a string of the form 16#xxxx_xxxx# for 32-bit addresses
- -- or 16#xxxx_xxxx_xxxx_xxxx# for 64-bit addresses. Hex characters
+ function Image (A : System.Address) return Image_String;
+ -- Returns a string of the form 16#hhhh_hhhh# for 32-bit addresses
+ -- or 16#hhhh_hhhh_hhhh_hhhh# for 64-bit addresses. Hex characters
-- are in upper case.
+ function Image_C (A : System.Address) return Image_C_String;
+ -- Returns a string of the form 0xhhhhhhhh for 32 bit addresses or
+ -- 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are in
+ -- upper case.
+
function Value (S : String) return System.Address;
-- Given a valid integer literal in any form, including the form returned
-- by the Image function in this package, yields the corresponding address.
+ -- Note that this routine will handle any Ada integer format, and will
+ -- also handle hex constants in C format (0xhh..hhh). Constraint_Error
+ -- may be raised for obviously incorrect data, but the routine is fairly
+ -- permissive, and in particular, all underscores in whatever position
+ -- are simply ignored completely.
end GNAT.Debug_Utilities;
diff --git a/gcc/ada/g-diopit.adb b/gcc/ada/g-diopit.adb
index ed1aafa27b8..a5ece7ce6b7 100644
--- a/gcc/ada/g-diopit.adb
+++ b/gcc/ada/g-diopit.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -190,8 +191,7 @@ package body GNAT.Directory_Operations.Iteration is
-- Starting with "../"
DS := Strings.Fixed.Index
- (SP (SP'First + 3 .. SP'Last),
- Dir_Seps);
+ (SP (SP'First + 3 .. SP'Last), Dir_Seps);
if DS = 0 then
@@ -224,22 +224,27 @@ package body GNAT.Directory_Operations.Iteration is
if DS = 0 then
- -- Se have "<drive>:\dir"
+ -- We have "<drive>:\dir"
- Read (SP (SP'First .. SP'First + 1),
+ Read (SP (SP'First .. SP'First + 2),
SP (SP'First + 3 .. SP'Last),
"");
else
-- We have "<drive>:\dir\kkk"
- Read (SP (SP'First .. SP'First + 1),
+ Read (SP (SP'First .. SP'First + 2),
SP (SP'First + 3 .. DS - 1),
SP (DS .. SP'Last));
end if;
else
- -- Starting with "<drive>:"
+ -- Starting with "<drive>:" and the drive letter not followed
+ -- by a directory separator. The proper semantic on Windows is
+ -- to read the content of the current selected directory on
+ -- this drive. For example, if drive C current selected
+ -- directory is c:\temp the suffix pattern "c:m*" is
+ -- equivalent to c:\temp\m*.
DS := Strings.Fixed.Index
(SP (SP'First + 2 .. SP'Last), Dir_Seps);
@@ -248,18 +253,13 @@ package body GNAT.Directory_Operations.Iteration is
-- We have "<drive>:dir"
- Read (SP (SP'First .. SP'First + 1),
- SP (SP'First + 2 .. SP'Last),
- "");
+ Read (SP, "", "");
else
-- We have "<drive>:dir/kkk"
- Read (SP (SP'First .. SP'First + 1),
- SP (SP'First + 2 .. DS - 1),
- SP (DS .. SP'Last));
+ Read (SP (SP'First .. DS - 1), "", SP (DS .. SP'Last));
end if;
-
end if;
elsif Strings.Maps.Is_In (SP (SP'First), Dir_Seps) then
@@ -267,16 +267,13 @@ package body GNAT.Directory_Operations.Iteration is
-- Starting with a /
DS := Strings.Fixed.Index
- (SP (SP'First + 1 .. SP'Last),
- Dir_Seps);
+ (SP (SP'First + 1 .. SP'Last), Dir_Seps);
if DS = 0 then
-- We have "/dir"
- Read (Current_Path,
- SP (SP'First + 1 .. SP'Last),
- "");
+ Read (Current_Path, SP (SP'First + 1 .. SP'Last), "");
else
-- We have "/dir/kkk"
@@ -294,9 +291,7 @@ package body GNAT.Directory_Operations.Iteration is
-- We have "dir"
- Read (Current_Path & '.',
- SP,
- "");
+ Read (Current_Path & '.', SP, "");
else
-- We have "dir/kkk"
diff --git a/gcc/ada/g-diopit.ads b/gcc/ada/g-diopit.ads
index 62b691a09c3..2f00712cb17 100644
--- a/gcc/ada/g-diopit.ads
+++ b/gcc/ada/g-diopit.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb
index 1967d236d63..ca200ebf843 100644
--- a/gcc/ada/g-dirope.adb
+++ b/gcc/ada/g-dirope.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -47,6 +48,9 @@ package body GNAT.Directory_Operations is
-- This is the low-level address directory structure as returned by the C
-- opendir routine.
+ Filename_Max : constant Integer := 1024;
+ -- 1024 is the value of FILENAME_MAX in stdio.h
+
procedure Free is new
Unchecked_Deallocation (Dir_Type_Value, Dir_Type);
@@ -140,9 +144,12 @@ package body GNAT.Directory_Operations is
-- Start processing for Base_Name
begin
+ if Path'Length <= Suffix'Length then
+ return Path;
+ end if;
+
if Case_Sensitive_File_Name then
return Basename (Path, Suffix);
-
else
return Basename
(Characters.Handling.To_Lower (Path),
@@ -155,7 +162,7 @@ package body GNAT.Directory_Operations is
----------------
procedure Change_Dir (Dir_Name : Dir_Name_Str) is
- C_Dir_Name : String := Dir_Name & ASCII.NUL;
+ C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
function chdir (Dir_Name : String) return Integer;
pragma Import (C, chdir, "chdir");
@@ -176,6 +183,7 @@ package body GNAT.Directory_Operations is
pragma Import (C, closedir, "closedir");
Discard : Integer;
+ pragma Warnings (Off, Discard);
begin
if not Is_Open (Dir) then
@@ -211,7 +219,13 @@ package body GNAT.Directory_Operations is
-- Expand_Path --
-----------------
- function Expand_Path (Path : Path_Name) return String is
+ function Expand_Path
+ (Path : Path_Name;
+ Mode : Environment_Style := System_Default)
+ return Path_Name
+ is
+ Environment_Variable_Char : Character;
+ pragma Import (C, Environment_Variable_Char, "__gnat_environment_char");
Result : OS_Lib.String_Access := new String (1 .. 200);
Result_Last : Natural := 0;
@@ -223,6 +237,9 @@ package body GNAT.Directory_Operations is
procedure Double_Result_Size;
-- Reallocate Result, doubling its size
+ function Is_Var_Prefix (C : Character) return Boolean;
+ pragma Inline (Is_Var_Prefix);
+
procedure Read (K : in out Positive);
-- Update Result while reading current Path starting at position K. If
-- a variable is found, call Var below.
@@ -269,38 +286,52 @@ package body GNAT.Directory_Operations is
Result := New_Result;
end Double_Result_Size;
+ -------------------
+ -- Is_Var_Prefix --
+ -------------------
+
+ function Is_Var_Prefix (C : Character) return Boolean is
+ begin
+ return (C = Environment_Variable_Char and then Mode = System_Default)
+ or else
+ (C = '$' and then (Mode = UNIX or else Mode = Both))
+ or else
+ (C = '%' and then (Mode = DOS or else Mode = Both));
+ end Is_Var_Prefix;
+
----------
-- Read --
----------
procedure Read (K : in out Positive) is
+ P : Character;
begin
For_All_Characters : loop
- if Path (K) = '$' then
+ if Is_Var_Prefix (Path (K)) then
+ P := Path (K);
-- Could be a variable
if K < Path'Last then
- if Path (K + 1) = '$' then
+ if Path (K + 1) = P then
- -- Not a variable after all, this is a double $, just
- -- insert one in the result string.
+ -- Not a variable after all, this is a double $ or %,
+ -- just insert one in the result string.
- Append ('$');
+ Append (P);
K := K + 1;
else
-- Let's parse the variable
- K := K + 1;
Var (K);
end if;
else
- -- We have an ending $ sign
+ -- We have an ending $ or % sign
- Append ('$');
+ Append (P);
end if;
else
@@ -322,27 +353,41 @@ package body GNAT.Directory_Operations is
---------
procedure Var (K : in out Positive) is
+ P : constant Character := Path (K);
+ T : Character;
E : Positive;
begin
- if Path (K) = '{' then
+ K := K + 1;
+
+ if P = '%' or else Path (K) = '{' then
- -- Look for closing } (curly bracket).
+ -- Set terminator character
+
+ if P = '%' then
+ T := '%';
+ else
+ T := '}';
+ K := K + 1;
+ end if;
+
+ -- Look for terminator character, k point to the first character
+ -- for the variable name.
E := K;
loop
E := E + 1;
- exit when Path (E) = '}' or else E = Path'Last;
+ exit when Path (E) = T or else E = Path'Last;
end loop;
- if Path (E) = '}' then
+ if Path (E) = T then
-- OK found, translate with environment value
declare
Env : OS_Lib.String_Access :=
- OS_Lib.Getenv (Path (K + 1 .. E - 1));
+ OS_Lib.Getenv (Path (K .. E - 1));
begin
Append (Env.all);
@@ -350,10 +395,15 @@ package body GNAT.Directory_Operations is
end;
else
- -- No closing curly bracket, not a variable after all or a
+ -- No terminator character, not a variable after all or a
-- syntax error, ignore it, insert string as-is.
- Append ('$');
+ Append (P); -- Add prefix character
+
+ if T = '}' then -- If we were looking for curly bracket
+ Append ('{'); -- terminator, add the curly bracket
+ end if;
+
Append (Path (K .. E));
end if;
@@ -466,13 +516,23 @@ package body GNAT.Directory_Operations is
Style : Path_Style := System_Default)
return String
is
- N_Path : String := Path;
- K : Positive := N_Path'First;
- Prev_Dirsep : Boolean := False;
+ N_Path : String := Path;
+ K : Positive := N_Path'First;
+ Prev_Dirsep : Boolean := False;
begin
- for J in Path'Range loop
+ if Dir_Separator = '\'
+ and then Path'Length > 1
+ and then Path (K .. K + 1) = "\\"
+ then
+ if Style = UNIX then
+ N_Path (K .. K + 1) := "//";
+ end if;
+ K := K + 2;
+ end if;
+
+ for J in K .. Path'Last loop
if Strings.Maps.Is_In (Path (J), Dir_Seps) then
if not Prev_Dirsep then
case Style is
@@ -548,7 +608,7 @@ package body GNAT.Directory_Operations is
--------------
procedure Make_Dir (Dir_Name : Dir_Name_Str) is
- C_Dir_Name : String := Dir_Name & ASCII.NUL;
+ C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
function mkdir (Dir_Name : String) return Integer;
pragma Import (C, mkdir, "__gnat_mkdir");
@@ -567,7 +627,7 @@ package body GNAT.Directory_Operations is
(Dir : out Dir_Type;
Dir_Name : Dir_Name_Str)
is
- C_File_Name : String := Dir_Name & ASCII.NUL;
+ C_File_Name : constant String := Dir_Name & ASCII.NUL;
function opendir
(File_Name : String)
@@ -596,8 +656,9 @@ package body GNAT.Directory_Operations is
Filename_Addr : Address;
Filename_Len : Integer;
- Buffer : array (0 .. 1024) of Character;
- -- 1024 is the value of FILENAME_MAX in stdio.h
+ Buffer : array (0 .. Filename_Max + 12) of Character;
+ -- 12 is the size of the dirent structure (see dirent.h), without the
+ -- field for the filename.
function readdir_gnat
(Directory : System.Address;
@@ -638,7 +699,8 @@ package body GNAT.Directory_Operations is
(Source => Address,
Target => Path_String_Access);
- Path_Access : Path_String_Access := Address_To_Access (Filename_Addr);
+ Path_Access : constant Path_String_Access :=
+ Address_To_Access (Filename_Addr);
begin
for J in Str'First .. Last loop
@@ -665,14 +727,60 @@ package body GNAT.Directory_Operations is
-- Remove_Dir --
----------------
- procedure Remove_Dir (Dir_Name : Dir_Name_Str) is
- C_Dir_Name : String := Dir_Name & ASCII.NUL;
+ procedure Remove_Dir
+ (Dir_Name : Dir_Name_Str;
+ Recursive : Boolean := False)
+ is
+ C_Dir_Name : constant String := Dir_Name & ASCII.NUL;
+ Current_Dir : constant Dir_Name_Str := Get_Current_Dir;
+ Last : Integer;
+ Str : String (1 .. Filename_Max);
+ Success : Boolean;
+ Working_Dir : Dir_Type;
procedure rmdir (Dir_Name : String);
pragma Import (C, rmdir, "rmdir");
begin
- rmdir (C_Dir_Name);
+ -- Remove the directory only if it is empty
+
+ if not Recursive then
+ rmdir (C_Dir_Name);
+
+ if GNAT.OS_Lib.Is_Directory (Dir_Name) then
+ raise Directory_Error;
+ end if;
+
+ -- Remove directory and all files and directories that it may contain
+
+ else
+ Change_Dir (Dir_Name);
+ Open (Working_Dir, ".");
+
+ loop
+ Read (Working_Dir, Str, Last);
+ exit when Last = 0;
+
+ if GNAT.OS_Lib.Is_Directory (Str (1 .. Last)) then
+ if Str (1 .. Last) /= "." and then Str (1 .. Last) /= ".." then
+ Remove_Dir (Str (1 .. Last), True);
+ Remove_Dir (Str (1 .. Last));
+ end if;
+
+ else
+ GNAT.OS_Lib.Delete_File (Str (1 .. Last), Success);
+
+ if not Success then
+ Change_Dir (Current_Dir);
+ raise Directory_Error;
+ end if;
+ end if;
+ end loop;
+
+ Change_Dir (Current_Dir);
+ Close (Working_Dir);
+ Remove_Dir (Dir_Name);
+ end if;
end Remove_Dir;
end GNAT.Directory_Operations;
diff --git a/gcc/ada/g-dirope.ads b/gcc/ada/g-dirope.ads
index e5d03b12616..ae790de9492 100644
--- a/gcc/ada/g-dirope.ads
+++ b/gcc/ada/g-dirope.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -38,6 +39,10 @@
-- See also child package GNAT.Directory_Operations.Iteration
+-- Note: support on OpenVMS is limited to the support of Unix-style
+-- directory names (OpenVMS native directory format is not supported).
+-- Read individual entries for more specific notes on OpenVMS support.
+
with Ada.Strings.Maps;
package GNAT.Directory_Operations is
@@ -50,6 +55,8 @@ package GNAT.Directory_Operations is
-- '\' character. It can also include drive letters if the operating
-- system provides for this. The final '/' or '\' in a Dir_Name_Str is
-- optional when passed as a procedure or function in parameter.
+ -- On OpenVMS, only Unix style path names are supported, not VMS style,
+ -- but the directory and file names are not case sensitive.
type Dir_Type is limited private;
-- A value used to reference a directory. Conceptually this value includes
@@ -79,9 +86,12 @@ package GNAT.Directory_Operations is
-- Create a new directory named Dir_Name. Raises Directory_Error if
-- Dir_Name cannot be created.
- procedure Remove_Dir (Dir_Name : Dir_Name_Str);
- -- Remove the directory named Dir_Name. Raises Directory_Error if Dir_Name
- -- cannot be removed.
+ procedure Remove_Dir
+ (Dir_Name : Dir_Name_Str;
+ Recursive : Boolean := False);
+ -- Remove the directory named Dir_Name. If Recursive is set to True, then
+ -- Remove_Dir removes all the subdirectories and files that are in
+ -- Dir_Name. Raises Directory_Error if Dir_Name cannot be removed.
function Get_Current_Dir return Dir_Name_Str;
-- Returns the current working directory for the execution environment.
@@ -105,7 +115,10 @@ package GNAT.Directory_Operations is
-- Returns directory name for Path. This is similar to the UNIX dirname
-- command. Everything after the last directory separator is removed. If
-- there is no directory separator the current working directory is
- -- returned.
+ -- returned. Note that the contents of Path is case-sensitive on
+ -- systems that have case-sensitive file names (like Unix), and
+ -- non-case-sensitive on systems where the file system is also non-
+ -- case-sensitive (such as Windows, and OpenVMS).
function Base_Name
(Path : Path_Name;
@@ -119,20 +132,29 @@ package GNAT.Directory_Operations is
-- represent the same file.
--
-- This function is not case-sensitive on systems that have a non
- -- case-sensitive file system like Windows, OS/2 and VMS.
+ -- case-sensitive file system like Windows and OpenVMS.
function File_Extension (Path : Path_Name) return String;
- -- Return the file extension. This is the string after the last dot
- -- character in File_Name (Path). It returns the empty string if no
- -- extension is found. The returned value does contains the file
- -- extension separator (dot character).
+ -- Return the file extension. This is defined as the string after the
+ -- last dot, including the dot itself. For example, if the file name
+ -- is "file1.xyz.adq", then the returned value would be ".adq". If no
+ -- dot is present in the file name, or the last character of the file
+ -- name is a dot, then the null string is returned.
function File_Name (Path : Path_Name) return String;
-- Returns the file name and the file extension if present. It removes all
-- path information. This is equivalent to Base_Name with default Extension
-- value.
- type Path_Style is (UNIX, DOS, System_Default);
+ type Path_Style is
+ (UNIX,
+ -- Use '/' as the directory separator. The default on Unix systems
+ -- and on OpenVMS.
+
+ DOS,
+ -- Use '\' as the directory separator. The default on Windows.
+
+ System_Default);
function Format_Pathname
(Path : Path_Name;
@@ -144,17 +166,36 @@ package GNAT.Directory_Operations is
-- different environments. If style is set to System_Default the routine
-- will use the default directory separator on the running environment.
- function Expand_Path (Path : Path_Name) return Path_Name;
- -- Returns Path with environment variables (string preceded by a dollar
- -- sign) replaced by the current environment variable value. For example,
+ type Environment_Style is
+ (UNIX,
+ -- Environment variables and OpenVMS logical names use $ as prefix and
+ -- can use curly brackets as in ${HOME}/mydir. If there is no closing
+ -- curly bracket for an opening one then translation is done, so for
+ -- example ${VAR/toto is returned as ${VAR/toto.
+
+ DOS,
+ -- Environment variables uses % as prefix and suffix
+ -- (e.g. %HOME%/mydir). The name DOS refer to "DOS-like" environment.
+ -- This includes al Windows systems.
+
+ Both,
+ -- Recognize both forms described above.
+
+ System_Default);
+ -- Uses either UNIX on Unix and OpenVMS systems, or DOS on Windows and
+ -- OS/2 depending on the running environment.
+
+ function Expand_Path
+ (Path : Path_Name;
+ Mode : Environment_Style := System_Default)
+ return Path_Name;
+ -- Returns Path with environment variables (or logical names on OpenVMS)
+ -- replaced by the current environment variable value. For example,
-- $HOME/mydir will be replaced by /home/joe/mydir if $HOME environment
- -- variable is set to /home/joe. The variable can be surrounded by the
- -- characters '{' and '}' (curly bracket) if needed as in ${HOME}/mydir.
- -- If an environment variable does not exists the variable will be replaced
- -- by the empty string. Two dollar signs are replaced by a single dollar
- -- sign. Note that a variable must start with a letter. If there is no
- -- closing curly bracket for an opening one there is no translation done,
- -- so for example ${VAR/toto is returned as ${VAR/toto.
+ -- variable is set to /home/joe and Mode is UNIX. If an environment
+ -- variable does not exists the variable will be replaced by the empty
+ -- string. Two dollar or percent signs are replaced by a single
+ -- dollar/percent sign. Note that a variable must start with a letter.
---------------
-- Iterators --
diff --git a/gcc/ada/g-dynhta.adb b/gcc/ada/g-dynhta.adb
new file mode 100644
index 00000000000..154d20516c4
--- /dev/null
+++ b/gcc/ada/g-dynhta.adb
@@ -0,0 +1,344 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- G N A T . D Y N A M I C _ H T A B L E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+package body GNAT.Dynamic_HTables is
+
+ --------------------
+ -- Static_HTable --
+ --------------------
+
+ package body Static_HTable is
+
+ type Table_Type is array (Header_Num) of Elmt_Ptr;
+
+ type Instance_Data is record
+ Table : Table_Type;
+ Iterator_Index : Header_Num;
+ Iterator_Ptr : Elmt_Ptr;
+ Iterator_Started : Boolean := False;
+ end record;
+
+ function Get_Non_Null (T : Instance) return Elmt_Ptr;
+ -- Returns Null_Ptr if Iterator_Started is False or if the Table is
+ -- empty. Returns Iterator_Ptr if non null, or the next non null
+ -- element in table if any.
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get (T : Instance; K : Key) return Elmt_Ptr is
+ Elmt : Elmt_Ptr;
+
+ begin
+ if T = null then
+ return Null_Ptr;
+ end if;
+
+ Elmt := T.Table (Hash (K));
+
+ loop
+ if Elmt = Null_Ptr then
+ return Null_Ptr;
+
+ elsif Equal (Get_Key (Elmt), K) then
+ return Elmt;
+
+ else
+ Elmt := Next (Elmt);
+ end if;
+ end loop;
+ end Get;
+
+ ---------------
+ -- Get_First --
+ ---------------
+
+ function Get_First (T : Instance) return Elmt_Ptr is
+ begin
+ if T = null then
+ return Null_Ptr;
+ end if;
+
+ T.Iterator_Started := True;
+ T.Iterator_Index := T.Table'First;
+ T.Iterator_Ptr := T.Table (T.Iterator_Index);
+ return Get_Non_Null (T);
+ end Get_First;
+
+ --------------
+ -- Get_Next --
+ --------------
+
+ function Get_Next (T : Instance) return Elmt_Ptr is
+ begin
+ if T = null or else not T.Iterator_Started then
+ return Null_Ptr;
+ end if;
+
+ T.Iterator_Ptr := Next (T.Iterator_Ptr);
+ return Get_Non_Null (T);
+ end Get_Next;
+
+ ------------------
+ -- Get_Non_Null --
+ ------------------
+
+ function Get_Non_Null (T : Instance) return Elmt_Ptr is
+ begin
+ if T = null then
+ return Null_Ptr;
+ end if;
+
+ while T.Iterator_Ptr = Null_Ptr loop
+ if T.Iterator_Index = T.Table'Last then
+ T.Iterator_Started := False;
+ return Null_Ptr;
+ end if;
+
+ T.Iterator_Index := T.Iterator_Index + 1;
+ T.Iterator_Ptr := T.Table (T.Iterator_Index);
+ end loop;
+
+ return T.Iterator_Ptr;
+ end Get_Non_Null;
+
+ ------------
+ -- Remove --
+ ------------
+
+ procedure Remove (T : Instance; K : Key) is
+ Index : constant Header_Num := Hash (K);
+ Elmt : Elmt_Ptr;
+ Next_Elmt : Elmt_Ptr;
+
+ begin
+ if T = null then
+ return;
+ end if;
+
+ Elmt := T.Table (Index);
+
+ if Elmt = Null_Ptr then
+ return;
+
+ elsif Equal (Get_Key (Elmt), K) then
+ T.Table (Index) := Next (Elmt);
+
+ else
+ loop
+ Next_Elmt := Next (Elmt);
+
+ if Next_Elmt = Null_Ptr then
+ return;
+
+ elsif Equal (Get_Key (Next_Elmt), K) then
+ Set_Next (Elmt, Next (Next_Elmt));
+ return;
+
+ else
+ Elmt := Next_Elmt;
+ end if;
+ end loop;
+ end if;
+ end Remove;
+
+ -----------
+ -- Reset --
+ -----------
+
+ procedure Reset (T : in out Instance) is
+ begin
+ if T = null then
+ return;
+ end if;
+
+ for J in T.Table'Range loop
+ T.Table (J) := Null_Ptr;
+ end loop;
+ end Reset;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (T : in out Instance; E : Elmt_Ptr) is
+ Index : Header_Num;
+
+ begin
+ if T = null then
+ T := new Instance_Data;
+ end if;
+
+ Index := Hash (Get_Key (E));
+ Set_Next (E, T.Table (Index));
+ T.Table (Index) := E;
+ end Set;
+ end Static_HTable;
+
+ --------------------
+ -- Simple_HTable --
+ --------------------
+
+ package body Simple_HTable is
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get (T : Instance; K : Key) return Element is
+ Tmp : Elmt_Ptr;
+
+ begin
+ if T = Nil then
+ return No_Element;
+ end if;
+
+ Tmp := Tab.Get (Tab.Instance (T), K);
+
+ if Tmp = null then
+ return No_Element;
+ else
+ return Tmp.E;
+ end if;
+ end Get;
+
+ ---------------
+ -- Get_First --
+ ---------------
+
+ function Get_First (T : Instance) return Element is
+ Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T));
+
+ begin
+ if Tmp = null then
+ return No_Element;
+ else
+ return Tmp.E;
+ end if;
+ end Get_First;
+
+ -------------
+ -- Get_Key --
+ -------------
+
+ function Get_Key (E : Elmt_Ptr) return Key is
+ begin
+ return E.K;
+ end Get_Key;
+
+ --------------
+ -- Get_Next --
+ --------------
+
+ function Get_Next (T : Instance) return Element is
+ Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T));
+
+ begin
+ if Tmp = null then
+ return No_Element;
+ else
+ return Tmp.E;
+ end if;
+ end Get_Next;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (E : Elmt_Ptr) return Elmt_Ptr is
+ begin
+ return E.Next;
+ end Next;
+
+ ------------
+ -- Remove --
+ ------------
+
+ procedure Remove (T : Instance; K : Key) is
+ Tmp : Elmt_Ptr;
+
+ begin
+ Tmp := Tab.Get (Tab.Instance (T), K);
+
+ if Tmp /= null then
+ Tab.Remove (Tab.Instance (T), K);
+ Free (Tmp);
+ end if;
+ end Remove;
+
+ -----------
+ -- Reset --
+ -----------
+
+ procedure Reset (T : in out Instance) is
+ E1, E2 : Elmt_Ptr;
+
+ begin
+ E1 := Tab.Get_First (Tab.Instance (T));
+ while E1 /= null loop
+ E2 := Tab.Get_Next (Tab.Instance (T));
+ Free (E1);
+ E1 := E2;
+ end loop;
+
+ Tab.Reset (Tab.Instance (T));
+ end Reset;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (T : in out Instance; K : Key; E : Element) is
+ Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K);
+
+ begin
+ if Tmp = null then
+ Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null));
+ else
+ Tmp.E := E;
+ end if;
+ end Set;
+
+ --------------
+ -- Set_Next --
+ --------------
+
+ procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
+ begin
+ E.Next := Next;
+ end Set_Next;
+ end Simple_HTable;
+
+end GNAT.Dynamic_HTables;
diff --git a/gcc/ada/g-dynhta.ads b/gcc/ada/g-dynhta.ads
new file mode 100644
index 00000000000..cea431467ce
--- /dev/null
+++ b/gcc/ada/g-dynhta.ads
@@ -0,0 +1,240 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- G N A T . D Y N A M I C _ H T A B L E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1995-2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Hash table searching routines
+
+-- This package contains two separate packages. The Simple_HTable package
+-- provides a very simple abstraction that associates one element to one
+-- key value and takes care of all allocations automatically using the heap.
+-- The Static_HTable package provides a more complex interface that allows
+-- complete control over allocation.
+
+-- This package provides a facility similar to that of GNAT.HTable, except
+-- that this package declares types that can be used to define dynamic
+-- instances of hash tables, while instantiations in GNAT.HTable creates a
+-- single instance of the hash table.
+
+-- Note that this interface should remain synchronized with those in
+-- GNAT.HTable to keep as much coherency as possible between these two
+-- related units.
+
+with Ada.Unchecked_Deallocation;
+package GNAT.Dynamic_HTables is
+
+ -------------------
+ -- Static_HTable --
+ -------------------
+
+ -- A low-level Hash-Table abstraction, not as easy to instantiate as
+ -- Simple_HTable but designed to allow complete control over the
+ -- allocation of necessary data structures. Particularly useful when
+ -- dynamic allocation is not desired. The model is that each Element
+ -- contains its own Key that can be retrieved by Get_Key. Furthermore,
+ -- Element provides a link that can be used by the HTable for linking
+ -- elements with same hash codes:
+
+ -- Element
+
+ -- +-------------------+
+ -- | Key |
+ -- +-------------------+
+ -- : other data :
+ -- +-------------------+
+ -- | Next Elmt |
+ -- +-------------------+
+
+ generic
+ type Header_Num is range <>;
+ -- An integer type indicating the number and range of hash headers.
+
+ type Element (<>) is limited private;
+ -- The type of element to be stored
+
+ type Elmt_Ptr is private;
+ -- The type used to reference an element (will usually be an access
+ -- type, but could be some other form of type such as an integer type).
+
+ Null_Ptr : Elmt_Ptr;
+ -- The null value of the Elmt_Ptr type.
+
+ with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
+ with function Next (E : Elmt_Ptr) return Elmt_Ptr;
+ -- The type must provide an internal link for the sake of the
+ -- staticness of the HTable.
+
+ type Key is limited private;
+ with function Get_Key (E : Elmt_Ptr) return Key;
+ with function Hash (F : Key) return Header_Num;
+ with function Equal (F1, F2 : Key) return Boolean;
+
+ package Static_HTable is
+
+ type Instance is private;
+ Nil : constant Instance;
+
+ procedure Reset (T : in out Instance);
+ -- Resets the hash table by setting all its elements to Null_Ptr. The
+ -- effect is to clear the hash table so that it can be reused. For the
+ -- most common case where Elmt_Ptr is an access type, and Null_Ptr is
+ -- null, this is only needed if the same table is reused in a new
+ -- context. If Elmt_Ptr is other than an access type, or Null_Ptr is
+ -- other than null, then Reset must be called before the first use
+ -- of the hash table.
+
+ procedure Set (T : in out Instance; E : Elmt_Ptr);
+ -- Insert the element pointer in the HTable
+
+ function Get (T : Instance; K : Key) return Elmt_Ptr;
+ -- Returns the latest inserted element pointer with the given Key
+ -- or null if none.
+
+ procedure Remove (T : Instance; K : Key);
+ -- Removes the latest inserted element pointer associated with the
+ -- given key if any, does nothing if none.
+
+ function Get_First (T : Instance) return Elmt_Ptr;
+ -- Returns Null_Ptr if the Htable is empty, otherwise returns one
+ -- non specified element. There is no guarantee that 2 calls to this
+ -- function will return the same element.
+
+ function Get_Next (T : Instance) return Elmt_Ptr;
+ -- Returns a non-specified element that has not been returned by the
+ -- same function since the last call to Get_First or Null_Ptr if
+ -- there is no such element or Get_First has bever been called. If
+ -- there is no call to 'Set' in between Get_Next calls, all the
+ -- elements of the Htable will be traversed.
+
+ private
+
+ type Instance_Data;
+ type Instance is access all Instance_Data;
+ Nil : constant Instance := null;
+
+ end Static_HTable;
+
+ -------------------
+ -- Simple_HTable --
+ -------------------
+
+ -- A simple hash table abstraction, easy to instantiate, easy to use.
+ -- The table associates one element to one key with the procedure Set.
+ -- Get retrieves the Element stored for a given Key. The efficiency of
+ -- retrieval is function of the size of the Table parameterized by
+ -- Header_Num and the hashing function Hash.
+
+ generic
+ type Header_Num is range <>;
+ -- An integer type indicating the number and range of hash headers.
+
+ type Element is private;
+ -- The type of element to be stored
+
+ No_Element : Element;
+ -- The object that is returned by Get when no element has been set for
+ -- a given key
+
+ type Key is private;
+ with function Hash (F : Key) return Header_Num;
+ with function Equal (F1, F2 : Key) return Boolean;
+
+ package Simple_HTable is
+
+ type Instance is private;
+ Nil : constant Instance;
+
+ procedure Set (T : in out Instance; K : Key; E : Element);
+ -- Associates an element with a given key. Overrides any previously
+ -- associated element.
+
+ procedure Reset (T : in out Instance);
+ -- Removes and frees all elements in the table
+
+ function Get (T : Instance; K : Key) return Element;
+ -- Returns the Element associated with a key or No_Element if the
+ -- given key has not associated element
+
+ procedure Remove (T : Instance; K : Key);
+ -- Removes the latest inserted element pointer associated with the
+ -- given key if any, does nothing if none.
+
+ function Get_First (T : Instance) return Element;
+ -- Returns No_Element if the Htable is empty, otherwise returns one
+ -- non specified element. There is no guarantee that two calls to this
+ -- function will return the same element, if the Htable has been
+ -- modified between the two calls.
+
+ function Get_Next (T : Instance) return Element;
+ -- Returns a non-specified element that has not been returned by the
+ -- same function since the last call to Get_First or No_Element if
+ -- there is no such element. If there is no call to 'Set' in between
+ -- Get_Next calls, all the elements of the Htable will be traversed.
+ -- To guarantee that all the elements of the Htable will be traversed,
+ -- no modification of the Htable (Set, Reset, Remove) should occur
+ -- between a call to Get_First and subsequent consecutive calls to
+ -- Get_Next, until one of these calls returns No_Element.
+
+ private
+
+ type Element_Wrapper;
+ type Elmt_Ptr is access all Element_Wrapper;
+ type Element_Wrapper is record
+ K : Key;
+ E : Element;
+ Next : Elmt_Ptr;
+ end record;
+
+ procedure Free is new
+ Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
+
+ procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
+ function Next (E : Elmt_Ptr) return Elmt_Ptr;
+ function Get_Key (E : Elmt_Ptr) return Key;
+
+ package Tab is new Static_HTable
+ (Header_Num => Header_Num,
+ Element => Element_Wrapper,
+ Elmt_Ptr => Elmt_Ptr,
+ Null_Ptr => null,
+ Set_Next => Set_Next,
+ Next => Next,
+ Key => Key,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => Equal);
+
+ type Instance is new Tab.Instance;
+ Nil : constant Instance := Instance (Tab.Nil);
+
+ end Simple_HTable;
+
+end GNAT.Dynamic_HTables;
diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb
index 40417ed3179..1fba1b1133b 100644
--- a/gcc/ada/g-dyntab.adb
+++ b/gcc/ada/g-dyntab.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,13 +26,16 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+with GNAT.Heap_Sort_G;
with System; use System;
with System.Memory; use System.Memory;
-with System.Address_To_Access_Conversions;
+
+with Unchecked_Conversion;
package body GNAT.Dynamic_Tables is
@@ -48,17 +51,8 @@ package body GNAT.Dynamic_Tables is
-- in Max. Works correctly to do an initial allocation if the table
-- is currently null.
- package Table_Conversions is
- new System.Address_To_Access_Conversions (Big_Table_Type);
- -- Address and Access conversions for a Table object.
-
- function To_Address (Table : Table_Ptr) return Address;
- pragma Inline (To_Address);
- -- Returns the Address for the Table object.
-
- function To_Pointer (Table : Address) return Table_Ptr;
- pragma Inline (To_Pointer);
- -- Returns the Access pointer for the Table object.
+ function To_Address is new Unchecked_Conversion (Table_Ptr, Address);
+ function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr);
--------------
-- Allocate --
@@ -95,6 +89,19 @@ package body GNAT.Dynamic_Tables is
T.P.Last_Val := T.P.Last_Val - 1;
end Decrement_Last;
+ --------------
+ -- For_Each --
+ --------------
+
+ procedure For_Each (Table : Instance) is
+ Quit : Boolean := False;
+ begin
+ for Index in Table_Low_Bound .. Table_Index_Type (Table.P.Last_Val) loop
+ Action (Index, Table.Table (Index), Quit);
+ exit when Quit;
+ end loop;
+ end For_Each;
+
----------
-- Free --
----------
@@ -162,12 +169,20 @@ package body GNAT.Dynamic_Tables is
----------------
procedure Reallocate (T : in out Instance) is
- New_Size : size_t;
+ New_Length : Integer;
+ New_Size : size_t;
begin
if T.P.Max < T.P.Last_Val then
while T.P.Max < T.P.Last_Val loop
- T.P.Length := T.P.Length * (100 + Table_Increment) / 100;
+ New_Length := T.P.Length * (100 + Table_Increment) / 100;
+
+ if New_Length > T.P.Length then
+ T.P.Length := New_Length;
+ else
+ T.P.Length := T.P.Length + 1;
+ end if;
+
T.P.Max := Min + T.P.Length - 1;
end loop;
end if;
@@ -188,7 +203,6 @@ package body GNAT.Dynamic_Tables is
if T.P.Length /= 0 and then T.Table = null then
raise Storage_Error;
end if;
-
end Reallocate;
-------------
@@ -212,7 +226,7 @@ package body GNAT.Dynamic_Tables is
Item : Table_Component_Type)
is
begin
- if Integer (Index) > T.P.Max then
+ if Integer (Index) > T.P.Last_Val then
Set_Last (T, Index);
end if;
@@ -238,22 +252,79 @@ package body GNAT.Dynamic_Tables is
end Set_Last;
----------------
- -- To_Address --
+ -- Sort_Table --
----------------
- function To_Address (Table : Table_Ptr) return Address is
- begin
- return Table_Conversions.To_Address
- (Table_Conversions.Object_Pointer (Table));
- end To_Address;
+ procedure Sort_Table (Table : in out Instance) is
- ----------------
- -- To_Pointer --
- ----------------
+ Temp : Table_Component_Type;
+ -- A temporary position to simulate index 0
+
+ -- Local subprograms
+
+ function Index_Of (Idx : Natural) return Table_Index_Type;
+ -- Apply Natural to indexs of the table
+
+ function Lower_Than (Op1, Op2 : Natural) return Boolean;
+ -- Compare two components
+
+ procedure Move (From : Natural; To : Natural);
+ -- Move one component
+
+ package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than);
+
+ --------------
+ -- Index_Of --
+ --------------
+
+ function Index_Of (Idx : Natural) return Table_Index_Type is
+ begin
+ return First + Table_Index_Type (Idx) - 1;
+ end Index_Of;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ if From = 0 then
+ Table.Table (Index_Of (To)) := Temp;
+
+ elsif To = 0 then
+ Temp := Table.Table (Index_Of (From));
+
+ else
+ Table.Table (Index_Of (To)) :=
+ Table.Table (Index_Of (From));
+ end if;
+ end Move;
+
+ ----------------
+ -- Lower_Than --
+ ----------------
+
+ function Lower_Than (Op1, Op2 : Natural) return Boolean is
+ begin
+ if Op1 = 0 then
+ return Lt (Temp, Table.Table (Index_Of (Op2)));
+
+ elsif Op2 = 0 then
+ return Lt (Table.Table (Index_Of (Op1)), Temp);
+
+ else
+ return
+ Lt (Table.Table (Index_Of (Op1)),
+ Table.Table (Index_Of (Op2)));
+ end if;
+ end Lower_Than;
+
+ -- Start of processing for Sort_Table
- function To_Pointer (Table : Address) return Table_Ptr is
begin
- return Table_Ptr (Table_Conversions.To_Pointer (Table));
- end To_Pointer;
+
+ Heap_Sort.Sort (Natural (Last (Table) - First) + 1);
+
+ end Sort_Table;
end GNAT.Dynamic_Tables;
diff --git a/gcc/ada/g-dyntab.ads b/gcc/ada/g-dyntab.ads
index 6adf4ee5573..1254075a4b0 100644
--- a/gcc/ada/g-dyntab.ads
+++ b/gcc/ada/g-dyntab.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -62,6 +63,11 @@ package GNAT.Dynamic_Tables is
-- Table : array (Table_Low_Bound .. <>) of Table_Component_Type;
+ -- Note: since the upper bound can be one less than the lower
+ -- bound for an empty array, the table index type must be able
+ -- to cover this range, e.g. if the lower bound is 1, then the
+ -- Table_Index_Type should be Natural rather than Positive.
+
-- Table_Component_Type may be any Ada type, except that controlled
-- types are not supported. Note however that default initialization
-- will NOT occur for array components.
@@ -148,11 +154,11 @@ package GNAT.Dynamic_Tables is
procedure Increment_Last (T : in out Instance);
pragma Inline (Increment_Last);
- -- Adds 1 to Last (same as Set_Last (Last + 1).
+ -- Adds 1 to Last (same as Set_Last (Last + 1)
procedure Decrement_Last (T : in out Instance);
pragma Inline (Decrement_Last);
- -- Subtracts 1 from Last (same as Set_Last (Last - 1).
+ -- Subtracts 1 from Last (same as Set_Last (Last - 1)
procedure Append (T : in out Instance; New_Val : Table_Component_Type);
pragma Inline (Append);
@@ -174,7 +180,29 @@ package GNAT.Dynamic_Tables is
procedure Allocate (T : in out Instance; Num : Integer := 1);
pragma Inline (Allocate);
- -- Adds Num to Last.
+ -- Adds Num to Last
+
+ generic
+ with procedure Action
+ (Index : Table_Index_Type;
+ Item : Table_Component_Type;
+ Quit : in out Boolean) is <>;
+ procedure For_Each (Table : Instance);
+ -- Calls procedure Action for each component of the table Table, or until
+ -- one of these calls set Quit to True.
+
+ generic
+ with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean;
+ procedure Sort_Table (Table : in out Instance);
+ -- This procedure sorts the components of table Table into ascending
+ -- order making calls to Lt to do required comparisons, and using
+ -- assignments to move components around. The Lt function returns True
+ -- if Comp1 is less than Comp2 (in the sense of the desired sort), and
+ -- False if Comp1 is greater than Comp2. For equal objects it does not
+ -- matter if True or False is returned (it is slightly more efficient
+ -- to return False). The sort is not stable (the order of equal items
+ -- in the table is not preserved).
+
private
diff --git a/gcc/ada/g-eacodu.adb b/gcc/ada/g-eacodu.adb
new file mode 100644
index 00000000000..3340c881c44
--- /dev/null
+++ b/gcc/ada/g-eacodu.adb
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . E X C E P T I O N _ A C T I O N S . C O R E _ D U M P --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the default (Unix) version.
+
+separate (GNAT.Exception_Actions)
+procedure Core_Dump (Occurrence : Exception_Occurrence) is
+ pragma Unreferenced (Occurrence);
+ SIG_ABORT : constant := 6;
+ procedure C_Abort;
+ pragma Import (C, C_Abort, "abort");
+ procedure Signal (Signum : Integer; Handler : System.Address);
+ pragma Import (C, Signal, "signal");
+
+begin
+ -- Unregister the default handler for SIGABRT, since otherwise we would
+ -- simply get a standard Ada exception, which is not what we want.
+
+ Signal (SIG_ABORT, System.Null_Address);
+ C_Abort;
+end Core_Dump;
diff --git a/gcc/ada/g-enblsp.adb b/gcc/ada/g-enblsp.adb
deleted file mode 100644
index 8c583291e29..00000000000
--- a/gcc/ada/g-enblsp.adb
+++ /dev/null
@@ -1,115 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT LIBRARY COMPONENTS --
--- --
--- G N A T . E X P E C T . N O N _ B L O C K I N G _ S P A W N --
--- --
--- B o d y --
--- --
--- Copyright (C) 2002 Ada Core Technologies, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
--- --
-------------------------------------------------------------------------------
-
--- This is the default version. Used everywhere except VMS.
-
-separate (GNAT.Expect)
-procedure Non_Blocking_Spawn
- (Descriptor : out Process_Descriptor'Class;
- Command : String;
- Args : GNAT.OS_Lib.Argument_List;
- Buffer_Size : Natural := 4096;
- Err_To_Out : Boolean := False)
-is
- function Fork return Process_Id;
- pragma Import (C, Fork, "__gnat_expect_fork");
- -- Starts a new process if possible.
- -- See the Unix command fork for more information. On systems that
- -- don't support this capability (Windows...), this command does
- -- nothing, and Fork will return Null_Pid.
-
- Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
-
- Arg : String_Access;
- Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
-
- Command_With_Path : String_Access;
-
-begin
- -- Create the rest of the pipes
-
- Set_Up_Communications
- (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
-
- -- Fork a new process
-
- Descriptor.Pid := Fork;
-
- -- Are we now in the child (or, for Windows, still in the common
- -- process).
-
- if Descriptor.Pid = Null_Pid then
-
- Command_With_Path := Locate_Exec_On_Path (Command);
-
- -- Prepare an array of arguments to pass to C
- Arg := new String (1 .. Command_With_Path'Length + 1);
- Arg (1 .. Command_With_Path'Length) := Command_With_Path.all;
- Arg (Arg'Last) := ASCII.Nul;
- Arg_List (1) := Arg.all'Address;
-
- for J in Args'Range loop
- Arg := new String (1 .. Args (J)'Length + 1);
- Arg (1 .. Args (J)'Length) := Args (J).all;
- Arg (Arg'Last) := ASCII.Nul;
- Arg_List (J + 2 - Args'First) := Arg.all'Address;
- end loop;
-
- Arg_List (Arg_List'Last) := System.Null_Address;
-
- -- This does not return on Unix systems
-
- Set_Up_Child_Communications
- (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
- Arg_List'Address);
-
- Free (Command_With_Path);
- end if;
-
- -- Did we have an error when spawning the child ?
-
- if Descriptor.Pid < Null_Pid then
- null;
- else
- -- We are now in the parent process
-
- Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3);
- end if;
-
- -- Create the buffer
-
- Descriptor.Buffer_Size := Buffer_Size;
-
- if Buffer_Size /= 0 then
- Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
- end if;
-end Non_Blocking_Spawn;
diff --git a/gcc/ada/g-excact.adb b/gcc/ada/g-excact.adb
new file mode 100644
index 00000000000..3c41a5138df
--- /dev/null
+++ b/gcc/ada/g-excact.adb
@@ -0,0 +1,134 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . E X C E P T I O N _ A C T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Unchecked_Conversion;
+with System;
+with System.Soft_Links; use System.Soft_Links;
+with System.Standard_Library; use System.Standard_Library;
+with System.Exception_Table; use System.Exception_Table;
+
+package body GNAT.Exception_Actions is
+
+ Global_Action : Exception_Action;
+ pragma Import (C, Global_Action, "__gnat_exception_actions_global_action");
+ -- Imported from Ada.Exceptions. Any change in the external name needs to
+ -- be coordinated with a-except.adb
+
+ Raise_Hook_Initialized : Boolean;
+ pragma Import
+ (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized");
+
+ function To_Raise_Action is new Ada.Unchecked_Conversion
+ (Exception_Action, Raise_Action);
+
+ -- ??? Would be nice to have this in System.Standard_Library
+ function To_Data is new Ada.Unchecked_Conversion
+ (Exception_Id, Exception_Data_Ptr);
+ function To_Id is new Ada.Unchecked_Conversion
+ (Exception_Data_Ptr, Exception_Id);
+
+ ----------------------------
+ -- Register_Global_Action --
+ ----------------------------
+
+ procedure Register_Global_Action (Action : Exception_Action) is
+ begin
+ Lock_Task.all;
+ Global_Action := Action;
+ Unlock_Task.all;
+ end Register_Global_Action;
+
+ ------------------------
+ -- Register_Id_Action --
+ ------------------------
+
+ procedure Register_Id_Action
+ (Id : Exception_Id;
+ Action : Exception_Action)
+ is
+ begin
+ if Id = Null_Id then
+ raise Program_Error;
+ end if;
+
+ Lock_Task.all;
+ To_Data (Id).Raise_Hook := To_Raise_Action (Action);
+ Raise_Hook_Initialized := True;
+ Unlock_Task.all;
+ end Register_Id_Action;
+
+ ---------------
+ -- Core_Dump --
+ ---------------
+
+ procedure Core_Dump (Occurrence : Exception_Occurrence) is separate;
+
+ ----------------
+ -- Name_To_Id --
+ ----------------
+
+ function Name_To_Id (Name : String) return Exception_Id is
+ begin
+ return To_Id (Internal_Exception (Name, False));
+ end Name_To_Id;
+
+ ---------------------------------
+ -- Registered_Exceptions_Count --
+ ---------------------------------
+
+ function Registered_Exceptions_Count return Natural renames
+ System.Exception_Table.Registered_Exceptions_Count;
+
+ -------------------------------
+ -- Get_Registered_Exceptions --
+ -------------------------------
+ -- This subprogram isn't an iterator to avoid concurrency problems,
+ -- since the exceptions are registered dynamically. Since we have to lock
+ -- the runtime while computing this array, this means that any callback in
+ -- an active iterator would be unable to access the runtime.
+
+ procedure Get_Registered_Exceptions
+ (List : out Exception_Id_Array;
+ Last : out Integer)
+ is
+ Ids : Exception_Data_Array (List'Range);
+ begin
+ Get_Registered_Exceptions (Ids, Last);
+
+ for L in List'First .. Last loop
+ List (L) := To_Id (Ids (L));
+ end loop;
+ end Get_Registered_Exceptions;
+
+end GNAT.Exception_Actions;
diff --git a/gcc/ada/g-excact.ads b/gcc/ada/g-excact.ads
new file mode 100644
index 00000000000..c90017fbfea
--- /dev/null
+++ b/gcc/ada/g-excact.ads
@@ -0,0 +1,118 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . E X C E P T I O N _ A C T I O N S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides support for callbacks on exceptions.
+
+-- These callbacks are called immediately when either a specific exception,
+-- or any exception, is raised, before any other actions taken by raise, in
+-- particular before any unwinding of the stack occcurs.
+
+-- Callbacks for specific exceptions are registered through calls to
+-- Register_Id_Action. Here is an example of code that uses this package to
+-- automatically core dump when the exception Constraint_Error is raised.
+
+-- Register_Id_Action (Constraint_Error'Identity, Core_Dump'Access);
+
+-- Subprograms are also provided to list the currently registered exceptions,
+-- or to convert from a string to an exception id.
+
+-- This package can easily be extended, for instance to provide a callback
+-- whenever an exception matching a regular expression is raised. The idea
+-- is to register a global action, called whenever any exception is raised.
+-- Dispatching can then be done directly in this global action callback.
+
+with Ada.Exceptions; use Ada.Exceptions;
+
+package GNAT.Exception_Actions is
+
+ type Exception_Action is access
+ procedure (Occurence : Exception_Occurrence);
+ -- General callback type whenever an exception is raised. The callback
+ -- procedure must not propagate an exception (execution of the program
+ -- is erroneous if such an exception is propagated).
+
+ procedure Register_Global_Action (Action : Exception_Action);
+ -- Action will be called whenever an exception is raised. Only one such
+ -- action can be registered at any given time, and registering a new action
+ -- will override any previous action that might have been registered.
+ --
+ -- Action is called before the exception is propagated to user's code.
+ -- If Action is null, this will in effect cancel all exception actions.
+
+ procedure Register_Id_Action
+ (Id : Exception_Id;
+ Action : Exception_Action);
+ -- Action will be called whenever an exception of type Id is raised. Only
+ -- one such action can be registered for each exception id, and registering
+ -- a new action will override any previous action registered for this
+ -- Exception_Id. Program_Error is raised if Id is Null_Id.
+
+ function Name_To_Id (Name : String) return Exception_Id;
+ -- Convert an exception name to an exception id. Null_Id is returned
+ -- if no such exception exists. Name must be an all upper-case string,
+ -- or the exception will not be found. The exception name must be fully
+ -- qualified (but not including Standard). It is not possible to convert
+ -- an exception that is declared within an unlabeled block.
+ --
+ -- Note: All non-predefined exceptions will return Null_Id for programs
+ -- compiled with pragma Restriction (No_Exception_Registration)
+
+ function Registered_Exceptions_Count return Natural;
+ -- Return the number of exceptions that have been registered so far.
+ -- Exceptions declared locally will not appear in this list until their
+ -- block has been executed at least once.
+ --
+ -- Note: The count includes only predefined exceptions for programs
+ -- compiled with pragma Restrictions (No_Exception_Registration).
+
+ type Exception_Id_Array is array (Natural range <>) of Exception_Id;
+
+ procedure Get_Registered_Exceptions
+ (List : out Exception_Id_Array;
+ Last : out Integer);
+ -- Return the list of registered exceptions.
+ -- Last is the index in List of the last exception returned.
+ --
+ -- An exception is registered the first time the block containing its
+ -- declaration is elaborated. Exceptions defined at library-level are
+ -- therefore immediately visible, whereas exceptions declared in local
+ -- blocks will not be visible until the block is executed at least once.
+ --
+ -- Note: The list contains only the predefined exceptions if the program
+ -- is compiled with pragma Restrictions (No_Exception_Registration);
+
+ procedure Core_Dump (Occurrence : Exception_Occurrence);
+ -- Dump memory (called a core dump in some systems), and abort execution
+ -- of the application.
+
+end GNAT.Exception_Actions;
diff --git a/gcc/ada/g-except.ads b/gcc/ada/g-except.ads
index 79118d92efa..b85da64f66a 100644
--- a/gcc/ada/g-except.ads
+++ b/gcc/ada/g-except.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2002 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,13 +27,20 @@
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides an interface for raising predefined exceptions
--- with an exception message. It can be used from Pure units. This unit
--- is for internal use only, it is not generally available to applications.
+-- with an exception message. It can be used from Pure units.
+
+-- There is no prohibition in Ada that prevents exceptions being raised
+-- from within pure units. The raise statement is perfectly acceptable.
+
+-- However, it is not normally possible to raise an exception with a
+-- message because the routine Ada.Exceptions.Raise_Exception is not in
+-- a Pure unit. This is an annoying and unnecessary restrictiona and this
+-- package allows for raising the standard predefined exceptions at least.
package GNAT.Exceptions is
pragma Pure (Exceptions);
diff --git a/gcc/ada/g-exctra.adb b/gcc/ada/g-exctra.adb
index 76a380f524d..a26f783d2d6 100644
--- a/gcc/ada/g-exctra.adb
+++ b/gcc/ada/g-exctra.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-exctra.ads b/gcc/ada/g-exctra.ads
index 7ccbf652c2c..d2a167a671b 100644
--- a/gcc/ada/g-exctra.ads
+++ b/gcc/ada/g-exctra.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb
index 32ed1c1e8fc..144b157feee 100644
--- a/gcc/ada/g-expect.adb
+++ b/gcc/ada/g-expect.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -86,38 +87,17 @@ package body GNAT.Expect is
pragma Import (C, Dup2);
procedure Kill (Pid : Process_Id; Sig_Num : Integer);
- pragma Import (C, Kill);
+ pragma Import (C, Kill, "__gnat_kill");
function Create_Pipe (Pipe : access Pipe_Type) return Integer;
pragma Import (C, Create_Pipe, "__gnat_pipe");
- function Read
- (Fd : File_Descriptor;
- A : System.Address;
- N : Integer)
- return Integer;
- pragma Import (C, Read, "read");
- -- Read N bytes to address A from file referenced by FD. Returned value
- -- is count of bytes actually read, which can be less than N at EOF.
-
- procedure Close (Fd : File_Descriptor);
- pragma Import (C, Close);
- -- Close a file given its file descriptor.
-
- function Write
- (Fd : File_Descriptor;
- A : System.Address;
- N : Integer)
- return Integer;
- pragma Import (C, Write, "write");
- -- Read N bytes to address A from file referenced by FD. Returned value
- -- is count of bytes actually read, which can be less than N at EOF.
-
function Poll
(Fds : System.Address;
Num_Fds : Integer;
Timeout : Integer;
- Is_Set : System.Address) return Integer;
+ Is_Set : System.Address)
+ return Integer;
pragma Import (C, Poll, "__gnat_expect_poll");
-- Check whether there is any data waiting on the file descriptor
-- Out_fd, and wait if there is none, at most Timeout milliseconds
@@ -310,7 +290,7 @@ package body GNAT.Expect is
is
N : Expect_Match;
Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
- Try_Until : Time := Clock + Duration (Timeout) / 1000.0;
+ Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0;
Timeout_Tmp : Integer := Timeout;
begin
@@ -729,10 +709,10 @@ package body GNAT.Expect is
(Descriptor : in out Process_Descriptor;
Timeout : Integer := 0)
is
+ Buffer_Size : constant Integer := 8192;
Num_Descriptors : Integer;
N : Integer;
Is_Set : aliased Integer;
- Buffer_Size : Integer := 8192;
Buffer : aliased String (1 .. Buffer_Size);
begin
@@ -856,7 +836,98 @@ package body GNAT.Expect is
Buffer_Size : Natural := 4096;
Err_To_Out : Boolean := False)
is
- separate;
+ function Fork return Process_Id;
+ pragma Import (C, Fork, "__gnat_expect_fork");
+ -- Starts a new process if possible. See the Unix command fork for more
+ -- information. On systems that do not support this capability (such as
+ -- Windows...), this command does nothing, and Fork will return
+ -- Null_Pid.
+
+ Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
+
+ Arg : String_Access;
+ Arg_List : String_List (1 .. Args'Length + 2);
+ C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
+
+ Command_With_Path : String_Access;
+
+ begin
+ -- Create the rest of the pipes
+
+ Set_Up_Communications
+ (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
+
+ Command_With_Path := Locate_Exec_On_Path (Command);
+
+ if Command_With_Path = null then
+ raise Invalid_Process;
+ end if;
+
+ -- Fork a new process
+
+ Descriptor.Pid := Fork;
+
+ -- Are we now in the child (or, for Windows, still in the common
+ -- process).
+
+ if Descriptor.Pid = Null_Pid then
+ -- Prepare an array of arguments to pass to C
+
+ Arg := new String (1 .. Command_With_Path'Length + 1);
+ Arg (1 .. Command_With_Path'Length) := Command_With_Path.all;
+ Arg (Arg'Last) := ASCII.NUL;
+ Arg_List (1) := Arg;
+
+ for J in Args'Range loop
+ Arg := new String (1 .. Args (J)'Length + 1);
+ Arg (1 .. Args (J)'Length) := Args (J).all;
+ Arg (Arg'Last) := ASCII.NUL;
+ Arg_List (J + 2 - Args'First) := Arg.all'Access;
+ end loop;
+
+ Arg_List (Arg_List'Last) := null;
+
+ -- Make sure all arguments are compatible with OS conventions
+
+ Normalize_Arguments (Arg_List);
+
+ -- Prepare low-level argument list from the normalized arguments
+
+ for K in Arg_List'Range loop
+ if Arg_List (K) /= null then
+ C_Arg_List (K) := Arg_List (K).all'Address;
+ else
+ C_Arg_List (K) := System.Null_Address;
+ end if;
+ end loop;
+
+ -- This does not return on Unix systems
+
+ Set_Up_Child_Communications
+ (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
+ C_Arg_List'Address);
+ end if;
+
+ Free (Command_With_Path);
+
+ -- Did we have an error when spawning the child ?
+
+ if Descriptor.Pid < Null_Pid then
+ raise Invalid_Process;
+ else
+ -- We are now in the parent process
+
+ Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3);
+ end if;
+
+ -- Create the buffer
+
+ Descriptor.Buffer_Size := Buffer_Size;
+
+ if Buffer_Size /= 0 then
+ Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
+ end if;
+ end Non_Blocking_Spawn;
-------------------------
-- Reinitialize_Buffer --
@@ -938,12 +1009,14 @@ package body GNAT.Expect is
Add_LF : Boolean := True;
Empty_Buffer : Boolean := False)
is
- N : Natural;
Full_Str : constant String := Str & ASCII.LF;
Last : Natural;
Result : Expect_Match;
Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access);
+ Dummy : Natural;
+ pragma Unreferenced (Dummy);
+
begin
if Empty_Buffer then
@@ -966,9 +1039,10 @@ package body GNAT.Expect is
Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input);
- N := Write (Descriptor.Input_Fd,
- Full_Str'Address,
- Last - Full_Str'First + 1);
+ Dummy :=
+ Write (Descriptor.Input_Fd,
+ Full_Str'Address,
+ Last - Full_Str'First + 1);
end Send;
-----------------
@@ -1032,7 +1106,7 @@ package body GNAT.Expect is
Dup2 (Input, GNAT.OS_Lib.Standin);
Dup2 (Output, GNAT.OS_Lib.Standout);
- Dup2 (Error, GNAT.OS_Lib.Standerr);
+ Dup2 (Error, GNAT.OS_Lib.Standerr);
Close (Input);
Close (Output);
Close (Error);
diff --git a/gcc/ada/g-expect.ads b/gcc/ada/g-expect.ads
index 07a3b1c5080..4a57022b52f 100644
--- a/gcc/ada/g-expect.ads
+++ b/gcc/ada/g-expect.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,26 +26,27 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Currently this package is implemented on all native GNAT ports except
-- for VMS. It is not yet implemented for any of the cross-ports (e.g. it
-- is not available for VxWorks or LynxOS).
---
+
-- Usage
-- =====
---
+
-- This package provides a set of subprograms similar to what is available
-- with the standard Tcl Expect tool.
-- It allows you to easily spawn and communicate with an external process.
-- You can send commands or inputs to the process, and compare the output
-- with some expected regular expression.
---
+
-- Usage example:
---
+
-- Non_Blocking_Spawn
-- (Fd, "ftp",
-- (1 => new String' ("machine@domaine")));
@@ -59,13 +60,13 @@
-- when others => null;
-- end case;
-- Close (Fd);
---
+
-- You can also combine multiple regular expressions together, and get the
-- specific string matching a parenthesis pair by doing something like. If you
-- expect either "lang=optional ada" or "lang=ada" from the external process,
-- you can group the two together, which is more efficient, and simply get the
-- name of the language by doing:
---
+
-- declare
-- Matched : Regexp_Array (0 .. 2);
-- begin
@@ -73,11 +74,11 @@
-- Put_Line ("Seen: " &
-- Expect_Out (Fd) (Matched (2).First .. Matched (2).Last));
-- end;
---
+
-- Alternatively, you might choose to use a lower-level interface to the
-- processes, where you can give your own input and output filters every
-- time characters are read from or written to the process.
---
+
-- procedure My_Filter
-- (Descriptor : Process_Descriptor'Class;
-- Str : String;
@@ -86,36 +87,35 @@
-- begin
-- Put_Line (Str);
-- end;
---
+
-- Non_Blocking_Spawn
-- (Fd, "tail",
-- (new String' ("-f"), new String' ("a_file")));
-- Add_Filter (Fd, My_Filter'Access, Output);
-- Expect (Fd, Result, "", 0); -- wait forever
---
+
-- The above example should probably be run in a separate task, since it is
-- blocking on the call to Expect.
---
+
-- Both examples can be combined, for instance to systematically print the
-- output seen by expect, even though you still want to let Expect do the
-- filtering. You can use the Trace_Filter subprogram for such a filter.
---
+
-- If you want to get the output of a simple command, and ignore any previous
-- existing output, it is recommended to do something like:
---
+
-- Expect (Fd, Result, ".*", Timeout => 0);
-- -- Empty the buffer, by matching everything (after checking
-- -- if there was any input).
---
+
-- Send (Fd, "command");
-- Expect (Fd, Result, ".."); -- match only on the output of command
---
+
-- Task Safety
-- ===========
---
--- This package is not task-safe. However, you can easily make is task safe
--- by encapsulating the type Process_Descriptor in a protected record.
--- There should not be concurrent calls to Expect.
+
+-- This package is not task-safe: there should be not concurrent calls to
+-- the functions defined in this package.
with System;
with GNAT.OS_Lib;
@@ -219,7 +219,7 @@ package GNAT.Expect is
function Get_Pid
(Descriptor : Process_Descriptor)
return Process_Id;
- -- Return the process id associated with a given process descriptor.
+ -- Return the process id assocated with a given process descriptor.
--------------------
-- Adding filters --
diff --git a/gcc/ada/g-heasor.adb b/gcc/ada/g-heasor.adb
new file mode 100644
index 00000000000..bd406a8fabb
--- /dev/null
+++ b/gcc/ada/g-heasor.adb
@@ -0,0 +1,132 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- G N A T . H E A P _ S O R T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body GNAT.Heap_Sort is
+
+ ----------
+ -- Sort --
+ ----------
+
+ -- We are using the classical heapsort algorithm (i.e. Floyd's Treesort3)
+ -- as described by Knuth ("The Art of Programming", Volume III, first
+ -- edition, section 5.2.3, p. 145-147) with the modification that is
+ -- mentioned in exercise 18. For more details on this algorithm, see
+ -- Robert B. K. Dewar PhD thesis "The use of Computers in the X-ray
+ -- Phase Problem". University of Chicago, 1968, which was the first
+ -- publication of the modification, which reduces the number of compares
+ -- from 2NlogN to NlogN.
+
+ procedure Sort (N : Natural; Xchg : Xchg_Procedure; Lt : Lt_Function) is
+ Max : Natural := N;
+ -- Current Max index in tree being sifted. Note that we make Max
+ -- Natural rather than Positive so that the case of sorting zero
+ -- elements is correctly handled (i.e. does nothing at all).
+
+ procedure Sift (S : Positive);
+ -- This procedure sifts up node S, i.e. converts the subtree rooted
+ -- at node S into a heap, given the precondition that any sons of
+ -- S are already heaps.
+
+ ----------
+ -- Sift --
+ ----------
+
+ procedure Sift (S : Positive) is
+ C : Positive := S;
+ Son : Positive;
+ Father : Positive;
+
+ begin
+ -- This is where the optimization is done, normally we would do a
+ -- comparison at each stage between the current node and the larger
+ -- of the two sons, and continue the sift only if the current node
+ -- was less than this maximum. In this modified optimized version,
+ -- we assume that the current node will be less than the larger
+ -- son, and unconditionally sift up. Then when we get to the bottom
+ -- of the tree, we check parents to make sure that we did not make
+ -- a mistake. This roughly cuts the number of comparisions in half,
+ -- since it is almost always the case that our assumption is correct.
+
+ -- Loop to pull up larger sons
+
+ loop
+ Son := C + C;
+
+ if Son < Max then
+ if Lt (Son, Son + 1) then
+ Son := Son + 1;
+ end if;
+ elsif Son > Max then
+ exit;
+ end if;
+
+ Xchg (Son, C);
+ C := Son;
+ end loop;
+
+ -- Loop to check fathers
+
+ while C /= S loop
+ Father := C / 2;
+
+ if Lt (Father, C) then
+ Xchg (Father, C);
+ C := Father;
+ else
+ exit;
+ end if;
+ end loop;
+ end Sift;
+
+ -- Start of processing for Sort
+
+ begin
+ -- Phase one of heapsort is to build the heap. This is done by
+ -- sifting nodes N/2 .. 1 in sequence.
+
+ for J in reverse 1 .. N / 2 loop
+ Sift (J);
+ end loop;
+
+ -- In phase 2, the largest node is moved to end, reducing the size
+ -- of the tree by one, and the displaced node is sifted down from
+ -- the top, so that the largest node is again at the top.
+
+ while Max > 1 loop
+ Xchg (1, Max);
+ Max := Max - 1;
+ Sift (1);
+ end loop;
+ end Sort;
+
+end GNAT.Heap_Sort;
diff --git a/gcc/ada/g-heasor.ads b/gcc/ada/g-heasor.ads
new file mode 100644
index 00000000000..1f81a4e3763
--- /dev/null
+++ b/gcc/ada/g-heasor.ads
@@ -0,0 +1,73 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- G N A T . H E A P _ S O R T --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Sort utility (Using Heapsort Algorithm)
+
+-- This package provides a heapsort routine that works with access to
+-- subprogram parameters, so that it can be used with different types with
+-- shared sorting code.
+
+-- See also GNAT.Heap_Sort_G and GNAT.Heap_Sort_A. These are older versions
+-- of this routine. In some cases GNAT.Heap_Sort_G may be a little faster
+-- than GNAT.Heap_Sort, at the expense of generic code duplication and a
+-- less convenient interface. The generic version also has the advantage
+-- of being Pure, while this unit can only be Preelaborate.
+
+-- This heapsort algorithm uses approximately N*log(N) compares in the
+-- worst case and is in place with no additional storage required. See
+-- the body for exact details of the algorithm used.
+
+package GNAT.Heap_Sort is
+pragma Preelaborate (Heap_Sort);
+
+ -- The data to be sorted is assumed to be indexed by integer values
+ -- from 1 to N, where N is the number of items to be sorted.
+
+ type Xchg_Procedure is access procedure (Op1, Op2 : Natural);
+ -- A pointer to a procedure that exchanges the two data items whose
+ -- index values are Op1 and Op2.
+
+ type Lt_Function is access function (Op1, Op2 : Natural) return Boolean;
+ -- A pointer to a function that compares two items and returns True if
+ -- the item with index value Op1 is less than the item with Index value
+ -- Op2, and False if the Op1 item is greater than the Op2 item. If
+ -- the items are equal, then it does not matter if True or False is
+ -- returned (but it is slightly more efficient to return False).
+
+ procedure Sort (N : Natural; Xchg : Xchg_Procedure; Lt : Lt_Function);
+ -- This procedures sorts items in the range from 1 to N into ascending
+ -- order making calls to Lt to do required comparisons, and calls to
+ -- Xchg to exchange items. The sort is not stable, that is the order
+ -- of equal items in the input data set is not preserved.
+
+end GNAT.Heap_Sort;
diff --git a/gcc/ada/g-hesora.adb b/gcc/ada/g-hesora.adb
index 71fab90d2a2..6b6ff307938 100644
--- a/gcc/ada/g-hesora.adb
+++ b/gcc/ada/g-hesora.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-hesora.ads b/gcc/ada/g-hesora.ads
index 019da395141..22e1d063c5f 100644
--- a/gcc/ada/g-hesora.ads
+++ b/gcc/ada/g-hesora.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2000 Ada Core Technologies, Inc. --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,18 +26,21 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Heapsort using access to procedure parameters
--- This package provides a heapsort routine that works with access to
+-- This package provides a heap sort routine that works with access to
-- subprogram parameters, so that it can be used with different types with
--- shared sorting code. See also GNAT.Heap_Sort_G, the generic version,
--- which is a little more efficient but does not allow code sharing.
--- The generic version is also Pure, while the access version can
--- only be Preelaborate.
+-- shared sorting code. It is considered obsoleted by GNAT.Heap_Sort which
+-- offers a similar routine with a more convenient interface.
+
+-- This heapsort algorithm uses approximately N*log(N) compares in the
+-- worst case and is in place with no additional storage required. See
+-- the body for exact details of the algorithm used.
package GNAT.Heap_Sort_A is
pragma Preelaborate (Heap_Sort_A);
diff --git a/gcc/ada/g-hesorg.adb b/gcc/ada/g-hesorg.adb
index 229a1e382e8..cc4a5b32489 100644
--- a/gcc/ada/g-hesorg.adb
+++ b/gcc/ada/g-hesorg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-1999 Ada Core Technologies, Inc. --
+-- Copyright (C) 1995-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -58,10 +59,17 @@ package body GNAT.Heap_Sort_G is
-- entry are irrelevant. This is just a minor optimization to avoid
-- what would otherwise be two junk moves in phase two of the sort.
+ ----------
+ -- Sift --
+ ----------
+
procedure Sift (S : Positive) is
C : Positive := S;
Son : Positive;
Father : Positive;
+ -- Note: by making the above all Positive, we ensure that a test
+ -- against zero for the temporary location can be resolved on the
+ -- basis of types when the routines are inlined.
begin
-- This is where the optimization is done, normally we would do a
@@ -78,10 +86,13 @@ package body GNAT.Heap_Sort_G is
loop
Son := 2 * C;
- exit when Son > Max;
- if Son < Max and then Lt (Son, Son + 1) then
- Son := Son + 1;
+ if Son < Max then
+ if Lt (Son, Son + 1) then
+ Son := Son + 1;
+ end if;
+ elsif Son > Max then
+ exit;
end if;
Move (Son, C);
diff --git a/gcc/ada/g-hesorg.ads b/gcc/ada/g-hesorg.ads
index ada7ca1cbc7..4980c028b56 100644
--- a/gcc/ada/g-hesorg.ads
+++ b/gcc/ada/g-hesorg.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2000 Ada Core Technologies, Inc. --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,17 +26,29 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Heapsort generic package using formal procedures
-- This package provides a generic heapsort routine that can be used with
--- different types of data. See also GNAT.Heap_Sort_A, a version that works
--- with subprogram parameters, allowing code sharing. The generic version
--- is slightly more efficient but does not allow code sharing. The generic
--- version is also Pure, while the access version can only be Preelaborate.
+-- different types of data.
+
+-- See also GNAT.Heap_Sort, a version that works with subprogram access
+-- parameters, allowing code sharing. The generic version is slightly more
+-- efficient but does not allow code sharing and has an interface that is
+-- more awkward to use. The generic version is also Pure, while the access
+-- subprogram version can only be Preelaborate.
+
+-- There is also GNAT.Heap_Sort_A, which is now considered obsolete, but
+-- was an older version working with subprogram parameters. This version
+-- is retained for bacwards compatibility with old versions of GNAT.
+
+-- This heapsort algorithm uses approximately N*log(N) compares in the
+-- worst case and is in place with no additional storage required. See
+-- the body for exact details of the algorithm used.
generic
-- The data to be sorted is assumed to be indexed by integer values from
@@ -44,14 +56,25 @@ generic
-- index value zero is used for a temporary location used during the sort.
with procedure Move (From : Natural; To : Natural);
- -- A procedure that moves the data item with index From to the data item
- -- with Index To. An index value of zero is used for moves from and to a
- -- single temporary location used by the sort.
+ -- A procedure that moves the data item with index value From to the data
+ -- item with index value To (the old value in To being lost). An index
+ -- value of zero is used for moves from and to a single temporary location
with function Lt (Op1, Op2 : Natural) return Boolean;
-- A function that compares two items and returns True if the item with
-- index Op1 is less than the item with Index Op2, and False if the Op1
- -- item is greater than or equal to the Op2 item.
+ -- item is greater than the Op2 item. If the two items are equal, then
+ -- it does not matter whether True or False is returned (it is slightly
+ -- more efficient to return False).
+
+ -- Note on use of temporary location
+
+ -- There are two ways of providing for the index value zero to represent
+ -- a temporary value. Either an extra location can be allocated at the
+ -- start of the array, or alternatively the Move and Lt subprograms can
+ -- test for the case of zero and treat it specially. In any case it is
+ -- desirable to specify the two subprograms as inlined and the tests for
+ -- zero will in this case be resolved at instantiation time.
package GNAT.Heap_Sort_G is
pragma Pure (Heap_Sort_G);
diff --git a/gcc/ada/g-htable.adb b/gcc/ada/g-htable.adb
index 5db9df2d7ca..f3eec2bcada 100644
--- a/gcc/ada/g-htable.adb
+++ b/gcc/ada/g-htable.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-1999 Ada Core Technologies, Inc. --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,335 +26,15 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with Ada.Unchecked_Deallocation;
-package body GNAT.HTable is
-
- --------------------
- -- Static_HTable --
- --------------------
-
- package body Static_HTable is
-
- Table : array (Header_Num) of Elmt_Ptr;
-
- Iterator_Index : Header_Num;
- Iterator_Ptr : Elmt_Ptr;
- Iterator_Started : Boolean := False;
-
- function Get_Non_Null return Elmt_Ptr;
- -- Returns Null_Ptr if Iterator_Started is false of the Table is
- -- empty. Returns Iterator_Ptr if non null, or the next non null
- -- element in table if any.
-
- ---------
- -- Get --
- ---------
-
- function Get (K : Key) return Elmt_Ptr is
- Elmt : Elmt_Ptr;
-
- begin
- Elmt := Table (Hash (K));
-
- loop
- if Elmt = Null_Ptr then
- return Null_Ptr;
-
- elsif Equal (Get_Key (Elmt), K) then
- return Elmt;
-
- else
- Elmt := Next (Elmt);
- end if;
- end loop;
- end Get;
-
- ---------------
- -- Get_First --
- ---------------
-
- function Get_First return Elmt_Ptr is
- begin
- Iterator_Started := True;
- Iterator_Index := Table'First;
- Iterator_Ptr := Table (Iterator_Index);
- return Get_Non_Null;
- end Get_First;
-
- --------------
- -- Get_Next --
- --------------
-
- function Get_Next return Elmt_Ptr is
- begin
- if not Iterator_Started then
- return Null_Ptr;
- end if;
-
- Iterator_Ptr := Next (Iterator_Ptr);
- return Get_Non_Null;
- end Get_Next;
-
- ------------------
- -- Get_Non_Null --
- ------------------
-
- function Get_Non_Null return Elmt_Ptr is
- begin
- while Iterator_Ptr = Null_Ptr loop
- if Iterator_Index = Table'Last then
- Iterator_Started := False;
- return Null_Ptr;
- end if;
-
- Iterator_Index := Iterator_Index + 1;
- Iterator_Ptr := Table (Iterator_Index);
- end loop;
-
- return Iterator_Ptr;
- end Get_Non_Null;
-
- ------------
- -- Remove --
- ------------
-
- procedure Remove (K : Key) is
- Index : constant Header_Num := Hash (K);
- Elmt : Elmt_Ptr;
- Next_Elmt : Elmt_Ptr;
-
- begin
- Elmt := Table (Index);
-
- if Elmt = Null_Ptr then
- return;
-
- elsif Equal (Get_Key (Elmt), K) then
- Table (Index) := Next (Elmt);
-
- else
- loop
- Next_Elmt := Next (Elmt);
-
- if Next_Elmt = Null_Ptr then
- return;
-
- elsif Equal (Get_Key (Next_Elmt), K) then
- Set_Next (Elmt, Next (Next_Elmt));
- return;
-
- else
- Elmt := Next_Elmt;
- end if;
- end loop;
- end if;
- end Remove;
-
- -----------
- -- Reset --
- -----------
-
- procedure Reset is
- begin
- for J in Table'Range loop
- Table (J) := Null_Ptr;
- end loop;
- end Reset;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (E : Elmt_Ptr) is
- Index : Header_Num;
-
- begin
- Index := Hash (Get_Key (E));
- Set_Next (E, Table (Index));
- Table (Index) := E;
- end Set;
-
- end Static_HTable;
-
- --------------------
- -- Simple_HTable --
- --------------------
-
- package body Simple_HTable is
-
- type Element_Wrapper;
- type Elmt_Ptr is access all Element_Wrapper;
- type Element_Wrapper is record
- K : Key;
- E : Element;
- Next : Elmt_Ptr;
- end record;
-
- procedure Free is new
- Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
-
- procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
- function Next (E : Elmt_Ptr) return Elmt_Ptr;
- function Get_Key (E : Elmt_Ptr) return Key;
-
- package Tab is new Static_HTable (
- Header_Num => Header_Num,
- Element => Element_Wrapper,
- Elmt_Ptr => Elmt_Ptr,
- Null_Ptr => null,
- Set_Next => Set_Next,
- Next => Next,
- Key => Key,
- Get_Key => Get_Key,
- Hash => Hash,
- Equal => Equal);
-
- ---------
- -- Get --
- ---------
-
- function Get (K : Key) return Element is
- Tmp : constant Elmt_Ptr := Tab.Get (K);
-
- begin
- if Tmp = null then
- return No_Element;
- else
- return Tmp.E;
- end if;
- end Get;
-
- ---------------
- -- Get_First --
- ---------------
-
- function Get_First return Element is
- Tmp : constant Elmt_Ptr := Tab.Get_First;
-
- begin
- if Tmp = null then
- return No_Element;
- else
- return Tmp.E;
- end if;
- end Get_First;
-
- -------------
- -- Get_Key --
- -------------
-
- function Get_Key (E : Elmt_Ptr) return Key is
- begin
- return E.K;
- end Get_Key;
-
- --------------
- -- Get_Next --
- --------------
-
- function Get_Next return Element is
- Tmp : constant Elmt_Ptr := Tab.Get_Next;
-
- begin
- if Tmp = null then
- return No_Element;
- else
- return Tmp.E;
- end if;
- end Get_Next;
-
- ----------
- -- Next --
- ----------
-
- function Next (E : Elmt_Ptr) return Elmt_Ptr is
- begin
- return E.Next;
- end Next;
-
- ------------
- -- Remove --
- ------------
-
- procedure Remove (K : Key) is
- Tmp : Elmt_Ptr;
-
- begin
- Tmp := Tab.Get (K);
-
- if Tmp /= null then
- Tab.Remove (K);
- Free (Tmp);
- end if;
- end Remove;
-
- -----------
- -- Reset --
- -----------
-
- procedure Reset is
- E1, E2 : Elmt_Ptr;
-
- begin
- E1 := Tab.Get_First;
- while E1 /= null loop
- E2 := Tab.Get_Next;
- Free (E1);
- E1 := E2;
- end loop;
-
- Tab.Reset;
- end Reset;
-
- ---------
- -- Set --
- ---------
-
- procedure Set (K : Key; E : Element) is
- Tmp : constant Elmt_Ptr := Tab.Get (K);
-
- begin
- if Tmp = null then
- Tab.Set (new Element_Wrapper'(K, E, null));
- else
- Tmp.E := E;
- end if;
- end Set;
-
- --------------
- -- Set_Next --
- --------------
-
- procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
- begin
- E.Next := Next;
- end Set_Next;
- end Simple_HTable;
-
- ----------
- -- Hash --
- ----------
-
- function Hash (Key : String) return Header_Num is
-
- type Uns is mod 2 ** 32;
-
- function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
- pragma Import (Intrinsic, Rotate_Left);
-
- Tmp : Uns := 0;
-
- begin
- for J in Key'Range loop
- Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J));
- end loop;
-
- return Header_Num'First +
- Header_Num'Base (Tmp mod Header_Num'Range_Length);
- end Hash;
+-- This is a dummy body, required because if we remove the body we have
+-- bootstrap path problems (this unit used to have a body, and if we do not
+-- supply a dummy body, the old incorrect body is picked up during the
+-- bootstrap process.
+package body GNAT.HTable is
end GNAT.HTable;
diff --git a/gcc/ada/g-htable.ads b/gcc/ada/g-htable.ads
index 114c6570261..de3ec07de0a 100644
--- a/gcc/ada/g-htable.ads
+++ b/gcc/ada/g-htable.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,21 +26,34 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Hash table searching routines
--- This package contains two separate packages. The Simple_Htable package
--- provides a very simple abstraction that asosicates one element to one
--- key values and takes care of all allocation automatically using the heap.
--- The Static_Htable package provides a more complex interface that allows
+-- This package contains two separate packages. The Simple_HTable package
+-- provides a very simple abstraction that associates one element to one
+-- key value and takes care of all allocations automatically using the heap.
+-- The Static_HTable package provides a more complex interface that allows
-- complete control over allocation.
+-- Note: actual code is found in System.HTable (s-htable.ads/adb) since
+-- this facility is accessed from run time routines, but clients should
+-- always access the version supplied via GNAT.HTable.
+
+with System.HTable;
+
package GNAT.HTable is
pragma Preelaborate (HTable);
+pragma Elaborate_Body;
+-- The elaborate body is because we have a dummy body to deal with bootstrap
+-- path problems (we used to have a real body, and now we don't need it any
+-- more, but the bootstrap requires that we have a dummy body, since otherwise
+-- the old body gets picked up.
+
-------------------
-- Simple_HTable --
-------------------
@@ -51,49 +64,53 @@ pragma Preelaborate (HTable);
-- retrieval is function of the size of the Table parameterized by
-- Header_Num and the hashing function Hash.
- generic
- type Header_Num is range <>;
- -- An integer type indicating the number and range of hash headers.
+ generic package Simple_HTable renames System.HTable.Simple_HTable;
+
+ -- For convenience of reference here is what this package has in it:
- type Element is private;
- -- The type of element to be stored
+ -- generic
+ -- type Header_Num is range <>;
+ -- -- An integer type indicating the number and range of hash headers
- No_Element : Element;
- -- The object that is returned by Get when no element has been set for
- -- a given key
+ -- type Element is private;
+ -- -- The type of element to be stored
- type Key is private;
- with function Hash (F : Key) return Header_Num;
- with function Equal (F1, F2 : Key) return Boolean;
+ -- No_Element : Element;
+ -- -- The object that is returned by Get when no element has been set
+ -- -- for a given key
- package Simple_HTable is
+ -- type Key is private;
+ -- with function Hash (F : Key) return Header_Num;
+ -- with function Equal (F1, F2 : Key) return Boolean;
- procedure Set (K : Key; E : Element);
- -- Associates an element with a given key. Overrides any previously
- -- associated element.
+ -- package Simple_HTable is
- procedure Reset;
- -- Removes and frees all elements in the table
+ -- procedure Set (K : Key; E : Element);
+ -- -- Associates an element with a given key. Overrides any previously
+ -- -- associated element.
- function Get (K : Key) return Element;
- -- Returns the Element associated with a key or No_Element if the
- -- given key has not associated element
+ -- procedure Reset;
+ -- -- Removes and frees all elements in the table
- procedure Remove (K : Key);
- -- Removes the latest inserted element pointer associated with the
- -- given key if any, does nothing if none.
+ -- function Get (K : Key) return Element;
+ -- -- Returns the Element associated with a key or No_Element if the
+ -- -- given key has not associated element
- function Get_First return Element;
- -- Returns No_Element if the Htable is empty, otherwise returns one
- -- non specified element. There is no guarantee that 2 calls to this
- -- function will return the same element.
+ -- procedure Remove (K : Key);
+ -- -- Removes the latest inserted element pointer associated with the
+ -- -- given key if any, does nothing if none.
- function Get_Next return Element;
- -- Returns a non-specified element that has not been returned by the
- -- same function since the last call to Get_First or No_Element if
- -- there is no such element. If there is no call to 'Set' in between
- -- Get_Next calls, all the elements of the Htable will be traversed.
- end Simple_HTable;
+ -- function Get_First return Element;
+ -- -- Returns No_Element if the HTable is empty, otherwise returns one
+ -- -- non specified element. There is no guarantee that 2 calls to
+ -- -- this function will return the same element.
+
+ -- function Get_Next return Element;
+ -- -- Returns a non-specified element that has not been returned by the
+ -- -- same function since the last call to Get_First or No_Element if
+ -- -- there is no such element. If there is no call to 'Set' in between
+ -- -- Get_Next calls, all the elements of the HTable will be traversed.
+ -- end Simple_HTable;
-------------------
-- Static_HTable --
@@ -117,65 +134,70 @@ pragma Preelaborate (HTable);
-- | Next Elmt |
-- +-------------------+
- generic
- type Header_Num is range <>;
- -- An integer type indicating the number and range of hash headers.
+ generic package Static_HTable renames System.HTable.Static_HTable;
+
+ -- For convenience of reference here is what this package has in it:
- type Element (<>) is limited private;
- -- The type of element to be stored
+ -- generic
+ -- type Header_Num is range <>;
+ -- -- An integer type indicating the number and range of hash headers.
- type Elmt_Ptr is private;
- -- The type used to reference an element (will usually be an access
- -- type, but could be some other form of type such as an integer type).
+ -- type Element (<>) is limited private;
+ -- -- The type of element to be stored
- Null_Ptr : Elmt_Ptr;
- -- The null value of the Elmt_Ptr type.
+ -- type Elmt_Ptr is private;
+ -- -- The type used to reference an element (will usually be an
+ -- -- access type, but could be some other form of type such as
+ -- -- an integer type).
- with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
- with function Next (E : Elmt_Ptr) return Elmt_Ptr;
- -- The type must provide an internal link for the sake of the
- -- staticness of the HTable.
+ -- Null_Ptr : Elmt_Ptr;
+ -- -- The null value of the Elmt_Ptr type.
- type Key is limited private;
- with function Get_Key (E : Elmt_Ptr) return Key;
- with function Hash (F : Key) return Header_Num;
- with function Equal (F1, F2 : Key) return Boolean;
+ -- with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
+ -- with function Next (E : Elmt_Ptr) return Elmt_Ptr;
+ -- -- The type must provide an internal link for the sake of the
+ -- -- staticness of the HTable.
- package Static_HTable is
+ -- type Key is limited private;
+ -- with function Get_Key (E : Elmt_Ptr) return Key;
+ -- with function Hash (F : Key) return Header_Num;
+ -- with function Equal (F1, F2 : Key) return Boolean;
- procedure Reset;
- -- Resets the hash table by setting all its elements to Null_Ptr. The
- -- effect is to clear the hash table so that it can be reused. For the
- -- most common case where Elmt_Ptr is an access type, and Null_Ptr is
- -- null, this is only needed if the same table is reused in a new
- -- context. If Elmt_Ptr is other than an access type, or Null_Ptr is
- -- other than null, then Reset must be called before the first use
- -- of the hash table.
+ -- package Static_HTable is
- procedure Set (E : Elmt_Ptr);
- -- Insert the element pointer in the HTable
+ -- procedure Reset;
+ -- -- Resets the hash table by setting all its elements to Null_Ptr.
+ -- -- The effect is to clear the hash table so that it can be reused.
+ -- -- For the most common case where Elmt_Ptr is an access type, and
+ -- -- Null_Ptr is null, this is only needed if the same table is
+ -- -- reused in a new context. If Elmt_Ptr is other than an access
+ -- -- type, or Null_Ptr is other than null, then Reset must be called
+ -- -- before the first use of the hash table.
- function Get (K : Key) return Elmt_Ptr;
- -- Returns the latest inserted element pointer with the given Key
- -- or null if none.
+ -- procedure Set (E : Elmt_Ptr);
+ -- -- Insert the element pointer in the HTable
- procedure Remove (K : Key);
- -- Removes the latest inserted element pointer associated with the
- -- given key if any, does nothing if none.
+ -- function Get (K : Key) return Elmt_Ptr;
+ -- -- Returns the latest inserted element pointer with the given Key
+ -- -- or null if none.
- function Get_First return Elmt_Ptr;
- -- Returns Null_Ptr if the Htable is empty, otherwise returns one
- -- non specified element. There is no guarantee that 2 calls to this
- -- function will return the same element.
+ -- procedure Remove (K : Key);
+ -- -- Removes the latest inserted element pointer associated with the
+ -- -- given key if any, does nothing if none.
- function Get_Next return Elmt_Ptr;
- -- Returns a non-specified element that has not been returned by the
- -- same function since the last call to Get_First or Null_Ptr if
- -- there is no such element or Get_First has bever been called. If
- -- there is no call to 'Set' in between Get_Next calls, all the
- -- elements of the Htable will be traversed.
+ -- function Get_First return Elmt_Ptr;
+ -- -- Returns Null_Ptr if the HTable is empty, otherwise returns one
+ -- -- non specified element. There is no guarantee that 2 calls to
+ -- -- this function will return the same element.
- end Static_HTable;
+ -- function Get_Next return Elmt_Ptr;
+ -- -- Returns a non-specified element that has not been returned by
+ -- -- the same function since the last call to Get_First or Null_Ptr
+ -- -- if there is no such element or Get_First has bever been called.
+ -- -- If there is no call to 'Set' in between Get_Next calls, all
+ -- -- the elements of the HTable will be traversed.
+
+ -- end Static_HTable;
----------
-- Hash --
@@ -183,8 +205,10 @@ pragma Preelaborate (HTable);
-- A generic hashing function working on String keys
- generic
- type Header_Num is range <>;
- function Hash (Key : String) return Header_Num;
+ generic function Hash renames System.HTable.Hash;
+
+ -- generic
+ -- type Header_Num is range <>;
+ -- function Hash (Key : String) return Header_Num;
end GNAT.HTable;
diff --git a/gcc/ada/g-io.adb b/gcc/ada/g-io.adb
index c4f191b9c0e..83f2e52821c 100644
--- a/gcc/ada/g-io.adb
+++ b/gcc/ada/g-io.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-io.ads b/gcc/ada/g-io.ads
index 526f1927a29..69aa6bfa4fc 100644
--- a/gcc/ada/g-io.ads
+++ b/gcc/ada/g-io.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-io_aux.adb b/gcc/ada/g-io_aux.adb
index 295ad84053c..04f6879bfe7 100644
--- a/gcc/ada/g-io_aux.adb
+++ b/gcc/ada/g-io_aux.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-io_aux.ads b/gcc/ada/g-io_aux.ads
index b22f0a189c7..1d351a2f47e 100644
--- a/gcc/ada/g-io_aux.ads
+++ b/gcc/ada/g-io_aux.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-locfil.adb b/gcc/ada/g-locfil.adb
index 00e8a1e21aa..8c39f2d425a 100644
--- a/gcc/ada/g-locfil.adb
+++ b/gcc/ada/g-locfil.adb
@@ -6,7 +6,6 @@
-- --
-- B o d y --
-- --
--- --
-- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
@@ -27,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-locfil.ads b/gcc/ada/g-locfil.ads
index 55e65aa79dc..97139597ab0 100644
--- a/gcc/ada/g-locfil.ads
+++ b/gcc/ada/g-locfil.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-md5.adb b/gcc/ada/g-md5.adb
index 492531f35e5..e126b8fce7b 100644
--- a/gcc/ada/g-md5.adb
+++ b/gcc/ada/g-md5.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-md5.ads b/gcc/ada/g-md5.ads
index 127422ae500..40d1b78c3dc 100644
--- a/gcc/ada/g-md5.ads
+++ b/gcc/ada/g-md5.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,10 +26,11 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
---
+
-- This package implements the MD5 Message-Digest Algorithm as described in
-- RFC 1321. The complete text of RFC 1321 can be found at:
--
diff --git a/gcc/ada/g-memdum.adb b/gcc/ada/g-memdum.adb
new file mode 100644
index 00000000000..fd2167c4a63
--- /dev/null
+++ b/gcc/ada/g-memdum.adb
@@ -0,0 +1,125 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- G N A T . M E M O R Y _ D U M P --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System; use System;
+with System.Storage_Elements; use System.Storage_Elements;
+
+with GNAT.IO; use GNAT.IO;
+with GNAT.Debug_Utilities; use GNAT.Debug_Utilities;
+
+with Unchecked_Conversion;
+
+package body GNAT.Memory_Dump is
+
+ ----------
+ -- Dump --
+ ----------
+
+ procedure Dump (Addr : System.Address; Count : Natural) is
+ Ctr : Natural := Count;
+ -- Count of bytes left to output
+
+ Adr : Address := Addr;
+ -- Current address
+
+ N : Natural := 0;
+ -- Number of bytes output on current line
+
+ C : Character;
+ -- Character at current storage address
+
+ AIL : constant := Address_Image_Length - 4 + 2;
+ -- Number of chars in initial address + colon + space
+
+ Line_Len : constant Natural := AIL + 3 * 16 + 2 + 16;
+ -- Line length for entire line
+
+ Line_Buf : String (1 .. Line_Len);
+
+ Hex : array (0 .. 15) of Character := "0123456789ABCDEF";
+
+ type Char_Ptr is access all Character;
+
+ function To_Char_Ptr is new Unchecked_Conversion (Address, Char_Ptr);
+
+ begin
+ while Ctr /= 0 loop
+
+ -- Start of line processing
+
+ if N = 0 then
+ declare
+ S : constant String := Image (Adr);
+ begin
+ Line_Buf (1 .. AIL) := S (4 .. S'Length - 1) & ": ";
+ Line_Buf (AIL + 1 .. Line_Buf'Last) := (others => ' ');
+ Line_Buf (AIL + 3 * 16 + 1) := '"';
+ end;
+ end if;
+
+ -- Add one character to current line
+
+ C := To_Char_Ptr (Adr).all;
+ Adr := Adr + 1;
+ Ctr := Ctr - 1;
+
+ Line_Buf (AIL + 3 * N + 1) := Hex (Character'Pos (C) / 16);
+ Line_Buf (AIL + 3 * N + 2) := Hex (Character'Pos (C) mod 16);
+
+ if C < ' ' or else C = Character'Val (16#7F#) then
+ C := '?';
+ end if;
+
+ Line_Buf (AIL + 3 * 16 + 2 + N) := C;
+ N := N + 1;
+
+ -- End of line processing
+
+ if N = 16 then
+ Line_Buf (Line_Buf'Last) := '"';
+ GNAT.IO.Put_Line (Line_Buf);
+ N := 0;
+ end if;
+ end loop;
+
+ -- Deal with possible last partial line
+
+ if N /= 0 then
+ Line_Buf (AIL + 3 * 16 + 2 + N) := '"';
+ GNAT.IO.Put_Line (Line_Buf (1 .. AIL + 3 * 16 + 2 + N));
+ end if;
+
+ return;
+ end Dump;
+
+end GNAT.Memory_Dump;
diff --git a/gcc/ada/g-memdum.ads b/gcc/ada/g-memdum.ads
new file mode 100644
index 00000000000..f092ed19ea4
--- /dev/null
+++ b/gcc/ada/g-memdum.ads
@@ -0,0 +1,56 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- G N A T . M E M O R Y _ D U M P --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- A routine for dumping memory to either standard output or standard error.
+-- Uses GNAT.IO for actual output (use the controls in GNAT.IO to specify
+-- the destination of the output, which by default is Standard_Output).
+
+with System;
+
+package GNAT.Memory_Dump is
+pragma Preelaborate (Memory_Dump);
+
+ procedure Dump (Addr : System.Address; Count : Natural);
+ -- Dumps indicated number (Count) of bytes, starting at the address given
+ -- by Addr. The coding of this routine in its current form assumes the
+ -- case of a byte addressable machine (and is therefore inapplicable to
+ -- machines like the AAMP, where the storage unit is not 8 bits). The
+ -- output is one or more lines in the following format, which is for the
+ -- case of 32-bit addresses (64-bit addressea are handled appropriately):
+ --
+ -- 0234_3368: 66 67 68 . . . 73 74 75 "fghijklmnopqstuv"
+ --
+ -- All but the last line have 16 bytes. A question mark is used in the
+ -- string data to indicate a non-printable character.
+
+end GNAT.Memory_Dump;
diff --git a/gcc/ada/g-os_lib.adb b/gcc/ada/g-os_lib.adb
index b92037b9d0d..24f6297b639 100644
--- a/gcc/ada/g-os_lib.adb
+++ b/gcc/ada/g-os_lib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 1995-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,10 +26,12 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+with System.Case_Util;
with System.Soft_Links;
with Unchecked_Conversion;
with System; use System;
@@ -38,6 +40,18 @@ package body GNAT.OS_Lib is
package SSL renames System.Soft_Links;
+ -- The following are used by Create_Temp_File
+
+ Current_Temp_File_Name : String := "GNAT-TEMP-000000.TMP";
+ -- Name of the temp file last created
+
+ Temp_File_Name_Last_Digit : constant Positive :=
+ Current_Temp_File_Name'Last - 4;
+ -- Position of the last digit in Current_Temp_File_Name
+
+ Max_Attempts : constant := 100;
+ -- The maximum number of attempts to create a new temp file
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -73,6 +87,42 @@ package body GNAT.OS_Lib is
-- Converts a C String to an Ada String. We could do this making use of
-- Interfaces.C.Strings but we prefer not to import that entire package
+ ---------
+ -- "<" --
+ ---------
+
+ function "<" (X, Y : OS_Time) return Boolean is
+ begin
+ return Long_Integer (X) < Long_Integer (Y);
+ end "<";
+
+ ----------
+ -- "<=" --
+ ----------
+
+ function "<=" (X, Y : OS_Time) return Boolean is
+ begin
+ return Long_Integer (X) <= Long_Integer (Y);
+ end "<=";
+
+ ---------
+ -- ">" --
+ ---------
+
+ function ">" (X, Y : OS_Time) return Boolean is
+ begin
+ return Long_Integer (X) > Long_Integer (Y);
+ end ">";
+
+ ----------
+ -- ">=" --
+ ----------
+
+ function ">=" (X, Y : OS_Time) return Boolean is
+ begin
+ return Long_Integer (X) >= Long_Integer (Y);
+ end ">=";
+
-----------------
-- Args_Length --
-----------------
@@ -96,7 +146,7 @@ package body GNAT.OS_Lib is
(Arg_String : String)
return Argument_List_Access
is
- Max_Args : Integer := Arg_String'Length;
+ Max_Args : constant Integer := Arg_String'Length;
New_Argv : Argument_List (1 .. Max_Args);
New_Argc : Natural := 0;
Idx : Integer;
@@ -105,6 +155,8 @@ package body GNAT.OS_Lib is
Idx := Arg_String'First;
loop
+ exit when Idx > Arg_String'Last;
+
declare
Quoted : Boolean := False;
Backqd : Boolean := False;
@@ -164,8 +216,6 @@ package body GNAT.OS_Lib is
Idx := Idx + 1;
end loop;
end;
-
- exit when Idx > Arg_String'Last;
end loop;
return new Argument_List'(New_Argv (1 .. New_Argc));
@@ -176,6 +226,7 @@ package body GNAT.OS_Lib is
---------------------
function C_String_Length (S : Address) return Integer is
+
function Strlen (S : Address) return Integer;
pragma Import (C, Strlen, "strlen");
@@ -187,6 +238,373 @@ package body GNAT.OS_Lib is
end if;
end C_String_Length;
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (FD : File_Descriptor) is
+ procedure C_Close (FD : File_Descriptor);
+ pragma Import (C, C_Close, "close");
+ begin
+ C_Close (FD);
+ end Close;
+
+ procedure Close (FD : File_Descriptor; Status : out Boolean) is
+ function C_Close (FD : File_Descriptor) return Integer;
+ pragma Import (C, C_Close, "close");
+ begin
+ Status := (C_Close (FD) = 0);
+ end Close;
+
+ ---------------
+ -- Copy_File --
+ ---------------
+
+ procedure Copy_File
+ (Name : String;
+ Pathname : String;
+ Success : out Boolean;
+ Mode : Copy_Mode := Copy;
+ Preserve : Attribute := Time_Stamps)
+ is
+ From : File_Descriptor;
+ To : File_Descriptor;
+
+ Copy_Error : exception;
+ -- Internal exception raised to signal error in copy
+
+ function Build_Path (Dir : String; File : String) return String;
+ -- Returns pathname Dir catenated with File adding the directory
+ -- separator only if needed.
+
+ procedure Copy (From, To : File_Descriptor);
+ -- Read data from From and place them into To. In both cases the
+ -- operations uses the current file position. Raises Constraint_Error
+ -- if a problem occurs during the copy.
+
+ procedure Copy_To (To_Name : String);
+ -- Does a straight copy from source to designated destination file
+
+ ----------------
+ -- Build_Path --
+ ----------------
+
+ function Build_Path (Dir : String; File : String) return String is
+ Res : String (1 .. Dir'Length + File'Length + 1);
+
+ Base_File_Ptr : Integer;
+ -- The base file name is File (Base_File_Ptr + 1 .. File'Last)
+
+ function Is_Dirsep (C : Character) return Boolean;
+ pragma Inline (Is_Dirsep);
+ -- Returns True if C is a directory separator. On Windows we
+ -- handle both styles of directory separator.
+
+ ---------------
+ -- Is_Dirsep --
+ ---------------
+
+ function Is_Dirsep (C : Character) return Boolean is
+ begin
+ return C = Directory_Separator or else C = '/';
+ end Is_Dirsep;
+
+ begin
+ -- Find base file name
+
+ Base_File_Ptr := File'Last;
+ while Base_File_Ptr >= File'First loop
+ exit when Is_Dirsep (File (Base_File_Ptr));
+ Base_File_Ptr := Base_File_Ptr - 1;
+ end loop;
+
+ declare
+ Base_File : String renames
+ File (Base_File_Ptr + 1 .. File'Last);
+
+ begin
+ Res (1 .. Dir'Length) := Dir;
+
+ if Is_Dirsep (Dir (Dir'Last)) then
+ Res (Dir'Length + 1 .. Dir'Length + Base_File'Length) :=
+ Base_File;
+ return Res (1 .. Dir'Length + Base_File'Length);
+
+ else
+ Res (Dir'Length + 1) := Directory_Separator;
+ Res (Dir'Length + 2 .. Dir'Length + 1 + Base_File'Length) :=
+ Base_File;
+ return Res (1 .. Dir'Length + 1 + Base_File'Length);
+ end if;
+ end;
+ end Build_Path;
+
+ ----------
+ -- Copy --
+ ----------
+
+ procedure Copy (From, To : File_Descriptor) is
+ Buf_Size : constant := 200_000;
+ Buffer : array (1 .. Buf_Size) of Character;
+ R : Integer;
+ W : Integer;
+
+ Status_From : Boolean;
+ Status_To : Boolean;
+ -- Statuses for the calls to Close
+
+ begin
+ if From = Invalid_FD or else To = Invalid_FD then
+ raise Copy_Error;
+ end if;
+
+ loop
+ R := Read (From, Buffer (1)'Address, Buf_Size);
+
+ -- For VMS, the buffer may not be full. So, we need to try again
+ -- until there is nothing to read.
+
+ exit when R = 0;
+
+ W := Write (To, Buffer (1)'Address, R);
+
+ if W < R then
+
+ -- Problem writing data, could be a disk full. Close files
+ -- without worrying about status, since we are raising a
+ -- Copy_Error exception in any case.
+
+ Close (From, Status_From);
+ Close (To, Status_To);
+
+ raise Copy_Error;
+ end if;
+ end loop;
+
+ Close (From, Status_From);
+ Close (To, Status_To);
+
+ if not (Status_From and Status_To) then
+ raise Copy_Error;
+ end if;
+ end Copy;
+
+ -------------
+ -- Copy_To --
+ -------------
+
+ procedure Copy_To (To_Name : String) is
+
+ function Copy_Attributes
+ (From, To : System.Address;
+ Mode : Integer)
+ return Integer;
+ pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
+ -- Mode = 0 - copy only time stamps.
+ -- Mode = 1 - copy time stamps and read/write/execute attributes
+
+ C_From : String (1 .. Name'Length + 1);
+ C_To : String (1 .. To_Name'Length + 1);
+
+ begin
+ From := Open_Read (Name, Binary);
+ To := Create_File (To_Name, Binary);
+ Copy (From, To);
+
+ -- Copy attributes
+
+ C_From (1 .. Name'Length) := Name;
+ C_From (C_From'Last) := ASCII.Nul;
+
+ C_To (1 .. To_Name'Length) := To_Name;
+ C_To (C_To'Last) := ASCII.Nul;
+
+ case Preserve is
+
+ when Time_Stamps =>
+ if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then
+ raise Copy_Error;
+ end if;
+
+ when Full =>
+ if Copy_Attributes (C_From'Address, C_To'Address, 1) = -1 then
+ raise Copy_Error;
+ end if;
+
+ when None =>
+ null;
+ end case;
+
+ end Copy_To;
+
+ -- Start of processing for Copy_File
+
+ begin
+ Success := True;
+
+ -- The source file must exist
+
+ if not Is_Regular_File (Name) then
+ raise Copy_Error;
+ end if;
+
+ -- The source file exists
+
+ case Mode is
+
+ -- Copy case, target file must not exist
+
+ when Copy =>
+
+ -- If the target file exists, we have an error
+
+ if Is_Regular_File (Pathname) then
+ raise Copy_Error;
+
+ -- Case of target is a directory
+
+ elsif Is_Directory (Pathname) then
+ declare
+ Dest : constant String := Build_Path (Pathname, Name);
+
+ begin
+ -- If the target file exists, we have an error
+ -- otherwise do the copy.
+
+ if Is_Regular_File (Dest) then
+ raise Copy_Error;
+ else
+ Copy_To (Dest);
+ end if;
+ end;
+
+ -- Case of normal copy to file (destination does not exist)
+
+ else
+ Copy_To (Pathname);
+ end if;
+
+ -- Overwrite case, destination file may or may not exist
+
+ when Overwrite =>
+ if Is_Directory (Pathname) then
+ Copy_To (Build_Path (Pathname, Name));
+ else
+ Copy_To (Pathname);
+ end if;
+
+ -- Appending case, destination file may or may not exist
+
+ when Append =>
+
+ -- Appending to existing file
+
+ if Is_Regular_File (Pathname) then
+
+ -- Append mode and destination file exists, append data
+ -- at the end of Pathname.
+
+ From := Open_Read (Name, Binary);
+ To := Open_Read_Write (Pathname, Binary);
+ Lseek (To, 0, Seek_End);
+
+ Copy (From, To);
+
+ -- Appending to directory, not allowed
+
+ elsif Is_Directory (Pathname) then
+ raise Copy_Error;
+
+ -- Appending when target file does not exist
+
+ else
+ Copy_To (Pathname);
+ end if;
+ end case;
+
+ -- All error cases are caught here
+
+ exception
+ when Copy_Error =>
+ Success := False;
+ end Copy_File;
+
+ procedure Copy_File
+ (Name : C_File_Name;
+ Pathname : C_File_Name;
+ Success : out Boolean;
+ Mode : Copy_Mode := Copy;
+ Preserve : Attribute := Time_Stamps)
+ is
+ Ada_Name : String_Access :=
+ To_Path_String_Access
+ (Name, C_String_Length (Name));
+
+ Ada_Pathname : String_Access :=
+ To_Path_String_Access
+ (Pathname, C_String_Length (Pathname));
+
+ begin
+ Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve);
+ Free (Ada_Name);
+ Free (Ada_Pathname);
+ end Copy_File;
+
+ ----------------------
+ -- Copy_Time_Stamps --
+ ----------------------
+
+ procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean) is
+
+ function Copy_Attributes
+ (From, To : System.Address;
+ Mode : Integer)
+ return Integer;
+ pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
+ -- Mode = 0 - copy only time stamps.
+ -- Mode = 1 - copy time stamps and read/write/execute attributes
+
+ begin
+ if Is_Regular_File (Source) and then Is_Writable_File (Dest) then
+ declare
+ C_Source : String (1 .. Source'Length + 1);
+ C_Dest : String (1 .. Dest'Length + 1);
+ begin
+ C_Source (1 .. C_Source'Length) := Source;
+ C_Source (C_Source'Last) := ASCII.Nul;
+
+ C_Dest (1 .. C_Dest'Length) := Dest;
+ C_Dest (C_Dest'Last) := ASCII.Nul;
+
+ if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then
+ Success := False;
+ else
+ Success := True;
+ end if;
+ end;
+
+ else
+ Success := False;
+ end if;
+ end Copy_Time_Stamps;
+
+ procedure Copy_Time_Stamps
+ (Source, Dest : C_File_Name;
+ Success : out Boolean)
+ is
+ Ada_Source : String_Access :=
+ To_Path_String_Access
+ (Source, C_String_Length (Source));
+
+ Ada_Dest : String_Access :=
+ To_Path_String_Access
+ (Dest, C_String_Length (Dest));
+ begin
+ Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success);
+ Free (Ada_Source);
+ Free (Ada_Dest);
+ end Copy_Time_Stamps;
+
-----------------
-- Create_File --
-----------------
@@ -269,6 +687,99 @@ package body GNAT.OS_Lib is
FD := Open_New_Temp (Name'Address, Binary);
end Create_Temp_File;
+ procedure Create_Temp_File
+ (FD : out File_Descriptor;
+ Name : out String_Access)
+ is
+ Pos : Positive;
+ Attempts : Natural := 0;
+ Current : String (Current_Temp_File_Name'Range);
+
+ begin
+ -- Loop until a new temp file can be created
+
+ File_Loop : loop
+ Locked : begin
+ -- We need to protect global variable Current_Temp_File_Name
+ -- against concurrent access by different tasks.
+
+ SSL.Lock_Task.all;
+
+ -- Start at the last digit
+
+ Pos := Temp_File_Name_Last_Digit;
+
+ Digit_Loop :
+ loop
+ -- Increment the digit by one
+
+ case Current_Temp_File_Name (Pos) is
+ when '0' .. '8' =>
+ Current_Temp_File_Name (Pos) :=
+ Character'Succ (Current_Temp_File_Name (Pos));
+ exit Digit_Loop;
+
+ when '9' =>
+
+ -- For 9, set the digit to 0 and go to the previous digit
+
+ Current_Temp_File_Name (Pos) := '0';
+ Pos := Pos - 1;
+
+ when others =>
+
+ -- If it is not a digit, then there are no available
+ -- temp file names. Return Invalid_FD. There is almost
+ -- no that this code will be ever be executed, since
+ -- it would mean that there are one million temp files
+ -- in the same directory!
+
+ SSL.Unlock_Task.all;
+ FD := Invalid_FD;
+ Name := null;
+ exit File_Loop;
+ end case;
+ end loop Digit_Loop;
+
+ Current := Current_Temp_File_Name;
+
+ -- We can now release the lock, because we are no longer
+ -- accessing Current_Temp_File_Name.
+
+ SSL.Unlock_Task.all;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
+ end Locked;
+
+ -- Attempt to create the file
+
+ FD := Create_New_File (Current, Binary);
+
+ if FD /= Invalid_FD then
+ Name := new String'(Current);
+ exit File_Loop;
+ end if;
+
+ if not Is_Regular_File (Current) then
+
+ -- If the file does not already exist and we are unable to create
+ -- it, we give up after Max_Attempts. Otherwise, we try again with
+ -- the next available file name.
+
+ Attempts := Attempts + 1;
+
+ if Attempts >= Max_Attempts then
+ FD := Invalid_FD;
+ Name := null;
+ exit File_Loop;
+ end if;
+ end if;
+ end loop File_Loop;
+ end Create_Temp_File;
+
-----------------
-- Delete_File --
-----------------
@@ -323,25 +834,6 @@ package body GNAT.OS_Lib is
return File_Time_Stamp (F_Name'Address);
end File_Time_Stamp;
- ----------
- -- Free --
- ----------
-
- procedure Free (Arg : in out String_List_Access) is
- X : String_Access;
-
- procedure Free_Array is new Unchecked_Deallocation
- (Object => String_List, Name => String_List_Access);
-
- begin
- for J in Arg'Range loop
- X := Arg (J);
- Free (X);
- end loop;
-
- Free_Array (Arg);
- end Free;
-
---------------------------
-- Get_Debuggable_Suffix --
---------------------------
@@ -434,9 +926,9 @@ package body GNAT.OS_Lib is
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
- Env_Value_Ptr : Address;
- Env_Value_Length : Integer;
- F_Name : String (1 .. Name'Length + 1);
+ Env_Value_Ptr : aliased Address;
+ Env_Value_Length : aliased Integer;
+ F_Name : aliased String (1 .. Name'Length + 1);
Result : String_Access;
begin
@@ -666,6 +1158,27 @@ package body GNAT.OS_Lib is
end Is_Regular_File;
----------------------
+ -- Is_Readable_File --
+ ----------------------
+
+ function Is_Readable_File (Name : C_File_Name) return Boolean is
+ function Is_Readable_File (Name : Address) return Integer;
+ pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
+
+ begin
+ return Is_Readable_File (Name) /= 0;
+ end Is_Readable_File;
+
+ function Is_Readable_File (Name : String) return Boolean is
+ F_Name : String (1 .. Name'Length + 1);
+
+ begin
+ F_Name (1 .. Name'Length) := Name;
+ F_Name (F_Name'Last) := ASCII.NUL;
+ return Is_Readable_File (F_Name'Address);
+ end Is_Readable_File;
+
+ ----------------------
-- Is_Writable_File --
----------------------
@@ -686,6 +1199,27 @@ package body GNAT.OS_Lib is
return Is_Writable_File (F_Name'Address);
end Is_Writable_File;
+ ----------------------
+ -- Is_Symbolic_Link --
+ ----------------------
+
+ function Is_Symbolic_Link (Name : C_File_Name) return Boolean is
+ function Is_Symbolic_Link (Name : Address) return Integer;
+ pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link");
+
+ begin
+ return Is_Symbolic_Link (Name) /= 0;
+ end Is_Symbolic_Link;
+
+ function Is_Symbolic_Link (Name : String) return Boolean is
+ F_Name : String (1 .. Name'Length + 1);
+
+ begin
+ F_Name (1 .. Name'Length) := Name;
+ F_Name (F_Name'Last) := ASCII.NUL;
+ return Is_Symbolic_Link (F_Name'Address);
+ end Is_Symbolic_Link;
+
-------------------------
-- Locate_Exec_On_Path --
-------------------------
@@ -797,10 +1331,11 @@ package body GNAT.OS_Lib is
procedure Normalize_Arguments (Args : in out Argument_List) is
procedure Quote_Argument (Arg : in out String_Access);
- -- Add quote around argument if it contains spaces.
+ -- Add quote around argument if it contains spaces
- Argument_Needs_Quote : Boolean;
- pragma Import (C, Argument_Needs_Quote, "__gnat_argument_needs_quote");
+ C_Argument_Needs_Quote : Integer;
+ pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote");
+ Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0;
--------------------
-- Quote_Argument --
@@ -826,6 +1361,7 @@ package body GNAT.OS_Lib is
Res (J) := '\';
J := J + 1;
Res (J) := '"';
+ Quote_Needed := True;
elsif Arg (K) = ' ' then
Res (J) := Arg (K);
@@ -839,10 +1375,28 @@ package body GNAT.OS_Lib is
if Quote_Needed then
- -- Ending quote
+ -- If null terminated string, put the quote before
- J := J + 1;
- Res (J) := '"';
+ if Res (J) = ASCII.Nul then
+ Res (J) := '"';
+ J := J + 1;
+ Res (J) := ASCII.Nul;
+
+ -- If argument is terminated by '\', then double it. Otherwise
+ -- the ending quote will be taken as-is. This is quite strange
+ -- spawn behavior from Windows, but this is what we see!
+
+ else
+ if Res (J) = '\' then
+ J := J + 1;
+ Res (J) := '\';
+ end if;
+
+ -- Ending quote
+
+ J := J + 1;
+ Res (J) := '"';
+ end if;
declare
Old : String_Access := Arg;
@@ -859,7 +1413,7 @@ package body GNAT.OS_Lib is
begin
if Argument_Needs_Quote then
for K in Args'Range loop
- if Args (K) /= null then
+ if Args (K) /= null and then Args (K)'Length /= 0 then
Quote_Argument (Args (K));
end if;
end loop;
@@ -871,9 +1425,11 @@ package body GNAT.OS_Lib is
------------------------
function Normalize_Pathname
- (Name : String;
- Directory : String := "")
- return String
+ (Name : String;
+ Directory : String := "";
+ Resolve_Links : Boolean := True;
+ Case_Sensitive : Boolean := True)
+ return String
is
Max_Path : Integer;
pragma Import (C, Max_Path, "__gnat_max_path_len");
@@ -884,6 +1440,9 @@ package body GNAT.OS_Lib is
Length : System.Address);
pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir");
+ function Change_Dir (Dir_Name : String) return Integer;
+ pragma Import (C, Change_Dir, "chdir");
+
Path_Buffer : String (1 .. Max_Path + Max_Path + 2);
End_Path : Natural := 0;
Link_Buffer : String (1 .. Max_Path + 2);
@@ -894,6 +1453,15 @@ package body GNAT.OS_Lib is
Max_Iterations : constant := 500;
+ function Get_File_Names_Case_Sensitive return Integer;
+ pragma Import
+ (C, Get_File_Names_Case_Sensitive,
+ "__gnat_get_file_names_case_sensitive");
+
+ Fold_To_Lower_Case : constant Boolean :=
+ not Case_Sensitive
+ and then Get_File_Names_Case_Sensitive = 0;
+
function Readlink
(Path : System.Address;
Buf : System.Address;
@@ -917,8 +1485,8 @@ package body GNAT.OS_Lib is
function Strlen (S : System.Address) return Integer;
pragma Import (C, Strlen, "strlen");
- function Get_Directory return String;
- -- If Directory is not empty, return it, adding a directory separator
+ function Get_Directory (Dir : String) return String;
+ -- If Dir is not empty, return it, adding a directory separator
-- if not already present, otherwise return current working directory
-- with terminating directory separator.
@@ -933,19 +1501,19 @@ package body GNAT.OS_Lib is
-- Get_Directory --
-------------------
- function Get_Directory return String is
+ function Get_Directory (Dir : String) return String is
begin
-- Directory given, add directory separator if needed
- if Directory'Length > 0 then
- if Directory (Directory'Length) = Directory_Separator then
+ if Dir'Length > 0 then
+ if Dir (Dir'Length) = Directory_Separator then
return Directory;
else
declare
- Result : String (1 .. Directory'Length + 1);
+ Result : String (1 .. Dir'Length + 1);
begin
- Result (1 .. Directory'Length) := Directory;
+ Result (1 .. Dir'Length) := Dir;
Result (Result'Length) := Directory_Separator;
return Result;
end;
@@ -971,7 +1539,7 @@ package body GNAT.OS_Lib is
end if;
end Get_Directory;
- Reference_Dir : constant String := Get_Directory;
+ Reference_Dir : constant String := Get_Directory (Directory);
-- Current directory name specified
-----------------
@@ -979,6 +1547,9 @@ package body GNAT.OS_Lib is
-----------------
function Final_Value (S : String) return String is
+ S1 : String := S;
+ -- We may need to fold S to lower case, so we need a variable
+
begin
-- Interix has the non standard notion of disk drive
-- indicated by two '/' followed by a capital letter
@@ -998,11 +1569,23 @@ package body GNAT.OS_Lib is
begin
Result (1) := '/';
Result (2 .. Result'Last) := S;
+
+ if Fold_To_Lower_Case then
+ System.Case_Util.To_Lower (Result);
+ end if;
+
return Result;
+
end;
else
- return S;
+
+ if Fold_To_Lower_Case then
+ System.Case_Util.To_Lower (S1);
+ end if;
+
+ return S1;
+
end if;
end Final_Value;
@@ -1042,8 +1625,8 @@ package body GNAT.OS_Lib is
Unchecked_Conversion (Source => Address,
Target => Path_String_Access);
- Path_Access : Path_String_Access :=
- Address_To_Access (Canonical_File_Addr);
+ Path_Access : constant Path_String_Access :=
+ Address_To_Access (Canonical_File_Addr);
begin
Path_Buffer (1 .. Canonical_File_Len) := Path_Access.all;
@@ -1062,6 +1645,85 @@ package body GNAT.OS_Lib is
end loop;
end if;
+ -- Resolving logical names from VMS.
+ -- If we have a Unix path on VMS such as /temp/..., and TEMP is a
+ -- logical name, we need to resolve this logical name.
+ -- As we have no means to know if we are on VMS, we need to do that
+ -- for absolute paths starting with '/'.
+ -- We find the directory, change to it, get the current directory,
+ -- and change the directory to this value.
+
+ if Path_Buffer (1) = '/' then
+ declare
+ Cur_Dir : String := Get_Directory ("");
+ -- Save the current directory, so that we can change dir back to
+ -- it. It is not a constant, because the last character (a
+ -- directory separator) is changed to ASCII.NUL to call the C
+ -- function chdir.
+
+ Path : String := Path_Buffer (1 .. End_Path + 1);
+ -- Copy of the current path. One character is added that may be
+ -- set to ASCII.NUL to call chdir.
+
+ Pos : Positive := End_Path;
+ -- Position of the last directory separator ('/')
+
+ Status : Integer;
+ -- Value returned by chdir
+
+ begin
+ -- Look for the last '/'
+
+ while Path (Pos) /= '/' loop
+ Pos := Pos - 1;
+ end loop;
+
+ -- Get the previous character that is not a '/'
+
+ while Pos > 1 and then Path (Pos) = '/' loop
+ Pos := Pos - 1;
+ end loop;
+
+ -- If we are at the start of the path, take the full path.
+ -- It may be a file in the root directory, but it may also be
+ -- a subdirectory of the root directory.
+
+ if Pos = 1 then
+ Pos := End_Path;
+ end if;
+
+ -- Add the ASCII.NUL to be able to call the C function chdir
+ Path (Pos + 1) := ASCII.NUL;
+
+ Status := Change_Dir (Path (1 .. Pos + 1));
+
+ -- If Status is not zero, then we do nothing: this is a file
+ -- path or it is not a valid directory path.
+
+ if Status = 0 then
+ declare
+ New_Dir : constant String := Get_Directory ("");
+ -- The directory path
+
+ New_Path : String (1 .. New_Dir'Length + End_Path - Pos);
+ -- The new complete path, that is built below
+
+ begin
+ New_Path (1 .. New_Dir'Length) := New_Dir;
+ New_Path (New_Dir'Length + 1 .. New_Path'Last) :=
+ Path_Buffer (Pos + 1 .. End_Path);
+ End_Path := New_Path'Length;
+ Path_Buffer (1 .. End_Path) := New_Path;
+ end;
+
+ -- Back to where we were before
+
+ Cur_Dir (Cur_Dir'Last) := ASCII.NUL;
+ Status := Change_Dir (Cur_Dir);
+ end if;
+ end;
+ end if;
+
-- Start the conversions
-- If this is not finished after Max_Iterations, give up and
@@ -1092,6 +1754,15 @@ package body GNAT.OS_Lib is
Start := Last + 1;
Finish := Last;
+ -- Ensure that Windows network drives are kept, e.g: \\server\drive-c
+
+ if Start = 2
+ and then Directory_Separator = '\'
+ and then Path_Buffer (1 .. 2) = "\\"
+ then
+ Start := 3;
+ end if;
+
-- If we have traversed the full pathname, return it
if Start > End_Path then
@@ -1127,7 +1798,13 @@ package body GNAT.OS_Lib is
if Last = 1 then
return (1 => Directory_Separator);
else
+
+ if Fold_To_Lower_Case then
+ System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1));
+ end if;
+
return Path_Buffer (1 .. Last - 1);
+
end if;
else
@@ -1173,9 +1850,9 @@ package body GNAT.OS_Lib is
-- Check if current field is a symbolic link
- else
+ elsif Resolve_Links then
declare
- Saved : Character := Path_Buffer (Finish + 1);
+ Saved : constant Character := Path_Buffer (Finish + 1);
begin
Path_Buffer (Finish + 1) := ASCII.NUL;
@@ -1209,6 +1886,9 @@ package body GNAT.OS_Lib is
Link_Buffer (1 .. Status);
end if;
end if;
+
+ else
+ Last := Finish + 1;
end if;
end loop;
@@ -1503,7 +2183,8 @@ package body GNAT.OS_Lib is
Unchecked_Conversion (Source => Address,
Target => Path_String_Access);
- Path_Access : Path_String_Access := Address_To_Access (Path_Addr);
+ Path_Access : constant Path_String_Access :=
+ Address_To_Access (Path_Addr);
Return_Val : String_Access;
diff --git a/gcc/ada/g-os_lib.ads b/gcc/ada/g-os_lib.ads
index c6dfede2021..f7cf85bb3fc 100644
--- a/gcc/ada/g-os_lib.ads
+++ b/gcc/ada/g-os_lib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1995-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- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -46,27 +47,44 @@
-- all GNAT implementations on all supported operating systems.
with System;
-with Unchecked_Deallocation;
+with GNAT.Strings;
package GNAT.OS_Lib is
pragma Elaborate_Body (OS_Lib);
- type String_Access is access all String;
+ subtype String_Access is Strings.String_Access;
-- General purpose string access type. Some of the functions in this
-- package allocate string results on the heap, and return a value of
-- this type. Note that the caller is responsible for freeing this
-- String to avoid memory leaks.
- procedure Free is new Unchecked_Deallocation
- (Object => String, Name => String_Access);
+ function "=" (Left, Right : in String_Access) return Boolean
+ renames Strings."=";
+
+ procedure Free (X : in out String_Access) renames Strings.Free;
-- This procedure is provided for freeing returned values of type
-- String_Access
- type String_List is array (Positive range <>) of String_Access;
- type String_List_Access is access all String_List;
+ subtype String_List is Strings.String_List;
+ function "=" (Left, Right : in String_List) return Boolean
+ renames Strings."=";
+
+ function "&" (Left : String_Access; Right : String_Access)
+ return String_List renames Strings."&";
+ function "&" (Left : String_Access; Right : String_List)
+ return String_List renames Strings."&";
+ function "&" (Left : String_List; Right : String_Access)
+ return String_List renames Strings."&";
+ function "&" (Left : String_List; Right : String_List)
+ return String_List renames Strings."&";
+
+ subtype String_List_Access is Strings.String_List_Access;
-- General purpose array and pointer for list of string accesses
+ function "=" (Left, Right : in String_List_Access) return Boolean
+ renames Strings."=";
- procedure Free (Arg : in out String_List_Access);
+ procedure Free (Arg : in out String_List_Access)
+ renames Strings.Free;
-- Frees the given array and all strings that its elements reference,
-- and then sets the argument to null. Provided for freeing returned
-- values of this type (including Argument_List_Access).
@@ -100,6 +118,14 @@ pragma Elaborate_Body (OS_Lib);
function GM_Minute (Date : OS_Time) return Minute_Type;
function GM_Second (Date : OS_Time) return Second_Type;
+ function "<" (X, Y : OS_Time) return Boolean;
+ function ">" (X, Y : OS_Time) return Boolean;
+ function ">=" (X, Y : OS_Time) return Boolean;
+ function "<=" (X, Y : OS_Time) return Boolean;
+ -- Basic comparison operators on OS_Time with obvious meanings. Note
+ -- that these have Intrinsic convention, so for example it is not
+ -- permissible to create accesses to any of these functions.
+
procedure GM_Split
(Date : OS_Time;
Year : out Year_Type;
@@ -125,15 +151,15 @@ pragma Elaborate_Body (OS_Lib);
-- permitted, and will be ignored (more accurately, the NUL and any
-- characters that follow it will be ignored).
- type File_Descriptor is private;
- -- Corresponds to the int file handle values used in the C routines,
+ type File_Descriptor is new Integer;
+ -- Corresponds to the int file handle values used in the C routines
- Standin : constant File_Descriptor;
- Standout : constant File_Descriptor;
- Standerr : constant File_Descriptor;
+ Standin : constant File_Descriptor := 0;
+ Standout : constant File_Descriptor := 1;
+ Standerr : constant File_Descriptor := 2;
-- File descriptors for standard input output files
- Invalid_FD : constant File_Descriptor;
+ Invalid_FD : constant File_Descriptor := -1;
-- File descriptor returned when error in opening/creating file;
type Mode is (Binary, Text);
@@ -145,7 +171,7 @@ pragma Elaborate_Body (OS_Lib);
-- Text as the mode parameter causes the system to do CR/LF translation
-- and also to recognize the DOS end of file character on input. The use
-- of Text where appropriate allows programs to take a portable Unix view
- -- of DOs-format files and process them appropriately.
+ -- of DOS-format files and process them appropriately.
function Open_Read
(Name : String;
@@ -188,15 +214,40 @@ pragma Elaborate_Body (OS_Lib);
procedure Create_Temp_File
(FD : out File_Descriptor;
Name : out Temp_File_Name);
- -- Create and open for writing a temporary file. The name of the
- -- file and the File Descriptor are returned. The File Descriptor
- -- returned is Invalid_FD in the case of failure. No mode parameter
- -- is provided. Since this is a temporary file, there is no point in
- -- doing text translation on it.
+ -- Create and open for writing a temporary file in the current working
+ -- directory. The name of the file and the File Descriptor are returned.
+ -- The File Descriptor returned is Invalid_FD in the case of failure.
+ -- No mode parameter is provided. Since this is a temporary file,
+ -- there is no point in doing text translation on it.
+ -- On some OSes, the maximum number of temp files that can be
+ -- created with this procedure may be limited. When the maximum is
+ -- reached, this procedure returns Invalid_FD. On some OSes, there may be
+ -- a race condition between processes trying to create temp files
+ -- at the same time in the same directory using this procedure.
+
+ procedure Create_Temp_File
+ (FD : out File_Descriptor;
+ Name : out String_Access);
+ -- Create and open for writing a temporary file in the current working
+ -- directory. The name of the file and the File Descriptor are returned.
+ -- No mode parameter is provided. Since this is a temporary file,
+ -- there is no point in doing text translation on it.
+ -- It is the responsibility of the caller to deallocate the access value
+ -- returned in Name.
+ -- This procedure will always succeed if the current working directory
+ -- is writable. If the current working directory is not writable, then
+ -- Invalid_FD is returned for the file descriptor and null for the Name.
+ -- There is no race condition problem between processes trying to
+ -- create temp files at the same time in the same directory.
+
+ procedure Close (FD : File_Descriptor; Status : out Boolean);
+ -- Close file referenced by FD. Status is False if the underlying service
+ -- failed. Reasons for failure include: disk full, disk quotas exceeded
+ -- and invalid file descriptor (the file may have been closed twice).
procedure Close (FD : File_Descriptor);
- pragma Import (C, Close, "close");
- -- Close file referenced by FD
+ -- Close file referenced by FD. This form is used when the caller
+ -- wants to ignore any possible error (see above for error cases).
procedure Delete_File (Name : String; Success : out Boolean);
-- Deletes file. Success is set True or False indicating if the delete is
@@ -206,8 +257,79 @@ pragma Elaborate_Body (OS_Lib);
(Old_Name : String;
New_Name : String;
Success : out Boolean);
- -- Rename a file. Success is set True or False indicating if the rename is
- -- successful.
+ -- Rename a file. Success is set True or False indicating if the
+ -- rename is successful or not.
+
+ -- The following defines the mode for the Copy_File procedure below.
+ -- Note that "time stamps and other file attributes" in the descriptions
+ -- below refers to the creation and last modification times, and also
+ -- the file access (read/write/execute) status flags.
+
+ type Copy_Mode is
+ (Copy,
+ -- Copy the file. It is an error if the target file already exists.
+ -- The time stamps and other file attributes are preserved in the copy.
+
+ Overwrite,
+ -- If the target file exists, the file is replaced otherwise
+ -- the file is just copied. The time stamps and other file
+ -- attributes are preserved in the copy.
+
+ Append);
+ -- If the target file exists, the contents of the source file
+ -- is appended at the end. Otherwise the source file is just
+ -- copied. The time stamps and other file attributes are
+ -- are preserved if the destination file does not exist.
+
+ type Attribute is
+ (Time_Stamps,
+ -- Copy time stamps from source file to target file. All other
+ -- attributes are set to normal default values for file creation.
+
+ Full,
+ -- All attributes are copied from the source file to the target
+ -- file. This includes the timestamps, and for example also includes
+ -- read/write/execute attributes in Unix systems.
+
+ None);
+ -- No attributes are copied. All attributes including the time stamp
+ -- values are set to normal default values for file creation.
+
+ -- Note: The default is Time_Stamps, which corresponds to the normal
+ -- default on Windows style systems. Full corresponds to the typical
+ -- effect of "cp -p" on Unix systems, and None corresponds to the
+ -- typical effect of "cp" on Unix systems.
+
+ -- Note: Time_Stamps and Full are not supported on VMS and VxWorks
+
+ procedure Copy_File
+ (Name : String;
+ Pathname : String;
+ Success : out Boolean;
+ Mode : Copy_Mode := Copy;
+ Preserve : Attribute := Time_Stamps);
+ -- Copy a file. Name must designate a single file (no wild cards allowed).
+ -- Pathname can be a filename or directory name. In the latter case Name
+ -- is copied into the directory preserving the same file name. Mode
+ -- defines the kind of copy, see above with the default being a normal
+ -- copy in which the target file must not already exist. Success is set
+ -- to True or False indicating if the copy is successful (depending on
+ -- the specified Mode).
+ --
+ -- Note: this procedure is only supported to a very limited extent on
+ -- VMS. The only supported mode is Overwrite, and the only supported
+ -- value for Preserve is None, resulting in the default action which
+ -- for Overwrite is to leave attributes unchanged. Furthermore, the
+ -- copy only works for simple text files.
+
+ procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean);
+ -- Copy Source file time stamps (last modification and last access time
+ -- stamps) to Dest file. Source and Dest must be valid filenames,
+ -- furthermore Dest must be writable. Success will be set to True if the
+ -- operation was successful and False otherwise.
+ --
+ -- Note: this procedure is not supported on VMS and VxWorks. On these
+ -- platforms, Success is always set to False.
function Read
(FD : File_Descriptor;
@@ -248,15 +370,17 @@ pragma Elaborate_Body (OS_Lib);
function File_Time_Stamp (Name : String) return OS_Time;
-- Given the name of a file or directory, Name, obtains and returns the
- -- time stamp. This function can be used for an unopend file.
+ -- time stamp. This function can be used for an unopened file.
function File_Time_Stamp (FD : File_Descriptor) return OS_Time;
-- Get time stamp of file from file descriptor FD
function Normalize_Pathname
- (Name : String;
- Directory : String := "")
- return String;
+ (Name : String;
+ Directory : String := "";
+ Resolve_Links : Boolean := True;
+ Case_Sensitive : Boolean := True)
+ return String;
-- Returns a file name as an absolute path name, resolving all relative
-- directories, and symbolic links. The parameter Directory is a fully
-- resolved path name for a directory, or the empty string (the default).
@@ -269,6 +393,11 @@ pragma Elaborate_Body (OS_Lib);
-- not true; for example, this is not true in Unix for two hard links
-- designating the same file.
--
+ -- If Resolve_Links is set to True, then the symbolic links, on systems
+ -- that support them, will be fully converted to the name of the file
+ -- or directory pointed to. This is slightly less efficient, since it
+ -- requires system calls.
+ --
-- If Name cannot be resolved or is null on entry (for example if there is
-- a circularity in symbolic links: A is a symbolic link for B, while B is
-- a symbolic link for A), then Normalize_Pathname returns an empty string.
@@ -276,6 +405,14 @@ pragma Elaborate_Body (OS_Lib);
-- In VMS, if Name follows the VMS syntax file specification, it is first
-- converted into Unix syntax. If the conversion fails, Normalize_Pathname
-- returns an empty string.
+ --
+ -- For case-sensitive file systems, the value of Case_Sensitive parameter
+ -- is ignored. In systems that have a non case-sensitive file system like
+ -- Windows and OpenVMS, if this parameter is set OFF, then the result
+ -- is returned folded to lower case, this allows to checks if two files
+ -- are the same by applying this function to their names and by comparing
+ -- the results of these calls. If Case_Sensitive is ON, this function does
+ -- not change the casing of file and directory names.
function Is_Absolute_Path (Name : String) return Boolean;
-- Returns True if Name is an absolute path name, i.e. it designates
@@ -289,9 +426,30 @@ pragma Elaborate_Body (OS_Lib);
-- Determines if the given string, Name, is the name of a directory.
-- Returns True if so, False otherwise.
+ function Is_Readable_File (Name : String) return Boolean;
+ -- Determines if the given string, Name, is the name of an existing
+ -- file that is readable. Returns True if so, False otherwise. Note
+ -- that this function simply interrogates the file attributes (e.g.
+ -- using the C function stat), so it does not indicate a situation
+ -- in which a file may not actually be readable due to some other
+ -- process having exclusive access.
+
function Is_Writable_File (Name : String) return Boolean;
-- Determines if the given string, Name, is the name of an existing
- -- file that is writable. Returns True if so, False otherwise.
+ -- file that is writable. Returns True if so, False otherwise. Note
+ -- that this function simply interrogates the file attributes (e.g.
+ -- using the C function stat), so it does not indicate a situation
+ -- in which a file may not actually be writeable due to some other
+ -- process having exclusive access.
+
+ function Is_Symbolic_Link (Name : String) return Boolean;
+ -- Determines if the given string, Name, is the path of a symbolic link
+ -- on systems that support it. Returns True if so, False if the path
+ -- is not a symbolic link or if the system does not support symbolic links.
+ --
+ -- A symbolic link is an indirect pointer to a file; its directory entry
+ -- contains the name of the file to which it is linked. Symbolic links may
+ -- span file systems and may refer to directories.
function Locate_Exec_On_Path
(Exec_Name : String)
@@ -312,7 +470,10 @@ pragma Elaborate_Body (OS_Lib);
-- directories listed in Path. If a file is found, its full pathname is
-- returned; otherwise, a null pointer is returned. If the File_Name given
-- is an absolute pathname, then Locate_Regular_File just checks that the
- -- file exists and is a regular file. Otherwise, the Path argument is
+ -- file exists and is a regular file. Otherwise, if the File_Name given
+ -- includes directory information, Locate_Regular_File first checks if
+ -- the file exists relative to the current directory. If it does not,
+ -- or if the File_Name given is a simple file name, the Path argument is
-- parsed according to OS conventions, and for each directory in the Path
-- a check is made if File_Name is a relative pathname of a regular file
-- from that directory.
@@ -338,7 +499,7 @@ pragma Elaborate_Body (OS_Lib);
-- The following section contains low-level routines using addresses to
-- pass file name and executable name. In each routine the name must be
-- Nul-Terminated. For complete documentation refer to the equivalent
- -- routine (but using string) defined above.
+ -- routine (using String in place of C_File_Name) defined above.
subtype C_File_Name is System.Address;
-- This subtype is used to document that a parameter is the address
@@ -371,13 +532,26 @@ pragma Elaborate_Body (OS_Lib);
New_Name : C_File_Name;
Success : out Boolean);
+ procedure Copy_File
+ (Name : C_File_Name;
+ Pathname : C_File_Name;
+ Success : out Boolean;
+ Mode : Copy_Mode := Copy;
+ Preserve : Attribute := Time_Stamps);
+
+ procedure Copy_Time_Stamps
+ (Source, Dest : C_File_Name;
+ Success : out Boolean);
+
function File_Time_Stamp (Name : C_File_Name) return OS_Time;
function Is_Regular_File (Name : C_File_Name) return Boolean;
function Is_Directory (Name : C_File_Name) return Boolean;
+ function Is_Readable_File (Name : C_File_Name) return Boolean;
function Is_Writable_File (Name : C_File_Name) return Boolean;
+ function Is_Symbolic_Link (Name : C_File_Name) return Boolean;
function Locate_Regular_File
(File_Name : C_File_Name;
@@ -405,7 +579,7 @@ pragma Elaborate_Body (OS_Lib);
-- on the same list it will do nothing the second time. Note that Spawn
-- and Non_Blocking_Spawn call Normalize_Arguments automatically, but
-- since there is a guarantee that a second call does nothing, this
- -- internal call with have no effect if Normalize_Arguments is called
+ -- internal call will have no effect if Normalize_Arguments is called
-- before calling Spawn. The call to Normalize_Arguments assumes that
-- the individual referenced arguments in Argument_List are on the heap,
-- and may free them and reallocate if they are modified.
@@ -423,6 +597,8 @@ pragma Elaborate_Body (OS_Lib);
-- argument. On some systems (notably Unix systems) a simple file
-- name may also work (if the executable can be located in the path).
--
+ -- "Spawn" should not be used in tasking applications.
+ --
-- Note: Arguments in Args that contain spaces and/or quotes such as
-- "--GCC=gcc -v" or "--GCC=""gcc -v""" are not portable across all
-- operating systems, and would not have the desired effect if they
@@ -448,6 +624,9 @@ pragma Elaborate_Body (OS_Lib);
-- Similar to the above procedure, but returns the actual status returned
-- by the operating system, or -1 under VxWorks and any other similar
-- operating systems which have no notion of separately spawnable programs.
+ --
+ -- "Spawn" should not be used in tasking applications.
+ --
type Process_Id is private;
-- A private type used to identify a process activated by the following
@@ -465,6 +644,8 @@ pragma Elaborate_Body (OS_Lib);
-- is returned. Parameters are to be used as in Spawn. If Invalid_Id
-- is returned the program could not be spawned.
--
+ -- "Non_Blocking_Spawn" should not be used in tasking applications.
+ --
-- This function will always return Invalid_Id under VxWorks, since
-- there is no notion of executables under this OS.
@@ -485,7 +666,7 @@ pragma Elaborate_Body (OS_Lib);
function Argument_String_To_List
(Arg_String : String)
return Argument_List_Access;
- -- Take a string that is a program and it's arguments and parse it into
+ -- Take a string that is a program and its arguments and parse it into
-- an Argument_List. Note that the result is allocated on the heap, and
-- must be freed by the programmer (when it is no longer needed) to avoid
-- memory leaks.
@@ -545,14 +726,21 @@ private
pragma Import (C, Path_Separator, "__gnat_path_separator");
pragma Import (C, Directory_Separator, "__gnat_dir_separator");
- type OS_Time is new Integer;
-
- type File_Descriptor is new Integer;
-
- Standin : constant File_Descriptor := 0;
- Standout : constant File_Descriptor := 1;
- Standerr : constant File_Descriptor := 2;
- Invalid_FD : constant File_Descriptor := -1;
+ type OS_Time is new Long_Integer;
+ -- Type used for timestamps in the compiler. This type is used to
+ -- hold time stamps, but may have a different representation than
+ -- C's time_t. This type needs to match the declaration of OS_Time
+ -- in adaint.h.
+
+ -- Add pragma Inline statements for comparison operations on OS_Time.
+ -- It would actually be nice to use pragma Import (Intrinsic) here,
+ -- but this was not properly supported till GNAT 3.15a, so that would
+ -- cause bootstrap path problems. To be changed later ???
+
+ pragma Inline ("<");
+ pragma Inline (">");
+ pragma Inline ("<=");
+ pragma Inline (">=");
type Process_Id is new Integer;
Invalid_Pid : constant Process_Id := -1;
diff --git a/gcc/ada/g-pehage.adb b/gcc/ada/g-pehage.adb
new file mode 100644
index 00000000000..91ec4182d7d
--- /dev/null
+++ b/gcc/ada/g-pehage.adb
@@ -0,0 +1,2400 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . P E R F E C T _ H A S H . G E N E R A T O R S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.IO_Exceptions; use Ada.IO_Exceptions;
+
+with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Table;
+
+package body GNAT.Perfect_Hash.Generators is
+
+ -- We are using the algorithm of J. Czech as described in Zbigniew
+ -- J. Czech, George Havas, and Bohdan S. Majewski ``An Optimal
+ -- Algorithm for Generating Minimal Perfect Hash Functions'',
+ -- Information Processing Letters, 43(1992) pp.257-264, Oct.1992
+
+ -- This minimal perfect hash function generator is based on random
+ -- graphs and produces a hash function of the form:
+
+ -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
+
+ -- where f1 and f2 are functions that map strings into integers,
+ -- and g is a function that maps integers into [0, m-1]. h can be
+ -- order preserving. For instance, let W = {w_0, ..., w_i, ...,
+ -- w_m-1}, h can be defined such that h (w_i) = i.
+
+ -- This algorithm defines two possible constructions of f1 and
+ -- f2. Method b) stores the hash function in less memory space at
+ -- the expense of greater CPU time.
+
+ -- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
+
+ -- size (Tk) = max (for w in W) (length (w)) * size (used char set)
+
+ -- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
+
+ -- size (Tk) = max (for w in W) (length (w)) but the table
+ -- lookups are replaced by multiplications.
+
+ -- where Tk values are randomly generated. n is defined later on
+ -- but the algorithm recommends to use a value a little bit
+ -- greater than 2m. Note that for large values of m, the main
+ -- memory space requirements comes from the memory space for
+ -- storing function g (>= 2m entries).
+
+ -- Random graphs are frequently used to solve difficult problems
+ -- that do not have polynomial solutions. This algorithm is based
+ -- on a weighted undirected graph. It comprises two steps: mapping
+ -- and assigment.
+
+ -- In the mapping step, a graph G = (V, E) is constructed, where V
+ -- = {0, 1, ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In
+ -- order for the assignment step to be successful, G has to be
+ -- acyclic. To have a high probability of generating an acyclic
+ -- graph, n >= 2m. If it is not acyclic, Tk have to be regenerated.
+
+ -- In the assignment step, the algorithm builds function g. As G
+ -- is acyclic, there is a vertex v1 with only one neighbor v2. Let
+ -- w_i be the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let
+ -- g (v1) = 0 by construction and g (v2) = (i - g (v1)) mod n (or
+ -- to be general, (h (i) - g (v1) mod n). If word w_j is such that
+ -- v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j - g (v2)) mod n
+ -- (or to be general, (h (j) - g (v2)) mod n). If w_i has no
+ -- neighbor, then another vertex is selected. The algorithm
+ -- traverses G to assign values to all the vertices. It cannot
+ -- assign a value to an already assigned vertex as G is acyclic.
+
+ subtype Word_Id is Integer;
+ subtype Key_Id is Integer;
+ subtype Vertex_Id is Integer;
+ subtype Edge_Id is Integer;
+ subtype Table_Id is Integer;
+
+ No_Vertex : constant Vertex_Id := -1;
+ No_Edge : constant Edge_Id := -1;
+ No_Table : constant Table_Id := -1;
+
+ Max_Word_Length : constant := 32;
+ subtype Word_Type is String (1 .. Max_Word_Length);
+ Null_Word : constant Word_Type := (others => ASCII.NUL);
+ -- Store keyword in a word. Note that the length of word is
+ -- limited to 32 characters.
+
+ type Key_Type is record
+ Edge : Edge_Id;
+ end record;
+ -- A key corresponds to an edge in the algorithm graph.
+
+ type Vertex_Type is record
+ First : Edge_Id;
+ Last : Edge_Id;
+ end record;
+ -- A vertex can be involved in several edges. First and Last are
+ -- the bounds of an array of edges stored in a global edge table.
+
+ type Edge_Type is record
+ X : Vertex_Id;
+ Y : Vertex_Id;
+ Key : Key_Id;
+ end record;
+ -- An edge is a peer of vertices. In the algorithm, a key
+ -- is associated to an edge.
+
+ package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32);
+ package IT is new GNAT.Table (Integer, Integer, 0, 32, 32);
+ -- The two main tables. IT is used to store several tables of
+ -- components containing only integers.
+
+ function Image (Int : Integer; W : Natural := 0) return String;
+ function Image (Str : String; W : Natural := 0) return String;
+ -- Return a string which includes string Str or integer Int
+ -- preceded by leading spaces if required by width W.
+
+ Output : File_Descriptor renames GNAT.OS_Lib.Standout;
+ -- Shortcuts
+
+ Max : constant := 78;
+ Last : Natural := 0;
+ Line : String (1 .. Max);
+ -- Use this line to provide buffered IO
+
+ procedure Add (C : Character);
+ procedure Add (S : String);
+ -- Add a character or a string in Line and update Last
+
+ procedure Put
+ (F : File_Descriptor;
+ S : String;
+ F1 : Natural;
+ L1 : Natural;
+ C1 : Natural;
+ F2 : Natural;
+ L2 : Natural;
+ C2 : Natural);
+ -- Write string S into file F as a element of an array of one or
+ -- two dimensions. Fk (resp. Lk and Ck) indicates the first (resp
+ -- last and current) index in the k-th dimension. If F1 = L1 the
+ -- array is considered as a one dimension array. This dimension is
+ -- described by F2 and L2. This routine takes care of all the
+ -- parenthesis, spaces and commas needed to format correctly the
+ -- array. Moreover, the array is well indented and is wrapped to
+ -- fit in a 80 col line. When the line is full, the routine writes
+ -- it into file F. When the array is completed, the routine adds a
+ -- semi-colon and writes the line into file F.
+
+ procedure New_Line
+ (F : File_Descriptor);
+ -- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib
+
+ procedure Put
+ (F : File_Descriptor;
+ S : String);
+ -- Simulate Ada.Text_IO.Put with GNAT.OS_Lib
+
+ procedure Put_Used_Char_Set
+ (File : File_Descriptor;
+ Title : String);
+ -- Output a title and a used character set
+
+ procedure Put_Int_Vector
+ (File : File_Descriptor;
+ Title : String;
+ Root : Integer;
+ Length : Natural);
+ -- Output a title and a vector
+
+ procedure Put_Int_Matrix
+ (File : File_Descriptor;
+ Title : String;
+ Table : Table_Id);
+ -- Output a title and a matrix. When the matrix has only one
+ -- non-empty dimension, it is output as a vector.
+
+ procedure Put_Edges
+ (File : File_Descriptor;
+ Title : String);
+ -- Output a title and an edge table
+
+ procedure Put_Initial_Keys
+ (File : File_Descriptor;
+ Title : String);
+ -- Output a title and a key table
+
+ procedure Put_Reduced_Keys
+ (File : File_Descriptor;
+ Title : String);
+ -- Output a title and a key table
+
+ procedure Put_Vertex_Table
+ (File : File_Descriptor;
+ Title : String);
+ -- Output a title and a vertex table
+
+ ----------------------------------
+ -- Character Position Selection --
+ ----------------------------------
+
+ -- We reduce the maximum key size by selecting representative
+ -- positions in these keys. We build a matrix with one word per
+ -- line. We fill the remaining space of a line with ASCII.NUL. The
+ -- heuristic selects the position that induces the minimum number
+ -- of collisions. If there are collisions, select another position
+ -- on the reduced key set responsible of the collisions. Apply the
+ -- heuristic until there is no more collision.
+
+ procedure Apply_Position_Selection;
+ -- Apply Position selection and build the reduced key table
+
+ procedure Parse_Position_Selection (Argument : String);
+ -- Parse Argument and compute the position set. Argument is a
+ -- list of substrings separated by commas. Each substring
+ -- represents a position or a range of positions (like x-y).
+
+ procedure Select_Character_Set;
+ -- Define an optimized used character set like Character'Pos in
+ -- order not to allocate tables of 256 entries.
+
+ procedure Select_Char_Position;
+ -- Find a min char position set in order to reduce the max key
+ -- length. The heuristic selects the position that induces the
+ -- minimum number of collisions. If there are collisions, select
+ -- another position on the reduced key set responsible of the
+ -- collisions. Apply the heuristic until there is no collision.
+
+ -----------------------------
+ -- Random Graph Generation --
+ -----------------------------
+
+ procedure Random (Seed : in out Natural);
+ -- Simulate Ada.Discrete_Numerics.Random.
+
+ procedure Generate_Mapping_Table
+ (T : Table_Id;
+ L1 : Natural;
+ L2 : Natural;
+ S : in out Natural);
+ -- Random generation of the tables below. T is already allocated.
+
+ procedure Generate_Mapping_Tables
+ (Opt : Optimization;
+ S : in out Natural);
+ -- Generate the mapping tables T1 and T2. They are used to define :
+ -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n.
+ -- Keys, NK and Chars are used to compute the matrix size.
+
+ ---------------------------
+ -- Algorithm Computation --
+ ---------------------------
+
+ procedure Compute_Edges_And_Vertices (Opt : Optimization);
+ -- Compute the edge and vertex tables. These are empty when a self
+ -- loop is detected (f1 (w) = f2 (w)). The edge table is sorted by
+ -- X value and then Y value. Keys is the key table and NK the
+ -- number of keys. Chars is the set of characters really used in
+ -- Keys. NV is the number of vertices recommended by the
+ -- algorithm. T1 and T2 are the mapping tables needed to compute
+ -- f1 (w) and f2 (w).
+
+ function Acyclic return Boolean;
+ -- Return True when the graph is acyclic. Vertices is the current
+ -- vertex table and Edges the current edge table.
+
+ procedure Assign_Values_To_Vertices;
+ -- Execute the assignment step of the algorithm. Keys is the
+ -- current key table. Vertices and Edges represent the random
+ -- graph. G is the result of the assignment step such that:
+ -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
+
+ function Sum
+ (Word : Word_Type;
+ Table : Table_Id;
+ Opt : Optimization)
+ return Natural;
+ -- For an optimization of CPU_Time return
+ -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n
+ -- For an optimization of Memory_Space return
+ -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n
+ -- Here NV = n
+
+ -------------------------------
+ -- Internal Table Management --
+ -------------------------------
+
+ function Allocate (N : Natural; S : Natural) return Table_Id;
+ -- procedure Deallocate (N : Natural; S : Natural);
+
+ ----------
+ -- Keys --
+ ----------
+
+ Key_Size : constant := 1;
+ Keys : Table_Id := No_Table;
+ NK : Natural;
+ -- NK : Number of Keys
+
+ function Initial (K : Key_Id) return Word_Id;
+ pragma Inline (Initial);
+
+ function Reduced (K : Key_Id) return Word_Id;
+ pragma Inline (Reduced);
+
+ function Get_Key (F : Key_Id) return Key_Type;
+ procedure Set_Key (F : Key_Id; Item : Key_Type);
+ -- Comments needed here ???
+
+ ------------------
+ -- Char_Pos_Set --
+ ------------------
+
+ Char_Pos_Size : constant := 1;
+ Char_Pos_Set : Table_Id := No_Table;
+ Char_Pos_Set_Len : Natural;
+ -- Character Selected Position Set
+
+ function Get_Char_Pos (P : Natural) return Natural;
+ procedure Set_Char_Pos (P : Natural; Item : Natural);
+ -- Comments needed here ???
+
+ -------------------
+ -- Used_Char_Set --
+ -------------------
+
+ Used_Char_Size : constant := 1;
+ Used_Char_Set : Table_Id := No_Table;
+ Used_Char_Set_Len : Natural;
+ -- Used Character Set : Define a new character mapping. When all
+ -- the characters are not present in the keys, in order to reduce
+ -- the size of some tables, we redefine the character mapping.
+
+ function Get_Used_Char (C : Character) return Natural;
+ procedure Set_Used_Char (C : Character; Item : Natural);
+
+ -------------------
+ -- Random Tables --
+ -------------------
+
+ Rand_Tab_Item_Size : constant := 1;
+ T1 : Table_Id := No_Table;
+ T2 : Table_Id := No_Table;
+ Rand_Tab_Len_1 : Natural;
+ Rand_Tab_Len_2 : Natural;
+ -- T1 : Values table to compute F1
+ -- T2 : Values table to compute F2
+
+ function Get_Rand_Tab (T : Integer; X, Y : Natural) return Natural;
+ procedure Set_Rand_Tab (T : Integer; X, Y : Natural; Item : Natural);
+
+ ------------------
+ -- Random Graph --
+ ------------------
+
+ Graph_Item_Size : constant := 1;
+ G : Table_Id := No_Table;
+ Graph_Len : Natural;
+ -- G : Values table to compute G
+
+ function Get_Graph (F : Natural) return Integer;
+ procedure Set_Graph (F : Natural; Item : Integer);
+ -- Comments needed ???
+
+ -----------
+ -- Edges --
+ -----------
+
+ Edge_Size : constant := 3;
+ Edges : Table_Id := No_Table;
+ Edges_Len : Natural;
+ -- Edges : Edge table of the random graph G
+
+ function Get_Edges (F : Natural) return Edge_Type;
+ procedure Set_Edges (F : Natural; Item : Edge_Type);
+
+ --------------
+ -- Vertices --
+ --------------
+
+ Vertex_Size : constant := 2;
+
+ Vertices : Table_Id := No_Table;
+ -- Vertex table of the random graph G
+
+ NV : Natural;
+ -- Number of Vertices
+
+ function Get_Vertices (F : Natural) return Vertex_Type;
+ procedure Set_Vertices (F : Natural; Item : Vertex_Type);
+ -- Comments needed ???
+
+ K2V : Float;
+ -- Ratio between Keys and Vertices (parameter of Czech's algorithm)
+
+ Opt : Optimization;
+ -- Optimization mode (memory vs CPU)
+
+ MKL : Natural;
+ -- Maximum of all the word length
+
+ S : Natural;
+ -- Seed
+
+ function Type_Size (L : Natural) return Natural;
+ -- Given the last L of an unsigned integer type T, return its size
+
+ -------------
+ -- Acyclic --
+ -------------
+
+ function Acyclic return Boolean
+ is
+ Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex);
+
+ function Traverse
+ (Edge : Edge_Id;
+ Mark : Vertex_Id)
+ return Boolean;
+ -- Propagate Mark from X to Y. X is already marked. Mark Y and
+ -- propagate it to the edges of Y except the one representing
+ -- the same key. Return False when Y is marked with Mark.
+
+ --------------
+ -- Traverse --
+ --------------
+
+ function Traverse
+ (Edge : Edge_Id;
+ Mark : Vertex_Id)
+ return Boolean
+ is
+ E : constant Edge_Type := Get_Edges (Edge);
+ K : constant Key_Id := E.Key;
+ Y : constant Vertex_Id := E.Y;
+ M : constant Vertex_Id := Marks (E.Y);
+ V : Vertex_Type;
+
+ begin
+ if M = Mark then
+ return False;
+
+ elsif M = No_Vertex then
+ Marks (Y) := Mark;
+ V := Get_Vertices (Y);
+
+ for J in V.First .. V.Last loop
+
+ -- Do not propagate to the edge representing the same key.
+
+ if Get_Edges (J).Key /= K
+ and then not Traverse (J, Mark)
+ then
+ return False;
+ end if;
+ end loop;
+ end if;
+
+ return True;
+ end Traverse;
+
+ Edge : Edge_Type;
+
+ -- Start of processing for Acyclic
+
+ begin
+ -- Edges valid range is
+
+ for J in 1 .. Edges_Len - 1 loop
+
+ Edge := Get_Edges (J);
+
+ -- Mark X of E when it has not been already done
+
+ if Marks (Edge.X) = No_Vertex then
+ Marks (Edge.X) := Edge.X;
+ end if;
+
+ -- Traverse E when this has not already been done
+
+ if Marks (Edge.Y) = No_Vertex
+ and then not Traverse (J, Edge.X)
+ then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end Acyclic;
+
+ ---------
+ -- Add --
+ ---------
+
+ procedure Add (C : Character) is
+ begin
+ Line (Last + 1) := C;
+ Last := Last + 1;
+ end Add;
+
+ ---------
+ -- Add --
+ ---------
+
+ procedure Add (S : String) is
+ Len : constant Natural := S'Length;
+
+ begin
+ Line (Last + 1 .. Last + Len) := S;
+ Last := Last + Len;
+ end Add;
+
+ --------------
+ -- Allocate --
+ --------------
+
+ function Allocate (N : Natural; S : Natural) return Table_Id is
+ L : constant Integer := IT.Last;
+
+ begin
+ IT.Set_Last (L + N * S);
+ return L + 1;
+ end Allocate;
+
+ ------------------------------
+ -- Apply_Position_Selection --
+ ------------------------------
+
+ procedure Apply_Position_Selection is
+ begin
+ WT.Set_Last (2 * NK - 1);
+ for J in 0 .. NK - 1 loop
+ declare
+ I_Word : constant Word_Type := WT.Table (Initial (J));
+ R_Word : Word_Type := Null_Word;
+ Index : Natural := I_Word'First - 1;
+
+ begin
+ -- Select the characters of Word included in the
+ -- position selection.
+
+ for C in 0 .. Char_Pos_Set_Len - 1 loop
+ exit when I_Word (Get_Char_Pos (C)) = ASCII.NUL;
+ Index := Index + 1;
+ R_Word (Index) := I_Word (Get_Char_Pos (C));
+ end loop;
+
+ -- Build the new table with the reduced word
+
+ WT.Table (Reduced (J)) := R_Word;
+ Set_Key (J, (Edge => No_Edge));
+ end;
+ end loop;
+ end Apply_Position_Selection;
+
+ -------------
+ -- Compute --
+ -------------
+
+ procedure Compute (Position : String := Default_Position) is
+ begin
+ Keys := Allocate (NK, Key_Size);
+
+ if Verbose then
+ Put_Initial_Keys (Output, "Initial Key Table");
+ end if;
+
+ if Position'Length /= 0 then
+ Parse_Position_Selection (Position);
+ else
+ Select_Char_Position;
+ end if;
+
+ if Verbose then
+ Put_Int_Vector
+ (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len);
+ end if;
+
+ Apply_Position_Selection;
+
+ if Verbose then
+ Put_Reduced_Keys (Output, "Reduced Keys Table");
+ end if;
+
+ Select_Character_Set;
+
+ if Verbose then
+ Put_Used_Char_Set (Output, "Character Position Table");
+ end if;
+
+ -- Perform Czech's algorithm
+
+ loop
+ Generate_Mapping_Tables (Opt, S);
+ Compute_Edges_And_Vertices (Opt);
+
+ -- When graph is not empty (no self-loop from previous
+ -- operation) and not acyclic.
+
+ exit when 0 < Edges_Len and then Acyclic;
+ end loop;
+
+ Assign_Values_To_Vertices;
+ end Compute;
+
+ -------------------------------
+ -- Assign_Values_To_Vertices --
+ -------------------------------
+
+ procedure Assign_Values_To_Vertices is
+ X : Vertex_Id;
+
+ procedure Assign (X : Vertex_Id);
+ -- Execute assignment on X's neighbors except the vertex that
+ -- we are coming from which is already assigned.
+
+ ------------
+ -- Assign --
+ ------------
+
+ procedure Assign (X : Vertex_Id)
+ is
+ E : Edge_Type;
+ V : constant Vertex_Type := Get_Vertices (X);
+
+ begin
+ for J in V.First .. V.Last loop
+ E := Get_Edges (J);
+ if Get_Graph (E.Y) = -1 then
+ Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK);
+ Assign (E.Y);
+ end if;
+ end loop;
+ end Assign;
+
+ -- Start of processing for Assign_Values_To_Vertices
+
+ begin
+ -- Value -1 denotes an unitialized value as it is supposed to
+ -- be in the range 0 .. NK.
+
+ if G = No_Table then
+ Graph_Len := NV;
+ G := Allocate (Graph_Len, Graph_Item_Size);
+ end if;
+
+ for J in 0 .. Graph_Len - 1 loop
+ Set_Graph (J, -1);
+ end loop;
+
+ for K in 0 .. NK - 1 loop
+ X := Get_Edges (Get_Key (K).Edge).X;
+
+ if Get_Graph (X) = -1 then
+ Set_Graph (X, 0);
+ Assign (X);
+ end if;
+ end loop;
+
+ for J in 0 .. Graph_Len - 1 loop
+ if Get_Graph (J) = -1 then
+ Set_Graph (J, 0);
+ end if;
+ end loop;
+
+ if Verbose then
+ Put_Int_Vector (Output, "Assign Values To Vertices", G, Graph_Len);
+ end if;
+ end Assign_Values_To_Vertices;
+
+ --------------------------------
+ -- Compute_Edges_And_Vertices --
+ --------------------------------
+
+ procedure Compute_Edges_And_Vertices (Opt : Optimization) is
+ X : Natural;
+ Y : Natural;
+ Key : Key_Type;
+ Edge : Edge_Type;
+ Vertex : Vertex_Type;
+ Not_Acyclic : Boolean := False;
+
+ procedure Move (From : Natural; To : Natural);
+ function Lt (L, R : Natural) return Boolean;
+ -- Subprograms needed for GNAT.Heap_Sort_A
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ Set_Edges (To, Get_Edges (From));
+ end Move;
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (L, R : Natural) return Boolean is
+ EL : constant Edge_Type := Get_Edges (L);
+ ER : constant Edge_Type := Get_Edges (R);
+
+ begin
+ return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y);
+ end Lt;
+
+ -- Start of processing for Compute_Edges_And_Vertices
+
+ begin
+ -- We store edges from 1 to 2 * NK and leave
+ -- zero alone in order to use GNAT.Heap_Sort_A.
+
+ Edges_Len := 2 * NK + 1;
+
+ if Edges = No_Table then
+ Edges := Allocate (Edges_Len, Edge_Size);
+ end if;
+
+ if Vertices = No_Table then
+ Vertices := Allocate (NV, Vertex_Size);
+ end if;
+
+ for J in 0 .. NV - 1 loop
+ Set_Vertices (J, (No_Vertex, No_Vertex - 1));
+ end loop;
+
+ -- For each w, X = f1 (w) and Y = f2 (w)
+
+ for J in 0 .. NK - 1 loop
+ Key := Get_Key (J);
+ Key.Edge := No_Edge;
+ Set_Key (J, Key);
+
+ X := Sum (WT.Table (Reduced (J)), T1, Opt);
+ Y := Sum (WT.Table (Reduced (J)), T2, Opt);
+
+ -- Discard T1 and T2 as soon as we discover a self loop
+
+ if X = Y then
+ Not_Acyclic := True;
+ exit;
+ end if;
+
+ -- We store (X, Y) and (Y, X) to ease assignment step
+
+ Set_Edges (2 * J + 1, (X, Y, J));
+ Set_Edges (2 * J + 2, (Y, X, J));
+ end loop;
+
+ -- Return an empty graph when self loop detected
+
+ if Not_Acyclic then
+ Edges_Len := 0;
+
+ else
+ if Verbose then
+ Put_Edges (Output, "Unsorted Edge Table");
+ Put_Int_Matrix (Output, "Function Table 1", T1);
+ Put_Int_Matrix (Output, "Function Table 2", T2);
+ end if;
+
+ -- Enforce consistency between edges and keys. Construct
+ -- Vertices and compute the list of neighbors of a vertex
+ -- First .. Last as Edges is sorted by X and then Y. To
+ -- compute the neighbor list, sort the edges.
+
+ Sort
+ (Edges_Len - 1,
+ Move'Unrestricted_Access,
+ Lt'Unrestricted_Access);
+
+ if Verbose then
+ Put_Edges (Output, "Sorted Edge Table");
+ Put_Int_Matrix (Output, "Function Table 1", T1);
+ Put_Int_Matrix (Output, "Function Table 2", T2);
+ end if;
+
+ -- Edges valid range is 1 .. 2 * NK
+
+ for E in 1 .. Edges_Len - 1 loop
+ Edge := Get_Edges (E);
+ Key := Get_Key (Edge.Key);
+
+ if Key.Edge = No_Edge then
+ Key.Edge := E;
+ Set_Key (Edge.Key, Key);
+ end if;
+
+ Vertex := Get_Vertices (Edge.X);
+
+ if Vertex.First = No_Edge then
+ Vertex.First := E;
+ end if;
+
+ Vertex.Last := E;
+ Set_Vertices (Edge.X, Vertex);
+ end loop;
+
+ if Verbose then
+ Put_Reduced_Keys (Output, "Key Table");
+ Put_Edges (Output, "Edge Table");
+ Put_Vertex_Table (Output, "Vertex Table");
+ end if;
+ end if;
+ end Compute_Edges_And_Vertices;
+
+ ------------
+ -- Define --
+ ------------
+
+ procedure Define
+ (Name : Table_Name;
+ Item_Size : out Natural;
+ Length_1 : out Natural;
+ Length_2 : out Natural)
+ is
+ begin
+ case Name is
+ when Character_Position =>
+ Item_Size := 8;
+ Length_1 := Char_Pos_Set_Len;
+ Length_2 := 0;
+
+ when Used_Character_Set =>
+ Item_Size := 8;
+ Length_1 := 256;
+ Length_2 := 0;
+
+ when Function_Table_1
+ | Function_Table_2 =>
+ Item_Size := Type_Size (NV);
+ Length_1 := Rand_Tab_Len_1;
+ Length_2 := Rand_Tab_Len_2;
+
+ when Graph_Table =>
+ Item_Size := Type_Size (NK);
+ Length_1 := NV;
+ Length_2 := 0;
+ end case;
+ end Define;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize is
+ begin
+ WT.Release;
+ IT.Release;
+
+ Keys := No_Table;
+ NK := 0;
+
+ Char_Pos_Set := No_Table;
+ Char_Pos_Set_Len := 0;
+
+ Used_Char_Set := No_Table;
+ Used_Char_Set_Len := 0;
+
+ T1 := No_Table;
+ T2 := No_Table;
+
+ Rand_Tab_Len_1 := 0;
+ Rand_Tab_Len_2 := 0;
+
+ G := No_Table;
+ Graph_Len := 0;
+
+ Edges := No_Table;
+ Edges_Len := 0;
+
+ Vertices := No_Table;
+ NV := 0;
+ end Finalize;
+
+ ----------------------------
+ -- Generate_Mapping_Table --
+ ----------------------------
+
+ procedure Generate_Mapping_Table
+ (T : Integer;
+ L1 : Natural;
+ L2 : Natural;
+ S : in out Natural)
+ is
+ begin
+ for J in 0 .. L1 - 1 loop
+ for K in 0 .. L2 - 1 loop
+ Random (S);
+ Set_Rand_Tab (T, J, K, S mod NV);
+ end loop;
+ end loop;
+ end Generate_Mapping_Table;
+
+ -----------------------------
+ -- Generate_Mapping_Tables --
+ -----------------------------
+
+ procedure Generate_Mapping_Tables
+ (Opt : Optimization;
+ S : in out Natural)
+ is
+ begin
+ -- If T1 and T2 are already allocated no need to do it
+ -- twice. Reuse them as their size has not changes.
+
+ if T1 = No_Table and then T2 = No_Table then
+ declare
+ Used_Char_Last : Natural := 0;
+ Used_Char : Natural;
+
+ begin
+ if Opt = CPU_Time then
+ for P in reverse Character'Range loop
+ Used_Char := Get_Used_Char (P);
+ if Used_Char /= 0 then
+ Used_Char_Last := Used_Char;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ Rand_Tab_Len_1 := Char_Pos_Set_Len;
+ Rand_Tab_Len_2 := Used_Char_Last + 1;
+ T1 := Allocate (Rand_Tab_Len_1 * Rand_Tab_Len_2,
+ Rand_Tab_Item_Size);
+ T2 := Allocate (Rand_Tab_Len_1 * Rand_Tab_Len_2,
+ Rand_Tab_Item_Size);
+ end;
+ end if;
+
+ Generate_Mapping_Table (T1, Rand_Tab_Len_1, Rand_Tab_Len_2, S);
+ Generate_Mapping_Table (T2, Rand_Tab_Len_1, Rand_Tab_Len_2, S);
+
+ if Verbose then
+ Put_Used_Char_Set (Output, "Used Character Set");
+ Put_Int_Matrix (Output, "Function Table 1", T1);
+ Put_Int_Matrix (Output, "Function Table 2", T2);
+ end if;
+ end Generate_Mapping_Tables;
+
+ ------------------
+ -- Get_Char_Pos --
+ ------------------
+
+ function Get_Char_Pos (P : Natural) return Natural is
+ N : constant Natural := Char_Pos_Set + P;
+
+ begin
+ return IT.Table (N);
+ end Get_Char_Pos;
+
+ ---------------
+ -- Get_Edges --
+ ---------------
+
+ function Get_Edges (F : Natural) return Edge_Type is
+ N : constant Natural := Edges + (F * Edge_Size);
+ E : Edge_Type;
+
+ begin
+ E.X := IT.Table (N);
+ E.Y := IT.Table (N + 1);
+ E.Key := IT.Table (N + 2);
+ return E;
+ end Get_Edges;
+
+ ---------------
+ -- Get_Graph --
+ ---------------
+
+ function Get_Graph (F : Natural) return Integer is
+ N : constant Natural := G + F * Graph_Item_Size;
+
+ begin
+ return IT.Table (N);
+ end Get_Graph;
+
+ -------------
+ -- Get_Key --
+ -------------
+
+ function Get_Key (F : Key_Id) return Key_Type is
+ N : constant Natural := Keys + F * Key_Size;
+ K : Key_Type;
+
+ begin
+ K.Edge := IT.Table (N);
+ return K;
+ end Get_Key;
+
+ ------------------
+ -- Get_Rand_Tab --
+ ------------------
+
+ function Get_Rand_Tab (T : Integer; X, Y : Natural) return Natural is
+ N : constant Natural :=
+ T + ((Y * Rand_Tab_Len_1) + X) * Rand_Tab_Item_Size;
+
+ begin
+ return IT.Table (N);
+ end Get_Rand_Tab;
+
+ -------------------
+ -- Get_Used_Char --
+ -------------------
+
+ function Get_Used_Char (C : Character) return Natural is
+ N : constant Natural :=
+ Used_Char_Set + Character'Pos (C) * Used_Char_Size;
+
+ begin
+ return IT.Table (N);
+ end Get_Used_Char;
+
+ ------------------
+ -- Get_Vertices --
+ ------------------
+
+ function Get_Vertices (F : Natural) return Vertex_Type is
+ N : constant Natural := Vertices + (F * Vertex_Size);
+ V : Vertex_Type;
+
+ begin
+ V.First := IT.Table (N);
+ V.Last := IT.Table (N + 1);
+ return V;
+ end Get_Vertices;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (Int : Integer; W : Natural := 0) return String is
+ B : String (1 .. 32);
+ L : Natural := 0;
+
+ procedure Img (V : Natural);
+ -- Compute image of V into B, starting at B (L), incrementing L
+
+ ---------
+ -- Img --
+ ---------
+
+ procedure Img (V : Natural) is
+ begin
+ if V > 9 then
+ Img (V / 10);
+ end if;
+
+ L := L + 1;
+ B (L) := Character'Val ((V mod 10) + Character'Pos ('0'));
+ end Img;
+
+ -- Start of processing for Image
+
+ begin
+ if Int < 0 then
+ L := L + 1;
+ B (L) := '-';
+ Img (-Int);
+ else
+ Img (Int);
+ end if;
+
+ return Image (B (1 .. L), W);
+ end Image;
+
+ -----------
+ -- Image --
+ -----------
+
+ function Image (Str : String; W : Natural := 0) return String is
+ Len : constant Natural := Str'Length;
+ Max : Natural := Len;
+
+ begin
+ if Max < W then
+ Max := W;
+ end if;
+
+ declare
+ Buf : String (1 .. Max) := (1 .. Max => ' ');
+
+ begin
+ for J in 0 .. Len - 1 loop
+ Buf (Max - Len + 1 + J) := Str (Str'First + J);
+ end loop;
+
+ return Buf;
+ end;
+ end Image;
+
+ -------------
+ -- Initial --
+ -------------
+
+ function Initial (K : Key_Id) return Word_Id is
+ begin
+ return K;
+ end Initial;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize
+ (Seed : Natural;
+ K_To_V : Float := Default_K_To_V;
+ Optim : Optimization := CPU_Time)
+ is
+ begin
+ WT.Init;
+ IT.Init;
+ S := Seed;
+
+ Keys := No_Table;
+ NK := 0;
+
+ Char_Pos_Set := No_Table;
+ Char_Pos_Set_Len := 0;
+
+ K2V := K_To_V;
+ Opt := Optim;
+ MKL := 0;
+ end Initialize;
+
+ ------------
+ -- Insert --
+ ------------
+
+ procedure Insert
+ (Value : String)
+ is
+ Word : Word_Type := Null_Word;
+ Len : constant Natural := Value'Length;
+
+ begin
+ Word (1 .. Len) := Value (Value'First .. Value'First + Len - 1);
+ WT.Set_Last (NK);
+ WT.Table (NK) := Word;
+ NK := NK + 1;
+ NV := Natural (Float (NK) * K2V);
+
+ if MKL < Len then
+ MKL := Len;
+ end if;
+ end Insert;
+
+ --------------
+ -- New_Line --
+ --------------
+
+ procedure New_Line (F : File_Descriptor) is
+ EOL : constant Character := ASCII.LF;
+
+ begin
+ if Write (F, EOL'Address, 1) /= 1 then
+ raise Program_Error;
+ end if;
+ end New_Line;
+
+ ------------------------------
+ -- Parse_Position_Selection --
+ ------------------------------
+
+ procedure Parse_Position_Selection (Argument : String) is
+ N : Natural := Argument'First;
+ L : constant Natural := Argument'Last;
+ M : constant Natural := MKL;
+
+ T : array (1 .. M) of Boolean := (others => False);
+
+ function Parse_Index return Natural;
+ -- Parse argument starting at index N to find an index
+
+ -----------------
+ -- Parse_Index --
+ -----------------
+
+ function Parse_Index return Natural
+ is
+ C : Character := Argument (N);
+ V : Natural := 0;
+
+ begin
+ if C = '$' then
+ N := N + 1;
+ return M;
+ end if;
+
+ if C not in '0' .. '9' then
+ Raise_Exception
+ (Program_Error'Identity, "cannot read position argument");
+ end if;
+
+ while C in '0' .. '9' loop
+ V := V * 10 + (Character'Pos (C) - Character'Pos ('0'));
+ N := N + 1;
+ exit when L < N;
+ C := Argument (N);
+ end loop;
+
+ return V;
+ end Parse_Index;
+
+ -- Start of processing for Parse_Position_Selection
+
+ begin
+ Char_Pos_Set_Len := 2 * NK;
+
+ -- Empty specification means all the positions
+
+ if L < N then
+ Char_Pos_Set_Len := M;
+ Char_Pos_Set := Allocate (Char_Pos_Set_Len, Char_Pos_Size);
+
+ for C in 0 .. Char_Pos_Set_Len - 1 loop
+ Set_Char_Pos (C, C + 1);
+ end loop;
+
+ else
+ loop
+ declare
+ First, Last : Natural;
+
+ begin
+ First := Parse_Index;
+ Last := First;
+
+ -- Detect a range
+
+ if N <= L and then Argument (N) = '-' then
+ N := N + 1;
+ Last := Parse_Index;
+ end if;
+
+ -- Include the positions in the selection
+
+ for J in First .. Last loop
+ T (J) := True;
+ end loop;
+ end;
+
+ exit when L < N;
+
+ if Argument (N) /= ',' then
+ Raise_Exception
+ (Program_Error'Identity, "cannot read position argument");
+ end if;
+
+ N := N + 1;
+ end loop;
+
+ -- Compute position selection length
+
+ N := 0;
+ for J in T'Range loop
+ if T (J) then
+ N := N + 1;
+ end if;
+ end loop;
+
+ -- Fill position selection
+
+ Char_Pos_Set_Len := N;
+ Char_Pos_Set := Allocate (Char_Pos_Set_Len, Char_Pos_Size);
+
+ N := 0;
+ for J in T'Range loop
+ if T (J) then
+ Set_Char_Pos (N, J);
+ N := N + 1;
+ end if;
+ end loop;
+ end if;
+ end Parse_Position_Selection;
+
+ -------------
+ -- Produce --
+ -------------
+
+ procedure Produce (Pkg_Name : String := Default_Pkg_Name) is
+ File : File_Descriptor;
+
+ Status : Boolean;
+ -- For call to Close;
+
+ function Type_Img (L : Natural) return String;
+ -- Return the larger unsigned type T such that T'Last < L
+
+ function Range_Img (F, L : Natural; T : String := "") return String;
+ -- Return string "[T range ]F .. L"
+
+ function Array_Img (N, T, R1 : String; R2 : String := "") return String;
+ -- Return string "N : constant array (R1[, R2]) of T;"
+
+ --------------
+ -- Type_Img --
+ --------------
+
+ function Type_Img (L : Natural) return String is
+ S : constant String := Image (Type_Size (L));
+ U : String := "Unsigned_ ";
+ N : Natural := 9;
+
+ begin
+ for J in S'Range loop
+ N := N + 1;
+ U (N) := S (J);
+ end loop;
+
+ return U (1 .. N);
+ end Type_Img;
+
+ ---------------
+ -- Range_Img --
+ ---------------
+
+ function Range_Img (F, L : Natural; T : String := "") return String is
+ FI : constant String := Image (F);
+ FL : constant Natural := FI'Length;
+ LI : constant String := Image (L);
+ LL : constant Natural := LI'Length;
+ TL : constant Natural := T'Length;
+ RI : String (1 .. TL + 7 + FL + 4 + LL);
+ Len : Natural := 0;
+
+ begin
+ if TL /= 0 then
+ RI (Len + 1 .. Len + TL) := T;
+ Len := Len + TL;
+ RI (Len + 1 .. Len + 7) := " range ";
+ Len := Len + 7;
+ end if;
+
+ RI (Len + 1 .. Len + FL) := FI;
+ Len := Len + FL;
+ RI (Len + 1 .. Len + 4) := " .. ";
+ Len := Len + 4;
+ RI (Len + 1 .. Len + LL) := LI;
+ Len := Len + LL;
+ return RI (1 .. Len);
+ end Range_Img;
+
+ ---------------
+ -- Array_Img --
+ ---------------
+
+ function Array_Img
+ (N, T, R1 : String;
+ R2 : String := "")
+ return String
+ is
+ begin
+ Last := 0;
+ Add (" ");
+ Add (N);
+ Add (" : constant array (");
+ Add (R1);
+
+ if R2 /= "" then
+ Add (", ");
+ Add (R2);
+ end if;
+
+ Add (") of ");
+ Add (T);
+ Add (" :=");
+ return Line (1 .. Last);
+ end Array_Img;
+
+ F : Natural;
+ L : Natural;
+ P : Natural;
+
+ PLen : constant Natural := Pkg_Name'Length;
+ FName : String (1 .. PLen + 4);
+
+ -- Start of processing for Produce
+
+ begin
+ FName (1 .. PLen) := Pkg_Name;
+ for J in 1 .. PLen loop
+ if FName (J) in 'A' .. 'Z' then
+ FName (J) := Character'Val (Character'Pos (FName (J))
+ - Character'Pos ('A')
+ + Character'Pos ('a'));
+
+ elsif FName (J) = '.' then
+ FName (J) := '-';
+ end if;
+ end loop;
+
+ FName (PLen + 1 .. PLen + 4) := ".ads";
+
+ File := Create_File (FName, Text);
+ Put (File, "package ");
+ Put (File, Pkg_Name);
+ Put (File, " is");
+ New_Line (File);
+ Put (File, " function Hash (S : String) return Natural;");
+ New_Line (File);
+ Put (File, "end ");
+ Put (File, Pkg_Name);
+ Put (File, ";");
+ New_Line (File);
+ Close (File, Status);
+
+ if not Status then
+ raise Device_Error;
+ end if;
+
+ FName (PLen + 4) := 'b';
+
+ File := Create_File (FName, Text);
+ Put (File, "with Interfaces; use Interfaces;");
+ New_Line (File);
+ New_Line (File);
+ Put (File, "package body ");
+ Put (File, Pkg_Name);
+ Put (File, " is");
+ New_Line (File);
+ New_Line (File);
+
+ if Opt = CPU_Time then
+ Put (File, Array_Img ("C", Type_Img (256), "Character"));
+ New_Line (File);
+
+ F := Character'Pos (Character'First);
+ L := Character'Pos (Character'Last);
+
+ for J in Character'Range loop
+ P := Get_Used_Char (J);
+ Put (File, Image (P), 0, 0, 0, F, L, Character'Pos (J));
+ end loop;
+
+ New_Line (File);
+ end if;
+
+ F := 0;
+ L := Char_Pos_Set_Len - 1;
+
+ Put (File, Array_Img ("P", "Natural", Range_Img (F, L)));
+ New_Line (File);
+
+ for J in F .. L loop
+ Put (File, Image (Get_Char_Pos (J)), 0, 0, 0, F, L, J);
+ end loop;
+
+ New_Line (File);
+
+ if Opt = CPU_Time then
+ Put_Int_Matrix
+ (File,
+ Array_Img ("T1", Type_Img (NV),
+ Range_Img (0, Rand_Tab_Len_1 - 1),
+ Range_Img (0, Rand_Tab_Len_2 - 1,
+ Type_Img (256))),
+ T1);
+
+ else
+ Put_Int_Matrix
+ (File,
+ Array_Img ("T1", Type_Img (NV),
+ Range_Img (0, Rand_Tab_Len_1 - 1)),
+ T1);
+ end if;
+
+ New_Line (File);
+
+ if Opt = CPU_Time then
+ Put_Int_Matrix
+ (File,
+ Array_Img ("T2", Type_Img (NV),
+ Range_Img (0, Rand_Tab_Len_1 - 1),
+ Range_Img (0, Rand_Tab_Len_2 - 1,
+ Type_Img (256))),
+ T2);
+
+ else
+ Put_Int_Matrix
+ (File,
+ Array_Img ("T2", Type_Img (NV),
+ Range_Img (0, Rand_Tab_Len_1 - 1)),
+ T2);
+ end if;
+
+ New_Line (File);
+
+ Put_Int_Vector
+ (File,
+ Array_Img ("G", Type_Img (NK),
+ Range_Img (0, Graph_Len - 1)),
+ G, Graph_Len);
+ New_Line (File);
+
+ Put (File, " function Hash (S : String) return Natural is");
+ New_Line (File);
+ Put (File, " F : constant Natural := S'First - 1;");
+ New_Line (File);
+ Put (File, " L : constant Natural := S'Length;");
+ New_Line (File);
+ Put (File, " F1, F2 : Natural := 0;");
+ New_Line (File);
+
+ Put (File, " J : ");
+
+ if Opt = CPU_Time then
+ Put (File, Type_Img (256));
+ else
+ Put (File, "Natural");
+ end if;
+
+ Put (File, ";");
+ New_Line (File);
+
+ Put (File, " begin");
+ New_Line (File);
+ Put (File, " for K in P'Range loop");
+ New_Line (File);
+ Put (File, " exit when L < P (K);");
+ New_Line (File);
+ Put (File, " J := ");
+
+ if Opt = CPU_Time then
+ Put (File, "C");
+ else
+ Put (File, "Character'Pos");
+ end if;
+
+ Put (File, " (S (P (K) + F));");
+ New_Line (File);
+
+ Put (File, " F1 := (F1 + Natural (T1 (K");
+
+ if Opt = CPU_Time then
+ Put (File, ", J");
+ end if;
+
+ Put (File, "))");
+
+ if Opt = Memory_Space then
+ Put (File, " * J");
+ end if;
+
+ Put (File, ") mod ");
+ Put (File, Image (NV));
+ Put (File, ";");
+ New_Line (File);
+
+ Put (File, " F2 := (F2 + Natural (T2 (K");
+
+ if Opt = CPU_Time then
+ Put (File, ", J");
+ end if;
+
+ Put (File, "))");
+
+ if Opt = Memory_Space then
+ Put (File, " * J");
+ end if;
+
+ Put (File, ") mod ");
+ Put (File, Image (NV));
+ Put (File, ";");
+ New_Line (File);
+
+ Put (File, " end loop;");
+ New_Line (File);
+
+ Put (File,
+ " return (Natural (G (F1)) + Natural (G (F2))) mod ");
+
+ Put (File, Image (NK));
+ Put (File, ";");
+ New_Line (File);
+ Put (File, " end Hash;");
+ New_Line (File);
+ New_Line (File);
+ Put (File, "end ");
+ Put (File, Pkg_Name);
+ Put (File, ";");
+ New_Line (File);
+ Close (File, Status);
+
+ if not Status then
+ raise Device_Error;
+ end if;
+ end Produce;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put (F : File_Descriptor; S : String) is
+ Len : constant Natural := S'Length;
+
+ begin
+ if Write (F, S'Address, Len) /= Len then
+ raise Program_Error;
+ end if;
+ end Put;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (F : File_Descriptor;
+ S : String;
+ F1 : Natural;
+ L1 : Natural;
+ C1 : Natural;
+ F2 : Natural;
+ L2 : Natural;
+ C2 : Natural)
+ is
+ Len : constant Natural := S'Length;
+
+ procedure Flush;
+
+ -----------
+ -- Flush --
+ -----------
+
+ procedure Flush is
+ begin
+ Put (F, Line (1 .. Last));
+ New_Line (F);
+ Last := 0;
+ end Flush;
+
+ -- Start of processing for Put
+
+ begin
+ if C1 = F1 and then C2 = F2 then
+ Last := 0;
+ end if;
+
+ if Last + Len + 3 > Max then
+ Flush;
+ end if;
+
+ if Last = 0 then
+ Line (Last + 1 .. Last + 5) := " ";
+ Last := Last + 5;
+
+ if F1 /= L1 then
+ if C1 = F1 and then C2 = F2 then
+ Add ('(');
+ else
+ Add (' ');
+ end if;
+ end if;
+ end if;
+
+ if C2 = F2 then
+ Add ('(');
+ else
+ Add (' ');
+ end if;
+
+ Line (Last + 1 .. Last + Len) := S;
+ Last := Last + Len;
+
+ if C2 = L2 then
+ Add (')');
+
+ if F1 = L1 then
+ Add (';');
+ Flush;
+ elsif C1 /= L1 then
+ Add (',');
+ Flush;
+ else
+ Add (')');
+ Add (';');
+ Flush;
+ end if;
+
+ else
+ Add (',');
+ end if;
+ end Put;
+
+ -----------------------
+ -- Put_Used_Char_Set --
+ -----------------------
+
+ procedure Put_Used_Char_Set
+ (File : File_Descriptor;
+ Title : String)
+ is
+ F : constant Natural := Character'Pos (Character'First);
+ L : constant Natural := Character'Pos (Character'Last);
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in Character'Range loop
+ Put
+ (File, Image (Get_Used_Char (J)), 0, 0, 0, F, L, Character'Pos (J));
+ end loop;
+ end Put_Used_Char_Set;
+
+ ----------
+ -- Put --
+ ----------
+
+ procedure Put_Int_Matrix
+ (File : File_Descriptor;
+ Title : String;
+ Table : Integer)
+ is
+ F1 : constant Natural := 0;
+ L1 : constant Natural := Rand_Tab_Len_1 - 1;
+ F2 : constant Natural := 0;
+ L2 : constant Natural := Rand_Tab_Len_2 - 1;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ if L2 = F2 then
+ for J in F1 .. L1 loop
+ Put (File,
+ Image (Get_Rand_Tab (Table, J, F2)), 0, 0, 0, F1, L1, J);
+ end loop;
+
+ else
+ for J in F1 .. L1 loop
+ for K in F2 .. L2 loop
+ Put (File,
+ Image (Get_Rand_Tab (Table, J, K)), F1, L1, J, F2, L2, K);
+ end loop;
+ end loop;
+ end if;
+ end Put_Int_Matrix;
+
+ --------------------
+ -- Put_Int_Vector --
+ --------------------
+
+ procedure Put_Int_Vector
+ (File : File_Descriptor;
+ Title : String;
+ Root : Integer;
+ Length : Natural)
+ is
+ F2 : constant Natural := 0;
+ L2 : constant Natural := Length - 1;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in F2 .. L2 loop
+ Put (File, Image (IT.Table (Root + J)), 0, 0, 0, F2, L2, J);
+ end loop;
+ end Put_Int_Vector;
+
+ ---------------
+ -- Put_Edges --
+ ---------------
+
+ procedure Put_Edges
+ (File : File_Descriptor;
+ Title : String)
+ is
+ E : Edge_Type;
+ F1 : constant Natural := 1;
+ L1 : constant Natural := Edges_Len - 1;
+ M : constant Natural := Max / 5;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ -- Edges valid range is 1 .. Edge_Len - 1
+
+ for J in F1 .. L1 loop
+ E := Get_Edges (J);
+ Put (File, Image (J, M), F1, L1, J, 1, 4, 1);
+ Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2);
+ Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3);
+ Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4);
+ end loop;
+ end Put_Edges;
+
+ ---------------------------
+ -- Put_Initial_Keys --
+ ---------------------------
+
+ procedure Put_Initial_Keys
+ (File : File_Descriptor;
+ Title : String)
+ is
+ F1 : constant Natural := 0;
+ L1 : constant Natural := NK - 1;
+ M : constant Natural := Max / 5;
+ K : Key_Type;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in F1 .. L1 loop
+ K := Get_Key (J);
+ Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
+ Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
+ Put (File, WT.Table (Initial (J)), F1, L1, J, 1, 3, 3);
+ end loop;
+ end Put_Initial_Keys;
+
+ ---------------------------
+ -- Put_Reduced_Keys --
+ ---------------------------
+
+ procedure Put_Reduced_Keys
+ (File : File_Descriptor;
+ Title : String)
+ is
+ F1 : constant Natural := 0;
+ L1 : constant Natural := NK - 1;
+ M : constant Natural := Max / 5;
+ K : Key_Type;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in F1 .. L1 loop
+ K := Get_Key (J);
+ Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
+ Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2);
+ Put (File, WT.Table (Reduced (J)), F1, L1, J, 1, 3, 3);
+ end loop;
+ end Put_Reduced_Keys;
+
+ ----------------------
+ -- Put_Vertex_Table --
+ ----------------------
+
+ procedure Put_Vertex_Table
+ (File : File_Descriptor;
+ Title : String)
+ is
+ F1 : constant Natural := 0;
+ L1 : constant Natural := NV - 1;
+ M : constant Natural := Max / 4;
+ V : Vertex_Type;
+
+ begin
+ Put (File, Title);
+ New_Line (File);
+
+ for J in F1 .. L1 loop
+ V := Get_Vertices (J);
+ Put (File, Image (J, M), F1, L1, J, 1, 3, 1);
+ Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2);
+ Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3);
+ end loop;
+ end Put_Vertex_Table;
+
+ ------------
+ -- Random --
+ ------------
+
+ procedure Random (Seed : in out Natural)
+ is
+ -- Park & Miller Standard Minimal using Schrage's algorithm to
+ -- avoid overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1)
+
+ R : Natural;
+ Q : Natural;
+ X : Integer;
+
+ begin
+ R := Seed mod 127773;
+ Q := Seed / 127773;
+ X := 16807 * R - 2836 * Q;
+
+ if X < 0 then
+ Seed := X + 2147483647;
+ else
+ Seed := X;
+ end if;
+ end Random;
+
+ -------------
+ -- Reduced --
+ -------------
+
+ function Reduced (K : Key_Id) return Word_Id is
+ begin
+ return K + NK;
+ end Reduced;
+
+ --------------------------
+ -- Select_Character_Set --
+ --------------------------
+
+ procedure Select_Character_Set
+ is
+ Last : Natural := 0;
+ Used : array (Character) of Boolean := (others => False);
+
+ begin
+ for J in 0 .. NK - 1 loop
+ for K in 1 .. Max_Word_Length loop
+ exit when WT.Table (Initial (J))(K) = ASCII.NUL;
+ Used (WT.Table (Initial (J))(K)) := True;
+ end loop;
+ end loop;
+
+ Used_Char_Set_Len := 256;
+ Used_Char_Set := Allocate (Used_Char_Set_Len, Used_Char_Size);
+
+ for J in Used'Range loop
+ if Used (J) then
+ Set_Used_Char (J, Last);
+ Last := Last + 1;
+ else
+ Set_Used_Char (J, 0);
+ end if;
+ end loop;
+ end Select_Character_Set;
+
+ --------------------------
+ -- Select_Char_Position --
+ --------------------------
+
+ procedure Select_Char_Position is
+
+ type Vertex_Table_Type is array (Natural range <>) of Vertex_Type;
+
+ procedure Build_Identical_Keys_Sets
+ (Table : in out Vertex_Table_Type;
+ Last : in out Natural;
+ Pos : in Natural);
+ -- Build a list of keys subsets that are identical with the
+ -- current position selection plus Pos. Once this routine is
+ -- called, reduced words are sorted by subsets and each item
+ -- (First, Last) in Sets defines the range of identical keys.
+
+ function Count_Identical_Keys
+ (Table : Vertex_Table_Type;
+ Last : Natural;
+ Pos : Natural)
+ return Natural;
+ -- For each subset in Sets, count the number of identical keys
+ -- if we add Pos to the current position selection.
+
+ Sel_Position : IT.Table_Type (1 .. MKL);
+ Last_Sel_Pos : Natural := 0;
+
+ -------------------------------
+ -- Build_Identical_Keys_Sets --
+ -------------------------------
+
+ procedure Build_Identical_Keys_Sets
+ (Table : in out Vertex_Table_Type;
+ Last : in out Natural;
+ Pos : in Natural)
+ is
+ S : constant Vertex_Table_Type := Table (1 .. Last);
+ C : constant Natural := Pos;
+ -- Shortcuts
+
+ F : Integer;
+ L : Integer;
+ -- First and last words of a subset
+
+ begin
+ Last := 0;
+
+ -- For each subset in S, extract the new subsets we have by
+ -- adding C in the position selection.
+
+ for J in S'Range loop
+ declare
+ Offset : Natural;
+ -- GNAT.Heap_Sort assumes that the first array index
+ -- is 1. Offset defines the translation to operate.
+
+ procedure Move (From : Natural; To : Natural);
+ function Lt (L, R : Natural) return Boolean;
+ -- Subprograms needed by GNAT.Heap_Sort_A
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ Target, Source : Natural;
+
+ begin
+ if From = 0 then
+ Source := 0;
+ Target := Offset + To;
+ elsif To = 0 then
+ Source := Offset + From;
+ Target := 0;
+ else
+ Source := Offset + From;
+ Target := Offset + To;
+ end if;
+
+ WT.Table (Reduced (Target)) := WT.Table (Reduced (Source));
+ end Move;
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (L, R : Natural) return Boolean is
+ C : constant Natural := Pos;
+ Left : Natural;
+ Right : Natural;
+
+ begin
+ if L = 0 then
+ Left := 0;
+ Right := Offset + R;
+ elsif R = 0 then
+ Left := Offset + L;
+ Right := 0;
+ else
+ Left := Offset + L;
+ Right := Offset + R;
+ end if;
+
+ return WT.Table (Reduced (Left))(C)
+ < WT.Table (Reduced (Right))(C);
+ end Lt;
+
+ -- Start of processing for Build_Identical_Key_Sets
+
+ begin
+ Offset := S (J).First - 1;
+ Sort
+ (S (J).Last - S (J).First + 1,
+ Move'Unrestricted_Access,
+ Lt'Unrestricted_Access);
+
+ F := -1;
+ L := -1;
+ for N in S (J).First .. S (J).Last - 1 loop
+
+ -- Two contiguous words are identical
+
+ if WT.Table (Reduced (N))(C) =
+ WT.Table (Reduced (N + 1))(C)
+ then
+ -- This is the first word of the subset
+
+ if F = -1 then
+ F := N;
+ end if;
+
+ L := N + 1;
+
+ -- This is the last word of the subset
+
+ elsif F /= -1 then
+ Last := Last + 1;
+ Table (Last) := (F, L);
+ F := -1;
+ end if;
+ end loop;
+
+ -- This is the last word of the subset and of the set
+
+ if F /= -1 then
+ Last := Last + 1;
+ Table (Last) := (F, L);
+ end if;
+ end;
+ end loop;
+ end Build_Identical_Keys_Sets;
+
+ --------------------------
+ -- Count_Identical_Keys --
+ --------------------------
+
+ function Count_Identical_Keys
+ (Table : Vertex_Table_Type;
+ Last : Natural;
+ Pos : Natural)
+ return Natural
+ is
+ N : array (Character) of Natural;
+ C : Character;
+ T : Natural := 0;
+
+ begin
+ -- For each subset, count the number of words that are still
+ -- identical when we include Sel_Position (Last_Sel_Pos) in
+ -- the position selection. Only focus on this position as the
+ -- other positions already produce identical keys.
+
+ for S in 1 .. Last loop
+
+ -- Count the occurrences of the different characters
+
+ N := (others => 0);
+ for K in Table (S).First .. Table (S).Last loop
+ C := WT.Table (Reduced (K))(Pos);
+ N (C) := N (C) + 1;
+ end loop;
+
+ -- Add to the total when there are two identical keys
+
+ for J in N'Range loop
+ if N (J) > 1 then
+ T := T + N (J);
+ end if;
+ end loop;
+ end loop;
+
+ return T;
+ end Count_Identical_Keys;
+
+ -- Start of processing for Select_Char_Position
+
+ begin
+ for C in Sel_Position'Range loop
+ Sel_Position (C) := C;
+ end loop;
+
+ -- Initialization of Words
+
+ WT.Set_Last (2 * NK - 1);
+
+ for K in 0 .. NK - 1 loop
+ WT.Table (Reduced (K) + 1) := WT.Table (Initial (K));
+ end loop;
+
+ declare
+ Collisions : Natural;
+ Min_Collisions : Natural := NK;
+ Old_Collisions : Natural;
+ Min_Coll_Sel_Pos : Natural := 0; -- init to kill warning
+ Min_Coll_Sel_Pos_Idx : Natural := 0; -- init to kill warning
+ Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK);
+ Same_Keys_Sets_Last : Natural := 1;
+
+ begin
+ Same_Keys_Sets_Table (1) := (1, NK);
+
+ loop
+ -- Preserve minimum identical keys and check later on
+ -- that this value is strictly decrementing. Otherwise,
+ -- it means that two keys are stricly identical.
+
+ Old_Collisions := Min_Collisions;
+
+ -- Find which position reduces the most of collisions
+
+ for J in Last_Sel_Pos + 1 .. Sel_Position'Last loop
+ Collisions := Count_Identical_Keys
+ (Same_Keys_Sets_Table,
+ Same_Keys_Sets_Last,
+ Sel_Position (J));
+
+ if Collisions < Min_Collisions then
+ Min_Collisions := Collisions;
+ Min_Coll_Sel_Pos := Sel_Position (J);
+ Min_Coll_Sel_Pos_Idx := J;
+ end if;
+ end loop;
+
+ if Old_Collisions = Min_Collisions then
+ Raise_Exception
+ (Program_Error'Identity, "some keys are identical");
+ end if;
+
+ -- Insert selected position and sort Sel_Position table
+
+ Last_Sel_Pos := Last_Sel_Pos + 1;
+ Sel_Position (Last_Sel_Pos + 1 .. Min_Coll_Sel_Pos_Idx) :=
+ Sel_Position (Last_Sel_Pos .. Min_Coll_Sel_Pos_Idx - 1);
+ Sel_Position (Last_Sel_Pos) := Min_Coll_Sel_Pos;
+
+ for P in 1 .. Last_Sel_Pos - 1 loop
+ if Min_Coll_Sel_Pos < Sel_Position (P) then
+ Sel_Position (P + 1 .. Last_Sel_Pos) :=
+ Sel_Position (P .. Last_Sel_Pos - 1);
+ Sel_Position (P) := Min_Coll_Sel_Pos;
+ exit;
+ end if;
+ end loop;
+
+ exit when Min_Collisions = 0;
+
+ Build_Identical_Keys_Sets
+ (Same_Keys_Sets_Table,
+ Same_Keys_Sets_Last,
+ Min_Coll_Sel_Pos);
+ end loop;
+ end;
+
+ Char_Pos_Set_Len := Last_Sel_Pos;
+ Char_Pos_Set := Allocate (Char_Pos_Set_Len, Char_Pos_Size);
+
+ for C in 1 .. Last_Sel_Pos loop
+ Set_Char_Pos (C - 1, Sel_Position (C));
+ end loop;
+ end Select_Char_Position;
+
+ ------------------
+ -- Set_Char_Pos --
+ ------------------
+
+ procedure Set_Char_Pos (P : Natural; Item : Natural) is
+ N : constant Natural := Char_Pos_Set + P;
+
+ begin
+ IT.Table (N) := Item;
+ end Set_Char_Pos;
+
+ ---------------
+ -- Set_Edges --
+ ---------------
+
+ procedure Set_Edges (F : Natural; Item : Edge_Type) is
+ N : constant Natural := Edges + (F * Edge_Size);
+
+ begin
+ IT.Table (N) := Item.X;
+ IT.Table (N + 1) := Item.Y;
+ IT.Table (N + 2) := Item.Key;
+ end Set_Edges;
+
+ ---------------
+ -- Set_Graph --
+ ---------------
+
+ procedure Set_Graph (F : Natural; Item : Integer) is
+ N : constant Natural := G + (F * Graph_Item_Size);
+
+ begin
+ IT.Table (N) := Item;
+ end Set_Graph;
+
+ -------------
+ -- Set_Key --
+ -------------
+
+ procedure Set_Key (F : Key_Id; Item : Key_Type) is
+ N : constant Natural := Keys + F * Key_Size;
+
+ begin
+ IT.Table (N) := Item.Edge;
+ end Set_Key;
+
+ ------------------
+ -- Set_Rand_Tab --
+ ------------------
+
+ procedure Set_Rand_Tab (T : Integer; X, Y : Natural; Item : Natural) is
+ N : constant Natural :=
+ T + ((Y * Rand_Tab_Len_1) + X) * Rand_Tab_Item_Size;
+
+ begin
+ IT.Table (N) := Item;
+ end Set_Rand_Tab;
+
+ -------------------
+ -- Set_Used_Char --
+ -------------------
+
+ procedure Set_Used_Char (C : Character; Item : Natural) is
+ N : constant Natural :=
+ Used_Char_Set + Character'Pos (C) * Used_Char_Size;
+
+ begin
+ IT.Table (N) := Item;
+ end Set_Used_Char;
+
+ ------------------
+ -- Set_Vertices --
+ ------------------
+
+ procedure Set_Vertices (F : Natural; Item : Vertex_Type) is
+ N : constant Natural := Vertices + (F * Vertex_Size);
+
+ begin
+ IT.Table (N) := Item.First;
+ IT.Table (N + 1) := Item.Last;
+ end Set_Vertices;
+
+ ---------
+ -- Sum --
+ ---------
+
+ function Sum
+ (Word : Word_Type;
+ Table : Table_Id;
+ Opt : Optimization)
+ return Natural
+ is
+ S : Natural := 0;
+ R : Natural;
+
+ begin
+ if Opt = CPU_Time then
+ for J in 0 .. Rand_Tab_Len_1 - 1 loop
+ exit when Word (J + 1) = ASCII.NUL;
+ R := Get_Rand_Tab (Table, J, Get_Used_Char (Word (J + 1)));
+ S := (S + R) mod NV;
+ end loop;
+
+ else
+ for J in 0 .. Rand_Tab_Len_1 - 1 loop
+ exit when Word (J + 1) = ASCII.NUL;
+ R := Get_Rand_Tab (Table, J, 0);
+ S := (S + R * Character'Pos (Word (J + 1))) mod NV;
+ end loop;
+ end if;
+
+ return S;
+ end Sum;
+
+ ---------------
+ -- Type_Size --
+ ---------------
+
+ function Type_Size (L : Natural) return Natural is
+ begin
+ if L <= 2 ** 8 then
+ return 8;
+ elsif L <= 2 ** 16 then
+ return 16;
+ else
+ return 32;
+ end if;
+ end Type_Size;
+
+ -----------
+ -- Value --
+ -----------
+
+ function Value
+ (Name : Table_Name;
+ J : Natural;
+ K : Natural := 0)
+ return Natural
+ is
+ begin
+ case Name is
+ when Character_Position =>
+ return Get_Char_Pos (J);
+
+ when Used_Character_Set =>
+ return Get_Used_Char (Character'Val (J));
+
+ when Function_Table_1 =>
+ return Get_Rand_Tab (T1, J, K);
+
+ when Function_Table_2 =>
+ return Get_Rand_Tab (T2, J, K);
+
+ when Graph_Table =>
+ return Get_Graph (J);
+
+ end case;
+ end Value;
+
+end GNAT.Perfect_Hash.Generators;
diff --git a/gcc/ada/g-pehage.ads b/gcc/ada/g-pehage.ads
new file mode 100644
index 00000000000..3db2e70b71b
--- /dev/null
+++ b/gcc/ada/g-pehage.ads
@@ -0,0 +1,186 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . P E R F E C T _ H A S H . G E N E R A T O R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a single generator of static minimal perfect
+-- hash functions. No collisions occur and each item can be retrieved
+-- from the table in one probe (perfect property). The hash table
+-- size corresponds to the exact size of W and *no larger* (minimal
+-- property). The key set has to be know in advance (static
+-- property). The hash functions are also order preservering. If w2
+-- is inserted after w1 in the generator, then f (w1) < f (w2). These
+-- hashing functions are convenient for use with realtime applications.
+
+package GNAT.Perfect_Hash.Generators is
+
+ Default_K_To_V : constant Float := 2.05;
+ -- Default ratio for the algorithm. When K is the number of keys,
+ -- V = (K_To_V) * K is the size of the main table of the hash function.
+
+ Default_Pkg_Name : constant String := "Perfect_Hash";
+ -- Default package name in which the hash function is defined.
+
+ Default_Position : constant String := "";
+ -- The generator allows selection of the character positions used
+ -- in the hash function. By default, all positions are selected.
+
+ type Optimization is (Memory_Space, CPU_Time);
+ Default_Optimization : constant Optimization := CPU_Time;
+ -- Optimize either the memory space or the execution time.
+
+ Verbose : Boolean := False;
+
+ procedure Initialize
+ (Seed : Natural;
+ K_To_V : Float := Default_K_To_V;
+ Optim : Optimization := CPU_Time);
+ -- Initialize the generator and its internal structures. Set the
+ -- ratio of vertices over keys in the random graphs. This value
+ -- has to be greater than 2.0 in order for the algorithm to succeed.
+
+ procedure Finalize;
+ -- Deallocate the internal structures.
+
+ procedure Insert (Value : String);
+ -- Insert a new key in the table.
+
+ procedure Compute (Position : String := Default_Position);
+ -- Compute the hash function. Position allows to define a
+ -- selection of character positions used in the keywords hash
+ -- function. Positions can be separated by commas and range like
+ -- x-y may be used. Character '$' represents the final character
+ -- of a key. With an empty position, the generator automatically
+ -- produces positions to reduce the memory usage.
+
+ procedure Produce (Pkg_Name : String := Default_Pkg_Name);
+ -- Generate the hash function package Pkg_Name. This package
+ -- includes the minimal perfect Hash function.
+
+ -- The routines and structures defined below allow producing the
+ -- hash function using a different way from the procedure above.
+ -- The procedure Define returns the lengths of an internal table
+ -- and its item type size. The function Value returns the value of
+ -- each item in the table.
+
+ -- The hash function has the following form:
+
+ -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m
+
+ -- G is a function based on a graph table [0,n-1] -> [0,m-1]. m is
+ -- the number of keys. n is an internally computed value and it
+ -- can be obtained as the length of vector G.
+
+ -- F1 and F2 are two functions based on two function tables T1 and
+ -- T2. Their definition depends on the chosen optimization mode.
+
+ -- Only some character positions are used in the keys because they
+ -- are significant. They are listed in a character position table
+ -- (P in the pseudo-code below). For instance, in {"jan", "feb",
+ -- "mar", "apr", "jun", "jul", "aug", "sep", "oct", "nov", "dec"},
+ -- only positions 2 and 3 are significant (the first character can
+ -- be ignored). In this example, P = {2, 3}
+
+ -- When Optimization is CPU_Time, the first dimension of T1 and T2
+ -- corresponds to the character position in the key and the second
+ -- to the character set. As all the character set is not used, we
+ -- define a used character table which associates a distinct index
+ -- to each used character (unused characters are mapped to
+ -- zero). In this case, the second dimension of T1 and T2 is
+ -- reduced to the used character set (C in the pseudo-code
+ -- below). Therefore, the hash function has the following:
+
+ -- function Hash (S : String) return Natural is
+ -- F : constant Natural := S'First - 1;
+ -- L : constant Natural := S'Length;
+ -- F1, F2 : Natural := 0;
+ -- J : <t>;
+
+ -- begin
+ -- for K in P'Range loop
+ -- exit when L < P (K);
+ -- J := C (S (P (K) + F));
+ -- F1 := (F1 + Natural (T1 (K, J))) mod <n>;
+ -- F2 := (F2 + Natural (T2 (K, J))) mod <n>;
+ -- end loop;
+
+ -- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
+ -- end Hash;
+
+ -- When Optimization is Memory_Space, the first dimension of T1
+ -- and T2 corresponds to the character position in the key and the
+ -- second dimension is ignored. T1 and T2 are no longer matrices
+ -- but vectors. Therefore, the used character table is not
+ -- available. The hash function has the following form:
+
+ -- function Hash (S : String) return Natural is
+ -- F : constant Natural := S'First - 1;
+ -- L : constant Natural := S'Length;
+ -- F1, F2 : Natural := 0;
+ -- J : <t>;
+
+ -- begin
+ -- for K in P'Range loop
+ -- exit when L < P (K);
+ -- J := Character'Pos (S (P (K) + F));
+ -- F1 := (F1 + Natural (T1 (K) * J)) mod <n>;
+ -- F2 := (F2 + Natural (T2 (K) * J)) mod <n>;
+ -- end loop;
+
+ -- return (Natural (G (F1)) + Natural (G (F2))) mod <m>;
+ -- end Hash;
+
+ type Table_Name is
+ (Character_Position,
+ Used_Character_Set,
+ Function_Table_1,
+ Function_Table_2,
+ Graph_Table);
+
+ procedure Define
+ (Name : Table_Name;
+ Item_Size : out Natural;
+ Length_1 : out Natural;
+ Length_2 : out Natural);
+ -- Return the definition of the table Name. This includes the
+ -- length of dimensions 1 and 2 and the size of an unsigned
+ -- integer item. When Length_2 is zero, the table has only one
+ -- dimension. All the ranges start from zero.
+
+ function Value
+ (Name : Table_Name;
+ J : Natural;
+ K : Natural := 0)
+ return Natural;
+ -- Return the value of the component (I, J) of the table
+ -- Name. When the table has only one dimension, J is ignored.
+
+end GNAT.Perfect_Hash.Generators;
diff --git a/gcc/ada/g-perhas.ads b/gcc/ada/g-perhas.ads
new file mode 100644
index 00000000000..92a899cf600
--- /dev/null
+++ b/gcc/ada/g-perhas.ads
@@ -0,0 +1,67 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . P E R F E C T _ H A S H --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002-2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package GNAT.Perfect_Hash is
+pragma Pure (Perfect_Hash);
+
+ -- The packages in this hierarchy implement perfect hash
+ -- functions. To understand what a perfect hash function is, we
+ -- define several notions. These definitions are inspired from the
+ -- following paper:
+ --
+ -- Zbigniew J. Czech, George Havas, and Bohdan S. Majewski ``An
+ -- Optimal Algorithm for Generating Minimal Perfect Hash Functions'',
+ -- Information Processing Letters, 43(1992) pp.257-264, Oct.1992
+ --
+ -- Let W be a set of m words. A hash function h is a function that
+ -- maps the set of words W into some given interval of integers
+ -- [0, k-1], where k is an integer, usually k >= m. h (w) where w
+ -- is a word computes an address or an integer from I for the
+ -- storage or the retrieval of that item. The storage area used to
+ -- store items is known as a hash table. Words for which the same
+ -- address is computed are called synonyms. Due to the existence
+ -- of synonyms a situation called collision may arise in which two
+ -- items w1 and w2 have the same address. Several schemes for
+ -- resolving known. A perfect hash function is an injection from
+ -- the word set W to the integer interval I with k >= m. If k = m,
+ -- then h is a minimal perfect hash function. A hash function is
+ -- order preserving if it puts entries into the hash table in a
+ -- prespecified order.
+ --
+ -- A minimal perfect hash function is defined by two properties:
+ -- * Since no collisions occur each item can be retrieved from the
+ -- table in *one* probe. This represents the "perfect" property.
+ -- * The hash table size corresponds to the exact size of W and
+ -- *no larger*. This represents the "minimal" property.
+
+end GNAT.Perfect_Hash;
diff --git a/gcc/ada/g-regexp.adb b/gcc/ada/g-regexp.adb
index 18852c362fe..ab63d731c49 100644
--- a/gcc/ada/g-regexp.adb
+++ b/gcc/ada/g-regexp.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-regexp.ads b/gcc/ada/g-regexp.ads
index 357923c982e..08ff51272a1 100644
--- a/gcc/ada/g-regexp.ads
+++ b/gcc/ada/g-regexp.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-regist.adb b/gcc/ada/g-regist.adb
index b1e963cf6dc..f63a7a97837 100644
--- a/gcc/ada/g-regist.adb
+++ b/gcc/ada/g-regist.adb
@@ -6,8 +6,7 @@
-- --
-- B o d y --
-- --
--- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -27,13 +26,14 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions;
with Interfaces.C;
with System;
+with GNAT.Directory_Operations;
package body GNAT.Registry is
@@ -60,7 +60,8 @@ package body GNAT.Registry is
ERROR_SUCCESS : constant Error_Code := 0;
- REG_SZ : constant := 1;
+ REG_SZ : constant := 1;
+ REG_EXPAND_SZ : constant := 2;
function RegCloseKey (Key : HKEY) return LONG;
pragma Import (Stdcall, RegCloseKey, "RegCloseKey");
@@ -131,6 +132,16 @@ package body GNAT.Registry is
return LONG;
pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA");
+ ---------------------
+ -- Local Constants --
+ ---------------------
+
+ Max_Key_Size : constant := 1_024;
+ -- Maximum number of characters for a registry key
+
+ Max_Value_Size : constant := 2_048;
+ -- Maximum number of characters for a key's value
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -239,17 +250,21 @@ package body GNAT.Registry is
-- For_Every_Key_Value --
-------------------------
- procedure For_Every_Key_Value (From_Key : HKEY) is
+ procedure For_Every_Key_Value
+ (From_Key : HKEY;
+ Expand : Boolean := False)
+ is
+ use GNAT.Directory_Operations;
use type LONG;
use type ULONG;
Index : ULONG := 0;
Result : LONG;
- Sub_Key : String (1 .. 100);
+ Sub_Key : String (1 .. Max_Key_Size);
pragma Warnings (Off, Sub_Key);
- Value : String (1 .. 100);
+ Value : String (1 .. Max_Value_Size);
pragma Warnings (Off, Value);
Size_Sub_Key : aliased ULONG;
@@ -274,19 +289,26 @@ package body GNAT.Registry is
exit when not (Result = ERROR_SUCCESS);
- if Type_Sub_Key = REG_SZ then
- Quit := False;
+ Quit := False;
+
+ if Type_Sub_Key = REG_EXPAND_SZ and then Expand then
+ Action (Natural (Index) + 1,
+ Sub_Key (1 .. Integer (Size_Sub_Key)),
+ Directory_Operations.Expand_Path
+ (Value (1 .. Integer (Size_Value) - 1),
+ Directory_Operations.DOS),
+ Quit);
+ elsif Type_Sub_Key = REG_SZ or else Type_Sub_Key = REG_EXPAND_SZ then
Action (Natural (Index) + 1,
Sub_Key (1 .. Integer (Size_Sub_Key)),
Value (1 .. Integer (Size_Value) - 1),
Quit);
-
- exit when Quit;
-
- Index := Index + 1;
end if;
+ exit when Quit;
+
+ Index := Index + 1;
end loop;
end For_Every_Key_Value;
@@ -353,13 +375,15 @@ package body GNAT.Registry is
function Query_Value
(From_Key : HKEY;
- Sub_Key : String)
+ Sub_Key : String;
+ Expand : Boolean := False)
return String
is
+ use GNAT.Directory_Operations;
use type LONG;
use type ULONG;
- Value : String (1 .. 100);
+ Value : String (1 .. Max_Value_Size);
pragma Warnings (Off, Value);
Size_Value : aliased ULONG;
@@ -381,7 +405,12 @@ package body GNAT.Registry is
Check_Result (Result, "Query_Value " & Sub_Key & " key");
- return Value (1 .. Integer (Size_Value - 1));
+ if Type_Value = REG_EXPAND_SZ and then Expand then
+ return Directory_Operations.Expand_Path
+ (Value (1 .. Integer (Size_Value - 1)), Directory_Operations.DOS);
+ else
+ return Value (1 .. Integer (Size_Value - 1));
+ end if;
end Query_Value;
---------------
diff --git a/gcc/ada/g-regist.ads b/gcc/ada/g-regist.ads
index a41686dc73e..3cbfebb546f 100644
--- a/gcc/ada/g-regist.ads
+++ b/gcc/ada/g-regist.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -26,7 +26,7 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -88,9 +88,15 @@ package GNAT.Registry is
function Key_Exists (From_Key : HKEY; Sub_Key : String) return Boolean;
-- Returns True if Sub_Key is defined under From_Key in the registry.
- function Query_Value (From_Key : HKEY; Sub_Key : String) return String;
+ function Query_Value
+ (From_Key : HKEY;
+ Sub_Key : String;
+ Expand : Boolean := False)
+ return String;
-- Returns the registry key's value associated with Sub_Key in From_Key
- -- registry key.
+ -- registry key. If Expand is set to True and the Sub_Key is a
+ -- REG_EXPAND_SZ the returned value will have the %name% variables
+ -- replaced by the corresponding environment variable value.
procedure Set_Value (From_Key : HKEY; Sub_Key : String; Value : String);
-- Add the pair (Sub_Key, Value) into From_Key registry key.
@@ -107,15 +113,18 @@ package GNAT.Registry is
Sub_Key : String;
Value : String;
Quit : in out Boolean);
- procedure For_Every_Key_Value (From_Key : HKEY);
+ procedure For_Every_Key_Value (From_Key : HKEY; Expand : Boolean := False);
-- Iterates over all the pairs (Sub_Key, Value) registered under
-- From_Key. Index will be set to 1 for the first key and will be
-- incremented by one in each iteration. Quit can be set to True to
-- stop iteration; its initial value is False.
--
- -- Key value that are not of type string are skipped. In this case, the
- -- iterator behaves exactly as if the key was not present. Note that you
- -- must use the Win32.Winreg API to deal with this case.
+ -- Key value that are not of type string (i.e. not REG_SZ / REG_EXPAND_SZ)
+ -- are skipped. In this case, the iterator behaves exactly as if the key
+ -- were not present. Note that you must use the Win32.Winreg API to deal
+ -- with this case. Furthermore, if Expand is set to True and the Sub_Key
+ -- is a REG_EXPAND_SZ the returned value will have the %name% variables
+ -- replaced by the corresponding environment variable value.
private
diff --git a/gcc/ada/g-regpat.adb b/gcc/ada/g-regpat.adb
index 1949a8a5540..4ad6efbf944 100644
--- a/gcc/ada/g-regpat.adb
+++ b/gcc/ada/g-regpat.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1986 by University of Toronto. --
--- Copyright (C) 1996-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 1996-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -240,7 +241,7 @@ package body GNAT.Regpat is
return Boolean;
-- Return True if the entry is set for C in the class Bitmap.
- procedure Reset_Class (Bitmap : in out Character_Class);
+ procedure Reset_Class (Bitmap : out Character_Class);
-- Clear all the entries in the class Bitmap.
pragma Inline (Set_In_Class);
@@ -256,7 +257,7 @@ package body GNAT.Regpat is
function Is_Alnum (C : Character) return Boolean;
-- Return True if C is an alphanum character or an underscore ('_')
- function Is_Space (C : Character) return Boolean;
+ function Is_White_Space (C : Character) return Boolean;
-- Return True if C is a whitespace character
function Is_Printable (C : Character) return Boolean;
@@ -305,7 +306,7 @@ package body GNAT.Regpat is
pragma Inline ("=");
pragma Inline (Is_Alnum);
- pragma Inline (Is_Space);
+ pragma Inline (Is_White_Space);
pragma Inline (Get_Next);
pragma Inline (Get_Next_Offset);
pragma Inline (Operand);
@@ -377,20 +378,19 @@ package body GNAT.Regpat is
Emit_Ptr : Pointer := Program_First;
Parse_Pos : Natural := Expression'First; -- Input-scan pointer
- Parse_End : Natural := Expression'Last;
+ Parse_End : constant Natural := Expression'Last;
----------------------------
-- Subprograms for Create --
----------------------------
procedure Emit (B : Character);
- -- Output the Character to the Program.
- -- If code-generation is disables, simply increments the program
- -- counter.
+ -- Output the Character B to the Program. If code-generation is
+ -- disabled, simply increments the program counter.
function Emit_Node (Op : Opcode) return Pointer;
-- If code-generation is enabled, Emit_Node outputs the
- -- opcode and reserves space for a pointer to the next node.
+ -- opcode Op and reserves space for a pointer to the next node.
-- Return value is the location of new opcode, ie old Emit_Ptr.
procedure Emit_Natural (IP : Pointer; N : Natural);
@@ -405,24 +405,26 @@ package body GNAT.Regpat is
procedure Parse
(Parenthesized : Boolean;
- Flags : in out Expression_Flags;
+ Flags : out Expression_Flags;
IP : out Pointer);
-- Parse regular expression, i.e. main body or parenthesized thing
-- Caller must absorb opening parenthesis.
procedure Parse_Branch
- (Flags : in out Expression_Flags;
+ (Flags : out Expression_Flags;
First : Boolean;
IP : out Pointer);
-- Implements the concatenation operator and handles '|'
-- First should be true if this is the first item of the alternative.
procedure Parse_Piece
- (Expr_Flags : in out Expression_Flags; IP : out Pointer);
+ (Expr_Flags : out Expression_Flags;
+ IP : out Pointer);
-- Parse something followed by possible [*+?]
procedure Parse_Atom
- (Expr_Flags : in out Expression_Flags; IP : out Pointer);
+ (Expr_Flags : out Expression_Flags;
+ IP : out Pointer);
-- Parse_Atom is the lowest level parse procedure.
-- Optimization: gobbles an entire sequence of ordinary characters
-- so that it can turn them into a single node, which is smaller to
@@ -475,15 +477,16 @@ package body GNAT.Regpat is
Greedy : out Boolean);
-- Parse the argument list for a curly operator.
-- It is assumed that IP is indeed pointing at a valid operator.
+ -- So what is IP and how come IP is not referenced in the body ???
procedure Parse_Character_Class (IP : out Pointer);
-- Parse a character class.
-- The calling subprogram should consume the opening '[' before.
- procedure Parse_Literal (Expr_Flags : in out Expression_Flags;
- IP : out Pointer);
- -- Parse_Literal encodes a string of characters
- -- to be matched exactly.
+ procedure Parse_Literal
+ (Expr_Flags : out Expression_Flags;
+ IP : out Pointer);
+ -- Parse_Literal encodes a string of characters to be matched exactly
function Parse_Posix_Character_Class return Std_Class;
-- Parse a posic character class, like [:alpha:] or [:^alpha:].
@@ -589,7 +592,7 @@ package body GNAT.Regpat is
Max : out Natural;
Greedy : out Boolean)
is
- pragma Warnings (Off, IP);
+ pragma Unreferenced (IP);
Save_Pos : Natural := Parse_Pos + 1;
@@ -701,8 +704,8 @@ package body GNAT.Regpat is
-- the operator before it.
if Emit_Code then
- Program (Operand + Size .. Emit_Ptr + Size)
- := Program (Operand .. Emit_Ptr);
+ Program (Operand + Size .. Emit_Ptr + Size) :=
+ Program (Operand .. Emit_Ptr);
end if;
-- Insert the operator at the position previously occupied by the
@@ -848,7 +851,7 @@ package body GNAT.Regpat is
procedure Parse
(Parenthesized : in Boolean;
- Flags : in out Expression_Flags;
+ Flags : out Expression_Flags;
IP : out Pointer)
is
E : String renames Expression;
@@ -972,7 +975,7 @@ package body GNAT.Regpat is
----------------
procedure Parse_Atom
- (Expr_Flags : in out Expression_Flags;
+ (Expr_Flags : out Expression_Flags;
IP : out Pointer)
is
C : Character;
@@ -1039,8 +1042,15 @@ package body GNAT.Regpat is
when '|' | ASCII.LF | ')' =>
Fail ("internal urp"); -- Supposed to be caught earlier
- when '?' | '+' | '*' | '{' =>
- Fail ("?+*{ follows nothing");
+ when '?' | '+' | '*' =>
+ Fail (C & " follows nothing");
+
+ when '{' =>
+ if Is_Curly_Operator (Parse_Pos - 1) then
+ Fail (C & " follows nothing");
+ else
+ Parse_Literal (Expr_Flags, IP);
+ end if;
when '\' =>
if Parse_Pos > Parse_End then
@@ -1096,7 +1106,7 @@ package body GNAT.Regpat is
IP := Emit_Node (REFF);
declare
- Save : Natural := Parse_Pos - 1;
+ Save : constant Natural := Parse_Pos - 1;
begin
while Parse_Pos <= Expression'Last
@@ -1124,7 +1134,7 @@ package body GNAT.Regpat is
------------------
procedure Parse_Branch
- (Flags : in out Expression_Flags;
+ (Flags : out Expression_Flags;
First : Boolean;
IP : out Pointer)
is
@@ -1132,7 +1142,9 @@ package body GNAT.Regpat is
Chain : Pointer;
Last : Pointer;
New_Flags : Expression_Flags;
- Dummy : Pointer;
+
+ Discard : Pointer;
+ pragma Warnings (Off, Discard);
begin
Flags := Worst_Expression; -- Tentatively
@@ -1168,10 +1180,11 @@ package body GNAT.Regpat is
Chain := Last;
end loop;
- if Chain = 0 then -- Loop ran zero CURLY
- Dummy := Emit_Node (NOTHING);
- end if;
+ -- Case where loop ran zero CURLY
+ if Chain = 0 then
+ Discard := Emit_Node (NOTHING);
+ end if;
end Parse_Branch;
---------------------------
@@ -1283,14 +1296,14 @@ package body GNAT.Regpat is
when ANYOF_SPACE =>
for Value in Class_Byte'Range loop
- if Is_Space (Character'Val (Value)) then
+ if Is_White_Space (Character'Val (Value)) then
Set_In_Class (Bitmap, Character'Val (Value));
end if;
end loop;
when ANYOF_NSPACE =>
for Value in Class_Byte'Range loop
- if not Is_Space (Character'Val (Value)) then
+ if not Is_White_Space (Character'Val (Value)) then
Set_In_Class (Bitmap, Character'Val (Value));
end if;
end loop;
@@ -1392,7 +1405,7 @@ package body GNAT.Regpat is
when ANYOF_PUNCT =>
for Value in Class_Byte'Range loop
if Is_Printable (Character'Val (Value))
- and then not Is_Space (Character'Val (Value))
+ and then not Is_White_Space (Character'Val (Value))
and then not Is_Alnum (Character'Val (Value))
then
Set_In_Class (Bitmap, Character'Val (Value));
@@ -1402,7 +1415,7 @@ package body GNAT.Regpat is
when ANYOF_NPUNCT =>
for Value in Class_Byte'Range loop
if not Is_Printable (Character'Val (Value))
- or else Is_Space (Character'Val (Value))
+ or else Is_White_Space (Character'Val (Value))
or else Is_Alnum (Character'Val (Value))
then
Set_In_Class (Bitmap, Character'Val (Value));
@@ -1520,17 +1533,17 @@ package body GNAT.Regpat is
-- This is a bit tricky due to quoted chars and due to
-- the multiplier characters '*', '+', and '?' that
-- take the SINGLE char previous as their operand.
- --
+
-- On entry, the character at Parse_Pos - 1 is going to go
-- into the string, no matter what it is. It could be
-- following a \ if Parse_Atom was entered from the '\' case.
- --
+
-- Basic idea is to pick up a good char in C and examine
-- the next char. If Is_Mult (C) then twiddle, if it's a \
-- then frozzle and if it's another magic char then push C and
-- terminate the string. If none of the above, push C on the
-- string and go around again.
- --
+
-- Start_Pos is used to remember where "the current character"
-- starts in the string, if due to an Is_Mult we need to back
-- up and put the current char in a separate 1-character string.
@@ -1539,12 +1552,13 @@ package body GNAT.Regpat is
-- flag at the end.
procedure Parse_Literal
- (Expr_Flags : in out Expression_Flags;
+ (Expr_Flags : out Expression_Flags;
IP : out Pointer)
is
Start_Pos : Natural := 0;
C : Character;
Length_Ptr : Pointer;
+
Has_Special_Operator : Boolean := False;
begin
@@ -1561,7 +1575,6 @@ package body GNAT.Regpat is
Parse_Loop :
loop
-
C := Expression (Parse_Pos); -- Get current character
case C is
@@ -1582,9 +1595,11 @@ package body GNAT.Regpat is
-- Are we looking at an operator, or is this
-- simply a normal character ?
+
elsif not Is_Mult (Parse_Pos) then
Start_Pos := Parse_Pos;
Case_Emit (C);
+
else
-- We've got something like "abc?d". Mark this as a
-- special case. What we want to emit is a first
@@ -1592,14 +1607,17 @@ package body GNAT.Regpat is
-- ultimately be transformed with a CURLY operator, A
-- special case has to be handled for "a?", since there
-- is no initial string to emit.
+
Has_Special_Operator := True;
exit Parse_Loop;
end if;
when '\' =>
Start_Pos := Parse_Pos;
+
if Parse_Pos = Parse_End then
Fail ("Trailing \");
+
else
case Expression (Parse_Pos + 1) is
when 'b' | 'B' | 's' | 'S' | 'd' | 'D'
@@ -1613,6 +1631,7 @@ package body GNAT.Regpat is
when 'a' => Emit (ASCII.BEL);
when others => Emit (Expression (Parse_Pos + 1));
end case;
+
Parse_Pos := Parse_Pos + 1;
end if;
@@ -1663,8 +1682,8 @@ package body GNAT.Regpat is
-- role is not redundant.
procedure Parse_Piece
- (Expr_Flags : in out Expression_Flags;
- IP : out Pointer)
+ (Expr_Flags : out Expression_Flags;
+ IP : out Pointer)
is
Op : Character;
New_Flags : Expression_Flags;
@@ -1774,7 +1793,26 @@ package body GNAT.Regpat is
Class : Std_Class := ANYOF_NONE;
E : String renames Expression;
+ -- Class names. Note that code assumes that the length of all
+ -- classes starting with the same letter have the same length.
+
+ Alnum : constant String := "alnum:]";
+ Alpha : constant String := "alpha:]";
+ Ascii_C : constant String := "ascii:]";
+ Cntrl : constant String := "cntrl:]";
+ Digit : constant String := "digit:]";
+ Graph : constant String := "graph:]";
+ Lower : constant String := "lower:]";
+ Print : constant String := "print:]";
+ Punct : constant String := "punct:]";
+ Space : constant String := "space:]";
+ Upper : constant String := "upper:]";
+ Word : constant String := "word:]";
+ Xdigit : constant String := "xdigit:]";
+
begin
+ -- Case of character class specified
+
if Parse_Pos <= Parse_End
and then Expression (Parse_Pos) = ':'
then
@@ -1789,150 +1827,196 @@ package body GNAT.Regpat is
Parse_Pos := Parse_Pos + 1;
end if;
- -- All classes have 6 characters at least
- -- ??? magid constant 6 should have a name!
+ -- Check for class names based on first letter
- if Parse_Pos + 6 <= Parse_End then
+ case Expression (Parse_Pos) is
- case Expression (Parse_Pos) is
- when 'a' =>
- if E (Parse_Pos .. Parse_Pos + 4) = "alnum:]" then
+ when 'a' =>
+
+ -- All 'a' classes have the same length (Alnum'Length)
+
+ if Parse_Pos + Alnum'Length - 1 <= Parse_End then
+
+ if E (Parse_Pos .. Parse_Pos + Alnum'Length - 1) =
+ Alnum
+ then
if Invert then
Class := ANYOF_NALNUMC;
else
Class := ANYOF_ALNUMC;
end if;
- elsif E (Parse_Pos .. Parse_Pos + 6) = "alpha:]" then
+ Parse_Pos := Parse_Pos + Alnum'Length;
+
+ elsif E (Parse_Pos .. Parse_Pos + Alpha'Length - 1) =
+ Alpha
+ then
if Invert then
Class := ANYOF_NALPHA;
else
Class := ANYOF_ALPHA;
end if;
- elsif E (Parse_Pos .. Parse_Pos + 6) = "ascii:]" then
+ Parse_Pos := Parse_Pos + Alpha'Length;
+
+ elsif E (Parse_Pos .. Parse_Pos + Ascii_C'Length - 1) =
+ Ascii_C
+ then
if Invert then
Class := ANYOF_NASCII;
else
Class := ANYOF_ASCII;
end if;
+ Parse_Pos := Parse_Pos + Ascii_C'Length;
end if;
+ end if;
- when 'c' =>
- if E (Parse_Pos .. Parse_Pos + 6) = "cntrl:]" then
- if Invert then
- Class := ANYOF_NCNTRL;
- else
- Class := ANYOF_CNTRL;
- end if;
+ when 'c' =>
+ if Parse_Pos + Cntrl'Length - 1 <= Parse_End
+ and then E (Parse_Pos .. Parse_Pos + Cntrl'Length - 1) =
+ Cntrl
+ then
+ if Invert then
+ Class := ANYOF_NCNTRL;
+ else
+ Class := ANYOF_CNTRL;
end if;
- when 'd' =>
+ Parse_Pos := Parse_Pos + Cntrl'Length;
+ end if;
- if E (Parse_Pos .. Parse_Pos + 6) = "digit:]" then
- if Invert then
- Class := ANYOF_NDIGIT;
- else
- Class := ANYOF_DIGIT;
- end if;
+ when 'd' =>
+ if Parse_Pos + Digit'Length - 1 <= Parse_End
+ and then E (Parse_Pos .. Parse_Pos + Digit'Length - 1) =
+ Digit
+ then
+ if Invert then
+ Class := ANYOF_NDIGIT;
+ else
+ Class := ANYOF_DIGIT;
end if;
- when 'g' =>
+ Parse_Pos := Parse_Pos + Digit'Length;
+ end if;
- if E (Parse_Pos .. Parse_Pos + 6) = "graph:]" then
- if Invert then
- Class := ANYOF_NGRAPH;
- else
- Class := ANYOF_GRAPH;
- end if;
+ when 'g' =>
+ if Parse_Pos + Graph'Length - 1 <= Parse_End
+ and then E (Parse_Pos .. Parse_Pos + Graph'Length - 1) =
+ Graph
+ then
+ if Invert then
+ Class := ANYOF_NGRAPH;
+ else
+ Class := ANYOF_GRAPH;
end if;
+ Parse_Pos := Parse_Pos + Graph'Length;
+ end if;
- when 'l' =>
-
- if E (Parse_Pos .. Parse_Pos + 6) = "lower:]" then
- if Invert then
- Class := ANYOF_NLOWER;
- else
- Class := ANYOF_LOWER;
- end if;
+ when 'l' =>
+ if Parse_Pos + Lower'Length - 1 <= Parse_End
+ and then E (Parse_Pos .. Parse_Pos + Lower'Length - 1) =
+ Lower
+ then
+ if Invert then
+ Class := ANYOF_NLOWER;
+ else
+ Class := ANYOF_LOWER;
end if;
+ Parse_Pos := Parse_Pos + Lower'Length;
+ end if;
- when 'p' =>
+ when 'p' =>
- if E (Parse_Pos .. Parse_Pos + 6) = "print:]" then
+ -- All 'p' classes have the same length
+
+ if Parse_Pos + Print'Length - 1 <= Parse_End then
+ if E (Parse_Pos .. Parse_Pos + Print'Length - 1) =
+ Print
+ then
if Invert then
Class := ANYOF_NPRINT;
else
Class := ANYOF_PRINT;
end if;
- elsif E (Parse_Pos .. Parse_Pos + 6) = "punct:]" then
+ Parse_Pos := Parse_Pos + Print'Length;
+
+ elsif E (Parse_Pos .. Parse_Pos + Punct'Length - 1) =
+ Punct
+ then
if Invert then
Class := ANYOF_NPUNCT;
else
Class := ANYOF_PUNCT;
end if;
- end if;
- when 's' =>
-
- if E (Parse_Pos .. Parse_Pos + 6) = "space:]" then
- if Invert then
- Class := ANYOF_NSPACE;
- else
- Class := ANYOF_SPACE;
- end if;
+ Parse_Pos := Parse_Pos + Punct'Length;
end if;
+ end if;
- when 'u' =>
-
- if E (Parse_Pos .. Parse_Pos + 6) = "upper:]" then
- if Invert then
- Class := ANYOF_NUPPER;
- else
- Class := ANYOF_UPPER;
- end if;
+ when 's' =>
+ if Parse_Pos + Space'Length - 1 <= Parse_End
+ and then E (Parse_Pos .. Parse_Pos + Space'Length - 1) =
+ Space
+ then
+ if Invert then
+ Class := ANYOF_NSPACE;
+ else
+ Class := ANYOF_SPACE;
end if;
- when 'w' =>
+ Parse_Pos := Parse_Pos + Space'Length;
+ end if;
- if E (Parse_Pos .. Parse_Pos + 5) = "word:]" then
- if Invert then
- Class := ANYOF_NALNUM;
- else
- Class := ANYOF_ALNUM;
- end if;
+ when 'u' =>
- Parse_Pos := Parse_Pos - 1;
+ if Parse_Pos + Upper'Length - 1 <= Parse_End
+ and then E (Parse_Pos .. Parse_Pos + Upper'Length - 1) =
+ Upper
+ then
+ if Invert then
+ Class := ANYOF_NUPPER;
+ else
+ Class := ANYOF_UPPER;
end if;
+ Parse_Pos := Parse_Pos + Upper'Length;
+ end if;
- when 'x' =>
-
- if Parse_Pos + 7 <= Parse_End
- and then E (Parse_Pos .. Parse_Pos + 7) = "xdigit:]"
- then
- if Invert then
- Class := ANYOF_NXDIGIT;
- else
- Class := ANYOF_XDIGIT;
- end if;
+ when 'w' =>
- Parse_Pos := Parse_Pos + 1;
+ if Parse_Pos + Word'Length - 1 <= Parse_End
+ and then E (Parse_Pos .. Parse_Pos + Word'Length - 1) =
+ Word
+ then
+ if Invert then
+ Class := ANYOF_NALNUM;
+ else
+ Class := ANYOF_ALNUM;
end if;
+ Parse_Pos := Parse_Pos + Word'Length;
+ end if;
- when others =>
- Class := ANYOF_NONE;
+ when 'x' =>
- end case;
+ if Parse_Pos + Xdigit'Length - 1 <= Parse_End
+ and then E (Parse_Pos .. Parse_Pos + Xdigit'Length - 1)
+ = Digit
+ then
+ if Invert then
+ Class := ANYOF_NXDIGIT;
+ else
+ Class := ANYOF_XDIGIT;
+ end if;
- if Class /= ANYOF_NONE then
- Parse_Pos := Parse_Pos + 7;
- end if;
+ Parse_Pos := Parse_Pos + Xdigit'Length;
+ end if;
- else
- Fail ("Invalid character class");
- end if;
+ when others =>
+ Fail ("Invalid character class");
+ end case;
+
+ -- Character class not specified
else
return ANYOF_NONE;
@@ -2040,7 +2124,7 @@ package body GNAT.Regpat is
end if;
declare
- Point : String := Pointer'Image (Index);
+ Point : constant String := Pointer'Image (Index);
begin
for J in 1 .. 6 - Point'Length loop
@@ -2218,8 +2302,8 @@ package body GNAT.Regpat is
Value : constant Class_Byte := Character'Pos (C);
begin
- return (Bitmap (Value / 8)
- and Bit_Conversion (Value mod 8)) /= 0;
+ return
+ (Bitmap (Value / 8) and Bit_Conversion (Value mod 8)) /= 0;
end Get_From_Class;
--------------
@@ -2264,26 +2348,24 @@ package body GNAT.Regpat is
------------------
function Is_Printable (C : Character) return Boolean is
- Value : constant Natural := Character'Pos (C);
-
begin
- return (Value > 32 and then Value < 127)
- or else Is_Space (C);
+ -- Printable if space or graphic character or other whitespace
+ -- Other white space includes (HT/LF/VT/FF/CR = codes 9-13)
+
+ return C in Character'Val (32) .. Character'Val (126)
+ or else C in ASCII.HT .. ASCII.CR;
end Is_Printable;
- --------------
- -- Is_Space --
- --------------
+ --------------------
+ -- Is_White_Space --
+ --------------------
- function Is_Space (C : Character) return Boolean is
+ function Is_White_Space (C : Character) return Boolean is
begin
- return C = ' '
- or else C = ASCII.HT
- or else C = ASCII.CR
- or else C = ASCII.LF
- or else C = ASCII.VT
- or else C = ASCII.FF;
- end Is_Space;
+ -- Note: HT = 9, LF = 10, VT = 11, FF = 12, CR = 13
+
+ return C = ' ' or else C in ASCII.HT .. ASCII.CR;
+ end Is_White_Space;
-----------
-- Match --
@@ -2292,10 +2374,15 @@ package body GNAT.Regpat is
procedure Match
(Self : Pattern_Matcher;
Data : String;
- Matches : out Match_Array)
+ Matches : out Match_Array;
+ Data_First : Integer := -1;
+ Data_Last : Positive := Positive'Last)
is
Program : Program_Data renames Self.Program; -- Shorter notation
+ First_In_Data : constant Integer := Integer'Max (Data_First, Data'First);
+ Last_In_Data : constant Integer := Integer'Min (Data_Last, Data'Last);
+
-- Global work variables
Input_Pos : Natural; -- String-input pointer
@@ -2365,9 +2452,11 @@ package body GNAT.Regpat is
-- particular by going through "ordinary" nodes (that don't
-- need to know whether the rest of the match failed) by
-- using a loop instead of recursion.
+ -- Why is the above comment part of the spec rather than body ???
- function Match_Whilem (IP : Pointer) return Boolean;
+ function Match_Whilem (IP : Pointer) return Boolean;
-- Return True if a WHILEM matches
+ -- How come IP is unreferenced in the body ???
function Recurse_Match (IP : Pointer; From : Natural) return Boolean;
pragma Inline (Recurse_Match);
@@ -2401,7 +2490,7 @@ package body GNAT.Regpat is
return Natural
is
begin
- for J in Start .. Data'Last loop
+ for J in Start .. Last_In_Data loop
if Data (J) = C then
return J;
end if;
@@ -2416,15 +2505,19 @@ package body GNAT.Regpat is
function Recurse_Match (IP : Pointer; From : Natural) return Boolean is
L : constant Natural := Last_Paren;
+
Tmp_F : constant Match_Array :=
- Matches_Full (From + 1 .. Matches_Full'Last);
+ Matches_Full (From + 1 .. Matches_Full'Last);
+
Start : constant Natural_Array :=
- Matches_Tmp (From + 1 .. Matches_Tmp'Last);
+ Matches_Tmp (From + 1 .. Matches_Tmp'Last);
Input : constant Natural := Input_Pos;
+
begin
if Match (IP) then
return True;
end if;
+
Last_Paren := L;
Matches_Full (Tmp_F'Range) := Tmp_F;
Matches_Tmp (Start'Range) := Start;
@@ -2480,28 +2573,24 @@ package body GNAT.Regpat is
null;
when BOL =>
- exit State_Machine when
- Input_Pos /= BOL_Pos
+ exit State_Machine when Input_Pos /= BOL_Pos
and then ((Self.Flags and Multiple_Lines) = 0
or else Data (Input_Pos - 1) /= ASCII.LF);
when MBOL =>
- exit State_Machine when
- Input_Pos /= BOL_Pos
+ exit State_Machine when Input_Pos /= BOL_Pos
and then Data (Input_Pos - 1) /= ASCII.LF;
when SBOL =>
exit State_Machine when Input_Pos /= BOL_Pos;
when EOL =>
- exit State_Machine when
- Input_Pos <= Data'Last
+ exit State_Machine when Input_Pos <= Data'Last
and then ((Self.Flags and Multiple_Lines) = 0
or else Data (Input_Pos) /= ASCII.LF);
when MEOL =>
- exit State_Machine when
- Input_Pos <= Data'Last
+ exit State_Machine when Input_Pos <= Data'Last
and then Data (Input_Pos) /= ASCII.LF;
when SEOL =>
@@ -2516,11 +2605,11 @@ package body GNAT.Regpat is
Ln : Boolean := False;
begin
- if Input_Pos /= Data'First then
+ if Input_Pos /= First_In_Data then
N := Is_Alnum (Data (Input_Pos - 1));
end if;
- if Input_Pos > Data'Last then
+ if Input_Pos > Last_In_Data then
Ln := False;
else
Ln := Is_Alnum (Data (Input_Pos));
@@ -2538,60 +2627,55 @@ package body GNAT.Regpat is
end;
when SPACE =>
- exit State_Machine when
- Input_Pos > Data'Last
- or else not Is_Space (Data (Input_Pos));
+ exit State_Machine when Input_Pos > Last_In_Data
+ or else not Is_White_Space (Data (Input_Pos));
Input_Pos := Input_Pos + 1;
when NSPACE =>
- exit State_Machine when
- Input_Pos > Data'Last
- or else Is_Space (Data (Input_Pos));
+ exit State_Machine when Input_Pos > Last_In_Data
+ or else Is_White_Space (Data (Input_Pos));
Input_Pos := Input_Pos + 1;
when DIGIT =>
- exit State_Machine when
- Input_Pos > Data'Last
+ exit State_Machine when Input_Pos > Last_In_Data
or else not Is_Digit (Data (Input_Pos));
Input_Pos := Input_Pos + 1;
when NDIGIT =>
- exit State_Machine when
- Input_Pos > Data'Last
+ exit State_Machine when Input_Pos > Last_In_Data
or else Is_Digit (Data (Input_Pos));
Input_Pos := Input_Pos + 1;
when ALNUM =>
- exit State_Machine when
- Input_Pos > Data'Last
+ exit State_Machine when Input_Pos > Last_In_Data
or else not Is_Alnum (Data (Input_Pos));
Input_Pos := Input_Pos + 1;
when NALNUM =>
- exit State_Machine when
- Input_Pos > Data'Last
+ exit State_Machine when Input_Pos > Last_In_Data
or else Is_Alnum (Data (Input_Pos));
Input_Pos := Input_Pos + 1;
when ANY =>
- exit State_Machine when Input_Pos > Data'Last
+ exit State_Machine when Input_Pos > Last_In_Data
or else Data (Input_Pos) = ASCII.LF;
Input_Pos := Input_Pos + 1;
when SANY =>
- exit State_Machine when Input_Pos > Data'Last;
+ exit State_Machine when Input_Pos > Last_In_Data;
Input_Pos := Input_Pos + 1;
when EXACT =>
declare
- Opnd : Pointer := String_Operand (Scan);
- Current : Positive := Input_Pos;
+ Opnd : Pointer := String_Operand (Scan);
+ Current : Positive := Input_Pos;
+
Last : constant Pointer :=
Opnd + String_Length (Program, Scan);
begin
while Opnd <= Last loop
- exit State_Machine when Current > Data'Last
+ exit State_Machine when Current > Last_In_Data
or else Program (Opnd) /= Data (Current);
Current := Current + 1;
Opnd := Opnd + 1;
@@ -2602,14 +2686,15 @@ package body GNAT.Regpat is
when EXACTF =>
declare
- Opnd : Pointer := String_Operand (Scan);
- Current : Positive := Input_Pos;
+ Opnd : Pointer := String_Operand (Scan);
+ Current : Positive := Input_Pos;
+
Last : constant Pointer :=
Opnd + String_Length (Program, Scan);
begin
while Opnd <= Last loop
- exit State_Machine when Current > Data'Last
+ exit State_Machine when Current > Last_In_Data
or else Program (Opnd) /= To_Lower (Data (Current));
Current := Current + 1;
Opnd := Opnd + 1;
@@ -2624,8 +2709,7 @@ package body GNAT.Regpat is
begin
Bitmap_Operand (Program, Scan, Bitmap);
- exit State_Machine when
- Input_Pos > Data'Last
+ exit State_Machine when Input_Pos > Last_In_Data
or else not Get_From_Class (Bitmap, Data (Input_Pos));
Input_Pos := Input_Pos + 1;
end;
@@ -2633,7 +2717,8 @@ package body GNAT.Regpat is
when OPEN =>
declare
No : constant Natural :=
- Character'Pos (Program (Operand (Scan)));
+ Character'Pos (Program (Operand (Scan)));
+
begin
Matches_Tmp (No) := Input_Pos;
end;
@@ -2641,9 +2726,11 @@ package body GNAT.Regpat is
when CLOSE =>
declare
No : constant Natural :=
- Character'Pos (Program (Operand (Scan)));
+ Character'Pos (Program (Operand (Scan)));
+
begin
Matches_Full (No) := (Matches_Tmp (No), Input_Pos - 1);
+
if Last_Paren < No then
Last_Paren := No;
end if;
@@ -2653,6 +2740,7 @@ package body GNAT.Regpat is
declare
No : constant Natural :=
Character'Pos (Program (Operand (Scan)));
+
Data_Pos : Natural;
begin
@@ -2663,8 +2751,9 @@ package body GNAT.Regpat is
end if;
Data_Pos := Matches_Full (No).First;
+
while Data_Pos <= Matches_Full (No).Last loop
- if Input_Pos > Data'Last
+ if Input_Pos > Last_In_Data
or else Data (Input_Pos) /= Data (Data_Pos)
then
return False;
@@ -2681,6 +2770,7 @@ package body GNAT.Regpat is
when STAR | PLUS | CURLY =>
declare
Greed : constant Boolean := Greedy;
+
begin
Greedy := True;
return Match_Simple_Operator (Op, Scan, Next, Greed);
@@ -2689,15 +2779,18 @@ package body GNAT.Regpat is
when CURLYX =>
-- Looking at something like:
+
-- 1: CURLYX {n,m} (->4)
-- 2: code for complex thing (->3)
-- 3: WHILEM (->0)
-- 4: NOTHING
declare
+ Min : constant Natural :=
+ Read_Natural (Program, Scan + 3);
+ Max : constant Natural :=
+ Read_Natural (Program, Scan + 5);
Cc : aliased Current_Curly_Record;
- Min : Natural := Read_Natural (Program, Scan + 3);
- Max : Natural := Read_Natural (Program, Scan + 5);
Has_Match : Boolean;
@@ -2723,9 +2816,6 @@ package body GNAT.Regpat is
when WHILEM =>
return Match_Whilem (IP);
-
- when others =>
- raise Expression_Error; -- Invalid instruction
end case;
Scan := Next;
@@ -2756,7 +2846,7 @@ package body GNAT.Regpat is
Operand_Code : Pointer;
Old : Natural;
Last_Pos : Natural;
- Save : Natural := Input_Pos;
+ Save : constant Natural := Input_Pos;
begin
-- Lookahead to avoid useless match attempts
@@ -2787,6 +2877,7 @@ package body GNAT.Regpat is
-- Non greedy operators
if not Greedy then
+
-- Test the minimal repetitions
if Min /= 0
@@ -2804,10 +2895,10 @@ package body GNAT.Regpat is
Last_Pos := Input_Pos + Max;
- if Last_Pos > Data'Last
+ if Last_Pos > Last_In_Data
or else Max = Natural'Last
then
- Last_Pos := Data'Last;
+ Last_Pos := Last_In_Data;
end if;
-- Look for the first possible opportunity
@@ -2890,7 +2981,7 @@ package body GNAT.Regpat is
while No >= Min loop
if not Next_Char_Known
- or else (Input_Pos <= Data'Last
+ or else (Input_Pos <= Last_In_Data
and then Data (Input_Pos) = Next_Char)
then
if Match (Next) then
@@ -2903,6 +2994,7 @@ package body GNAT.Regpat is
No := No - 1;
Input_Pos := Save + No;
end loop;
+
return False;
end if;
end Match_Simple_Operator;
@@ -2911,20 +3003,20 @@ package body GNAT.Regpat is
-- Match_Whilem --
------------------
- -- This is really hard to understand, because after we match what we're
- -- trying to match, we must make sure the rest of the REx is going to
- -- match for sure, and to do that we have to go back UP the parse tree
- -- by recursing ever deeper. And if it fails, we have to reset our
- -- parent's current state that we can try again after backing off.
+ -- This is really hard to understand, because after we match what we
+ -- are trying to match, we must make sure the rest of the REx is going
+ -- to match for sure, and to do that we have to go back UP the parse
+ -- tree by recursing ever deeper. And if it fails, we have to reset
+ -- our parent's current state that we can try again after backing off.
function Match_Whilem (IP : Pointer) return Boolean is
- pragma Warnings (Off, IP);
+ pragma Unreferenced (IP);
Cc : Current_Curly_Access := Current_Curly;
- N : Natural := Cc.Cur + 1;
+ N : constant Natural := Cc.Cur + 1;
Ln : Natural := 0;
- Lastloc : Natural := Cc.Lastloc;
+ Lastloc : constant Natural := Cc.Lastloc;
-- Detection of 0-len.
begin
@@ -3058,8 +3150,8 @@ package body GNAT.Regpat is
Bitmap : Character_Class;
begin
- if Max = Natural'Last or else Scan + Max - 1 > Data'Last then
- Last := Data'Last;
+ if Max = Natural'Last or else Scan + Max - 1 > Last_In_Data then
+ Last := Last_In_Data;
else
Last := Scan + Max - 1;
end if;
@@ -3125,14 +3217,14 @@ package body GNAT.Regpat is
when SPACE =>
while Scan <= Last
- and then Is_Space (Data (Scan))
+ and then Is_White_Space (Data (Scan))
loop
Scan := Scan + 1;
end loop;
when NSPACE =>
while Scan <= Last
- and then not Is_Space (Data (Scan))
+ and then not Is_White_Space (Data (Scan))
loop
Scan := Scan + 1;
end loop;
@@ -3202,7 +3294,7 @@ package body GNAT.Regpat is
Must_First : constant Pointer := Self.Must_Have;
Must_Last : constant Pointer :=
Must_First + Pointer (Self.Must_Have_Length - 1);
- Next_Try : Natural := Index (Data'First, First);
+ Next_Try : Natural := Index (First_In_Data, First);
begin
while Next_Try /= 0
@@ -3226,11 +3318,11 @@ package body GNAT.Regpat is
-- Simplest case first: an anchored match need be tried only once
if Self.Anchored and then (Self.Flags and Multiple_Lines) = 0 then
- Matched := Try (Data'First);
+ Matched := Try (First_In_Data);
elsif Self.Anchored then
declare
- Next_Try : Natural := Data'First;
+ Next_Try : Natural := First_In_Data;
begin
-- Test the first position in the buffer
Matched := Try (Next_Try);
@@ -3238,8 +3330,8 @@ package body GNAT.Regpat is
-- Else only test after newlines
if not Matched then
- while Next_Try <= Data'Last loop
- while Next_Try <= Data'Last
+ while Next_Try <= Last_In_Data loop
+ while Next_Try <= Last_In_Data
and then Data (Next_Try) /= ASCII.LF
loop
Next_Try := Next_Try + 1;
@@ -3247,7 +3339,7 @@ package body GNAT.Regpat is
Next_Try := Next_Try + 1;
- if Next_Try <= Data'Last then
+ if Next_Try <= Last_In_Data then
Matched := Try (Next_Try);
exit when Matched;
end if;
@@ -3256,11 +3348,10 @@ package body GNAT.Regpat is
end;
elsif Self.First /= ASCII.NUL then
-
-- We know what char it must start with
declare
- Next_Try : Natural := Index (Data'First, Self.First);
+ Next_Try : Natural := Index (First_In_Data, Self.First);
begin
while Next_Try /= 0 loop
@@ -3273,10 +3364,10 @@ package body GNAT.Regpat is
else
-- Messy cases: try all locations (including for the empty string)
- Matched := Try (Data'First);
+ Matched := Try (First_In_Data);
if not Matched then
- for S in Data'First + 1 .. Data'Last loop
+ for S in First_In_Data + 1 .. Last_In_Data loop
Matched := Try (S);
exit when Matched;
end loop;
@@ -3295,13 +3386,15 @@ package body GNAT.Regpat is
function Match
(Self : Pattern_Matcher;
- Data : String)
+ Data : String;
+ Data_First : Integer := -1;
+ Data_Last : Positive := Positive'Last)
return Natural
is
Matches : Match_Array (0 .. 0);
begin
- Match (Self, Data, Matches);
+ Match (Self, Data, Matches, Data_First, Data_Last);
if Matches (0) = No_Match then
return Data'First - 1;
else
@@ -3313,24 +3406,28 @@ package body GNAT.Regpat is
(Expression : String;
Data : String;
Matches : out Match_Array;
- Size : Program_Size := 0)
+ Size : Program_Size := 0;
+ Data_First : Integer := -1;
+ Data_Last : Positive := Positive'Last)
is
PM : Pattern_Matcher (Size);
Finalize_Size : Program_Size;
begin
if Size = 0 then
- Match (Compile (Expression), Data, Matches);
+ Match (Compile (Expression), Data, Matches, Data_First, Data_Last);
else
Compile (PM, Expression, Finalize_Size);
- Match (PM, Data, Matches);
+ Match (PM, Data, Matches, Data_First, Data_Last);
end if;
end Match;
function Match
(Expression : String;
Data : String;
- Size : Program_Size := 0)
+ Size : Program_Size := 0;
+ Data_First : Integer := -1;
+ Data_Last : Positive := Positive'Last)
return Natural
is
PM : Pattern_Matcher (Size);
@@ -3338,17 +3435,19 @@ package body GNAT.Regpat is
begin
if Size = 0 then
- return Match (Compile (Expression), Data);
+ return Match (Compile (Expression), Data, Data_First, Data_Last);
else
Compile (PM, Expression, Final_Size);
- return Match (PM, Data);
+ return Match (PM, Data, Data_First, Data_Last);
end if;
end Match;
function Match
(Expression : String;
Data : String;
- Size : Program_Size := 0)
+ Size : Program_Size := 0;
+ Data_First : Integer := -1;
+ Data_Last : Positive := Positive'Last)
return Boolean
is
Matches : Match_Array (0 .. 0);
@@ -3357,10 +3456,10 @@ package body GNAT.Regpat is
begin
if Size = 0 then
- Match (Compile (Expression), Data, Matches);
+ Match (Compile (Expression), Data, Matches, Data_First, Data_Last);
else
Compile (PM, Expression, Final_Size);
- Match (PM, Data, Matches);
+ Match (PM, Data, Matches, Data_First, Data_Last);
end if;
return Matches (0).First >= Data'First;
@@ -3457,8 +3556,8 @@ package body GNAT.Regpat is
begin
for J in Str'Range loop
case Str (J) is
- when '^' | '$' | '|' | '*' | '+' | '?' | '{'
- | '}' | '[' | ']' | '(' | ')' | '\' =>
+ when '^' | '$' | '|' | '*' | '+' | '?' | '{' |
+ '}' | '[' | ']' | '(' | ')' | '\' =>
S (Last + 1) := '\';
S (Last + 2) := Str (J);
@@ -3491,7 +3590,7 @@ package body GNAT.Regpat is
-- Reset_Class --
-----------------
- procedure Reset_Class (Bitmap : in out Character_Class) is
+ procedure Reset_Class (Bitmap : out Character_Class) is
begin
Bitmap := (others => 0);
end Reset_Class;
diff --git a/gcc/ada/g-regpat.ads b/gcc/ada/g-regpat.ads
index b3af0d82618..ba00b04a5cd 100644
--- a/gcc/ada/g-regpat.ads
+++ b/gcc/ada/g-regpat.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1986 by University of Toronto. --
--- Copyright (C) 1996-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 1996-2002 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -74,10 +75,13 @@ pragma Preelaborate (Regpat);
-- regexp ::= expr
-- ::= ^ expr -- anchor at the beginning of string
-- ::= expr $ -- anchor at the end of string
+
-- expr ::= term
-- ::= term | term -- alternation (term or term ...)
+
-- term ::= item
-- ::= item item ... -- concatenation (item then item)
+
-- item ::= elmt -- match elmt
-- ::= elmt * -- zero or more elmt's
-- ::= elmt + -- one or more elmt's
@@ -93,6 +97,7 @@ pragma Preelaborate (Regpat);
-- non-greedy version
-- ::= elmt { num , num2 }? -- matches between num and num2 times
-- non-greedy version
+
-- elmt ::= nchr -- matches given character
-- ::= [range range ...] -- matches any character listed
-- ::= [^ range range ...] -- matches any character not listed
@@ -100,10 +105,12 @@ pragma Preelaborate (Regpat);
-- -- except newlines
-- ::= ( expr ) -- parens used for grouping
-- ::= \ num -- reference to num-th parenthesis
+
-- range ::= char - char -- matches chars in given range
-- ::= nchr
-- ::= [: posix :] -- any character in the POSIX range
-- ::= [:^ posix :] -- not in the POSIX range
+
-- posix ::= alnum -- alphanumeric characters
-- ::= alpha -- alphabetic characters
-- ::= ascii -- ascii characters (0 .. 127)
@@ -120,6 +127,7 @@ pragma Preelaborate (Regpat);
-- char ::= any character, including special characters
-- ASCII.NUL is not supported.
+
-- nchr ::= any character except \()[].*+?^ or \char to match char
-- \n means a newline (ASCII.LF)
-- \t means a tab (ASCII.HT)
@@ -217,7 +225,7 @@ pragma Preelaborate (Regpat);
-- the first parenthesis pair.
-- declare
- -- Matches : Match_Array;
+ -- Matches : Match_Array (0 .. 1);
-- Regexp : String := "a(b|c)d";
-- Str : String := "gacdg";
@@ -227,6 +235,33 @@ pragma Preelaborate (Regpat);
-- -- returns 'c'
-- end;
+ -- Finding all occurrences
+ -- =======================
+
+ -- Finding all the occurrences of a regular expression in a string cannot
+ -- be done by simply passing a slice of the string. This wouldn't work for
+ -- anchored regular expressions (the ones starting with "^" or ending with
+ -- "$").
+ -- Instead, you need to use the last parameter to Match (Data_First), as in
+ -- the following loop:
+
+ -- declare
+ -- Str : String :=
+ -- "-- first line" & ASCII.LF & "-- second line";
+ -- Matches : Match_array (0 .. 0);
+ -- Regexp : Pattern_Matcher := Compile ("^--", Multiple_Lines);
+ -- Current : Natural := Str'First;
+ -- begin
+ -- loop
+ -- Match (Regexp, Str, Matches, Current);
+ -- exit when Matches (0) = No_Match;
+ --
+ -- -- Process the match at position Matches (0).First
+ --
+ -- Current := Matches (0).Last + 1;
+ -- end loop;
+ -- end;
+
-- String Substitution
-- ===================
@@ -239,7 +274,7 @@ pragma Preelaborate (Regpat);
-- declare
-- Regexp : String := "([a-z]+) +([a-z]+)";
-- Str : String := " first second third ";
- -- Matches : Match_Array;
+ -- Matches : Match_Array (0 .. 2);
-- begin
-- Match (Compile (Regexp), Str, Matches);
@@ -380,9 +415,8 @@ pragma Preelaborate (Regpat);
function Paren_Count (Regexp : Pattern_Matcher) return Match_Count;
pragma Inline (Paren_Count);
-
-- Return the number of parenthesis pairs in Regexp.
-
+ --
-- This is the maximum index that will be filled if a Match_Array is
-- used as an argument to Match.
--
@@ -413,8 +447,23 @@ pragma Preelaborate (Regpat);
(Expression : String;
Data : String;
Matches : out Match_Array;
- Size : Program_Size := 0);
- -- Match Expression against Data and store result in Matches.
+ Size : Program_Size := 0;
+ Data_First : Integer := -1;
+ Data_Last : Positive := Positive'Last);
+ -- Match Expression against Data (Data_First .. Data_Last) and store
+ -- result in Matches.
+ --
+ -- Data_First defaults to Data'First if unspecified (that is the
+ -- dummy value of -1 is interpreted to mean Data'First).
+ --
+ -- Data_Last defaults to Data'Last if unspecified (that is the
+ -- dummy value of Positive'Last is interpreted to mean Data'Last)
+ --
+ -- It is important that Data contains the whole string (or file) you
+ -- want to matched against, even if you start in the middle, since
+ -- otherwise regular expressions starting with "^" or ending with "$" will
+ -- be improperly processed.
+ --
-- Function raises Storage_Error if Size is too small for Expression,
-- or Expression_Error if Expression is not a legal regular expression.
-- If Size is 0, then the appropriate size is automatically calculated
@@ -425,19 +474,26 @@ pragma Preelaborate (Regpat);
function Match
(Expression : String;
Data : String;
- Size : Program_Size := 0)
+ Size : Program_Size := 0;
+ Data_First : Integer := -1;
+ Data_Last : Positive := Positive'Last)
return Natural;
- -- Return the position where Data matches, or (Data'First - 1) if there is
- -- no match.
+ -- Return the position where Data matches, or (Data'First - 1) if
+ -- there is no match.
+ --
-- Function raises Storage_Error if Size is too small for Expression
-- or Expression_Error if Expression is not a legal regular expression
+ --
-- If Size is 0, then the appropriate size is automatically calculated
-- by this package, but this is slightly slower.
+ -- See description of Data_First and Data_Last above.
function Match
(Expression : String;
Data : String;
- Size : Program_Size := 0)
+ Size : Program_Size := 0;
+ Data_First : Integer := -1;
+ Data_Last : Positive := Positive'Last)
return Boolean;
-- Return True if Data matches Expression. Match raises Storage_Error
-- if Size is too small for Expression, or Expression_Error if Expression
@@ -445,6 +501,8 @@ pragma Preelaborate (Regpat);
--
-- If Size is 0, then the appropriate size is automatically calculated
-- by this package, but this is slightly slower.
+ --
+ -- See description of Data_First and Data_Last above.
------------------------------------------------
-- Matching a pre-compiled regular expression --
@@ -455,25 +513,33 @@ pragma Preelaborate (Regpat);
-- compile it once.
function Match
- (Self : Pattern_Matcher;
- Data : String)
+ (Self : Pattern_Matcher;
+ Data : String;
+ Data_First : Integer := -1;
+ Data_Last : Positive := Positive'Last)
return Natural;
-- Return the position where Data matches, or (Data'First - 1) if there is
-- no match. Raises Expression_Error if Expression is not a legal regular
-- expression.
+ --
+ -- See description of Data_First and Data_Last above.
pragma Inline (Match);
-- All except the last one below.
procedure Match
- (Self : Pattern_Matcher;
- Data : String;
- Matches : out Match_Array);
+ (Self : Pattern_Matcher;
+ Data : String;
+ Matches : out Match_Array;
+ Data_First : Integer := -1;
+ Data_Last : Positive := Positive'Last);
-- Match Data using the given pattern matcher and store result in Matches.
-- Raises Expression_Error if Expression is not a legal regular expression.
-- The expression matches if Matches (0) /= No_Match.
--
-- At most Matches'Length parenthesis are returned.
+ --
+ -- See description of Data_First and Data_Last above.
-----------
-- Debug --
diff --git a/gcc/ada/g-semaph.adb b/gcc/ada/g-semaph.adb
new file mode 100644
index 00000000000..812cf192f93
--- /dev/null
+++ b/gcc/ada/g-semaph.adb
@@ -0,0 +1,86 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- G N A T . S E M A P H O R E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+package body GNAT.Semaphores is
+
+ ------------------------
+ -- Counting_Semaphore --
+ ------------------------
+
+ protected body Counting_Semaphore is
+
+ -----------
+ -- Seize --
+ -----------
+
+ entry Seize when Count > 0 is
+ begin
+ Count := Count - 1;
+ end Seize;
+
+ -------------
+ -- Release --
+ -------------
+
+ procedure Release is
+ begin
+ Count := Count + 1;
+ end Release;
+ end Counting_Semaphore;
+
+ ----------------------
+ -- Binary_Semaphore --
+ ----------------------
+
+ protected body Binary_Semaphore is
+
+ -----------
+ -- Seize --
+ -----------
+
+ entry Seize when Available is
+ begin
+ Available := False;
+ end Seize;
+
+ -------------
+ -- Release --
+ -------------
+
+ procedure Release is
+ begin
+ Available := True;
+ end Release;
+ end Binary_Semaphore;
+
+end GNAT.Semaphores;
diff --git a/gcc/ada/g-semaph.ads b/gcc/ada/g-semaph.ads
new file mode 100644
index 00000000000..a8720b32437
--- /dev/null
+++ b/gcc/ada/g-semaph.ads
@@ -0,0 +1,100 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT LIBRARY COMPONENTS --
+-- --
+-- G N A T . S E M A P H O R E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides classic counting semaphores and binary semaphores.
+-- Both types are visibly defined as protected types so that users can make
+-- conditional and timed calls when appropriate.
+
+with System;
+
+package GNAT.Semaphores is
+
+ Default_Ceiling : constant System.Priority := System.Default_Priority;
+ -- A convenient value for the priority discriminants that follow.
+
+ ------------------------
+ -- Counting_Semaphore --
+ ------------------------
+
+ protected type Counting_Semaphore
+ (Initial_Value : Natural;
+ -- A counting semaphore contains an internal counter. The initial
+ -- value of this counter is set by clients via the discriminant.
+
+ Ceiling : System.Priority)
+ -- Users must specify the ceiling priority for the object.
+ -- If the Real-Time Systems Annex is not in use this value
+ -- is not important.
+ is
+ pragma Priority (Ceiling);
+
+ entry Seize;
+ -- Blocks caller until/unless the semaphore's internal counter
+ -- is greater than zero.
+ -- Decrements the semaphore's internal counter when executed.
+
+ procedure Release;
+ -- Increments the semaphore's internal counter.
+
+ private
+ Count : Natural := Initial_Value;
+ end Counting_Semaphore;
+
+ ----------------------
+ -- Binary_Semaphore --
+ ----------------------
+
+ protected type Binary_Semaphore
+ (Initially_Available : Boolean;
+ -- Binary semaphores are either available or not; there is no
+ -- internal count involved. The discriminant value determines
+ -- whether the individual object is initially available.
+ Ceiling : System.Priority)
+ -- Users must specify the ceiling priority for the object.
+ -- If the Real-Time Systems Annex is not in use
+ -- this value is not important.
+ is
+ pragma Priority (Ceiling);
+
+ entry Seize;
+ -- Blocks the caller unless/until semaphore is available.
+ -- After execution the semaphore is no longer available.
+
+ procedure Release;
+ -- Makes the semaphore available.
+
+ private
+ Available : Boolean := Initially_Available;
+ end Binary_Semaphore;
+
+end GNAT.Semaphores;
diff --git a/gcc/ada/g-soccon.ads b/gcc/ada/g-soccon.ads
index 8f55fc189e4..abe651de512 100644
--- a/gcc/ada/g-soccon.ads
+++ b/gcc/ada/g-soccon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2000-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- --
@@ -26,88 +26,133 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+-- This package provides target dependent definitions of constant for use
+-- by the GNAT.Sockets package (g-socket.ads). This package should not be
+-- directly with'ed by an applications program.
+
-- This is the version for GNU/Linux
package GNAT.Sockets.Constants is
- -- Families
-
- AF_INET : constant := 2;
- AF_INET6 : constant := 10;
-
- -- Modes
-
- SOCK_STREAM : constant := 1;
- SOCK_DGRAM : constant := 2;
-
- -- Socket Errors
-
- EBADF : constant := 9;
- ENOTSOCK : constant := 88;
- ENOTCONN : constant := 107;
- ENOBUFS : constant := 105;
- EOPNOTSUPP : constant := 95;
- EFAULT : constant := 14;
- EWOULDBLOCK : constant := 11;
- EADDRNOTAVAIL : constant := 99;
- EMSGSIZE : constant := 90;
- EADDRINUSE : constant := 98;
- EINVAL : constant := 22;
- EACCES : constant := 13;
- EAFNOSUPPORT : constant := 97;
- EISCONN : constant := 106;
- ETIMEDOUT : constant := 110;
- ECONNREFUSED : constant := 111;
- ENETUNREACH : constant := 101;
- EALREADY : constant := 114;
- EINPROGRESS : constant := 115;
- ENOPROTOOPT : constant := 92;
- EPROTONOSUPPORT : constant := 93;
- EINTR : constant := 4;
- EIO : constant := 5;
- ESOCKTNOSUPPORT : constant := 94;
-
- -- Host Errors
-
- HOST_NOT_FOUND : constant := 1;
- TRY_AGAIN : constant := 2;
- NO_ADDRESS : constant := 4;
- NO_RECOVERY : constant := 3;
-
- -- Control Flags
-
- FIONBIO : constant := 21537;
- FIONREAD : constant := 21531;
-
- -- Shutdown Modes
-
- SHUT_RD : constant := 0;
- SHUT_WR : constant := 1;
- SHUT_RDWR : constant := 2;
-
- -- Protocol Levels
-
- SOL_SOCKET : constant := 1;
- IPPROTO_IP : constant := 0;
- IPPROTO_UDP : constant := 17;
- IPPROTO_TCP : constant := 6;
-
- -- Socket Options
-
- TCP_NODELAY : constant := 1;
- SO_SNDBUF : constant := 7;
- SO_RCVBUF : constant := 8;
- SO_REUSEADDR : constant := 2;
- SO_KEEPALIVE : constant := 9;
- SO_LINGER : constant := 13;
- SO_ERROR : constant := 4;
- SO_BROADCAST : constant := 6;
- IP_ADD_MEMBERSHIP : constant := 35;
- IP_DROP_MEMBERSHIP : constant := 36;
- IP_MULTICAST_TTL : constant := 33;
- IP_MULTICAST_LOOP : constant := 34;
+ --------------
+ -- Families --
+ --------------
+
+ AF_INET : constant := 2; -- IPv4 address family
+ AF_INET6 : constant := 10; -- IPv6 address family
+
+ -----------
+ -- Modes --
+ -----------
+
+ SOCK_STREAM : constant := 1; -- Stream socket
+ SOCK_DGRAM : constant := 2; -- Datagram socket
+
+ -------------------
+ -- Socket errors --
+ -------------------
+
+ EACCES : constant := 13; -- Permission denied
+ EADDRINUSE : constant := 98; -- Address already in use
+ EADDRNOTAVAIL : constant := 99; -- Cannot assign address
+ EAFNOSUPPORT : constant := 97; -- Addr family not supported
+ EALREADY : constant := 114; -- Operation in progress
+ EBADF : constant := 9; -- Bad file descriptor
+ ECONNABORTED : constant := 103; -- Connection aborted
+ ECONNREFUSED : constant := 111; -- Connection refused
+ ECONNRESET : constant := 104; -- Connection reset by peer
+ EDESTADDRREQ : constant := 89; -- Destination addr required
+ EFAULT : constant := 14; -- Bad address
+ EHOSTDOWN : constant := 112; -- Host is down
+ EHOSTUNREACH : constant := 113; -- No route to host
+ EINPROGRESS : constant := 115; -- Operation now in progress
+ EINTR : constant := 4; -- Interrupted system call
+ EINVAL : constant := 22; -- Invalid argument
+ EIO : constant := 5; -- Input output error
+ EISCONN : constant := 106; -- Socket already connected
+ ELOOP : constant := 40; -- Too many symbolic lynks
+ EMFILE : constant := 24; -- Too many open files
+ EMSGSIZE : constant := 90; -- Message too long
+ ENAMETOOLONG : constant := 36; -- Name too long
+ ENETDOWN : constant := 100; -- Network is down
+ ENETRESET : constant := 102; -- Disconn. on network reset
+ ENETUNREACH : constant := 101; -- Network is unreachable
+ ENOBUFS : constant := 105; -- No buffer space available
+ ENOPROTOOPT : constant := 92; -- Protocol not available
+ ENOTCONN : constant := 107; -- Socket not connected
+ ENOTSOCK : constant := 88; -- Operation on non socket
+ EOPNOTSUPP : constant := 95; -- Operation not supported
+ EPFNOSUPPORT : constant := 96; -- Unknown protocol family
+ EPROTONOSUPPORT : constant := 93; -- Unknown protocol
+ EPROTOTYPE : constant := 91; -- Unknown protocol type
+ ESHUTDOWN : constant := 108; -- Cannot send once shutdown
+ ESOCKTNOSUPPORT : constant := 94; -- Socket type not supported
+ ETIMEDOUT : constant := 110; -- Connection timed out
+ ETOOMANYREFS : constant := 109; -- Too many references
+ EWOULDBLOCK : constant := 11; -- Operation would block
+
+ -----------------
+ -- Host errors --
+ -----------------
+
+ HOST_NOT_FOUND : constant := 1; -- Unknown host
+ TRY_AGAIN : constant := 2; -- Host name lookup failure
+ NO_DATA : constant := 4; -- No data record for name
+ NO_RECOVERY : constant := 3; -- Non recoverable errors
+
+ -------------------
+ -- Control flags --
+ -------------------
+
+ FIONBIO : constant := 21537; -- Set/clear non-blocking io
+ FIONREAD : constant := 21531; -- How many bytes to read
+
+ --------------------
+ -- Shutdown modes --
+ --------------------
+
+ SHUT_RD : constant := 0; -- No more recv
+ SHUT_WR : constant := 1; -- No more send
+ SHUT_RDWR : constant := 2; -- No more recv/send
+
+ ---------------------
+ -- Protocol levels --
+ ---------------------
+
+ SOL_SOCKET : constant := 1; -- Options for socket level
+ IPPROTO_IP : constant := 0; -- Dummy protocol for IP
+ IPPROTO_UDP : constant := 17; -- UDP
+ IPPROTO_TCP : constant := 6; -- TCP
+
+ -------------------
+ -- Request flags --
+ -------------------
+
+ MSG_OOB : constant := 1; -- Process out-of-band data
+ MSG_PEEK : constant := 2; -- Peek at incoming data
+ MSG_EOR : constant := 128; -- Send end of record
+ MSG_WAITALL : constant := 256; -- Wait for full reception
+
+ --------------------
+ -- Socket options --
+ --------------------
+
+ TCP_NODELAY : constant := 1; -- Do not coalesce packets
+ SO_SNDBUF : constant := 7; -- Set/get send buffer size
+ SO_RCVBUF : constant := 8; -- Set/get recv buffer size
+ SO_REUSEADDR : constant := 2; -- Bind reuse local address
+ SO_KEEPALIVE : constant := 9; -- Enable keep-alive msgs
+ SO_LINGER : constant := 13; -- Defer close to flush data
+ SO_ERROR : constant := 4; -- Get/clear error status
+ SO_BROADCAST : constant := 6; -- Can send broadcast msgs
+ IP_ADD_MEMBERSHIP : constant := 35; -- Join a multicast group
+ IP_DROP_MEMBERSHIP : constant := 36; -- Leave a multicast group
+ IP_MULTICAST_TTL : constant := 33; -- Set/get multicast TTL
+ IP_MULTICAST_LOOP : constant := 34; -- Set/get mcast loopback
+
end GNAT.Sockets.Constants;
diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb
index 27ebe1c366d..5ad723bab26 100644
--- a/gcc/ada/g-socket.adb
+++ b/gcc/ada/g-socket.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,13 +26,13 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Streams; use Ada.Streams;
with Ada.Exceptions; use Ada.Exceptions;
-with Ada.Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with Interfaces.C.Strings;
@@ -55,6 +55,8 @@ package body GNAT.Sockets is
Finalized : Boolean := False;
Initialized : Boolean := False;
+ ENOERROR : constant := 0;
+
-- Correspondance tables
Families : constant array (Family_Type) of C.int :=
@@ -94,8 +96,14 @@ package body GNAT.Sockets is
Multicast_TTL => Constants.IP_MULTICAST_TTL,
Multicast_Loop => Constants.IP_MULTICAST_LOOP);
+ Flags : constant array (0 .. 3) of C.int :=
+ (0 => Constants.MSG_OOB, -- Process_Out_Of_Band_Data
+ 1 => Constants.MSG_PEEK, -- Peek_At_Incoming_Data
+ 2 => Constants.MSG_WAITALL, -- Wait_For_A_Full_Reception
+ 3 => Constants.MSG_EOR); -- Send_End_Of_Record
+
Socket_Error_Id : constant Exception_Id := Socket_Error'Identity;
- Host_Error_Id : constant Exception_Id := Host_Error'Identity;
+ Host_Error_Id : constant Exception_Id := Host_Error'Identity;
Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF";
-- Use to print in hexadecimal format
@@ -114,20 +122,22 @@ package body GNAT.Sockets is
-- Associate an enumeration value (error_type) to en error value
-- (errno). From_Errno prevents from mixing h_errno with errno.
- function To_Host_Name (N : String) return Host_Name_Type;
- function To_String (HN : Host_Name_Type) return String;
+ function To_Name (N : String) return Name_Type;
+ function To_String (HN : Name_Type) return String;
-- Conversion functions
- function Port_To_Network
- (Port : C.unsigned_short)
+ function To_Int (F : Request_Flag_Type) return C.int;
+
+ function Short_To_Network
+ (S : C.unsigned_short)
return C.unsigned_short;
- pragma Inline (Port_To_Network);
+ pragma Inline (Short_To_Network);
-- Convert a port number into a network port number
- function Network_To_Port
- (Net_Port : C.unsigned_short)
- return C.unsigned_short
- renames Port_To_Network;
+ function Network_To_Short
+ (S : C.unsigned_short)
+ return C.unsigned_short
+ renames Short_To_Network;
-- Symetric operation
function Image
@@ -137,14 +147,20 @@ package body GNAT.Sockets is
-- Output an array of inet address components either in
-- hexadecimal or in decimal mode.
+ function Is_IP_Address (Name : String) return Boolean;
+ -- Return true when Name is an IP address in standard dot notation.
+
function To_In_Addr (Addr : Inet_Addr_Type) return Thin.In_Addr;
function To_Inet_Addr (Addr : In_Addr) return Inet_Addr_Type;
-- Conversion functions
- function To_Host_Entry (Host : Hostent) return Host_Entry_Type;
+ function To_Host_Entry (E : Hostent) return Host_Entry_Type;
+ -- Conversion function
+
+ function To_Service_Entry (E : Servent) return Service_Entry_Type;
-- Conversion function
- function To_Timeval (Val : Duration) return Timeval;
+ function To_Timeval (Val : Selector_Duration) return Timeval;
-- Separate Val in seconds and microseconds
procedure Raise_Socket_Error (Error : Integer);
@@ -155,12 +171,8 @@ package body GNAT.Sockets is
-- Raise Host_Error exception with message describing error code
-- (note hstrerror seems to be obsolete).
- -- Types needed for Socket_Set_Type
-
- type Socket_Set_Record is new Fd_Set;
-
- procedure Free is
- new Ada.Unchecked_Deallocation (Socket_Set_Record, Socket_Set_Type);
+ procedure Narrow (Item : in out Socket_Set_Type);
+ -- Update Last as it may be greater than the real last socket.
-- Types needed for Datagram_Socket_Stream_Type
@@ -200,20 +212,28 @@ package body GNAT.Sockets is
(Stream : in out Stream_Socket_Stream_Type;
Item : Ada.Streams.Stream_Element_Array);
+ ---------
+ -- "+" --
+ ---------
+
+ function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is
+ begin
+ return L or R;
+ end "+";
+
--------------------
-- Abort_Selector --
--------------------
procedure Abort_Selector (Selector : Selector_Type) is
- Buf : Character;
- Res : C.int;
+ Buf : Character;
+ Discard : C.int;
+ pragma Warnings (Off, Discard);
begin
-- Send an empty array to unblock C select system call
- if Selector.In_Progress then
- Res := C_Write (C.int (Selector.W_Sig_Socket), Buf'Address, 1);
- end if;
+ Discard := C_Write (C.int (Selector.W_Sig_Socket), Buf'Address, 1);
end Abort_Selector;
-------------------
@@ -239,7 +259,7 @@ package body GNAT.Sockets is
Socket := Socket_Type (Res);
Address.Addr := To_Inet_Addr (Sin.Sin_Addr);
- Address.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
+ Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
end Accept_Socket;
---------------
@@ -277,6 +297,19 @@ package body GNAT.Sockets is
return To_String (E.Aliases (N));
end Aliases;
+ -------------
+ -- Aliases --
+ -------------
+
+ function Aliases
+ (S : Service_Entry_Type;
+ N : Positive := 1)
+ return String
+ is
+ begin
+ return To_String (S.Aliases (N));
+ end Aliases;
+
--------------------
-- Aliases_Length --
--------------------
@@ -286,6 +319,15 @@ package body GNAT.Sockets is
return E.Aliases_Length;
end Aliases_Length;
+ --------------------
+ -- Aliases_Length --
+ --------------------
+
+ function Aliases_Length (S : Service_Entry_Type) return Natural is
+ begin
+ return S.Aliases_Length;
+ end Aliases_Length;
+
-----------------
-- Bind_Socket --
-----------------
@@ -296,15 +338,18 @@ package body GNAT.Sockets is
is
Res : C.int;
Sin : aliased Sockaddr_In;
- Len : aliased C.int := Sin'Size / 8;
+ Len : constant C.int := Sin'Size / 8;
begin
if Address.Family = Family_Inet6 then
raise Socket_Error;
end if;
- Sin.Sin_Family := C.unsigned_short (Families (Address.Family));
- Sin.Sin_Port := Port_To_Network (C.unsigned_short (Address.Port));
+ Set_Length (Sin'Unchecked_Access, Len);
+ Set_Family (Sin'Unchecked_Access, Families (Address.Family));
+ Set_Port
+ (Sin'Unchecked_Access,
+ Short_To_Network (C.unsigned_short (Address.Port)));
Res := C_Bind (C.int (Socket), Sin'Address, Len);
@@ -322,19 +367,34 @@ package body GNAT.Sockets is
R_Socket_Set : in out Socket_Set_Type;
W_Socket_Set : in out Socket_Set_Type;
Status : out Selector_Status;
- Timeout : Duration := Forever)
+ Timeout : Selector_Duration := Forever)
+ is
+ E_Socket_Set : Socket_Set_Type; -- (No_Socket, No_Socket_Set)
+ begin
+ Check_Selector
+ (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout);
+ end Check_Selector;
+
+ procedure Check_Selector
+ (Selector : in out Selector_Type;
+ R_Socket_Set : in out Socket_Set_Type;
+ W_Socket_Set : in out Socket_Set_Type;
+ E_Socket_Set : in out Socket_Set_Type;
+ Status : out Selector_Status;
+ Timeout : Selector_Duration := Forever)
is
Res : C.int;
- Len : C.int;
- RSet : aliased Fd_Set;
- WSet : aliased Fd_Set;
+ Last : C.int;
+ RSet : Socket_Set_Type;
+ WSet : Socket_Set_Type;
+ ESet : Socket_Set_Type;
TVal : aliased Timeval;
TPtr : Timeval_Access;
begin
Status := Completed;
- -- No timeout or Forever is indicated by a null timeval pointer.
+ -- No timeout or Forever is indicated by a null timeval pointer
if Timeout = Forever then
TPtr := null;
@@ -343,41 +403,39 @@ package body GNAT.Sockets is
TPtr := TVal'Unchecked_Access;
end if;
- -- Copy R_Socket_Set in RSet and add read signalling socket.
+ -- Copy R_Socket_Set in RSet and add read signalling socket
- if R_Socket_Set = null then
- RSet := Null_Fd_Set;
- else
- RSet := Fd_Set (R_Socket_Set.all);
- end if;
+ RSet := (Set => New_Socket_Set (R_Socket_Set.Set),
+ Last => R_Socket_Set.Last);
+ Set (RSet, Selector.R_Sig_Socket);
- Set (RSet, C.int (Selector.R_Sig_Socket));
- Len := Max (RSet) + 1;
+ -- Copy W_Socket_Set in WSet
- -- Copy W_Socket_Set in WSet.
+ WSet := (Set => New_Socket_Set (W_Socket_Set.Set),
+ Last => W_Socket_Set.Last);
- if W_Socket_Set = null then
- WSet := Null_Fd_Set;
- else
- WSet := Fd_Set (W_Socket_Set.all);
- end if;
+ -- Copy E_Socket_Set in ESet
+
+ ESet := (Set => New_Socket_Set (E_Socket_Set.Set),
+ Last => E_Socket_Set.Last);
- Len := C.int'Max (Max (RSet) + 1, Len);
+ Last := C.int'Max (C.int'Max (C.int (RSet.Last),
+ C.int (WSet.Last)),
+ C.int (ESet.Last));
- Selector.In_Progress := True;
Res :=
C_Select
- (Len,
- RSet'Unchecked_Access,
- WSet'Unchecked_Access,
- null, TPtr);
- Selector.In_Progress := False;
+ (Last + 1,
+ RSet.Set,
+ WSet.Set,
+ ESet.Set,
+ TPtr);
-- If Select was resumed because of read signalling socket,
-- read this data and remove socket from set.
- if Is_Set (RSet, C.int (Selector.R_Sig_Socket)) then
- Clear (RSet, C.int (Selector.R_Sig_Socket));
+ if Is_Set (RSet, Selector.R_Sig_Socket) then
+ Clear (RSet, Selector.R_Sig_Socket);
declare
Buf : Character;
@@ -385,27 +443,43 @@ package body GNAT.Sockets is
Res := C_Read (C.int (Selector.R_Sig_Socket), Buf'Address, 1);
end;
- -- Select was resumed because of read signalling socket, but
- -- the call is said aborted only when there is no other read
- -- or write event.
-
- if Is_Empty (RSet)
- and then Is_Empty (WSet)
- then
- Status := Aborted;
- end if;
+ Status := Aborted;
elsif Res = 0 then
Status := Expired;
end if;
- if R_Socket_Set /= null then
- R_Socket_Set.all := Socket_Set_Record (RSet);
+ -- Update RSet, WSet and ESet in regard to their new socket
+ -- sets.
+
+ Narrow (RSet);
+ Narrow (WSet);
+ Narrow (ESet);
+
+ -- Reset RSet as it should be if R_Sig_Socket was not added.
+
+ if Is_Empty (RSet) then
+ Empty (RSet);
+ end if;
+
+ if Is_Empty (WSet) then
+ Empty (WSet);
end if;
- if W_Socket_Set /= null then
- W_Socket_Set.all := Socket_Set_Record (WSet);
+ if Is_Empty (ESet) then
+ Empty (ESet);
end if;
+
+ -- Deliver RSet, WSet and ESet.
+
+ Empty (R_Socket_Set);
+ R_Socket_Set := RSet;
+
+ Empty (W_Socket_Set);
+ W_Socket_Set := WSet;
+
+ Empty (E_Socket_Set);
+ E_Socket_Set := ESet;
end Check_Selector;
-----------
@@ -416,31 +490,39 @@ package body GNAT.Sockets is
(Item : in out Socket_Set_Type;
Socket : Socket_Type)
is
+ Last : aliased C.int := C.int (Item.Last);
+
begin
- if Item = null then
- Item := new Socket_Set_Record;
- Empty (Fd_Set (Item.all));
+ if Item.Last /= No_Socket then
+ Remove_Socket_From_Set (Item.Set, C.int (Socket));
+ Last_Socket_In_Set (Item.Set, Last'Unchecked_Access);
+ Item.Last := Socket_Type (Last);
end if;
-
- Clear (Fd_Set (Item.all), C.int (Socket));
end Clear;
--------------------
-- Close_Selector --
--------------------
+ -- Comments needed below ???
+ -- Why are exceptions ignored ???
+
procedure Close_Selector (Selector : in out Selector_Type) is
begin
begin
Close_Socket (Selector.R_Sig_Socket);
- exception when Socket_Error =>
- null;
+
+ exception
+ when Socket_Error =>
+ null;
end;
begin
Close_Socket (Selector.W_Sig_Socket);
- exception when Socket_Error =>
- null;
+
+ exception
+ when Socket_Error =>
+ null;
end;
end Close_Selector;
@@ -469,16 +551,19 @@ package body GNAT.Sockets is
is
Res : C.int;
Sin : aliased Sockaddr_In;
- Len : aliased C.int := Sin'Size / 8;
+ Len : constant C.int := Sin'Size / 8;
begin
if Server.Family = Family_Inet6 then
raise Socket_Error;
end if;
- Sin.Sin_Family := C.unsigned_short (Families (Server.Family));
- Sin.Sin_Addr := To_In_Addr (Server.Addr);
- Sin.Sin_Port := Port_To_Network (C.unsigned_short (Server.Port));
+ Set_Length (Sin'Unchecked_Access, Len);
+ Set_Family (Sin'Unchecked_Access, Families (Server.Family));
+ Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr));
+ Set_Port
+ (Sin'Unchecked_Access,
+ Short_To_Network (C.unsigned_short (Server.Port)));
Res := C_Connect (C.int (Socket), Sin'Address, Len);
@@ -527,6 +612,22 @@ package body GNAT.Sockets is
end case;
end Control_Socket;
+ ----------
+ -- Copy --
+ ----------
+
+ procedure Copy
+ (Source : Socket_Set_Type;
+ Target : in out Socket_Set_Type)
+ is
+ begin
+ Empty (Target);
+ if Source.Last /= No_Socket then
+ Target.Set := New_Socket_Set (Source.Set);
+ Target.Last := Source.Last;
+ end if;
+ end Copy;
+
---------------------
-- Create_Selector --
---------------------
@@ -541,10 +642,11 @@ package body GNAT.Sockets is
Err : Integer;
begin
- -- We open two signalling sockets. One socket to send a signal
- -- to a another socket that always included in a C_Select
- -- socket set. When received, it resumes the task suspended in
- -- C_Select.
+ -- We open two signalling sockets. One of them is used to
+ -- send data to the other, which is included in a C_Select
+ -- socket set. The communication is used to force the call
+ -- to C_Select to complete, and the waiting task to resume
+ -- its execution.
-- Create a listening socket
@@ -653,9 +755,12 @@ package body GNAT.Sockets is
procedure Empty (Item : in out Socket_Set_Type) is
begin
- if Item /= null then
- Free (Item);
+ if Item.Set /= No_Socket_Set then
+ Free_Socket_Set (Item.Set);
+ Item.Set := No_Socket_Set;
end if;
+
+ Item.Last := No_Socket;
end Empty;
--------------
@@ -672,6 +777,28 @@ package body GNAT.Sockets is
end if;
end Finalize;
+ ---------
+ -- Get --
+ ---------
+
+ procedure Get
+ (Item : in out Socket_Set_Type;
+ Socket : out Socket_Type)
+ is
+ S : aliased C.int;
+ L : aliased C.int := C.int (Item.Last);
+
+ begin
+ if Item.Last /= No_Socket then
+ Get_Socket_From_Set
+ (Item.Set, L'Unchecked_Access, S'Unchecked_Access);
+ Item.Last := Socket_Type (L);
+ Socket := Socket_Type (S);
+ else
+ Socket := No_Socket;
+ end if;
+ end Get;
+
-----------------
-- Get_Address --
-----------------
@@ -720,7 +847,7 @@ package body GNAT.Sockets is
-- Translate from the C format to the API format
declare
- HE : Host_Entry_Type := To_Host_Entry (Res.all);
+ HE : constant Host_Entry_Type := To_Host_Entry (Res.all);
begin
Task_Lock.Unlock;
@@ -732,15 +859,18 @@ package body GNAT.Sockets is
-- Get_Host_By_Name --
----------------------
- function Get_Host_By_Name
- (Name : String)
- return Host_Entry_Type
- is
- HN : C.char_array := C.To_C (Name);
+ function Get_Host_By_Name (Name : String) return Host_Entry_Type is
+ HN : constant C.char_array := C.To_C (Name);
Res : Hostent_Access;
Err : Integer;
begin
+ -- Detect IP address name and redirect to Inet_Addr.
+
+ if Is_IP_Address (Name) then
+ return Get_Host_By_Address (Inet_Addr (Name));
+ end if;
+
-- This C function is not always thread-safe. Protect against
-- concurrent access.
@@ -756,7 +886,7 @@ package body GNAT.Sockets is
-- Translate from the C format to the API format
declare
- HE : Host_Entry_Type := To_Host_Entry (Res.all);
+ HE : constant Host_Entry_Type := To_Host_Entry (Res.all);
begin
Task_Lock.Unlock;
@@ -768,10 +898,7 @@ package body GNAT.Sockets is
-- Get_Peer_Name --
-------------------
- function Get_Peer_Name
- (Socket : Socket_Type)
- return Sock_Addr_Type
- is
+ function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is
Sin : aliased Sockaddr_In;
Len : aliased C.int := Sin'Size / 8;
Res : Sock_Addr_Type (Family_Inet);
@@ -782,11 +909,85 @@ package body GNAT.Sockets is
end if;
Res.Addr := To_Inet_Addr (Sin.Sin_Addr);
- Res.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
+ Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
return Res;
end Get_Peer_Name;
+ -------------------------
+ -- Get_Service_By_Name --
+ -------------------------
+
+ function Get_Service_By_Name
+ (Name : String;
+ Protocol : String)
+ return Service_Entry_Type
+ is
+ SN : constant C.char_array := C.To_C (Name);
+ SP : constant C.char_array := C.To_C (Protocol);
+ Res : Servent_Access;
+
+ begin
+ -- This C function is not always thread-safe. Protect against
+ -- concurrent access.
+
+ Task_Lock.Lock;
+ Res := C_Getservbyname (SN, SP);
+
+ if Res = null then
+ Task_Lock.Unlock;
+ Ada.Exceptions.Raise_Exception
+ (Service_Error'Identity, "Service not found");
+ end if;
+
+ -- Translate from the C format to the API format
+
+ declare
+ SE : constant Service_Entry_Type := To_Service_Entry (Res.all);
+
+ begin
+ Task_Lock.Unlock;
+ return SE;
+ end;
+ end Get_Service_By_Name;
+
+ -------------------------
+ -- Get_Service_By_Port --
+ -------------------------
+
+ function Get_Service_By_Port
+ (Port : Port_Type;
+ Protocol : String)
+ return Service_Entry_Type
+ is
+ SP : constant C.char_array := C.To_C (Protocol);
+ Res : Servent_Access;
+
+ begin
+ -- This C function is not always thread-safe. Protect against
+ -- concurrent access.
+
+ Task_Lock.Lock;
+ Res := C_Getservbyport
+ (C.int (Short_To_Network (C.unsigned_short (Port))), SP);
+
+ if Res = null then
+ Task_Lock.Unlock;
+ Ada.Exceptions.Raise_Exception
+ (Service_Error'Identity, "Service not found");
+ end if;
+
+ -- Translate from the C format to the API format
+
+ declare
+ SE : constant Service_Entry_Type := To_Service_Entry (Res.all);
+
+ begin
+ Task_Lock.Unlock;
+ return SE;
+ end;
+ end Get_Service_By_Port;
+
---------------------
-- Get_Socket_Name --
---------------------
@@ -795,19 +996,19 @@ package body GNAT.Sockets is
(Socket : Socket_Type)
return Sock_Addr_Type
is
- Sin : aliased Sockaddr_In;
- Len : aliased C.int := Sin'Size / 8;
- Res : Sock_Addr_Type (Family_Inet);
+ Sin : aliased Sockaddr_In;
+ Len : aliased C.int := Sin'Size / 8;
+ Res : C.int;
+ Addr : Sock_Addr_Type := No_Sock_Addr;
begin
- if C_Getsockname (C.int (Socket), Sin'Address, Len'Access) = Failure then
- Raise_Socket_Error (Socket_Errno);
+ Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access);
+ if Res /= Failure then
+ Addr.Addr := To_Inet_Addr (Sin.Sin_Addr);
+ Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
end if;
- Res.Addr := To_Inet_Addr (Sin.Sin_Addr);
- Res.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
-
- return Res;
+ return Addr;
end Get_Socket_Name;
-----------------------
@@ -942,7 +1143,7 @@ package body GNAT.Sockets is
procedure Img10 (V : Inet_Addr_Comp_Type) is
Img : constant String := V'Img;
- Len : Natural := Img'Length - 1;
+ Len : constant Natural := Img'Length - 1;
begin
Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last);
@@ -1055,20 +1256,39 @@ package body GNAT.Sockets is
function Is_Empty (Item : Socket_Set_Type) return Boolean is
begin
- return Item = null or else Is_Empty (Fd_Set (Item.all));
+ return Item.Last = No_Socket;
end Is_Empty;
+ -------------------
+ -- Is_IP_Address --
+ -------------------
+
+ function Is_IP_Address (Name : String) return Boolean is
+ begin
+ for J in Name'Range loop
+ if Name (J) /= '.'
+ and then Name (J) not in '0' .. '9'
+ then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end Is_IP_Address;
+
------------
-- Is_Set --
------------
function Is_Set
(Item : Socket_Set_Type;
- Socket : Socket_Type) return Boolean
+ Socket : Socket_Type)
+ return Boolean
is
begin
- return Item /= null
- and then Is_Set (Fd_Set (Item.all), C.int (Socket));
+ return Item.Last /= No_Socket
+ and then Socket <= Item.Last
+ and then Is_Socket_In_Set (Item.Set, C.int (Socket));
end Is_Set;
-------------------
@@ -1088,6 +1308,20 @@ package body GNAT.Sockets is
end if;
end Listen_Socket;
+ ------------
+ -- Narrow --
+ ------------
+
+ procedure Narrow (Item : in out Socket_Set_Type) is
+ Last : aliased C.int := C.int (Item.Last);
+
+ begin
+ if Item.Set /= No_Socket_Set then
+ Last_Socket_In_Set (Item.Set, Last'Unchecked_Access);
+ Item.Last := Socket_Type (Last);
+ end if;
+ end Narrow;
+
-------------------
-- Official_Name --
-------------------
@@ -1097,30 +1331,32 @@ package body GNAT.Sockets is
return To_String (E.Official);
end Official_Name;
- ---------------------
- -- Port_To_Network --
- ---------------------
+ -------------------
+ -- Official_Name --
+ -------------------
- function Port_To_Network
- (Port : C.unsigned_short)
- return C.unsigned_short
- is
- use type C.unsigned_short;
+ function Official_Name (S : Service_Entry_Type) return String is
begin
- if Default_Bit_Order = High_Order_First then
+ return To_String (S.Official);
+ end Official_Name;
- -- No conversion needed. On these platforms, htons() defaults
- -- to a null procedure.
+ -----------------
+ -- Port_Number --
+ -----------------
- return Port;
+ function Port_Number (S : Service_Entry_Type) return Port_Type is
+ begin
+ return S.Port;
+ end Port_Number;
- else
- -- We need to swap the high and low byte on this short to make
- -- the port number network compliant.
+ -------------------
+ -- Protocol_Name --
+ -------------------
- return (Port / 256) + (Port mod 256) * 256;
- end if;
- end Port_To_Network;
+ function Protocol_Name (S : Service_Entry_Type) return String is
+ begin
+ return To_String (S.Protocol);
+ end Protocol_Name;
----------------------
-- Raise_Host_Error --
@@ -1139,7 +1375,7 @@ package body GNAT.Sockets is
when Constants.HOST_NOT_FOUND => return "Host not found";
when Constants.TRY_AGAIN => return "Try again";
when Constants.NO_RECOVERY => return "No recovery";
- when Constants.NO_ADDRESS => return "No address";
+ when Constants.NO_DATA => return "No address";
when others => return "Unknown error";
end case;
end Error_Message;
@@ -1229,6 +1465,71 @@ package body GNAT.Sockets is
end loop;
end Read;
+ --------------------
+ -- Receive_Socket --
+ --------------------
+
+ procedure Receive_Socket
+ (Socket : Socket_Type;
+ Item : out Ada.Streams.Stream_Element_Array;
+ Last : out Ada.Streams.Stream_Element_Offset;
+ Flags : Request_Flag_Type := No_Request_Flag)
+ is
+ use type Ada.Streams.Stream_Element_Offset;
+
+ Res : C.int;
+
+ begin
+ Res := C_Recv
+ (C.int (Socket),
+ Item (Item'First)'Address,
+ Item'Length,
+ To_Int (Flags));
+
+ if Res = Failure then
+ Raise_Socket_Error (Socket_Errno);
+ end if;
+
+ Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
+ end Receive_Socket;
+
+ --------------------
+ -- Receive_Socket --
+ --------------------
+
+ procedure Receive_Socket
+ (Socket : Socket_Type;
+ Item : out Ada.Streams.Stream_Element_Array;
+ Last : out Ada.Streams.Stream_Element_Offset;
+ From : out Sock_Addr_Type;
+ Flags : Request_Flag_Type := No_Request_Flag)
+ is
+ use type Ada.Streams.Stream_Element_Offset;
+
+ Res : C.int;
+ Sin : aliased Sockaddr_In;
+ Len : aliased C.int := Sin'Size / 8;
+
+ begin
+ Res :=
+ C_Recvfrom
+ (C.int (Socket),
+ Item (Item'First)'Address,
+ Item'Length,
+ To_Int (Flags),
+ Sin'Unchecked_Access,
+ Len'Unchecked_Access);
+
+ if Res = Failure then
+ Raise_Socket_Error (Socket_Errno);
+ end if;
+
+ Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
+
+ From.Addr := To_Inet_Addr (Sin.Sin_Addr);
+ From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
+ end Receive_Socket;
+
-------------------
-- Resolve_Error --
-------------------
@@ -1243,15 +1544,17 @@ package body GNAT.Sockets is
begin
if not From_Errno then
case Error_Value is
- when HOST_NOT_FOUND => return Unknown_Host;
- when TRY_AGAIN => return Host_Name_Lookup_Failure;
- when NO_RECOVERY => return No_Address_Associated_With_Name;
- when NO_ADDRESS => return Unknown_Server_Error;
- when others => return Cannot_Resolve_Error;
+ when Constants.HOST_NOT_FOUND => return Unknown_Host;
+ when Constants.TRY_AGAIN => return Host_Name_Lookup_Failure;
+ when Constants.NO_RECOVERY =>
+ return Non_Recoverable_Error;
+ when Constants.NO_DATA => return Unknown_Server_Error;
+ when others => return Cannot_Resolve_Error;
end case;
end if;
case Error_Value is
+ when ENOERROR => return Success;
when EACCES => return Permission_Denied;
when EADDRINUSE => return Address_Already_In_Use;
when EADDRNOTAVAIL => return Cannot_Assign_Requested_Address;
@@ -1259,25 +1562,44 @@ package body GNAT.Sockets is
return Address_Family_Not_Supported_By_Protocol;
when EALREADY => return Operation_Already_In_Progress;
when EBADF => return Bad_File_Descriptor;
+ when ECONNABORTED => return Software_Caused_Connection_Abort;
when ECONNREFUSED => return Connection_Refused;
+ when ECONNRESET => return Connection_Reset_By_Peer;
+ when EDESTADDRREQ => return Destination_Address_Required;
when EFAULT => return Bad_Address;
+ when EHOSTDOWN => return Host_Is_Down;
+ when EHOSTUNREACH => return No_Route_To_Host;
when EINPROGRESS => return Operation_Now_In_Progress;
when EINTR => return Interrupted_System_Call;
when EINVAL => return Invalid_Argument;
when EIO => return Input_Output_Error;
when EISCONN => return Transport_Endpoint_Already_Connected;
+ when ELOOP => return Too_Many_Symbolic_Links;
+ when EMFILE => return Too_Many_Open_Files;
when EMSGSIZE => return Message_Too_Long;
+ when ENAMETOOLONG => return File_Name_Too_Long;
+ when ENETDOWN => return Network_Is_Down;
+ when ENETRESET =>
+ return Network_Dropped_Connection_Because_Of_Reset;
when ENETUNREACH => return Network_Is_Unreachable;
when ENOBUFS => return No_Buffer_Space_Available;
when ENOPROTOOPT => return Protocol_Not_Available;
when ENOTCONN => return Transport_Endpoint_Not_Connected;
+ when ENOTSOCK => return Socket_Operation_On_Non_Socket;
when EOPNOTSUPP => return Operation_Not_Supported;
+ when EPFNOSUPPORT => return Protocol_Family_Not_Supported;
when EPROTONOSUPPORT => return Protocol_Not_Supported;
+ when EPROTOTYPE => return Protocol_Wrong_Type_For_Socket;
+ when ESHUTDOWN =>
+ return Cannot_Send_After_Transport_Endpoint_Shutdown;
when ESOCKTNOSUPPORT => return Socket_Type_Not_Supported;
when ETIMEDOUT => return Connection_Timed_Out;
+ when ETOOMANYREFS => return Too_Many_References;
when EWOULDBLOCK => return Resource_Temporarily_Unavailable;
- when others => return Cannot_Resolve_Error;
+ when others => null;
end case;
+
+ return Cannot_Resolve_Error;
end Resolve_Error;
-----------------------
@@ -1286,11 +1608,11 @@ package body GNAT.Sockets is
function Resolve_Exception
(Occurrence : Exception_Occurrence)
- return Error_Type
+ return Error_Type
is
- Id : Exception_Id := Exception_Identity (Occurrence);
- Msg : constant String := Exception_Message (Occurrence);
- First : Natural := Msg'First;
+ Id : constant Exception_Id := Exception_Identity (Occurrence);
+ Msg : constant String := Exception_Message (Occurrence);
+ First : Natural := Msg'First;
Last : Natural;
Val : Integer;
@@ -1327,64 +1649,58 @@ package body GNAT.Sockets is
end Resolve_Exception;
--------------------
- -- Receive_Socket --
+ -- Receive_Vector --
--------------------
- procedure Receive_Socket
+ procedure Receive_Vector
(Socket : Socket_Type;
- Item : out Ada.Streams.Stream_Element_Array;
- Last : out Ada.Streams.Stream_Element_Offset)
+ Vector : Vector_Type;
+ Count : out Ada.Streams.Stream_Element_Count)
is
- use type Ada.Streams.Stream_Element_Offset;
-
Res : C.int;
begin
- Res := C_Recv
- (C.int (Socket),
- Item (Item'First)'Address,
- Item'Length, 0);
+ Res :=
+ C_Readv
+ (C.int (Socket),
+ Vector (Vector'First)'Address,
+ Vector'Length);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
- Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
- end Receive_Socket;
+ Count := Ada.Streams.Stream_Element_Count (Res);
+ end Receive_Vector;
- --------------------
- -- Receive_Socket --
- --------------------
+ -----------------
+ -- Send_Socket --
+ -----------------
- procedure Receive_Socket
+ procedure Send_Socket
(Socket : Socket_Type;
- Item : out Ada.Streams.Stream_Element_Array;
+ Item : Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset;
- From : out Sock_Addr_Type)
+ Flags : Request_Flag_Type := No_Request_Flag)
is
use type Ada.Streams.Stream_Element_Offset;
- Res : C.int;
- Sin : aliased Sockaddr_In;
- Len : aliased C.int := Sin'Size / 8;
+ Res : C.int;
begin
- Res := C_Recvfrom
- (C.int (Socket),
- Item (Item'First)'Address,
- Item'Length, 0,
- Sin'Unchecked_Access,
- Len'Unchecked_Access);
+ Res :=
+ C_Send
+ (C.int (Socket),
+ Item (Item'First)'Address,
+ Item'Length,
+ To_Int (Flags));
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
-
- From.Addr := To_Inet_Addr (Sin.Sin_Addr);
- From.Port := Port_Type (Network_To_Port (Sin.Sin_Port));
- end Receive_Socket;
+ end Send_Socket;
-----------------
-- Send_Socket --
@@ -1393,17 +1709,31 @@ package body GNAT.Sockets is
procedure Send_Socket
(Socket : Socket_Type;
Item : Ada.Streams.Stream_Element_Array;
- Last : out Ada.Streams.Stream_Element_Offset)
+ Last : out Ada.Streams.Stream_Element_Offset;
+ To : Sock_Addr_Type;
+ Flags : Request_Flag_Type := No_Request_Flag)
is
use type Ada.Streams.Stream_Element_Offset;
- Res : C.int;
+ Res : C.int;
+ Sin : aliased Sockaddr_In;
+ Len : constant C.int := Sin'Size / 8;
begin
- Res := C_Send
+ Set_Length (Sin'Unchecked_Access, Len);
+ Set_Family (Sin'Unchecked_Access, Families (To.Family));
+ Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr));
+ Set_Port
+ (Sin'Unchecked_Access,
+ Short_To_Network (C.unsigned_short (To.Port)));
+
+ Res := C_Sendto
(C.int (Socket),
Item (Item'First)'Address,
- Item'Length, 0);
+ Item'Length,
+ To_Int (Flags),
+ Sin'Unchecked_Access,
+ Len);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
@@ -1413,39 +1743,28 @@ package body GNAT.Sockets is
end Send_Socket;
-----------------
- -- Send_Socket --
+ -- Send_Vector --
-----------------
- procedure Send_Socket
+ procedure Send_Vector
(Socket : Socket_Type;
- Item : Ada.Streams.Stream_Element_Array;
- Last : out Ada.Streams.Stream_Element_Offset;
- To : Sock_Addr_Type)
+ Vector : Vector_Type;
+ Count : out Ada.Streams.Stream_Element_Count)
is
- use type Ada.Streams.Stream_Element_Offset;
-
Res : C.int;
- Sin : aliased Sockaddr_In;
- Len : aliased C.int := Sin'Size / 8;
-
begin
- Sin.Sin_Family := C.unsigned_short (Families (To.Family));
- Sin.Sin_Addr := To_In_Addr (To.Addr);
- Sin.Sin_Port := Port_To_Network (C.unsigned_short (To.Port));
-
- Res := C_Sendto
- (C.int (Socket),
- Item (Item'First)'Address,
- Item'Length, 0,
- Sin'Unchecked_Access,
- Len);
+ Res :=
+ C_Writev
+ (C.int (Socket),
+ Vector (Vector'First)'Address,
+ Vector'Length);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
- Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1);
- end Send_Socket;
+ Count := Ada.Streams.Stream_Element_Count (Res);
+ end Send_Vector;
---------
-- Set --
@@ -1453,11 +1772,15 @@ package body GNAT.Sockets is
procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is
begin
- if Item = null then
- Item := new Socket_Set_Record'(Socket_Set_Record (Null_Fd_Set));
+ if Item.Set = No_Socket_Set then
+ Item.Set := New_Socket_Set (No_Socket_Set);
+ Item.Last := Socket;
+
+ elsif Item.Last < Socket then
+ Item.Last := Socket;
end if;
- Set (Fd_Set (Item.all), C.int (Socket));
+ Insert_Socket_In_Set (Item.Set, C.int (Socket));
end Set;
-----------------------
@@ -1533,6 +1856,32 @@ package body GNAT.Sockets is
end if;
end Set_Socket_Option;
+ ----------------------
+ -- Short_To_Network --
+ ----------------------
+
+ function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is
+ use type C.unsigned_short;
+
+ begin
+ pragma Warnings (Off);
+
+ -- Big-endian case. No conversion needed. On these platforms,
+ -- htons() defaults to a null procedure.
+
+ if Default_Bit_Order = High_Order_First then
+ return S;
+
+ -- Little-endian case. We must swap the high and low bytes of this
+ -- short to make the port number network compliant.
+
+ else
+ return (S / 256) + (S mod 256) * 256;
+ end if;
+
+ pragma Warnings (On);
+ end Short_To_Network;
+
---------------------
-- Shutdown_Socket --
---------------------
@@ -1558,7 +1907,7 @@ package body GNAT.Sockets is
function Stream
(Socket : Socket_Type;
Send_To : Sock_Addr_Type)
- return Stream_Access
+ return Stream_Access
is
S : Datagram_Socket_Stream_Access;
@@ -1574,10 +1923,7 @@ package body GNAT.Sockets is
-- Stream --
------------
- function Stream
- (Socket : Socket_Type)
- return Stream_Access
- is
+ function Stream (Socket : Socket_Type) return Stream_Access is
S : Stream_Socket_Stream_Access;
begin
@@ -1599,22 +1945,19 @@ package body GNAT.Sockets is
-- To_Host_Entry --
-------------------
- function To_Host_Entry
- (Host : Hostent)
- return Host_Entry_Type
- is
+ function To_Host_Entry (E : Hostent) return Host_Entry_Type is
use type C.size_t;
Official : constant String :=
- C.Strings.Value (Host.H_Name);
+ C.Strings.Value (E.H_Name);
Aliases : constant Chars_Ptr_Array :=
- Chars_Ptr_Pointers.Value (Host.H_Aliases);
+ Chars_Ptr_Pointers.Value (E.H_Aliases);
-- H_Aliases points to a list of name aliases. The list is
-- terminated by a NULL pointer.
Addresses : constant In_Addr_Access_Array :=
- In_Addr_Access_Pointers.Value (Host.H_Addr_List);
+ In_Addr_Access_Pointers.Value (E.H_Addr_List);
-- H_Addr_List points to a list of binary addresses (in network
-- byte order). The list is terminated by a NULL pointer.
--
@@ -1630,13 +1973,13 @@ package body GNAT.Sockets is
Target : Natural;
begin
- Result.Official := To_Host_Name (Official);
+ Result.Official := To_Name (Official);
Source := Aliases'First;
Target := Result.Aliases'First;
while Target <= Result.Aliases_Length loop
Result.Aliases (Target) :=
- To_Host_Name (C.Strings.Value (Aliases (Source)));
+ To_Name (C.Strings.Value (Aliases (Source)));
Source := Source + 1;
Target := Target + 1;
end loop;
@@ -1653,15 +1996,6 @@ package body GNAT.Sockets is
return Result;
end To_Host_Entry;
- ------------------
- -- To_Host_Name --
- ------------------
-
- function To_Host_Name (N : String) return Host_Name_Type is
- begin
- return (N'Length, N);
- end To_Host_Name;
-
----------------
-- To_In_Addr --
----------------
@@ -1697,11 +2031,91 @@ package body GNAT.Sockets is
return Result;
end To_Inet_Addr;
+ ------------
+ -- To_Int --
+ ------------
+
+ function To_Int (F : Request_Flag_Type) return C.int
+ is
+ Current : Request_Flag_Type := F;
+ Result : C.int := 0;
+
+ begin
+ for J in Flags'Range loop
+ exit when Current = 0;
+
+ if Current mod 2 /= 0 then
+ if Flags (J) = -1 then
+ Raise_Socket_Error (Constants.EOPNOTSUPP);
+ end if;
+ Result := Result + Flags (J);
+ end if;
+
+ Current := Current / 2;
+ end loop;
+
+ return Result;
+ end To_Int;
+
+ -------------
+ -- To_Name --
+ -------------
+
+ function To_Name (N : String) return Name_Type is
+ begin
+ return Name_Type'(N'Length, N);
+ end To_Name;
+
+ ----------------------
+ -- To_Service_Entry --
+ ----------------------
+
+ function To_Service_Entry (E : Servent) return Service_Entry_Type is
+ use type C.size_t;
+
+ Official : constant String :=
+ C.Strings.Value (E.S_Name);
+
+ Aliases : constant Chars_Ptr_Array :=
+ Chars_Ptr_Pointers.Value (E.S_Aliases);
+ -- S_Aliases points to a list of name aliases. The list is
+ -- terminated by a NULL pointer.
+
+ Protocol : constant String :=
+ C.Strings.Value (E.S_Proto);
+
+ Result : Service_Entry_Type
+ (Aliases_Length => Aliases'Length - 1);
+ -- The last element is a null pointer.
+
+ Source : C.size_t;
+ Target : Natural;
+
+ begin
+ Result.Official := To_Name (Official);
+
+ Source := Aliases'First;
+ Target := Result.Aliases'First;
+ while Target <= Result.Aliases_Length loop
+ Result.Aliases (Target) :=
+ To_Name (C.Strings.Value (Aliases (Source)));
+ Source := Source + 1;
+ Target := Target + 1;
+ end loop;
+
+ Result.Port :=
+ Port_Type (Network_To_Short (C.unsigned_short (E.S_Port)));
+
+ Result.Protocol := To_Name (Protocol);
+
+ return Result;
+ end To_Service_Entry;
+
---------------
-- To_String --
---------------
- function To_String (HN : Host_Name_Type) return String is
+ function To_String (HN : Name_Type) return String is
begin
return HN.Name (1 .. HN.Length);
end To_String;
@@ -1710,11 +2124,13 @@ package body GNAT.Sockets is
-- To_Timeval --
----------------
- function To_Timeval (Val : Duration) return Timeval is
- S : Timeval_Unit := Timeval_Unit (Val);
- MS : Timeval_Unit := Timeval_Unit (1_000_000 * (Val - Duration (S)));
+ function To_Timeval (Val : Selector_Duration) return Timeval is
+ S : Timeval_Unit;
+ MS : Timeval_Unit;
begin
+ S := Timeval_Unit (Val - 0.5);
+ MS := Timeval_Unit (1_000_000 * (Val - Selector_Duration (S)));
return (S, MS);
end To_Timeval;
diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads
index 213de119c02..57a83743f1e 100644
--- a/gcc/ada/g-socket.ads
+++ b/gcc/ada/g-socket.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,311 +26,343 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
--- This package provides an interface to the sockets communication facility
--- provided on many operating systems. Currently this is implemented on all
--- native GNAT ports except for VMS. It is not yet implemented on the Lynx
--- cross-ports.
+-- This package provides an interface to the sockets communication
+-- facility provided on many operating systems. This is implemented
+-- on the following platforms:
--- Another restriction is that there is no multicast support under Windows
--- or under any system on which the multicast support is not available or
--- installed.
+-- All native ports, except Interix, with restrictions as follows
+
+-- Multicast is available only on systems which provide support
+-- for this feature, so it is not available if Multicast is not
+-- supported, or not installed. In particular Multicast is not
+-- available with the Windows version.
+
+-- The VMS implementation has implemented using the DECC RTL Socket
+-- API, and is thus subject to limitations in the implementation of
+-- this API.
+
+-- This package is not supported on the Interix port of GNAT.
+
+-- VxWorks cross ports fully implement this package.
+
+-- This package is not yet implemented on LynxOS.
with Ada.Exceptions;
with Ada.Streams;
+with System;
+
package GNAT.Sockets is
-- Sockets are designed to provide a consistent communication facility
- -- between applications. This package provides an Ada-like intrerface
- -- similar to that proposed as part of the BSD socket layer. This is a
- -- system independent thick binding.
+ -- between applications. This package provides an Ada-like interface
+ -- similar to that proposed as part of the BSD socket layer.
+
+ -- GNAT.Sockets has been designed with several ideas in mind.
+
+ -- This is a system independent interface. Therefore, we try as
+ -- much as possible to mask system incompatibilities. Some
+ -- functionalities are not available because there are not fully
+ -- supported on some systems.
+
+ -- This is a thick binding. For instance, a major effort has been
+ -- done to avoid using memory addresses or untyped ints. We
+ -- preferred to define streams and enumeration types. Errors are
+ -- not returned as returned values but as exceptions.
+
+ -- This package provides a POSIX-compliant interface (between two
+ -- different implementations of the same routine, we adopt the one
+ -- closest to the POSIX specification). For instance, using
+ -- select(), the notification of an asynchronous connect failure
+ -- is delivered in the write socket set (POSIX) instead of the
+ -- exception socket set (NT).
-- Here is a typical example of what you can do:
-- with GNAT.Sockets; use GNAT.Sockets;
- --
+
-- with Ada.Text_IO;
-- with Ada.Exceptions; use Ada.Exceptions;
- --
+
-- procedure PingPong is
- --
+
-- Group : constant String := "239.255.128.128";
- -- -- Multicast groupe: administratively scoped IP address
- --
+ -- -- Multicast group: administratively scoped IP address
+
-- task Pong is
-- entry Start;
-- entry Stop;
-- end Pong;
- --
+
-- task body Pong is
-- Address : Sock_Addr_Type;
-- Server : Socket_Type;
-- Socket : Socket_Type;
-- Channel : Stream_Access;
- --
+
-- begin
-- accept Start;
--
-- -- Get an Internet address of a host (here the local host name).
-- -- Note that a host can have several addresses. Here we get
-- -- the first one which is supposed to be the official one.
- --
+
-- Address.Addr := Addresses (Get_Host_By_Name (Host_Name), 1);
- --
+
-- -- Get a socket address that is an Internet address and a port
- --
- -- Address.Port := 5432;
- --
+
+ -- Address.Port := 5876;
+
-- -- The first step is to create a socket. Once created, this
-- -- socket must be associated to with an address. Usually only
-- -- a server (Pong here) needs to bind an address explicitly.
-- -- Most of the time clients can skip this step because the
-- -- socket routines will bind an arbitrary address to an unbound
-- -- socket.
- --
+
-- Create_Socket (Server);
- --
- -- -- Allow reuse of local addresses.
- --
+
+ -- -- Allow reuse of local addresses
+
-- Set_Socket_Option
-- (Server,
-- Socket_Level,
-- (Reuse_Address, True));
- --
+
-- Bind_Socket (Server, Address);
- --
- -- -- A server marks a socket as willing to receive connect events.
- --
+
+ -- -- A server marks a socket as willing to receive connect events
+
-- Listen_Socket (Server);
- --
+
-- -- Once a server calls Listen_Socket, incoming connects events
-- -- can be accepted. The returned Socket is a new socket that
-- -- represents the server side of the connection. Server remains
-- -- available to receive further connections.
- --
+
-- Accept_Socket (Server, Socket, Address);
- --
- -- -- Return a stream associated to the connected socket.
- --
+
+ -- -- Return a stream associated to the connected socket
+
-- Channel := Stream (Socket);
- --
+
-- -- Force Pong to block
- --
+
-- delay 0.2;
- --
- -- -- Receive and print message from client Ping.
- --
+
+ -- -- Receive and print message from client Ping
+
-- declare
-- Message : String := String'Input (Channel);
- --
+
-- begin
-- Ada.Text_IO.Put_Line (Message);
- --
- -- -- Send same message to server Pong.
- --
+
+ -- -- Send same message back to client Ping
+
-- String'Output (Channel, Message);
-- end;
- --
+
-- Close_Socket (Server);
-- Close_Socket (Socket);
- --
+
-- -- Part of the multicast example
- --
+
-- -- Create a datagram socket to send connectionless, unreliable
-- -- messages of a fixed maximum length.
- --
+
-- Create_Socket (Socket, Family_Inet, Socket_Datagram);
- --
- -- -- Allow reuse of local addresses.
- --
+
+ -- -- Allow reuse of local addresses
+
-- Set_Socket_Option
-- (Socket,
-- Socket_Level,
-- (Reuse_Address, True));
- --
- -- -- Join a multicast group.
- --
+
+ -- -- Join a multicast group
+
-- Set_Socket_Option
-- (Socket,
-- IP_Protocol_For_IP_Level,
-- (Add_Membership, Inet_Addr (Group), Any_Inet_Addr));
- --
+
-- -- Controls the live time of the datagram to avoid it being
-- -- looped forever due to routing errors. Routers decrement
-- -- the TTL of every datagram as it traverses from one network
-- -- to another and when its value reaches 0 the packet is
-- -- dropped. Default is 1.
- --
+
-- Set_Socket_Option
-- (Socket,
-- IP_Protocol_For_IP_Level,
-- (Multicast_TTL, 1));
- --
- -- -- Want the data you send to be looped back to your host.
- --
+
+ -- -- Want the data you send to be looped back to your host
+
-- Set_Socket_Option
-- (Socket,
-- IP_Protocol_For_IP_Level,
-- (Multicast_Loop, True));
- --
- -- -- If this socket is intended to receive messages, bind it to a
- -- -- given socket address.
- --
+
+ -- -- If this socket is intended to receive messages, bind it
+ -- -- to a given socket address.
+
-- Address.Addr := Any_Inet_Addr;
-- Address.Port := 55505;
- --
+
-- Bind_Socket (Socket, Address);
- --
+
-- -- If this socket is intended to send messages, provide the
-- -- receiver socket address.
- --
+
-- Address.Addr := Inet_Addr (Group);
-- Address.Port := 55506;
- --
+
-- Channel := Stream (Socket, Address);
- --
- -- -- Receive and print message from client Ping.
- --
+
+ -- -- Receive and print message from client Ping
+
-- declare
-- Message : String := String'Input (Channel);
- --
+
-- begin
- --
- -- -- Get the address of the sender.
- --
+ -- -- Get the address of the sender
+
-- Address := Get_Address (Channel);
-- Ada.Text_IO.Put_Line (Message & " from " & Image (Address));
- --
- -- -- Send same message to server Pong.
- --
+
+ -- -- Send same message back to client Ping
+
-- String'Output (Channel, Message);
-- end;
- --
+
-- Close_Socket (Socket);
- --
+
-- accept Stop;
- --
+
-- exception when E : others =>
-- Ada.Text_IO.Put_Line
-- (Exception_Name (E) & ": " & Exception_Message (E));
-- end Pong;
- --
+
-- task Ping is
-- entry Start;
-- entry Stop;
-- end Ping;
- --
+
-- task body Ping is
-- Address : Sock_Addr_Type;
-- Socket : Socket_Type;
-- Channel : Stream_Access;
- --
+
-- begin
-- accept Start;
- --
- -- -- See comments in Ping section for the first steps.
- --
+
+ -- -- See comments in Ping section for the first steps
+
-- Address.Addr := Addresses (Get_Host_By_Name (Host_Name), 1);
- -- Address.Port := 5432;
+ -- Address.Port := 5876;
-- Create_Socket (Socket);
- --
+
-- Set_Socket_Option
-- (Socket,
-- Socket_Level,
-- (Reuse_Address, True));
- --
+
-- -- Force Pong to block
- --
+
-- delay 0.2;
- --
+
-- -- If the client's socket is not bound, Connect_Socket will
-- -- bind to an unused address. The client uses Connect_Socket to
-- -- create a logical connection between the client's socket and
-- -- a server's socket returned by Accept_Socket.
- --
+
-- Connect_Socket (Socket, Address);
- --
+
-- Channel := Stream (Socket);
- --
+
-- -- Send message to server Pong.
- --
+
-- String'Output (Channel, "Hello world");
- --
+
-- -- Force Ping to block
- --
+
-- delay 0.2;
- --
- -- -- Receive and print message from server Pong.
- --
+
+ -- -- Receive and print message from server Pong
+
-- Ada.Text_IO.Put_Line (String'Input (Channel));
-- Close_Socket (Socket);
- --
- -- -- Part of multicast example. Code similar to Pong's one.
- --
+
+ -- -- Part of multicast example. Code similar to Pong's one
+
-- Create_Socket (Socket, Family_Inet, Socket_Datagram);
- --
+
-- Set_Socket_Option
-- (Socket,
-- Socket_Level,
-- (Reuse_Address, True));
- --
+
-- Set_Socket_Option
-- (Socket,
-- IP_Protocol_For_IP_Level,
-- (Add_Membership, Inet_Addr (Group), Any_Inet_Addr));
- --
+
-- Set_Socket_Option
-- (Socket,
-- IP_Protocol_For_IP_Level,
-- (Multicast_TTL, 1));
- --
+
-- Set_Socket_Option
-- (Socket,
-- IP_Protocol_For_IP_Level,
-- (Multicast_Loop, True));
- --
+
-- Address.Addr := Any_Inet_Addr;
-- Address.Port := 55506;
- --
+
-- Bind_Socket (Socket, Address);
- --
+
-- Address.Addr := Inet_Addr (Group);
-- Address.Port := 55505;
- --
+
-- Channel := Stream (Socket, Address);
- --
- -- -- Send message to server Pong.
- --
+
+ -- -- Send message to server Pong
+
-- String'Output (Channel, "Hello world");
- --
- -- -- Receive and print message from server Pong.
- --
+
+ -- -- Receive and print message from server Pong
+
-- declare
-- Message : String := String'Input (Channel);
- --
+
-- begin
-- Address := Get_Address (Channel);
-- Ada.Text_IO.Put_Line (Message & " from " & Image (Address));
-- end;
- --
+
-- Close_Socket (Socket);
- --
+
-- accept Stop;
- --
+
-- exception when E : others =>
-- Ada.Text_IO.Put_Line
-- (Exception_Name (E) & ": " & Exception_Message (E));
-- end Ping;
- --
+
-- begin
-- -- Indicate whether the thread library provides process
-- -- blocking IO. Basically, if you are not using FSU threads
-- -- the default is ok.
- --
+
-- Initialize (Process_Blocking_IO => False);
-- Ping.Start;
-- Pong.Start;
@@ -340,11 +372,18 @@ package GNAT.Sockets is
-- end PingPong;
procedure Initialize (Process_Blocking_IO : Boolean := False);
- -- Initialize must be called before using any socket routines. If
- -- the thread library provides process blocking IO - basically
- -- with FSU threads - GNAT.Sockets should be initialized with a
- -- value of True to simulate thread blocking IO. Further calls to
- -- Initialize will be ignored.
+ -- Initialize must be called before using any other socket routines.
+ -- The Process_Blocking_IO parameter indicates whether the thread
+ -- library provides process-blocking or thread-blocking input/output
+ -- operations. In the former case (typically with FSU threads)
+ -- GNAT.Sockets should be initialized with a value of True to
+ -- provide task-blocking IO through an emulation mechanism.
+ -- Only the first call to Initialize is taken into account (further
+ -- calls will be ignored). Note that with the default value
+ -- of Process_Blocking_IO, this operation is a no-op on UNIX
+ -- platforms, but applications should make sure to call it
+ -- if portability is expected: some platforms (such as Windows)
+ -- require initialization before any other socket operations.
procedure Finalize;
-- After Finalize is called it is not possible to use any routines
@@ -431,7 +470,7 @@ package GNAT.Sockets is
-- Convert address image from numbers-and-dots notation into an
-- inet address.
- -- Host entries provide a complete information on a given host:
+ -- Host entries provide complete information on a given host:
-- the official name, an array of alternative names or aliases and
-- array of network addresses.
@@ -473,11 +512,50 @@ package GNAT.Sockets is
function Get_Host_By_Name
(Name : String)
return Host_Entry_Type;
- -- Return host entry structure for the given host name
+ -- Return host entry structure for the given host name. Here name
+ -- is either a host name, or an IP address.
function Host_Name return String;
-- Return the name of the current host
+ -- Service entries provide complete information on a given
+ -- service: the official name, an array of alternative names or
+ -- aliases and the port number.
+
+ type Service_Entry_Type (Aliases_Length : Natural) is private;
+
+ function Official_Name (S : Service_Entry_Type) return String;
+ -- Return official name in service entry
+
+ function Port_Number (S : Service_Entry_Type) return Port_Type;
+ -- Return port number in service entry
+
+ function Protocol_Name (S : Service_Entry_Type) return String;
+ -- Return Protocol in service entry (usually UDP or TCP)
+
+ function Aliases_Length (S : Service_Entry_Type) return Natural;
+ -- Return number of aliases in service entry
+
+ function Aliases
+ (S : Service_Entry_Type;
+ N : Positive := 1)
+ return String;
+ -- Return N'th aliases in service entry. The first index is 1.
+
+ function Get_Service_By_Name
+ (Name : String;
+ Protocol : String)
+ return Service_Entry_Type;
+ -- Return service entry structure for the given service name
+
+ function Get_Service_By_Port
+ (Port : Port_Type;
+ Protocol : String)
+ return Service_Entry_Type;
+ -- Return service entry structure for the given service port number
+
+ Service_Error : exception;
+
-- Errors are described by an enumeration type. There is only one
-- exception Socket_Error in this package to deal with an error
-- during a socket routine. Once raised, its message contains the
@@ -486,32 +564,48 @@ package GNAT.Sockets is
-- The name of the enumeration constant documents the error condition.
type Error_Type is
- (Permission_Denied,
+ (Success,
+ Permission_Denied,
Address_Already_In_Use,
Cannot_Assign_Requested_Address,
Address_Family_Not_Supported_By_Protocol,
Operation_Already_In_Progress,
Bad_File_Descriptor,
+ Software_Caused_Connection_Abort,
Connection_Refused,
+ Connection_Reset_By_Peer,
+ Destination_Address_Required,
Bad_Address,
+ Host_Is_Down,
+ No_Route_To_Host,
Operation_Now_In_Progress,
Interrupted_System_Call,
Invalid_Argument,
Input_Output_Error,
Transport_Endpoint_Already_Connected,
+ Too_Many_Symbolic_Links,
+ Too_Many_Open_Files,
Message_Too_Long,
+ File_Name_Too_Long,
+ Network_Is_Down,
+ Network_Dropped_Connection_Because_Of_Reset,
Network_Is_Unreachable,
No_Buffer_Space_Available,
Protocol_Not_Available,
Transport_Endpoint_Not_Connected,
+ Socket_Operation_On_Non_Socket,
Operation_Not_Supported,
+ Protocol_Family_Not_Supported,
Protocol_Not_Supported,
+ Protocol_Wrong_Type_For_Socket,
+ Cannot_Send_After_Transport_Endpoint_Shutdown,
Socket_Type_Not_Supported,
Connection_Timed_Out,
+ Too_Many_References,
Resource_Temporarily_Unavailable,
Unknown_Host,
Host_Name_Lookup_Failure,
- No_Address_Associated_With_Name,
+ Non_Recoverable_Error,
Unknown_Server_Error,
Cannot_Resolve_Error);
@@ -541,7 +635,7 @@ package GNAT.Sockets is
No_Delay, -- Do not delay send to coalesce packets (TCP_NODELAY)
Add_Membership, -- Join a multicast group
Drop_Membership, -- Leave a multicast group
- Multicast_TTL, -- Indicates the time-to-live of sent multicast packets
+ Multicast_TTL, -- Indicate the time-to-live of sent multicast packets
Multicast_Loop); -- Sent multicast packets are looped to the local socket
type Option_Type (Name : Option_Name := Keep_Alive) is record
@@ -599,11 +693,53 @@ package GNAT.Sockets is
end case;
end record;
+ -- A request flag allows to specify the type of message
+ -- transmissions or receptions. A request flag can be a
+ -- combination of zero or more predefined request flags.
+
+ type Request_Flag_Type is private;
+
+ No_Request_Flag : constant Request_Flag_Type;
+ -- This flag corresponds to the normal execution of an operation.
+
+ Process_Out_Of_Band_Data : constant Request_Flag_Type;
+ -- This flag requests that the receive or send function operates
+ -- on out-of-band data when the socket supports this notion (e.g.
+ -- Socket_Stream).
+
+ Peek_At_Incoming_Data : constant Request_Flag_Type;
+ -- This flag causes the receive operation to return data from the
+ -- beginning of the receive queue without removing that data from
+ -- the queue. A subsequent receive call will return the same data.
+
+ Wait_For_A_Full_Reception : constant Request_Flag_Type;
+ -- This flag requests that the operation block until the full
+ -- request is satisfied. However, the call may still return less
+ -- data than requested if a signal is caught, an error or
+ -- disconnect occurs, or the next data to be received is of a dif-
+ -- ferent type than that returned.
+
+ Send_End_Of_Record : constant Request_Flag_Type;
+ -- This flag indicates that the entire message has been sent and
+ -- so this terminates the record.
+
+ function "+" (L, R : Request_Flag_Type) return Request_Flag_Type;
+ -- Combine flag L with flag R
+
+ type Stream_Element_Reference is access all Ada.Streams.Stream_Element;
+
+ type Vector_Element is record
+ Base : Stream_Element_Reference;
+ Length : Ada.Streams.Stream_Element_Count;
+ end record;
+
+ type Vector_Type is array (Integer range <>) of Vector_Element;
+
procedure Create_Socket
(Socket : out Socket_Type;
Family : Family_Type := Family_Inet;
Mode : Mode_Type := Socket_Stream);
- -- Create an endpoint for communication. Raise Socket_Error on error.
+ -- Create an endpoint for communication. Raises Socket_Error on error.
procedure Accept_Socket
(Server : Socket_Type;
@@ -613,7 +749,7 @@ package GNAT.Sockets is
-- connections, creates a new connected socket with mostly the
-- same properties as Server, and allocates a new socket. The
-- returned Address is filled in with the address of the
- -- connection. Raise Socket_Error on error.
+ -- connection. Raises Socket_Error on error.
procedure Bind_Socket
(Socket : Socket_Type;
@@ -628,30 +764,31 @@ package GNAT.Sockets is
(Socket : Socket_Type;
Server : in out Sock_Addr_Type);
-- Make a connection to another socket which has the address of
- -- Server. Raise Socket_Error on error.
+ -- Server. Raises Socket_Error on error.
procedure Control_Socket
(Socket : Socket_Type;
Request : in out Request_Type);
-- Obtain or set parameter values that control the socket. This
-- control differs from the socket options in that they are not
- -- specific to sockets but are avaiable for any device.
+ -- specific to sockets but are available for any device.
function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type;
-- Return the peer or remote socket address of a socket. Raise
-- Socket_Error on error.
function Get_Socket_Name (Socket : Socket_Type) return Sock_Addr_Type;
- -- Return the local or current socket address of a socket. Raise
- -- Socket_Error on error.
+ -- Return the local or current socket address of a socket. Return
+ -- No_Sock_Addr on error (for instance, socket closed or not
+ -- locally bound).
function Get_Socket_Option
(Socket : Socket_Type;
Level : Level_Type := Socket_Level;
Name : Option_Name)
return Option_Type;
- -- Get the options associated with a socket. Raise Socket_Error on
- -- error.
+ -- Get the options associated with a socket. Raises Socket_Error
+ -- on error.
procedure Listen_Socket
(Socket : Socket_Type;
@@ -664,26 +801,36 @@ package GNAT.Sockets is
procedure Receive_Socket
(Socket : Socket_Type;
Item : out Ada.Streams.Stream_Element_Array;
- Last : out Ada.Streams.Stream_Element_Offset);
+ Last : out Ada.Streams.Stream_Element_Offset;
+ Flags : Request_Flag_Type := No_Request_Flag);
-- Receive message from Socket. Last is the index value such that
-- Item (Last) is the last character assigned. Note that Last is
-- set to Item'First - 1 when the socket has been closed by
- -- peer. This is not an error and no exception is raised. Raise
- -- Socket_Error on error.
+ -- peer. This is not an error and no exception is raised. Flags
+ -- allows to control the reception. Raise Socket_Error on error.
procedure Receive_Socket
(Socket : Socket_Type;
Item : out Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset;
- From : out Sock_Addr_Type);
+ From : out Sock_Addr_Type;
+ Flags : Request_Flag_Type := No_Request_Flag);
-- Receive message from Socket. If Socket is not
-- connection-oriented, the source address From of the message is
-- filled in. Last is the index value such that Item (Last) is the
- -- last character assigned. Raise Socket_Error on error.
+ -- last character assigned. Flags allows to control the
+ -- reception. Raises Socket_Error on error.
+
+ procedure Receive_Vector
+ (Socket : Socket_Type;
+ Vector : Vector_Type;
+ Count : out Ada.Streams.Stream_Element_Count);
+ -- Receive data from a socket and scatter it into the set of vector
+ -- elements Vector. Count is set to the count of received stream elements.
function Resolve_Exception
(Occurrence : Ada.Exceptions.Exception_Occurrence)
- return Error_Type;
+ return Error_Type;
-- When Socket_Error or Host_Error are raised, the exception
-- message contains the error code between brackets and a string
-- describing the error code. Resolve_Error extracts the error
@@ -693,24 +840,36 @@ package GNAT.Sockets is
procedure Send_Socket
(Socket : Socket_Type;
Item : Ada.Streams.Stream_Element_Array;
- Last : out Ada.Streams.Stream_Element_Offset);
+ Last : out Ada.Streams.Stream_Element_Offset;
+ Flags : Request_Flag_Type := No_Request_Flag);
-- Transmit a message to another socket. Note that Last is set to
- -- Item'First when socket has been closed by peer. This is not an
- -- error and no exception is raised. Raise Socket_Error on error;
+ -- Item'First-1 when socket has been closed by peer. This is not
+ -- considered an error and no exception is raised. Flags allows to
+ -- control the transmission. Raises Socket_Error on any other
+ -- error condition.
procedure Send_Socket
(Socket : Socket_Type;
Item : Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset;
- To : Sock_Addr_Type);
+ To : Sock_Addr_Type;
+ Flags : Request_Flag_Type := No_Request_Flag);
-- Transmit a message to another socket. The address is given by
- -- To. Raise Socket_Error on error;
+ -- To. Flags allows to control the transmission. Raises
+ -- Socket_Error on error.
+
+ procedure Send_Vector
+ (Socket : Socket_Type;
+ Vector : Vector_Type;
+ Count : out Ada.Streams.Stream_Element_Count);
+ -- Transmit data gathered from the set of vector elements Vector to a
+ -- socket. Count is set to the count of transmitted stream elements.
procedure Set_Socket_Option
(Socket : Socket_Type;
Level : Level_Type := Socket_Level;
Option : Option_Type);
- -- Manipulate socket options. Raise Socket_Error on error.
+ -- Manipulate socket options. Raises Socket_Error on error.
procedure Shutdown_Socket
(Socket : Socket_Type;
@@ -739,11 +898,11 @@ package GNAT.Sockets is
function Get_Address
(Stream : Stream_Access)
- return Sock_Addr_Type;
+ return Sock_Addr_Type;
-- Return the socket address from which the last message was
-- received.
- type Socket_Set_Type is private;
+ type Socket_Set_Type is limited private;
-- This type allows to manipulate sets of sockets. It allows to
-- wait for events on multiple endpoints at one time. This is an
-- access type on a system dependent structure. To avoid memory
@@ -753,14 +912,18 @@ package GNAT.Sockets is
procedure Clear (Item : in out Socket_Set_Type; Socket : Socket_Type);
-- Remove Socket from Item
- procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type);
- -- Insert Socket into Item
+ procedure Copy (Source : Socket_Set_Type; Target : in out Socket_Set_Type);
+ -- Copy Source into Target as Socket_Set_Type is limited private
procedure Empty (Item : in out Socket_Set_Type);
-- Remove all Sockets from Item and deallocate internal data
+ procedure Get (Item : in out Socket_Set_Type; Socket : out Socket_Type);
+ -- Extract a Socket from socket set Item. Socket is set to
+ -- No_Socket when the set is empty.
+
function Is_Empty
- (Item : Socket_Set_Type)
+ (Item : Socket_Set_Type)
return Boolean;
-- Return True if Item is empty
@@ -770,6 +933,9 @@ package GNAT.Sockets is
return Boolean;
-- Return True if Socket is present in Item
+ procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type);
+ -- Insert Socket into Item
+
-- C select() waits for a number of file descriptors to change
-- status. Usually, three independent sets of descriptors are
-- watched (read, write and exception). A timeout gives an upper
@@ -790,11 +956,19 @@ package GNAT.Sockets is
-- abort a select operation is typically to add a socket in one of
-- the socket sets when the timeout is set to forever.
- Forever : constant Duration;
-
type Selector_Type is limited private;
type Selector_Access is access all Selector_Type;
+ -- Selector_Duration is a subtype of Standard.Duration because the
+ -- full range of Standard.Duration cannot be represented in the
+ -- equivalent C structure. Moreover, negative values are not
+ -- allowed to avoid system incompatibilities.
+
+ Immediate : constant := 0.0;
+ Forever : constant := Duration (Integer'Last) * 1.0;
+
+ subtype Selector_Duration is Duration range Immediate .. Forever;
+
procedure Create_Selector (Selector : out Selector_Type);
-- Create a new selector
@@ -808,7 +982,7 @@ package GNAT.Sockets is
R_Socket_Set : in out Socket_Set_Type;
W_Socket_Set : in out Socket_Set_Type;
Status : out Selector_Status;
- Timeout : Duration := Forever);
+ Timeout : Selector_Duration := Forever);
-- Return when one Socket in R_Socket_Set has some data to be read
-- or if one Socket in W_Socket_Set is ready to receive some
-- data. In these cases Status is set to Completed and sockets
@@ -818,7 +992,21 @@ package GNAT.Sockets is
-- received while checking socket status. As this procedure
-- returns when Timeout occurs, it is a design choice to keep this
-- procedure process blocking. Note that a Timeout of 0.0 returns
- -- immediatly.
+ -- immediately. Also note that two different objects must be passed
+ -- as R_Socket_Set and W_Socket_Set (even if they contain the same
+ -- set of Sockets), or some event will be lost.
+
+ procedure Check_Selector
+ (Selector : in out Selector_Type;
+ R_Socket_Set : in out Socket_Set_Type;
+ W_Socket_Set : in out Socket_Set_Type;
+ E_Socket_Set : in out Socket_Set_Type;
+ Status : out Selector_Status;
+ Timeout : Selector_Duration := Forever);
+ -- This refined version of Check_Selector allows to watch for
+ -- exception events (that is notifications of out-of-band
+ -- transmission and reception). As above, all of R_Socket_Set,
+ -- W_Socket_Set and E_Socket_Set must be different objects.
procedure Abort_Selector (Selector : Selector_Type);
-- Send an abort signal to the selector.
@@ -828,18 +1016,23 @@ private
type Socket_Type is new Integer;
No_Socket : constant Socket_Type := -1;
- Forever : constant Duration := Duration'Last;
-
type Selector_Type is limited record
R_Sig_Socket : Socket_Type;
W_Sig_Socket : Socket_Type;
- In_Progress : Boolean := False;
end record;
+
+ pragma Volatile (Selector_Type);
+
-- The two signalling sockets are used to abort a select
-- operation.
- type Socket_Set_Record;
- type Socket_Set_Type is access all Socket_Set_Record;
+ subtype Socket_Set_Access is System.Address;
+ No_Socket_Set : constant Socket_Set_Access := System.Null_Address;
+
+ type Socket_Set_Type is record
+ Last : Socket_Type := No_Socket;
+ Set : Socket_Set_Access := No_Socket_Set;
+ end record;
subtype Inet_Addr_Comp_Type is Natural range 0 .. 255;
-- Octet for Internet address
@@ -867,25 +1060,39 @@ private
No_Sock_Addr : constant Sock_Addr_Type := (Family_Inet, No_Inet_Addr, 0);
- Max_Host_Name_Length : constant := 64;
+ Max_Name_Length : constant := 64;
-- The constant MAXHOSTNAMELEN is usually set to 64
- subtype Host_Name_Index is Natural range 1 .. Max_Host_Name_Length;
+ subtype Name_Index is Natural range 1 .. Max_Name_Length;
- type Host_Name_Type
- (Length : Host_Name_Index := Max_Host_Name_Length)
+ type Name_Type
+ (Length : Name_Index := Max_Name_Length)
is record
Name : String (1 .. Length);
end record;
-- We need fixed strings to avoid access types in host entry type
- type Host_Name_Array is array (Natural range <>) of Host_Name_Type;
+ type Name_Array is array (Natural range <>) of Name_Type;
type Inet_Addr_Array is array (Natural range <>) of Inet_Addr_Type;
type Host_Entry_Type (Aliases_Length, Addresses_Length : Natural) is record
- Official : Host_Name_Type;
- Aliases : Host_Name_Array (1 .. Aliases_Length);
+ Official : Name_Type;
+ Aliases : Name_Array (1 .. Aliases_Length);
Addresses : Inet_Addr_Array (1 .. Addresses_Length);
end record;
+ type Service_Entry_Type (Aliases_Length : Natural) is record
+ Official : Name_Type;
+ Aliases : Name_Array (1 .. Aliases_Length);
+ Port : Port_Type;
+ Protocol : Name_Type;
+ end record;
+
+ type Request_Flag_Type is mod 2 ** 8;
+ No_Request_Flag : constant Request_Flag_Type := 0;
+ Process_Out_Of_Band_Data : constant Request_Flag_Type := 1;
+ Peek_At_Incoming_Data : constant Request_Flag_Type := 2;
+ Wait_For_A_Full_Reception : constant Request_Flag_Type := 4;
+ Send_End_Of_Record : constant Request_Flag_Type := 8;
+
end GNAT.Sockets;
diff --git a/gcc/ada/g-socthi.adb b/gcc/ada/g-socthi.adb
index d39d8389cd1..2c337e00ea2 100644
--- a/gcc/ada/g-socthi.adb
+++ b/gcc/ada/g-socthi.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,36 +26,39 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+-- This package provides a target dependent thin interface to the sockets
+-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
+-- should not be directly with'ed by an applications program.
+
+-- This is the default version
+
with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Task_Lock;
with Interfaces.C; use Interfaces.C;
package body GNAT.Sockets.Thin is
+ Non_Blocking_Sockets : constant Fd_Set_Access
+ := New_Socket_Set (No_Socket_Set);
-- When this package is initialized with Process_Blocking_IO set
-- to True, sockets are set in non-blocking mode to avoid blocking
-- the whole process when a thread wants to perform a blocking IO
- -- operation. But the user can set a socket in non-blocking mode
- -- by purpose. We track the socket in such a mode by redefining
- -- C_Ioctl. In blocking IO operations, we exit normally when the
- -- non-blocking flag is set by user, we poll and try later when
- -- this flag is set automatically by this package.
-
- type Socket_Info is record
- Non_Blocking : Boolean := False;
- end record;
-
- Table : array (C.int range 0 .. 31) of Socket_Info;
- -- Get info on blocking flag. This array is limited to 32 sockets
- -- because the select operation allows socket set of less then 32
- -- sockets.
+ -- operation. But the user can also set a socket in non-blocking
+ -- mode by purpose. In order to make a difference between these
+ -- two situations, we track the origin of non-blocking mode in
+ -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has
+ -- been set in non-blocking mode by the user.
Quantum : constant Duration := 0.2;
- -- comment needed ???
+ -- When Thread_Blocking_IO is False, we set sockets in
+ -- non-blocking mode and we spend a period of time Quantum between
+ -- two attempts on a blocking operation.
Thread_Blocking_IO : Boolean := True;
@@ -121,7 +124,8 @@ package body GNAT.Sockets.Thin is
return C.int;
pragma Import (C, Syscall_Socket, "socket");
- procedure Set_Non_Blocking (S : C.int);
+ function Non_Blocking_Socket (S : C.int) return Boolean;
+ procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
--------------
-- C_Accept --
@@ -133,29 +137,34 @@ package body GNAT.Sockets.Thin is
Addrlen : access C.int)
return C.int
is
- Res : C.int;
+ R : C.int;
+ Val : aliased C.int := 1;
+
+ Discard : C.int;
+ pragma Warnings (Off, Discard);
begin
loop
- Res := Syscall_Accept (S, Addr, Addrlen);
+ R := Syscall_Accept (S, Addr, Addrlen);
exit when Thread_Blocking_IO
- or else Res /= Failure
- or else Table (S).Non_Blocking
+ or else R /= Failure
+ or else Non_Blocking_Socket (S)
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
if not Thread_Blocking_IO
- and then Res /= Failure
+ and then R /= Failure
then
-- A socket inherits the properties ot its server especially
- -- the FNDELAY flag.
+ -- the FIONBIO flag. Do not use C_Ioctl as this subprogram
+ -- tracks sockets set in non-blocking mode by user.
- Table (Res).Non_Blocking := Table (S).Non_Blocking;
- Set_Non_Blocking (Res);
+ Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
+ Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
end if;
- return Res;
+ return R;
end C_Accept;
---------------
@@ -175,33 +184,39 @@ package body GNAT.Sockets.Thin is
if Thread_Blocking_IO
or else Res /= Failure
- or else Table (S).Non_Blocking
+ or else Non_Blocking_Socket (S)
or else Errno /= Constants.EINPROGRESS
then
return Res;
end if;
declare
- Set : aliased Fd_Set;
- Now : aliased Timeval;
+ WSet : Fd_Set_Access;
+ Now : aliased Timeval;
begin
+ WSet := New_Socket_Set (No_Socket_Set);
loop
- Set := 2 ** Natural (S);
+ Insert_Socket_In_Set (WSet, S);
Now := Immediat;
Res := C_Select
(S + 1,
- null, Set'Unchecked_Access,
- null, Now'Unchecked_Access);
+ No_Fd_Set,
+ WSet,
+ No_Fd_Set,
+ Now'Unchecked_Access);
exit when Res > 0;
if Res = Failure then
+ Free_Socket_Set (WSet);
return Res;
end if;
delay Quantum;
end loop;
+
+ Free_Socket_Set (WSet);
end;
Res := Syscall_Connect (S, Name, Namelen);
@@ -229,7 +244,9 @@ package body GNAT.Sockets.Thin is
if not Thread_Blocking_IO
and then Req = Constants.FIONBIO
then
- Table (S).Non_Blocking := (Arg.all /= 0);
+ if Arg.all /= 0 then
+ Set_Non_Blocking_Socket (S, True);
+ end if;
end if;
return Syscall_Ioctl (S, Req, Arg);
@@ -253,7 +270,7 @@ package body GNAT.Sockets.Thin is
Res := Syscall_Recv (S, Msg, Len, Flags);
exit when Thread_Blocking_IO
or else Res /= Failure
- or else Table (S).Non_Blocking
+ or else Non_Blocking_Socket (S)
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
@@ -281,7 +298,7 @@ package body GNAT.Sockets.Thin is
Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
exit when Thread_Blocking_IO
or else Res /= Failure
- or else Table (S).Non_Blocking
+ or else Non_Blocking_Socket (S)
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
@@ -307,7 +324,7 @@ package body GNAT.Sockets.Thin is
Res := Syscall_Send (S, Msg, Len, Flags);
exit when Thread_Blocking_IO
or else Res /= Failure
- or else Table (S).Non_Blocking
+ or else Non_Blocking_Socket (S)
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
@@ -335,7 +352,7 @@ package body GNAT.Sockets.Thin is
Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
exit when Thread_Blocking_IO
or else Res /= Failure
- or else Table (S).Non_Blocking
+ or else Non_Blocking_Socket (S)
or else Errno /= Constants.EWOULDBLOCK;
delay Quantum;
end loop;
@@ -353,44 +370,27 @@ package body GNAT.Sockets.Thin is
Protocol : C.int)
return C.int
is
- Res : C.int;
+ R : C.int;
+ Val : aliased C.int := 1;
+
+ Discard : C.int;
+ pragma Unreferenced (Discard);
begin
- Res := Syscall_Socket (Domain, Typ, Protocol);
+ R := Syscall_Socket (Domain, Typ, Protocol);
if not Thread_Blocking_IO
- and then Res /= Failure
+ and then R /= Failure
then
- Set_Non_Blocking (Res);
- end if;
-
- return Res;
- end C_Socket;
-
- -----------
- -- Clear --
- -----------
+ -- Do not use C_Ioctl as this subprogram tracks sockets set
+ -- in non-blocking mode by user.
- procedure Clear
- (Item : in out Fd_Set;
- Socket : in C.int)
- is
- Mask : constant Fd_Set := 2 ** Natural (Socket);
-
- begin
- if (Item and Mask) /= 0 then
- Item := Item xor Mask;
+ Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access);
+ Set_Non_Blocking_Socket (R, False);
end if;
- end Clear;
- -----------
- -- Empty --
- -----------
-
- procedure Empty (Item : in out Fd_Set) is
- begin
- Item := 0;
- end Empty;
+ return R;
+ end C_Socket;
--------------
-- Finalize --
@@ -410,65 +410,87 @@ package body GNAT.Sockets.Thin is
Thread_Blocking_IO := not Process_Blocking_IO;
end Initialize;
- --------------
- -- Is_Empty --
- --------------
+ -------------------------
+ -- Non_Blocking_Socket --
+ -------------------------
+
+ function Non_Blocking_Socket (S : C.int) return Boolean is
+ R : Boolean;
- function Is_Empty (Item : Fd_Set) return Boolean is
begin
- return Item = 0;
- end Is_Empty;
+ Task_Lock.Lock;
+ R := Is_Socket_In_Set (Non_Blocking_Sockets, S);
+ Task_Lock.Unlock;
+ return R;
+ end Non_Blocking_Socket;
+
+ -----------------
+ -- Set_Address --
+ -----------------
+
+ procedure Set_Address
+ (Sin : Sockaddr_In_Access;
+ Address : In_Addr)
+ is
+ begin
+ Sin.Sin_Addr := Address;
+ end Set_Address;
- ------------
- -- Is_Set --
- ------------
+ ----------------
+ -- Set_Family --
+ ----------------
- function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean is
+ procedure Set_Family
+ (Sin : Sockaddr_In_Access;
+ Family : C.int)
+ is
begin
- return (Item and 2 ** Natural (Socket)) /= 0;
- end Is_Set;
+ Sin.Sin_Family := C.unsigned_short (Family);
+ end Set_Family;
- ---------
- -- Max --
- ---------
+ ----------------
+ -- Set_Length --
+ ----------------
- function Max (Item : Fd_Set) return C.int
+ procedure Set_Length
+ (Sin : Sockaddr_In_Access;
+ Len : C.int)
is
- L : C.int := -1;
- C : Fd_Set := Item;
+ pragma Unreferenced (Sin);
+ pragma Unreferenced (Len);
begin
- while C /= 0 loop
- L := L + 1;
- C := C / 2;
- end loop;
- return L;
- end Max;
+ null;
+ end Set_Length;
- ---------
- -- Set --
- ---------
+ -----------------------------
+ -- Set_Non_Blocking_Socket --
+ -----------------------------
- procedure Set (Item : in out Fd_Set; Socket : in C.int) is
+ procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
begin
- Item := Item or 2 ** Natural (Socket);
- end Set;
-
- ----------------------
- -- Set_Non_Blocking --
- ----------------------
+ Task_Lock.Lock;
- procedure Set_Non_Blocking (S : C.int) is
- Res : C.int;
- Val : aliased C.int := 1;
+ if V then
+ Insert_Socket_In_Set (Non_Blocking_Sockets, S);
+ else
+ Remove_Socket_From_Set (Non_Blocking_Sockets, S);
+ end if;
- begin
+ Task_Lock.Unlock;
+ end Set_Non_Blocking_Socket;
- -- Do not use C_Fcntl because this subprogram tracks the
- -- sockets set by user in non-blocking mode.
+ --------------
+ -- Set_Port --
+ --------------
- Res := Syscall_Ioctl (S, Constants.FIONBIO, Val'Unchecked_Access);
- end Set_Non_Blocking;
+ procedure Set_Port
+ (Sin : Sockaddr_In_Access;
+ Port : C.unsigned_short)
+ is
+ begin
+ Sin.Sin_Port := Port;
+ end Set_Port;
--------------------------
-- Socket_Error_Message --
diff --git a/gcc/ada/g-socthi.ads b/gcc/ada/g-socthi.ads
index a0236ecdeed..3155fd0e502 100644
--- a/gcc/ada/g-socthi.ads
+++ b/gcc/ada/g-socthi.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,12 +26,18 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with Interfaces.C.Pointers;
+-- This package provides a target dependent thin interface to the sockets
+-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
+-- should not be directly with'ed by an applications program.
+
+-- This is the default version
+with Interfaces.C.Pointers;
with Interfaces.C.Strings;
with GNAT.Sockets.Constants;
with GNAT.OS_Lib;
@@ -40,8 +46,6 @@ with System;
package GNAT.Sockets.Thin is
- -- ??? more comments needed ???
-
-- This package is intended for hosts implementing BSD sockets with a
-- standard interface. It will be used as a default for all the platforms
-- that do not have a specific version of this file.
@@ -61,13 +65,8 @@ package GNAT.Sockets.Thin is
-- Returns the error message string for the error number Errno. If
-- Errno is not known it returns "Unknown system error".
- type Fd_Set is mod 2 ** 32;
- pragma Convention (C, Fd_Set);
-
- Null_Fd_Set : constant Fd_Set := 0;
-
- type Fd_Set_Access is access all Fd_Set;
- pragma Convention (C, Fd_Set_Access);
+ subtype Fd_Set_Access is System.Address;
+ No_Fd_Set : constant Fd_Set_Access := System.Null_Address;
type Timeval_Unit is new C.int;
pragma Convention (C, Timeval_Unit);
@@ -140,6 +139,31 @@ package GNAT.Sockets.Thin is
pragma Convention (C, Sockaddr_In_Access);
-- Access to internet socket address
+ procedure Set_Length
+ (Sin : Sockaddr_In_Access;
+ Len : C.int);
+ pragma Inline (Set_Length);
+ -- Set Sin.Sin_Length to Len.
+ -- On this platform, nothing is done as there is no such field.
+
+ procedure Set_Family
+ (Sin : Sockaddr_In_Access;
+ Family : C.int);
+ pragma Inline (Set_Family);
+ -- Set Sin.Sin_Family to Family
+
+ procedure Set_Port
+ (Sin : Sockaddr_In_Access;
+ Port : C.unsigned_short);
+ pragma Inline (Set_Port);
+ -- Set Sin.Sin_Port to Port
+
+ procedure Set_Address
+ (Sin : Sockaddr_In_Access;
+ Address : In_Addr);
+ pragma Inline (Set_Address);
+ -- Set Sin.Sin_Addr to Address
+
type Hostent is record
H_Name : C.Strings.chars_ptr;
H_Aliases : Chars_Ptr_Pointers.Pointer;
@@ -154,6 +178,19 @@ package GNAT.Sockets.Thin is
pragma Convention (C, Hostent_Access);
-- Access to host entry
+ type Servent is record
+ S_Name : C.Strings.chars_ptr;
+ S_Aliases : Chars_Ptr_Pointers.Pointer;
+ S_Port : C.int;
+ S_Proto : C.Strings.chars_ptr;
+ end record;
+ pragma Convention (C, Servent);
+ -- Service entry
+
+ type Servent_Access is access all Servent;
+ pragma Convention (C, Servent_Access);
+ -- Access to service entry
+
type Two_Int is array (0 .. 1) of C.int;
pragma Convention (C, Two_Int);
-- Used with pipe()
@@ -201,6 +238,16 @@ package GNAT.Sockets.Thin is
Namelen : access C.int)
return C.int;
+ function C_Getservbyname
+ (Name : C.char_array;
+ Proto : C.char_array)
+ return Servent_Access;
+
+ function C_Getservbyport
+ (Port : C.int;
+ Proto : C.char_array)
+ return Servent_Access;
+
function C_Getsockname
(S : C.int;
Name : System.Address;
@@ -233,6 +280,12 @@ package GNAT.Sockets.Thin is
Count : C.int)
return C.int;
+ function C_Readv
+ (Fd : C.int;
+ Iov : System.Address;
+ Iovcnt : C.int)
+ return C.int;
+
function C_Recv
(S : C.int;
Msg : System.Address;
@@ -306,36 +359,89 @@ package GNAT.Sockets.Thin is
Count : C.int)
return C.int;
- -- Return highest numbered socket (what does this refer to???)
-
- procedure Clear (Item : in out Fd_Set; Socket : in C.int);
- procedure Empty (Item : in out Fd_Set);
- function Is_Empty (Item : Fd_Set) return Boolean;
- function Is_Set (Item : Fd_Set; Socket : C.int) return Boolean;
- function Max (Item : Fd_Set) return C.int;
- procedure Set (Item : in out Fd_Set; Socket : in C.int);
+ function C_Writev
+ (Fd : C.int;
+ Iov : System.Address;
+ Iovcnt : C.int)
+ return C.int;
+
+ procedure Free_Socket_Set
+ (Set : Fd_Set_Access);
+ -- Free system-dependent socket set
+
+ procedure Get_Socket_From_Set
+ (Set : Fd_Set_Access;
+ Socket : Int_Access;
+ Last : Int_Access);
+ -- Get last socket in Socket and remove it from the socket
+ -- set. The parameter Last is a maximum value of the largest
+ -- socket. This hint is used to avoid scanning very large socket
+ -- sets. After a call to Get_Socket_From_Set, Last is set back to
+ -- the real largest socket in the socket set.
+
+ procedure Insert_Socket_In_Set
+ (Set : Fd_Set_Access;
+ Socket : C.int);
+ -- Insert socket in the socket set
+
+ function Is_Socket_In_Set
+ (Set : Fd_Set_Access;
+ Socket : C.int)
+ return Boolean;
+ -- Check whether Socket is in the socket set
+
+ procedure Last_Socket_In_Set
+ (Set : Fd_Set_Access;
+ Last : Int_Access);
+ -- Find the largest socket in the socket set. This is needed for
+ -- select(). When Last_Socket_In_Set is called, parameter Last is
+ -- a maximum value of the largest socket. This hint is used to
+ -- avoid scanning very large socket sets. After the call, Last is
+ -- set back to the real largest socket in the socket set.
+
+ function New_Socket_Set
+ (Set : Fd_Set_Access)
+ return Fd_Set_Access;
+ -- Allocate a new socket set which is a system-dependent structure
+ -- and initialize by copying Set if it is non-null, by making it
+ -- empty otherwise.
+
+ procedure Remove_Socket_From_Set
+ (Set : Fd_Set_Access;
+ Socket : C.int);
+ -- Remove socket from the socket set
procedure Finalize;
procedure Initialize (Process_Blocking_IO : Boolean);
private
-
pragma Import (C, C_Bind, "bind");
pragma Import (C, C_Close, "close");
pragma Import (C, C_Gethostbyaddr, "gethostbyaddr");
pragma Import (C, C_Gethostbyname, "gethostbyname");
pragma Import (C, C_Gethostname, "gethostname");
pragma Import (C, C_Getpeername, "getpeername");
+ pragma Import (C, C_Getservbyname, "getservbyname");
+ pragma Import (C, C_Getservbyport, "getservbyport");
pragma Import (C, C_Getsockname, "getsockname");
pragma Import (C, C_Getsockopt, "getsockopt");
pragma Import (C, C_Inet_Addr, "inet_addr");
pragma Import (C, C_Listen, "listen");
pragma Import (C, C_Read, "read");
+ pragma Import (C, C_Readv, "readv");
pragma Import (C, C_Select, "select");
pragma Import (C, C_Setsockopt, "setsockopt");
pragma Import (C, C_Shutdown, "shutdown");
pragma Import (C, C_Strerror, "strerror");
pragma Import (C, C_System, "system");
pragma Import (C, C_Write, "write");
-
+ pragma Import (C, C_Writev, "writev");
+
+ pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set");
+ pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set");
+ pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set");
+ pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set");
+ pragma Import (C, New_Socket_Set, "__gnat_new_socket_set");
+ pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set");
+ pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set");
end GNAT.Sockets.Thin;
diff --git a/gcc/ada/g-soliop.ads b/gcc/ada/g-soliop.ads
index 6f40df91042..d22678d2421 100644
--- a/gcc/ada/g-soliop.ads
+++ b/gcc/ada/g-soliop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,12 +26,17 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-package GNAT.Sockets.Linker_Options is
+-- This package is used to provide target specific linker_options for the
+-- support of scokets as required by the package GNAT.Sockets.
- -- Empty version of this package.
+-- This is an empty version for default use where no additional libraries
+-- are required. On some targets a target specific version of this unit
+-- ensures linking with required libraries for proper sockets operation.
+package GNAT.Sockets.Linker_Options is
end GNAT.Sockets.Linker_Options;
diff --git a/gcc/ada/g-souinf.ads b/gcc/ada/g-souinf.ads
index 0d52b023c3a..a5574994931 100644
--- a/gcc/ada/g-souinf.ads
+++ b/gcc/ada/g-souinf.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-speche.adb b/gcc/ada/g-speche.adb
index 48dd4ab9108..f58cb619e24 100644
--- a/gcc/ada/g-speche.adb
+++ b/gcc/ada/g-speche.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -132,7 +133,7 @@ package body GNAT.Spelling_Checker is
-- Length is 1 too long. Execute loop to check for single insertion
elsif FN = EN + 1 then
- for J in 1 .. FN - 1 loop
+ for J in 1 .. EN - 1 loop
if Found (FF + J) /= Expect (EF + J) then
return Found (FF + J + 1 .. FL) = Expect (EF + J .. EL);
end if;
diff --git a/gcc/ada/g-speche.ads b/gcc/ada/g-speche.ads
index c89e515c712..af07acbfa3b 100644
--- a/gcc/ada/g-speche.ads
+++ b/gcc/ada/g-speche.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-spipat.adb b/gcc/ada/g-spipat.adb
index e0fa74a41fa..3832a7603e8 100644
--- a/gcc/ada/g-spipat.adb
+++ b/gcc/ada/g-spipat.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -612,7 +613,7 @@ package body GNAT.Spitbol.Patterns is
-- occurs in constructing a pattern, and it means that the pattern
-- matching circuitry does not have to keep track of the structure
-- of a pattern with respect to concatenation, since the appropriate
- -- successor is always at hand.
+ -- succesor is always at hand.
-- Concatenation itself generates no additional possibilities for
-- backtracking, but the constituent patterns of the concatenated
@@ -1307,7 +1308,7 @@ package body GNAT.Spitbol.Patterns is
Start : out Natural;
Stop : out Natural);
-- Identical in all respects to XMatch, except that trace information is
- -- output on Standard_Output during execution of the match. This is the
+ -- output on Standard_Ouput during execution of the match. This is the
-- version that is called if the original Match call has Debug => True.
---------
@@ -2403,7 +2404,7 @@ package body GNAT.Spitbol.Patterns is
----------------------
procedure Delete_Ampersand is
- L : Natural := Length (Result);
+ L : constant Natural := Length (Result);
begin
if L > 2 then
@@ -2702,9 +2703,9 @@ package body GNAT.Spitbol.Patterns is
---------------
procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean) is
+ Indx : constant Natural := Length (Result);
E1 : PE_Ptr := E;
Mult : Boolean := False;
- Indx : Natural := Length (Result);
begin
-- The image of EOP is "" (the null string)
@@ -3967,7 +3968,8 @@ package body GNAT.Spitbol.Patterns is
-- Arbno pattern.
when PC_Arbno_Y => declare
- Null_Match : Boolean := (Cursor = Stack (Stack_Base - 1).Cursor);
+ Null_Match : constant Boolean :=
+ Cursor = Stack (Stack_Base - 1).Cursor;
begin
Pop_Region;
@@ -4095,7 +4097,7 @@ package body GNAT.Spitbol.Patterns is
-- Break (string pointer case)
when PC_Break_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ Str : constant String_Access := Get_String (Node.VP.all);
begin
while Cursor < Length loop
@@ -4156,7 +4158,7 @@ package body GNAT.Spitbol.Patterns is
-- BreakX (string pointer case)
when PC_BreakX_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ Str : constant String_Access := Get_String (Node.VP.all);
begin
while Cursor < Length loop
@@ -4316,7 +4318,7 @@ package body GNAT.Spitbol.Patterns is
-- NotAny (string pointer case)
when PC_NotAny_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ Str : constant String_Access := Get_String (Node.VP.all);
begin
if Cursor < Length
@@ -4371,7 +4373,7 @@ package body GNAT.Spitbol.Patterns is
-- NSpan (string pointer case)
when PC_NSpan_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ Str : constant String_Access := Get_String (Node.VP.all);
begin
while Cursor < Length
@@ -4613,7 +4615,7 @@ package body GNAT.Spitbol.Patterns is
-- Span (string pointer case)
when PC_Span_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ Str : constant String_Access := Get_String (Node.VP.all);
P : Natural := Cursor;
begin
@@ -4728,8 +4730,8 @@ package body GNAT.Spitbol.Patterns is
-- String (pointer case)
when PC_String_VP => declare
- S : String_Access := Get_String (Node.VP.all);
- Len : constant Natural := S'Length;
+ S : constant String_Access := Get_String (Node.VP.all);
+ Len : constant Natural := S'Length;
begin
if (Length - Cursor) >= Len
@@ -5269,7 +5271,7 @@ package body GNAT.Spitbol.Patterns is
-- Any (string pointer case)
when PC_Any_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ Str : constant String_Access := Get_String (Node.VP.all);
begin
Dout (Img (Node) & "matching Any", Str.all);
@@ -5330,7 +5332,8 @@ package body GNAT.Spitbol.Patterns is
-- Arbno pattern.
when PC_Arbno_Y => declare
- Null_Match : Boolean := (Cursor = Stack (Stack_Base - 1).Cursor);
+ Null_Match : constant Boolean :=
+ Cursor = Stack (Stack_Base - 1).Cursor;
begin
Dout (Img (Node) & "extending Arbno");
@@ -5472,7 +5475,7 @@ package body GNAT.Spitbol.Patterns is
-- Break (string pointer case)
when PC_Break_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ Str : constant String_Access := Get_String (Node.VP.all);
begin
Dout (Img (Node) & "matching Break", Str.all);
@@ -5541,7 +5544,7 @@ package body GNAT.Spitbol.Patterns is
-- BreakX (string pointer case)
when PC_BreakX_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ Str : constant String_Access := Get_String (Node.VP.all);
begin
Dout (Img (Node) & "matching BreakX", Str.all);
@@ -5726,7 +5729,7 @@ package body GNAT.Spitbol.Patterns is
-- NotAny (string pointer case)
when PC_NotAny_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ Str : constant String_Access := Get_String (Node.VP.all);
begin
Dout (Img (Node) & "matching NotAny", Str.all);
@@ -5789,7 +5792,7 @@ package body GNAT.Spitbol.Patterns is
-- NSpan (string pointer case)
when PC_NSpan_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ Str : constant String_Access := Get_String (Node.VP.all);
begin
Dout (Img (Node) & "matching NSpan", Str.all);
@@ -6066,7 +6069,7 @@ package body GNAT.Spitbol.Patterns is
-- Span (string pointer case)
when PC_Span_VP => declare
- Str : String_Access := Get_String (Node.VP.all);
+ Str : constant String_Access := Get_String (Node.VP.all);
P : Natural := Cursor;
begin
@@ -6197,7 +6200,7 @@ package body GNAT.Spitbol.Patterns is
-- String (vstring pointer case)
when PC_String_VP => declare
- S : String_Access := Get_String (Node.VP.all);
+ S : constant String_Access := Get_String (Node.VP.all);
Len : constant Natural :=
Ada.Strings.Unbounded.Length (Node.VP.all);
diff --git a/gcc/ada/g-spipat.ads b/gcc/ada/g-spipat.ads
index 3d08f0be852..3a62e1c0ec1 100644
--- a/gcc/ada/g-spipat.ads
+++ b/gcc/ada/g-spipat.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-1999 Ada Core Technologies, Inc. --
+-- Copyright (C) 1997-2002 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -85,7 +86,6 @@ pragma Elaborate_Body (Patterns);
-- replacement string is specified, then the subject string is modified
-- by replacing the matched substring with the given replacement.
-
-- Concatenation and Alternation
-- =============================
@@ -134,7 +134,6 @@ pragma Elaborate_Body (Patterns);
-- Here we use the dot simply to separate the pieces of the string
-- matched by the three separate elements.
-
-- Moving the Start Point
-- ======================
@@ -172,7 +171,6 @@ pragma Elaborate_Body (Patterns);
-- We will also see later how the effect of an anchored match can be
-- obtained for a single specified anchor point if this is desired.
-
-- Other Pattern Elements
-- ======================
@@ -216,7 +214,6 @@ pragma Elaborate_Body (Patterns);
-- pattern element, which is useful in conjunction with some
-- of the special pattern elements that have side effects.
-
-- Pattern Construction Functions
-- ==============================
@@ -311,7 +308,6 @@ pragma Elaborate_Body (Patterns);
-- but the use of recursive patterns in the general case can construct
-- complex patterns which could not otherwise be built.
-
-- Pattern Assignment Operations
-- =============================
@@ -353,7 +349,6 @@ pragma Elaborate_Body (Patterns);
-- the matched substring. These are particularly useful in debugging
-- pattern matches.
-
-- Deferred Matching
-- =================
@@ -610,7 +605,6 @@ pragma Elaborate_Body (Patterns);
-- define patterns and the functions they call at the outer level
-- where possible, to avoid such problems.
-
-- Correspondence with Pattern Matching in SPITBOL
-- ===============================================
@@ -1160,14 +1154,12 @@ private
-- Pattern reference. PE's use PE_Ptr values to reference other PE's
type Pattern is new Controlled with record
-
- Stk : Natural;
+ Stk : Natural := 0;
-- Maximum number of stack entries required for matching this
-- pattern. See description of pattern history stack in body.
- P : PE_Ptr;
+ P : PE_Ptr := null;
-- Pointer to initial pattern element for pattern
-
end record;
pragma Finalize_Storage_Only (Pattern);
@@ -1184,11 +1176,11 @@ private
Var : VString_Ptr;
-- Pointer to subject string. Set to null if match failed.
- Start : Natural;
+ Start : Natural := 1;
-- Starting index position (1's origin) of matched section of
-- subject string. Only valid if Var is non-null.
- Stop : Natural;
+ Stop : Natural := 0;
-- Ending index position (1's origin) of matched section of
-- subject string. Only valid if Var is non-null.
diff --git a/gcc/ada/g-spitbo.adb b/gcc/ada/g-spitbo.adb
index 626a6332b4f..d7598bd72b2 100644
--- a/gcc/ada/g-spitbo.adb
+++ b/gcc/ada/g-spitbo.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-spitbo.ads b/gcc/ada/g-spitbo.ads
index d0688e3ce1c..1bac7f357ee 100644
--- a/gcc/ada/g-spitbo.ads
+++ b/gcc/ada/g-spitbo.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-sptabo.ads b/gcc/ada/g-sptabo.ads
index 9beb7a4aa76..0ef72201ebf 100644
--- a/gcc/ada/g-sptabo.ads
+++ b/gcc/ada/g-sptabo.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-sptain.ads b/gcc/ada/g-sptain.ads
index 01e08fa4919..edabfa7c460 100644
--- a/gcc/ada/g-sptain.ads
+++ b/gcc/ada/g-sptain.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-sptavs.ads b/gcc/ada/g-sptavs.ads
index 7601506c9bb..d1b8787883b 100644
--- a/gcc/ada/g-sptavs.ads
+++ b/gcc/ada/g-sptavs.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-exnsfl.ads b/gcc/ada/g-string.adb
index 012d7854223..7d8a4acf78e 100644
--- a/gcc/ada/s-exnsfl.ads
+++ b/gcc/ada/g-string.adb
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . E X N _ S F L T --
+-- G N A T . S T R I N G S --
-- --
--- S p e c --
+-- B o d y --
-- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,14 +31,31 @@
-- --
------------------------------------------------------------------------------
--- Short_Float exponentiation (checks off)
+package body GNAT.Strings is
-with System.Exn_Gen;
+ ----------
+ -- Free --
+ ----------
-package System.Exn_SFlt is
-pragma Pure (Exn_SFlt);
+ procedure Free (Arg : in out String_List_Access) is
+ X : String_Access;
- function Exn_Short_Float is
- new System.Exn_Gen.Exn_Float_Type (Short_Float);
+ procedure Free_Array is new Unchecked_Deallocation
+ (Object => String_List, Name => String_List_Access);
-end System.Exn_SFlt;
+ begin
+ -- First free all the String_Access components if any
+
+ if Arg /= null then
+ for J in Arg'Range loop
+ X := Arg (J);
+ Free (X);
+ end loop;
+ end if;
+
+ -- Now free the allocated array
+
+ Free_Array (Arg);
+ end Free;
+
+end GNAT.Strings;
diff --git a/gcc/ada/s-exngen.ads b/gcc/ada/g-string.ads
index fabdf491a33..57915e16f69 100644
--- a/gcc/ada/s-exngen.ads
+++ b/gcc/ada/g-string.ads
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . E X N _ G E N --
+-- G N A T . S T R I N G S --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,34 +31,28 @@
-- --
------------------------------------------------------------------------------
--- This package contains the generic functions which are instantiated with
--- predefined integer and real types to generate the runtime exponentiation
--- functions called by expanded code generated by Expand_Op_Expon. This
--- version of the package contains routines that are compiled with overflow
--- checks suppressed, so they are called for exponentiation operations which
--- do not require overflow checking
+-- Common String access types and related subprograms
-package System.Exn_Gen is
-pragma Pure (System.Exn_Gen);
+with Unchecked_Deallocation;
- -- Exponentiation for float types (checks off)
+package GNAT.Strings is
- generic
- type Type_Of_Base is digits <>;
+ type String_Access is access all String;
+ -- General purpose string access type. Note that the caller is
+ -- responsible for freeing allocated strings to avoid memory leaks.
- function Exn_Float_Type
- (Left : Type_Of_Base;
- Right : Integer)
- return Type_Of_Base;
+ procedure Free is new Unchecked_Deallocation
+ (Object => String, Name => String_Access);
+ -- This procedure is provided for freeing allocated values of type
+ -- String_Access.
- -- Exponentiation for signed integer base
+ type String_List is array (Positive range <>) of String_Access;
+ type String_List_Access is access all String_List;
+ -- General purpose array and pointer for list of string accesses
- generic
- type Type_Of_Base is range <>;
+ procedure Free (Arg : in out String_List_Access);
+ -- Frees the given array and all strings that its elements reference,
+ -- and then sets the argument to null. Provided for freeing allocated
+ -- values of this type.
- function Exn_Integer_Type
- (Left : Type_Of_Base;
- Right : Natural)
- return Type_Of_Base;
-
-end System.Exn_Gen;
+end GNAT.Strings;
diff --git a/gcc/ada/s-exnlfl.ads b/gcc/ada/g-strspl.ads
index 7ede56d2ca0..03b7cc95ce3 100644
--- a/gcc/ada/s-exnlfl.ads
+++ b/gcc/ada/g-strspl.ads
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . E X N _ L F L T --
+-- G N A T . S T R I N G _ S P L I T --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-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- --
@@ -31,14 +31,16 @@
-- --
------------------------------------------------------------------------------
--- Long_Float exponentiation (checks on)
+-- Useful string-manipulation routines: given a set of separators, split
+-- a string wherever the separators appear, and provide direct access
+-- to the resulting slices. See GNAT.Array_Split for full documentation.
-with System.Exn_Gen;
+with Ada.Strings.Maps; use Ada.Strings;
+with GNAT.Array_Split;
-package System.Exn_LFlt is
-pragma Pure (Exn_LFlt);
-
- function Exn_Long_Float is
- new System.Exn_Gen.Exn_Float_Type (Long_Float);
-
-end System.Exn_LFlt;
+package GNAT.String_Split is new GNAT.Array_Split
+ (Element => Character,
+ Element_Sequence => String,
+ Element_Set => Maps.Character_Set,
+ To_Set => Maps.To_Set,
+ Is_In => Maps.Is_In);
diff --git a/gcc/ada/g-table.adb b/gcc/ada/g-table.adb
index a1e5ef9aa73..57f7c724058 100644
--- a/gcc/ada/g-table.adb
+++ b/gcc/ada/g-table.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-table.ads b/gcc/ada/g-table.ads
index 0e671f561a7..daa8e2b31fa 100644
--- a/gcc/ada/g-table.ads
+++ b/gcc/ada/g-table.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -89,6 +90,19 @@ pragma Elaborate_Body (Table);
-- restrict the use of table for discriminated types. If it is necessary
-- to take the access of a table element, use Unrestricted_Access.
+ -- WARNING: On HPPA, the virtual addressing approach used in this unit
+ -- is incompatible with the indexing instructions on the HPPA. So when
+ -- using this unit, compile your application with -mdisable-indexing.
+
+ -- WARNING: If the table is reallocated, then the address of all its
+ -- components will change. So do not capture the address of an element
+ -- and then use the address later after the table may be reallocated.
+ -- One tricky case of this is passing an element of the table to a
+ -- subprogram by reference where the table gets reallocated during
+ -- the execution of the subprogram. The best rule to follow is never
+ -- to pass a table element as a parameter except for the case of IN
+ -- mode parameters with scalar values.
+
type Table_Type is
array (Table_Index_Type range <>) of Table_Component_Type;
@@ -154,11 +168,11 @@ pragma Elaborate_Body (Table);
procedure Increment_Last;
pragma Inline (Increment_Last);
- -- Adds 1 to Last (same as Set_Last (Last + 1).
+ -- Adds 1 to Last (same as Set_Last (Last + 1)
procedure Decrement_Last;
pragma Inline (Decrement_Last);
- -- Subtracts 1 from Last (same as Set_Last (Last - 1).
+ -- Subtracts 1 from Last (same as Set_Last (Last - 1)
procedure Append (New_Val : Table_Component_Type);
pragma Inline (Append);
diff --git a/gcc/ada/g-tasloc.adb b/gcc/ada/g-tasloc.adb
index c0b01450f53..ff0fb2c0016 100644
--- a/gcc/ada/g-tasloc.adb
+++ b/gcc/ada/g-tasloc.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-tasloc.ads b/gcc/ada/g-tasloc.ads
index f2090b5ceb5..1307f3e1849 100644
--- a/gcc/ada/g-tasloc.ads
+++ b/gcc/ada/g-tasloc.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-thread.adb b/gcc/ada/g-thread.adb
index 6208674d361..30367306b2f 100644
--- a/gcc/ada/g-thread.adb
+++ b/gcc/ada/g-thread.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2000 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,23 +26,33 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Task_Identification; use Ada.Task_Identification;
with System.Task_Primitives.Operations;
with System.Tasking;
-with System.OS_Interface;
+with System.Tasking.Stages; use System.Tasking.Stages;
+with System.OS_Interface; use System.OS_Interface;
+with System.Soft_Links; use System.Soft_Links;
with Unchecked_Conversion;
package body GNAT.Threads is
use System;
+ package STPO renames System.Task_Primitives.Operations;
+
+ type Thread_Id_Ptr is access all Thread_Id;
+
function To_Addr is new Unchecked_Conversion (Task_Id, Address);
function To_Id is new Unchecked_Conversion (Address, Task_Id);
function To_Id is new Unchecked_Conversion (Address, Tasking.Task_ID);
+ function To_Tid is new Unchecked_Conversion
+ (Address, Ada.Task_Identification.Task_Id);
+ function To_Thread is new Unchecked_Conversion (Address, Thread_Id_Ptr);
type Code_Proc is access procedure (Id : Address; Parm : Void_Ptr);
@@ -71,7 +81,8 @@ package body GNAT.Threads is
(Code : Address;
Parm : Void_Ptr;
Size : Natural;
- Prio : Integer) return System.Address
+ Prio : Integer)
+ return System.Address
is
TP : Tptr;
@@ -82,12 +93,63 @@ package body GNAT.Threads is
return To_Addr (TP'Identity);
end Create_Thread;
+ ---------------------
+ -- Register_Thread --
+ ---------------------
+
+ function Register_Thread return System.Address is
+ begin
+ return Task_Primitives.Operations.Register_Foreign_Thread.all'Address;
+ end Register_Thread;
+
+ -----------------------
+ -- Unregister_Thread --
+ -----------------------
+
+ procedure Unregister_Thread is
+ Self_Id : constant Tasking.Task_ID := Task_Primitives.Operations.Self;
+
+ begin
+ Self_Id.Common.State := Tasking.Terminated;
+ Destroy_TSD (Self_Id.Common.Compiler_Data);
+ Free_Task (Self_Id);
+ end Unregister_Thread;
+
+ --------------------------
+ -- Unregister_Thread_Id --
+ --------------------------
+
+ procedure Unregister_Thread_Id (Thread : System.Address) is
+ Thr : constant Thread_Id := To_Thread (Thread).all;
+ T : Tasking.Task_ID;
+
+ use type Tasking.Task_ID;
+
+ begin
+ STPO.Lock_RTS;
+
+ T := Tasking.All_Tasks_List;
+ loop
+ exit when T = null or else STPO.Get_Thread_Id (T) = Thr;
+
+ T := T.Common.All_Tasks_Link;
+ end loop;
+
+ STPO.Unlock_RTS;
+
+ if T /= null then
+ T.Common.State := Tasking.Terminated;
+ Destroy_TSD (T.Common.Compiler_Data);
+ Free_Task (T);
+ end if;
+ end Unregister_Thread_Id;
+
--------------------
-- Destroy_Thread --
--------------------
procedure Destroy_Thread (Id : Address) is
- Tid : Task_Id := To_Id (Id);
+ Tid : constant Task_Id := To_Id (Id);
begin
Abort_Task (Tid);
@@ -100,10 +162,22 @@ package body GNAT.Threads is
procedure Get_Thread (Id : Address; Thread : Address) is
use System.OS_Interface;
- Thr : Thread_Id;
- for Thr use at Thread;
+ Thr : Thread_Id_Ptr := To_Thread (Thread);
+
begin
- Thr := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id));
+ Thr.all := Task_Primitives.Operations.Get_Thread_Id (To_Id (Id));
end Get_Thread;
+ ----------------
+ -- To_Task_Id --
+ ----------------
+
+ function To_Task_Id
+ (Id : System.Address)
+ return Ada.Task_Identification.Task_Id
+ is
+ begin
+ return To_Tid (Id);
+ end To_Task_Id;
+
end GNAT.Threads;
diff --git a/gcc/ada/g-thread.ads b/gcc/ada/g-thread.ads
index e39f896e25b..5d0acb27fb8 100644
--- a/gcc/ada/g-thread.ads
+++ b/gcc/ada/g-thread.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2000 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -36,6 +37,7 @@
-- e.g. a C program, to create a thread that the Ada run-time knows about.
with System;
+with Ada.Task_Identification;
package GNAT.Threads is
@@ -68,6 +70,46 @@ package GNAT.Threads is
-- extern void *__gnat_create_thread
-- (void (*code)(void *, void *), void *parm, int size, int prio);
+ function Register_Thread return System.Address;
+ pragma Export (C, Register_Thread, "__gnat_register_thread");
+ -- Create an Ada task Id for the current thread if needed.
+ -- If the thread could not be registered, System.Null_Address is returned.
+ --
+ -- This function returns the Ada Id of the current task that can then be
+ -- used as a parameter to the procedures below.
+ --
+ -- C declaration:
+ --
+ -- extern void *__gnat_register_thread ();
+ --
+ -- Here is a typical usage of the Register/Unregister_Thread procedures:
+ --
+ -- void thread_body ()
+ -- {
+ -- void *task_id = __gnat_register_thread ();
+ -- ... thread body ...
+ -- __gnat_unregister_thread ();
+ -- }
+
+ procedure Unregister_Thread;
+ pragma Export (C, Unregister_Thread, "__gnat_unregister_thread");
+ -- Unregister the current task from the GNAT run time and destroy the
+ -- memory allocated for its task id.
+ --
+ -- C declaration:
+ --
+ -- extern void __gnat_unregister_thread ();
+
+ procedure Unregister_Thread_Id (Thread : System.Address);
+ pragma Export (C, Unregister_Thread_Id, "__gnat_unregister_thread_id");
+ -- Unregister the task associated with Thread from the GNAT run time and
+ -- destroy the memory allocated for its task id.
+ -- If no task id is associated with Thread, do nothing.
+ --
+ -- C declaration:
+ --
+ -- extern void __gnat_unregister_thread_id (pthread_t *thread);
+
procedure Destroy_Thread (Id : System.Address);
pragma Export (C, Destroy_Thread, "__gnat_destroy_thread");
-- This procedure may be used to prematurely abort the created thread.
@@ -90,4 +132,11 @@ package GNAT.Threads is
--
-- extern void __gnat_get_thread (void *id, pthread_t *thread);
+ function To_Task_Id
+ (Id : System.Address)
+ return Ada.Task_Identification.Task_Id;
+ -- Ada interface only.
+ -- Given a low level Id, as returned by Create_Thread, return a Task_Id,
+ -- so that operations in Ada.Task_Identification can be used.
+
end GNAT.Threads;
diff --git a/gcc/ada/g-traceb.adb b/gcc/ada/g-traceb.adb
index 14978dcc771..5cfb2ca3d5e 100644
--- a/gcc/ada/g-traceb.adb
+++ b/gcc/ada/g-traceb.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-traceb.ads b/gcc/ada/g-traceb.ads
index 30d5fc80a46..761e480f835 100644
--- a/gcc/ada/g-traceb.ads
+++ b/gcc/ada/g-traceb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2002 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -63,6 +64,7 @@
-- VxWorks Alpha
with System;
+with Ada.Exceptions.Traceback;
package GNAT.Traceback is
pragma Elaborate_Body;
@@ -70,7 +72,7 @@ package GNAT.Traceback is
subtype Code_Loc is System.Address;
-- Code location used in building tracebacks
- type Tracebacks_Array is array (Positive range <>) of Code_Loc;
+ subtype Tracebacks_Array is Ada.Exceptions.Traceback.Tracebacks_Array;
-- Traceback array used to hold a generated traceback list.
----------------
diff --git a/gcc/ada/g-trasym.adb b/gcc/ada/g-trasym.adb
index cff8aca520f..13d7450908f 100644
--- a/gcc/ada/g-trasym.adb
+++ b/gcc/ada/g-trasym.adb
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/g-trasym.ads b/gcc/ada/g-trasym.ads
index 5c3255855e6..0bb3509b9ed 100644
--- a/gcc/ada/g-trasym.ads
+++ b/gcc/ada/g-trasym.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -38,17 +39,17 @@
-- The routines provided in this package assume that your application has
-- been compiled with debugging information turned on, since this information
-- is used to build a symbolic traceback.
---
+
-- In order to retrieve symbolic information, functions in this package will
-- read on disk all the debug information of the executable file (found via
-- Argument (0), so any path information needed to read the executable file
-- need to be provided when launching the executable), and load then in
-- memory, causing a significant cpu and memory overhead.
---
+
-- This package is not intended to be used within a shared library,
-- symbolic tracebacks are only supported for the main executable
-- and not for shared libraries.
---
+
-- You should consider using off-line symbolic traceback instead, using
-- addr2line or gdb.
@@ -62,10 +63,9 @@ pragma Elaborate_Body (Traceback.Symbolic);
------------------------
function Symbolic_Traceback (Traceback : Tracebacks_Array) return String;
- -- Build a string containing a symbolic traceback of the given call chain.
+ -- Build a string containing a symbolic traceback of the given call chain
function Symbolic_Traceback (E : Exception_Occurrence) return String;
- -- Build a string containing a symbolic traceback of the given exception
- -- occurrence.
+ -- Build string containing symbolic traceback of given exception occurrence
end GNAT.Traceback.Symbolic;
diff --git a/gcc/ada/s-exnlin.ads b/gcc/ada/g-wistsp.ads
index aa249087308..226f579ef3e 100644
--- a/gcc/ada/s-exnlin.ads
+++ b/gcc/ada/g-wistsp.ads
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNAT RUNTIME COMPONENTS --
+-- GNAT COMPILER COMPONENTS --
-- --
--- S Y S T E M . E X N _ L I N T --
+-- G N A T . W I D E _ S T R I N G _ S P L I T --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-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- --
@@ -31,14 +31,16 @@
-- --
------------------------------------------------------------------------------
--- Long_Integer exponentiation (checks off)
+-- Useful wide_string-manipulation routines: given a set of separators, split
+-- a wide_string wherever the separators appear, and provide direct access
+-- to the resulting slices. See GNAT.Array_Split for full documentation.
-with System.Exn_Gen;
+with Ada.Strings.Wide_Maps; use Ada.Strings;
+with GNAT.Array_Split;
-package System.Exn_LInt is
-pragma Pure (Exn_LInt);
-
- function Exn_Long_Integer is
- new System.Exn_Gen.Exn_Integer_Type (Long_Integer);
-
-end System.Exn_LInt;
+package GNAT.Wide_String_Split is new GNAT.Array_Split
+ (Element => Wide_Character,
+ Element_Sequence => Wide_String,
+ Element_Set => Wide_Maps.Wide_Character_Set,
+ To_Set => Wide_Maps.To_Set,
+ Is_In => Wide_Maps.Is_In);
diff --git a/gcc/ada/gigi.h b/gcc/ada/gigi.h
index 8ad8a2a26fd..573d934b4ab 100644
--- a/gcc/ada/gigi.h
+++ b/gcc/ada/gigi.h
@@ -6,7 +6,6 @@
* *
* C Header File *
* *
- * *
* Copyright (C) 1992-2003 Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
@@ -31,6 +30,10 @@
* *
****************************************************************************/
+/* The largest alignment, in bits, that is needed for using the widest
+ move instruction. */
+extern unsigned int largest_move_alignment;
+
/* Declare all functions and types used by gigi. */
/* See if DECL has an RTL that is indirect via a pseudo-register or a
@@ -44,6 +47,10 @@ extern void record_code_position PARAMS ((Node_Id));
/* Insert the code for GNAT_NODE at the position saved for that node. */
extern void insert_code_for PARAMS ((Node_Id));
+/* Compute the alignment of the largest mode that can be used for copying
+ objects. */
+extern void gnat_compute_largest_alignment PARAMS ((void));
+
/* Routine called by gcc for emitting a stack check. GNU_EXPR is the
expression that contains the last address on the stack to check. */
extern tree emit_stack_check PARAMS ((tree));
@@ -63,9 +70,6 @@ extern int default_pass_by_ref PARAMS ((tree));
if it should be passed by reference. */
extern int must_pass_by_ref PARAMS ((tree));
-/* This function returns the version of GCC being used. Here it's GCC 3. */
-extern int gcc_version PARAMS ((void));
-
/* Elaboration routines for the front end. */
extern void elab_all_gnat PARAMS ((void));
@@ -136,7 +140,7 @@ extern tree rm_size PARAMS ((tree));
the name in GNU_ID and SUFFIX. */
extern tree concat_id_with_name PARAMS ((tree, const char *));
-/* Return the name to be used for GNAT_ENTITY. If a type, create a
+/* Return the name to be used for GNAT_ENTITY. If a type, create a
fully-qualified name, possibly with type information encoding.
Otherwise, return the name. */
extern tree get_entity_name PARAMS ((Entity_Id));
@@ -245,7 +249,7 @@ extern void init_code_table PARAMS ((void));
extern Node_Id error_gnat_node;
/* This is equivalent to stabilize_reference in GCC's tree.c, but we know
- how to handle our new nodes and we take an extra argument that says
+ how to handle our new nodes and we take an extra argument that says
whether to force evaluation of everything. */
extern tree gnat_stabilize_reference PARAMS ((tree, int));
@@ -298,7 +302,7 @@ extern int force_global;
/* Data structures used to represent attributes. */
-enum attr_type {ATTR_MACHINE_ATTRIBUTE, ATTR_LINK_ALIAS,
+enum attr_type {ATTR_MACHINE_ATTRIBUTE, ATTR_LINK_ALIAS,
ATTR_LINK_SECTION, ATTR_WEAK_EXTERNAL};
struct attrib
@@ -346,6 +350,8 @@ enum standard_datatypes
ADT_setjmp_decl,
ADT_longjmp_decl,
ADT_raise_nodefer_decl,
+ ADT_begin_handler_decl,
+ ADT_end_handler_decl,
ADT_LAST};
extern GTY(()) tree gnat_std_decls[(int) ADT_LAST];
@@ -367,6 +373,8 @@ extern GTY(()) tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
#define setjmp_decl gnat_std_decls[(int) ADT_setjmp_decl]
#define longjmp_decl gnat_std_decls[(int) ADT_longjmp_decl]
#define raise_nodefer_decl gnat_std_decls[(int) ADT_raise_nodefer_decl]
+#define begin_handler_decl gnat_std_decls[(int) ADT_begin_handler_decl]
+#define end_handler_decl gnat_std_decls[(int) ADT_end_handler_decl]
/* Routines expected by the gcc back-end. They must have exactly the same
prototype and names as below. */
@@ -414,13 +422,13 @@ extern void set_block PARAMS ((tree));
Returns the ..._DECL node. */
extern tree pushdecl PARAMS ((tree));
-/* Create the predefined scalar types such as `integer_type_node' needed
+/* Create the predefined scalar types such as `integer_type_node' needed
in the gcc back-end and initialize the global binding level. */
extern void gnat_init_decl_processing PARAMS ((void));
extern void init_gigi_decls PARAMS ((tree, tree));
extern void gnat_init_gcc_eh PARAMS ((void));
-/* Return an integer type with the number of bits of precision given by
+/* Return an integer type with the number of bits of precision given by
PRECISION. UNSIGNEDP is nonzero if the type is unsigned; otherwise
it is a signed type. */
extern tree gnat_type_for_size PARAMS ((unsigned, int));
@@ -433,18 +441,11 @@ extern tree gnat_type_for_mode PARAMS ((enum machine_mode, int));
extern tree gnat_unsigned_type PARAMS ((tree));
/* Return the signed version of a TYPE_NODE, a scalar type. */
-extern tree gnat_signed_type PARAMS ((tree));
+extern tree gnat_signed_type PARAMS ((tree));
/* Return a type the same as TYPE except unsigned or signed according to
UNSIGNEDP. */
-extern tree gnat_signed_or_unsigned_type PARAMS ((int, tree));
-
-/* This function is called indirectly from toplev.c to handle incomplete
- declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise,
- compile_file in toplev.c makes an indirect call through the function pointer
- incomplete_decl_finalize_hook which is initialized to this routine in
- init_decl_processing. */
-extern void gnat_finish_incomplete_decl PARAMS ((tree));
+extern tree gnat_signed_or_unsigned_type PARAMS ((int, tree));
/* Create an expression whose value is that of EXPR,
converted to type TYPE. The TREE_TYPE of the value
@@ -459,7 +460,7 @@ extern tree convert PARAMS ((tree, tree));
/* GNAT_ENTITY is a GNAT tree node for a defining identifier.
GNU_DECL is the GCC tree which is to be associated with
GNAT_ENTITY. Such gnu tree node is always an ..._DECL node.
- If NO_CHECK is nonzero, the latter check is suppressed.
+ If NO_CHECK is nonzero, the latter check is suppressed.
If GNU_DECL is zero, a previous association is to be reset. */
extern void save_gnu_tree PARAMS ((Entity_Id, tree, int));
@@ -475,7 +476,7 @@ extern int present_gnu_tree PARAMS ((Entity_Id));
extern void init_gnat_to_gnu PARAMS ((void));
/* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL
- nodes (FIELDLIST), finish constructing the record or union type.
+ nodes (FIELDLIST), finish constructing the record or union type.
If HAS_REP is nonzero, this record has a rep clause; don't call
layout_type but merely set the size and alignment ourselves.
If DEFER_DEBUG is nonzero, do not call the debugging routines
@@ -486,7 +487,7 @@ extern void finish_record_type PARAMS ((tree, tree, int, int));
subprogram. If it is void_type_node, then we are dealing with a procedure,
otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
PARM_DECL nodes that are the subprogram arguments. CICO_LIST is the
- copy-in/copy-out list to be stored into TYPE_CI_CO_LIST.
+ copy-in/copy-out list to be stored into TYPE_CI_CO_LIST.
RETURNS_UNCONSTRAINED is nonzero if the function returns an unconstrained
object. RETURNS_BY_REF is nonzero if the function returns by reference.
RETURNS_WITH_DSP is nonzero if the function is to return with a
@@ -502,7 +503,7 @@ extern tree copy_type PARAMS ((tree));
extern tree create_index_type PARAMS ((tree, tree, tree));
/* Return a TYPE_DECL node. TYPE_NAME gives the name of the type (a character
- string) and TYPE is a ..._TYPE node giving its data type.
+ string) and TYPE is a ..._TYPE node giving its data type.
ARTIFICIAL_P is nonzero if this is a declaration that was generated
by the compiler. DEBUG_INFO_P is nonzero if we need to write debugging
information about this type. */
@@ -518,7 +519,7 @@ extern tree create_type_decl PARAMS ((tree, tree, struct attrib *,
PUBLIC_FLAG is nonzero if this definition is to be made visible outside of
the current compilation unit. This flag should be set when processing the
- variable definitions in a package specification. EXTERN_FLAG is nonzero
+ variable definitions in a package specification. EXTERN_FLAG is nonzero
when processing an external variable declaration (as opposed to a
definition: no storage is to be allocated for the variable here).
STATIC_FLAG is only relevant when not at top level. In that case
@@ -635,8 +636,9 @@ extern tree remove_conversions PARAMS ((tree, int));
likewise return an expression pointing to the underlying array. */
extern tree maybe_unconstrained_array PARAMS ((tree));
-/* Return an expression that does an unchecked converstion of EXPR to TYPE. */
-extern tree unchecked_convert PARAMS ((tree, tree));
+/* Return an expression that does an unchecked converstion of EXPR to TYPE.
+ If NOTRUNC_P is set, truncation operations should be suppressed. */
+extern tree unchecked_convert PARAMS ((tree, tree, int));
/* Prepare expr to be an argument of a TRUTH_NOT_EXPR or other logical
operation.
@@ -693,7 +695,7 @@ extern tree build_call_raise PARAMS((int));
/* Return a CONSTRUCTOR of TYPE whose list is LIST. This is not the
same as build_constructor in the language-independent tree.c. */
-extern tree gnat_build_constructor PARAMS((tree, tree));
+extern tree gnat_build_constructor PARAMS((tree, tree));
/* Return a COMPONENT_REF to access a field that is given by COMPONENT,
an IDENTIFIER_NODE giving the name of the field, FIELD, a FIELD_DECL,
@@ -708,17 +710,18 @@ extern tree build_component_ref PARAMS((tree, tree, tree));
GNAT_PROC, if present is a procedure to call and GNAT_POOL is the
storage pool to use. If not preset, malloc and free will be used. */
extern tree build_call_alloc_dealloc PARAMS((tree, tree, int, Entity_Id,
- Entity_Id));
+ Entity_Id, Node_Id));
/* Build a GCC tree to correspond to allocating an object of TYPE whose
initial value if INIT, if INIT is nonzero. Convert the expression to
- RESULT_TYPE, which must be some type of pointer. Return the tree.
+ RESULT_TYPE, which must be some type of pointer. Return the tree.
GNAT_PROC and GNAT_POOL optionally give the procedure to call and
- the storage pool to use. */
+ the storage pool to use. GNAT_NODE is used to provide an error
+ location for restriction violations messages. */
extern tree build_allocator PARAMS((tree, tree, tree, Entity_Id,
- Entity_Id));
+ Entity_Id, Node_Id));
-/* Fill in a VMS descriptor for EXPR and return a constructor for it.
+/* Fill in a VMS descriptor for EXPR and return a constructor for it.
GNAT_FORMAL is how we find the descriptor record. */
extern tree fill_vms_descriptor PARAMS((tree, Entity_Id));
diff --git a/gcc/ada/gmem.c b/gcc/ada/gmem.c
index fe9928c6918..c21fa47c8ff 100644
--- a/gcc/ada/gmem.c
+++ b/gcc/ada/gmem.c
@@ -4,7 +4,6 @@
* *
* G M E M *
* *
- * *
* C Implementation File *
* *
* Copyright (C) 2000-2003 Free Software Foundation, Inc. *
@@ -41,46 +40,39 @@
NOTE: This capability is currently supported on the following targets:
DEC Unix
- SGI Irix
GNU/Linux x86
Solaris (sparc and x86) (*)
Windows 98/95/NT (x86)
(*) on these targets, the compilation must be done with -funwind-tables to
- be able to build the stack backtrace. */
-
-#ifdef __alpha_vxworks
-#include "vxWorks.h"
-#endif
-
-#ifdef IN_RTS
-#include "tconfig.h"
-#include "tsystem.h"
-#else
-#include "config.h"
-#include "system.h"
-#endif
+ be able to build the stack backtrace.
+*/
-#include "adaint.h"
+#include <stdio.h>
static FILE *gmemfile;
/* tb_len is the number of call level supported by this module */
-#define TB_LEN 200
-
-static char *tracebk[TB_LEN];
+#define tb_len 200
+static char * tracebk [tb_len];
static int cur_tb_len, cur_tb_pos;
-static void gmem_read_backtrace PARAMS ((void));
-static char *spc2nul PARAMS ((char *));
+#define LOG_EOF '*'
+#define LOG_ALLOC 'A'
+#define LOG_DEALL 'D'
+
+struct struct_storage_elmt {
+ char Elmt;
+ void * Address;
+ size_t Size;
+};
+
+extern void
+convert_addresses (char *addrs[], int n_addr, void *buf, int *len);
-extern int __gnat_gmem_initialize PARAMS ((char *));
-extern void __gnat_gmem_a2l_initialize PARAMS ((char *));
-extern void __gnat_gmem_read_next PARAMS ((char *));
-extern void __gnat_gmem_read_bt_frame PARAMS ((char *));
-
-/* Reads backtrace information from gmemfile placing them in tracebk
- array. cur_tb_len is the size of this array. */
+/* reads backtrace information from gmemfile placing them in tracebk
+ array. cur_tb_len is the size of this array
+*/
static void
gmem_read_backtrace ()
@@ -90,20 +82,19 @@ gmem_read_backtrace ()
cur_tb_pos = 0;
}
-/* Initialize gmem feature from the dumpname file. Return 1 if the
- dumpname has been generated by GMEM (instrumented malloc/free) and 0 if not
- (i.e. probably a GDB generated file). */
+/* initialize gmem feature from the dumpname file. It returns 1 if the
+ dumpname has beed generated by GMEM (instrumented malloc/free) and 0 if not
+ (i.e. probably a GDB generated file).
+*/
-int
-__gnat_gmem_initialize (dumpname)
- char *dumpname;
+int __gnat_gmem_initialize (char *dumpname)
{
- char header[10];
+ char header [10];
gmemfile = fopen (dumpname, "rb");
fread (header, 10, 1, gmemfile);
- /* Check for GMEM magic-tag. */
+ /* check for GMEM magic-tag */
if (memcmp (header, "GMEM DUMP\n", 10))
{
fclose (gmemfile);
@@ -113,53 +104,50 @@ __gnat_gmem_initialize (dumpname)
return 1;
}
-/* Initialize addr2line library */
+/* initialize addr2line library */
-void
-__gnat_gmem_a2l_initialize (exename)
- char *exename;
+void __gnat_gmem_a2l_initialize (char *exename)
{
extern char **gnat_argv;
- char s[100];
+ char s [100];
int l;
- gnat_argv[0] = exename;
+ gnat_argv [0] = exename;
convert_addresses (tracebk, 1, s, &l);
}
/* Read next allocation of deallocation information from the GMEM file and
- write an alloc/free information in buf to be processed by GDB (see gnatmem
- implementation). */
+ write an alloc/free information in buf to be processed by gnatmem */
void
__gnat_gmem_read_next (buf)
- char *buf;
+ struct struct_storage_elmt *buf;
{
void *addr;
- int size;
+ size_t size;
int j;
j = fgetc (gmemfile);
if (j == EOF)
{
fclose (gmemfile);
- sprintf (buf, "Program exited.");
+ buf->Elmt = LOG_EOF;
}
else
{
switch (j)
{
case 'A' :
- fread (&addr, sizeof (char *), 1, gmemfile);
- fread (&size, sizeof (int), 1, gmemfile);
- sprintf (buf, "ALLOC^%d^0x%lx^", size, (long) addr);
+ buf->Elmt = LOG_ALLOC;
+ fread (&(buf->Address), sizeof (void *), 1, gmemfile);
+ fread (&(buf->Size), sizeof (size_t), 1, gmemfile);
break;
case 'D' :
- fread (&addr, sizeof (char *), 1, gmemfile);
- sprintf (buf, "DEALL^0x%lx^", (long) addr);
+ buf->Elmt = LOG_DEALL;
+ fread (&(buf->Address), sizeof (void *), 1, gmemfile);
break;
default:
- puts ("GMEM dump file corrupt");
+ puts ("GNATMEM dump file corrupt");
__gnat_os_exit (1);
}
@@ -167,48 +155,26 @@ __gnat_gmem_read_next (buf)
}
}
-/* Scans the line until the space or new-line character is encountered;
- this character is replaced by nul and its position is returned. */
+/* Read the next frame from the current traceback, and move the cursor to the
+ next frame */
-static char *
-spc2nul (s)
- char *s;
+void __gnat_gmem_read_next_frame (void** addr)
{
- while (*++s)
- if (*s == ' ' || *s == '\n')
- {
- *s = 0;
- return s;
- }
-
- abort ();
+ if (cur_tb_pos >= cur_tb_len) {
+ *addr = NULL;
+ } else {
+ *addr = (void*)*(tracebk + cur_tb_pos);
+ ++cur_tb_pos;
+ }
}
-/* Convert backtrace address in tracebk at position cur_tb_pos to a symbolic
- traceback information returned in buf and to be processed by GDB (see
- gnatmem implementation). */
+/* Converts addr into a symbolic traceback, and stores the result in buf
+ with a format suitable for gnatmem */
-void
-__gnat_gmem_read_bt_frame (buf)
- char *buf;
+void __gnat_gmem_symbolic (void * addr, char* buf, int* length)
{
- int l = 0;
- char s[1000];
- char *name, *file;
-
- if (cur_tb_pos >= cur_tb_len)
- {
- buf[0] = ' ';
- buf[1] = '\0';
- return;
- }
-
- convert_addresses (tracebk + cur_tb_pos, 1, s, &l);
- s[l] = '\0';
- name = spc2nul (s) + 4;
- file = spc2nul (name) + 4;
- spc2nul (file);
- ++cur_tb_pos;
+ char* addresses [] = { (char*)addr };
+ extern char** gnat_argv;
- sprintf (buf, "# %s () at %s", name, file);
+ convert_addresses (addresses, 1, buf, length);
}
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index 09a34c6d8a2..dcae02ee0b7 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.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- --
@@ -31,6 +31,7 @@ with Csets; use Csets;
with Debug; use Debug;
with Elists;
with Errout; use Errout;
+with Fmap;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Frontend;
@@ -39,15 +40,22 @@ with Hostparm;
with Inline;
with Lib; use Lib;
with Lib.Writ; use Lib.Writ;
+with Lib.Xref;
with Namet; use Namet;
with Nlists;
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
+with Prepcomp;
with Repinfo; use Repinfo;
-with Restrict; use Restrict;
+with Restrict;
+with Rident;
with Sem;
+with Sem_Ch8;
+with Sem_Ch12;
with Sem_Ch13;
+with Sem_Eval;
+with Sem_Type;
with Sinfo; use Sinfo;
with Sinput.L; use Sinput.L;
with Snames;
@@ -58,7 +66,7 @@ with Tree_Gen;
with Treepr; use Treepr;
with Ttypes;
with Types; use Types;
-with Uintp;
+with Uintp; use Uintp;
with Uname; use Uname;
with Urealp;
with Usage;
@@ -75,9 +83,6 @@ procedure Gnat1drv is
Main_Kind : Node_Kind;
-- Kind of main compilation unit node.
- Original_Operating_Mode : Operating_Mode_Type;
- -- Save operating type specified by options
-
Back_End_Mode : Back_End.Back_End_Mode_Type;
-- Record back end mode
@@ -92,10 +97,14 @@ begin
-- because it initialize a table that is filled by
-- Scan_Compiler_Arguments.
+ Osint.Initialize;
+ Fmap.Reset_Tables;
Lib.Initialize;
+ Lib.Xref.Initialize;
Scan_Compiler_Arguments;
Osint.Add_Default_Search_Dirs;
+ Nlists.Initialize;
Sinput.Initialize;
Sem.Initialize;
Csets.Initialize;
@@ -106,14 +115,72 @@ begin
Snames.Initialize;
Stringt.Initialize;
Inline.Initialize;
+ Sem_Ch8.Initialize;
+ Sem_Ch12.Initialize;
Sem_Ch13.Initialize;
+ Sem_Eval.Initialize;
+ Sem_Type.Init_Interp_Tables;
+
+ -- Acquire target parameters from system.ads (source of package System)
+
+ declare
+ use Sinput;
+
+ S : Source_File_Index;
+ N : Name_Id;
+ R : Restrict.Restriction_Id;
+ P : Restrict.Restriction_Parameter_Id;
+
+ begin
+ Name_Buffer (1 .. 10) := "system.ads";
+ Name_Len := 10;
+ N := Name_Find;
+ S := Load_Source_File (N);
+
+ if S = No_Source_File then
+ Write_Line
+ ("fatal error, run-time library not installed correctly");
+ Write_Line
+ ("cannot locate file system.ads");
+ raise Unrecoverable_Error;
+
+ -- Here if system.ads successfully read. Remember its source index.
+
+ else
+ System_Source_File_Index := S;
+ end if;
- -- Acquire target parameters and perform required setup
+ Targparm.Get_Target_Parameters
+ (System_Text => Source_Text (S),
+ Source_First => Source_First (S),
+ Source_Last => Source_Last (S));
- Targparm.Get_Target_Parameters;
+ -- Acquire configuration pragma information from Targparm
- if Targparm.High_Integrity_Mode_On_Target then
- Set_No_Run_Time_Mode;
+ for J in Rident.Partition_Restrictions loop
+ R := Restrict.Partition_Restrictions (J);
+
+ if Targparm.Restrictions_On_Target (J) then
+ Restrict.Restrictions (R) := True;
+ Restrict.Restrictions_Loc (R) := System_Location;
+ end if;
+ end loop;
+
+ for K in Rident.Restriction_Parameter_Id loop
+ P := Restrict.Restriction_Parameter_Id (K);
+
+ if Targparm.Restriction_Parameters_On_Target (K) /= No_Uint then
+ Restrict.Restriction_Parameters (P) :=
+ Targparm.Restriction_Parameters_On_Target (K);
+ Restrict.Restriction_Parameters_Loc (P) := System_Location;
+ end if;
+ end loop;
+ end;
+
+ -- Set Configurable_Run_Time mode if system.ads flag set
+
+ if Targparm.Configurable_Run_Time_On_Target or Debug_Flag_YY then
+ Configurable_Run_Time_Mode := True;
end if;
-- Output copyright notice if full list mode
@@ -123,14 +190,8 @@ begin
then
Write_Eol;
Write_Str ("GNAT ");
-
- if Targparm.High_Integrity_Mode_On_Target then
- Write_Str ("Pro High Integrity ");
- end if;
-
Write_Str (Gnat_Version_String);
- Write_Eol;
- Write_Str ("Copyright 1992-2002 Free Software Foundation, Inc.");
+ Write_Str (" Copyright 1992-2003 Free Software Foundation, Inc.");
Write_Eol;
end if;
@@ -154,9 +215,9 @@ begin
if Targparm.ZCX_By_Default_On_Target then
if Targparm.GCC_ZCX_Support_On_Target then
- Exception_Mechanism := GCC_ZCX;
+ Exception_Mechanism := Back_End_ZCX_Exceptions;
else
- Exception_Mechanism := Front_End_ZCX;
+ Exception_Mechanism := Front_End_ZCX_Exceptions;
end if;
end if;
@@ -164,15 +225,16 @@ begin
if Opt.Zero_Cost_Exceptions_Set then
if Opt.Zero_Cost_Exceptions_Val = False then
- Exception_Mechanism := Setjmp_Longjmp;
+ Exception_Mechanism := Front_End_Setjmp_Longjmp_Exceptions;
+
+ elsif Debug_Flag_XX then
+ Exception_Mechanism := Front_End_ZCX_Exceptions;
elsif Targparm.GCC_ZCX_Support_On_Target then
- Exception_Mechanism := GCC_ZCX;
+ Exception_Mechanism := Back_End_ZCX_Exceptions;
- elsif Targparm.Front_End_ZCX_Support_On_Target
- or else Debug_Flag_XX
- then
- Exception_Mechanism := Front_End_ZCX;
+ elsif Targparm.Front_End_ZCX_Support_On_Target then
+ Exception_Mechanism := Front_End_ZCX_Exceptions;
else
Osint.Fail
@@ -192,9 +254,9 @@ begin
and
Targparm.Backend_Overflow_Checks_On_Target))
then
- Suppress_Options.Overflow_Checks := False;
+ Suppress_Options (Overflow_Check) := False;
else
- Suppress_Options.Overflow_Checks := True;
+ Suppress_Options (Overflow_Check) := True;
end if;
-- Check we have exactly one source file, this happens only in
@@ -388,31 +450,21 @@ begin
elsif Operating_Mode /= Generate_Code then
Back_End_Mode := Skip;
- -- We can generate code for a subprogram body unless its corresponding
- -- subprogram spec is a generic delaration. Note that the check for
- -- No (Library_Unit) here is a defensive check that should not be
- -- necessary, since the Library_Unit field should be set properly.
+ -- We can generate code for a subprogram body unless there were
+ -- missing subunits. Note that we always generate code for all
+ -- generic units (a change from some previous versions of GNAT).
elsif Main_Kind = N_Subprogram_Body
and then not Subunits_Missing
- and then (No (Library_Unit (Main_Unit_Node))
- or else Nkind (Unit (Library_Unit (Main_Unit_Node))) /=
- N_Generic_Subprogram_Declaration
- or else Generic_Separately_Compiled (Main_Unit_Entity))
then
Back_End_Mode := Generate_Object;
- -- We can generate code for a package body unless its corresponding
- -- package spec is a generic declaration. As described above, the
- -- check for No (LIbrary_Unit) is a defensive check.
+ -- We can generate code for a package body unless there are subunits
+ -- missing (note that we always generate code for generic units, which
+ -- is a change from some earlier versions of GNAT).
elsif Main_Kind = N_Package_Body
and then not Subunits_Missing
- and then (No (Library_Unit (Main_Unit_Node))
- or else Nkind (Unit (Library_Unit (Main_Unit_Node))) /=
- N_Generic_Package_Declaration
- or else Generic_Separately_Compiled (Main_Unit_Entity))
-
then
Back_End_Mode := Generate_Object;
@@ -430,14 +482,12 @@ begin
Back_End_Mode := Generate_Object;
-- We can generate code for a generic package declaration of a generic
- -- subprogram declaration only if does not require a body, and if it
- -- is a generic that is separately compiled.
+ -- subprogram declaration only if does not require a body.
elsif (Main_Kind = N_Generic_Package_Declaration
or else
Main_Kind = N_Generic_Subprogram_Declaration)
and then not Body_Required (Main_Unit_Node)
- and then Generic_Separately_Compiled (Main_Unit_Entity)
then
Back_End_Mode := Generate_Object;
@@ -450,11 +500,9 @@ begin
Back_End_Mode := Generate_Object;
-- Compilation units that are generic renamings do not require bodies
- -- so we can generate code for them in the separately compiled case
+ -- so we can generate code for them.
- elsif Main_Kind in N_Generic_Renaming_Declaration
- and then Generic_Separately_Compiled (Main_Unit_Entity)
- then
+ elsif Main_Kind in N_Generic_Renaming_Declaration then
Back_End_Mode := Generate_Object;
-- In all other cases (specs which have bodies, generics, and bodies
@@ -479,28 +527,46 @@ begin
-- cannot generate code).
if Back_End_Mode = Skip then
- Write_Str ("No code generated for ");
+ Write_Str ("cannot generate code for ");
Write_Str ("file ");
Write_Name (Unit_File_Name (Main_Unit));
if Subunits_Missing then
Write_Str (" (missing subunits)");
+ Write_Eol;
+ Write_Str ("to check parent unit");
elsif Main_Kind = N_Subunit then
Write_Str (" (subunit)");
-
- elsif Main_Kind = N_Package_Body
- or else Main_Kind = N_Subprogram_Body
- then
- Write_Str (" (generic unit)");
+ Write_Eol;
+ Write_Str ("to check subunit");
elsif Main_Kind = N_Subprogram_Declaration then
Write_Str (" (subprogram spec)");
+ Write_Eol;
+ Write_Str ("to check subprogram spec");
+
+ -- Generic package body in GNAT implementation mode
+
+ elsif Main_Kind = N_Package_Body and then GNAT_Mode then
+ Write_Str (" (predefined generic)");
+ Write_Eol;
+ Write_Str ("to check predefined generic");
-- Only other case is a package spec
else
Write_Str (" (package spec)");
+ Write_Eol;
+ Write_Str ("to check package spec");
+ end if;
+
+ Write_Str (" for errors, use ");
+
+ if Hostparm.OpenVMS then
+ Write_Str ("/NOLOAD");
+ else
+ Write_Str ("-gnatc");
end if;
Write_Eol;
@@ -546,6 +612,11 @@ begin
Lib.Writ.Ensure_System_Dependency;
+ -- Add dependencies, if any, on preprocessing data file and on
+ -- preprocessing definition file(s).
+
+ Prepcomp.Add_Dependencies;
+
-- Back end needs to explicitly unlock tables it needs to touch
Atree.Lock;
@@ -559,16 +630,7 @@ begin
Namet.Lock;
Stringt.Lock;
- -- There are cases where the back end emits warnings, e.g. on objects
- -- that are too large and will cause Storage_Error. If such a warning
- -- appears in a generic context, then it is always appropriately
- -- placed on the instance rather than the template, since gigi only
- -- deals with generated code in instances (in particular the warning
- -- for oversize objects clearly belongs on the instance).
-
- Warn_On_Instance := True;
-
- -- Here we call the backend to generate the output code
+ -- Here we call the back end to generate the output code
Back_End.Call_Back_End (Back_End_Mode);
@@ -590,10 +652,7 @@ begin
-- annotate representation information for List_Rep_Info.
Errout.Finalize;
-
- if Opt.List_Representation_Info /= 0 or else Debug_Flag_AA then
- List_Rep_Info;
- end if;
+ List_Rep_Info;
-- Only write the library if the backend did not generate any error
-- messages. Otherwise signal errors to the driver program so that
diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb
index 3a377773145..45dda7404f2 100644
--- a/gcc/ada/gnatbind.adb
+++ b/gcc/ada/gnatbind.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- --
@@ -33,16 +33,21 @@ with Bindgen; use Bindgen;
with Bindusg;
with Butil; use Butil;
with Csets;
+with Fmap;
with Gnatvsn; use Gnatvsn;
with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
with Osint.B; use Osint.B;
with Output; use Output;
+with Rident; use Rident;
with Switch; use Switch;
with Switch.B; use Switch.B;
with Targparm; use Targparm;
with Types; use Types;
+with Uintp; use Uintp;
+
+with System.Case_Util; use System.Case_Util;
procedure Gnatbind is
@@ -58,14 +63,15 @@ procedure Gnatbind is
Std_Lib_File : File_Name_Type;
-- Standard library
- Text : Text_Buffer_Ptr;
- Id : ALI_Id;
-
+ Text : Text_Buffer_Ptr;
Next_Arg : Positive;
Output_File_Name_Seen : Boolean := False;
+ Output_File_Name : String_Ptr := new String'("");
- Output_File_Name : String_Ptr := new String'("");
+ L_Switch_Seen : Boolean := False;
+
+ Mapping_File : String_Ptr := null;
procedure Scan_Bind_Arg (Argv : String);
-- Scan and process binder specific arguments. Argv is a single argument.
@@ -112,6 +118,13 @@ procedure Gnatbind is
elsif Argv (2) = 'L' then
if Argv'Length >= 3 then
+
+ -- Remember that the -L switch was specified, so that if this
+ -- is on OpenVMS, the export names are put in uppercase.
+ -- This is not known before the target parameters are read.
+
+ L_Switch_Seen := True;
+
Opt.Bind_For_Library := True;
Opt.Ada_Init_Name :=
new String'(Argv (3 .. Argv'Last) & Opt.Ada_Init_Suffix);
@@ -123,6 +136,7 @@ procedure Gnatbind is
-- This option (-Lxxx) implies -n
Opt.Bind_Main_Program := False;
+
else
Fail
("Prefix of initialization and finalization " &
@@ -139,6 +153,8 @@ procedure Gnatbind is
C2 : Character := Argv (4);
begin
+ -- Fold to upper case
+
if C1 in 'a' .. 'z' then
C1 := Character'Val (Character'Pos (C1) - 32);
end if;
@@ -147,28 +163,36 @@ procedure Gnatbind is
C2 := Character'Val (Character'Pos (C2) - 32);
end if;
- if C1 = 'I' and then C2 = 'N' then
- Initialize_Scalars_Mode := 'I';
+ -- Test valid option and set mode accordingly
+
+ if C1 = 'E' and then C2 = 'V' then
+ null;
+
+ elsif C1 = 'I' and then C2 = 'N' then
+ null;
elsif C1 = 'L' and then C2 = 'O' then
- Initialize_Scalars_Mode := 'L';
+ null;
elsif C1 = 'H' and then C2 = 'I' then
- Initialize_Scalars_Mode := 'H';
+ null;
elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'F')
and then
(C2 in '0' .. '9' or else C2 in 'A' .. 'F')
then
- Initialize_Scalars_Mode := 'X';
- Initialize_Scalars_Val (1) := C1;
- Initialize_Scalars_Val (2) := C2;
+ null;
- -- Invalid -S switch, let Switch give error
+ -- Invalid -S switch, let Switch give error, set defalut of IN
else
Scan_Binder_Switches (Argv);
+ C1 := 'I';
+ C2 := 'N';
end if;
+
+ Initialize_Scalars_Mode1 := C1;
+ Initialize_Scalars_Mode2 := C2;
end;
-- -aIdir
@@ -205,11 +229,20 @@ procedure Gnatbind is
elsif Argv (2 .. Argv'Last) = "shared" then
Opt.Shared_Libgnat := True;
+ -- -F=mapping_file
+
+ elsif Argv'Length >= 4 and then Argv (2 .. 3) = "F=" then
+ if Mapping_File /= null then
+ Fail ("cannot specify several mapping files");
+ end if;
+
+ Mapping_File := new String'(Argv (4 .. Argv'Last));
+
-- -Mname
elsif Argv'Length >= 3 and then Argv (2) = 'M' then
Opt.Bind_Alternate_Main_Name := True;
- Opt.Alternate_Main_Name := new String '(Argv (3 .. Argv'Last));
+ Opt.Alternate_Main_Name := new String'(Argv (3 .. Argv'Last));
-- All other options are single character and are handled
-- by Scan_Binder_Switches.
@@ -310,19 +343,43 @@ begin
Osint.Add_Default_Search_Dirs;
- if Verbose_Mode then
- Namet.Initialize;
- Targparm.Get_Target_Parameters;
+ -- Carry out package initializations. These are initializations which
+ -- might logically be performed at elaboration time, but Namet at
+ -- least can't be done that way (because it is used in the Compiler),
+ -- and we decide to be consistent. Like elaboration, the order in
+ -- which these calls are made is in some cases important.
- Write_Eol;
- Write_Str ("GNATBIND ");
+ Csets.Initialize;
+ Namet.Initialize;
- if Targparm.High_Integrity_Mode_On_Target then
- Write_Str ("Pro High Integrity ");
- end if;
+ -- Acquire target parameters
+
+ Targparm.Get_Target_Parameters;
+
+ -- On OpenVMS, when -L is used, all external names used in pragmas Export
+ -- are in upper case. The reason is that on OpenVMS, the macro-assembler
+ -- MACASM-32, used to build Stand-Alone Libraries, only understands
+ -- uppercase.
+ if L_Switch_Seen and then OpenVMS_On_Target then
+ To_Upper (Opt.Ada_Init_Name.all);
+ To_Upper (Opt.Ada_Final_Name.all);
+ To_Upper (Opt.Ada_Main_Name.all);
+ end if;
+
+ -- Acquire configurable run-time mode
+
+ if Configurable_Run_Time_On_Target then
+ Configurable_Run_Time_Mode := True;
+ end if;
+
+ -- Output copyright notice if in verbose mode
+
+ if Verbose_Mode then
+ Write_Eol;
+ Write_Str ("GNATBIND ");
Write_Str (Gnat_Version_String);
- Write_Str (" Copyright 1995-2002 Free Software Foundation, Inc.");
+ Write_Str (" Copyright 1995-2003 Free Software Foundation, Inc.");
Write_Eol;
end if;
@@ -333,19 +390,19 @@ begin
Exit_Program (E_Fatal);
end if;
+ -- If a mapping file was specified, initialize the file mapping
+
+ if Mapping_File /= null then
+ Fmap.Initialize (Mapping_File.all);
+ end if;
+
-- The block here is to catch the Unrecoverable_Error exception in the
-- case where we exceed the maximum number of permissible errors or some
-- other unrecoverable error occurs.
begin
- -- Carry out package initializations. These are initializations which
- -- might logically be performed at elaboration time, but Namet at
- -- least can't be done that way (because it is used in the Compiler),
- -- and we decide to be consistent. Like elaboration, the order in
- -- which these calls are made is in some cases important.
-
- Csets.Initialize;
- Namet.Initialize;
+ -- Initialize binder packages
+
Initialize_Binderr;
Initialize_ALI;
Initialize_ALI_Source;
@@ -371,29 +428,70 @@ begin
end if;
Text := Read_Library_Info (Main_Lib_File, True);
- Id := Scan_ALI
- (F => Main_Lib_File,
- T => Text,
- Ignore_ED => Force_RM_Elaboration_Order,
- Err => False);
+
+ declare
+ Id : ALI_Id;
+ pragma Warnings (Off, Id);
+
+ begin
+ Id := Scan_ALI
+ (F => Main_Lib_File,
+ T => Text,
+ Ignore_ED => Force_RM_Elaboration_Order,
+ Err => False);
+ end;
+
Free (Text);
end loop;
+ -- No_Run_Time mode
+
+ if No_Run_Time_Mode then
+
+ -- Set standard restrictions
+
+ Restrictions_On_Target (No_Finalization) := True;
+ Restrictions_On_Target (No_Exception_Handlers) := True;
+ Restrictions_On_Target (No_Tasking) := True;
+ Restriction_Parameters_On_Target (Max_Tasks) := Uint_0;
+
+ -- Set standard configuration parameters
+
+ Suppress_Standard_Library_On_Target := True;
+ Configurable_Run_Time_Mode := True;
+ end if;
+
+ -- For main ALI files, even if they are interfaces, we get their
+ -- dependencies. To be sure, we reset the Interface flag for all main
+ -- ALI files.
+
+ for Index in ALIs.First .. ALIs.Last loop
+ ALIs.Table (Index).Interface := False;
+ end loop;
+
-- Add System.Standard_Library to list to ensure that these files are
-- included in the bind, even if not directly referenced from Ada code
- -- This is of course omitted in No_Run_Time mode
+ -- This is suppressed if the configurable run-time requests it.
- if not No_Run_Time_Specified then
+ if not Suppress_Standard_Library_On_Target then
Name_Buffer (1 .. 12) := "s-stalib.ali";
Name_Len := 12;
Std_Lib_File := Name_Find;
Text := Read_Library_Info (Std_Lib_File, True);
- Id :=
- Scan_ALI
- (F => Std_Lib_File,
- T => Text,
- Ignore_ED => Force_RM_Elaboration_Order,
- Err => False);
+
+ declare
+ Id : ALI_Id;
+ pragma Warnings (Off, Id);
+
+ begin
+ Id :=
+ Scan_ALI
+ (F => Std_Lib_File,
+ T => Text,
+ Ignore_ED => Force_RM_Elaboration_Order,
+ Err => False);
+ end;
+
Free (Text);
end if;
@@ -441,6 +539,16 @@ begin
Check_Consistency;
Check_Configuration_Consistency;
+ -- Acquire restrictions and add them to target restrictions. After
+ -- this loop, Restrictions_On_Target entries will be set True for
+ -- all partition-wide restrictions specified in the partition.
+
+ for J in Partition_Restrictions loop
+ if Restrictions (J) = 'r' then
+ Restrictions_On_Target (J) := True;
+ end if;
+ end loop;
+
-- Complete bind if no errors
if Errors_Detected = 0 then
@@ -453,9 +561,12 @@ begin
Write_Eol;
for J in Elab_Order.First .. Elab_Order.Last loop
- Write_Str (" ");
- Write_Unit_Name (Units.Table (Elab_Order.Table (J)).Uname);
- Write_Eol;
+ if not Units.Table (Elab_Order.Table (J)).Interface then
+ Write_Str (" ");
+ Write_Unit_Name
+ (Units.Table (Elab_Order.Table (J)).Uname);
+ Write_Eol;
+ end if;
end loop;
Write_Eol;
diff --git a/gcc/ada/gnatchop.adb b/gcc/ada/gnatchop.adb
index 7a535d3d837..3e771e5a05d 100644
--- a/gcc/ada/gnatchop.adb
+++ b/gcc/ada/gnatchop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 1998-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -19,7 +19,8 @@
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/gnatclean.adb b/gcc/ada/gnatclean.adb
new file mode 100644
index 00000000000..b146d241b1f
--- /dev/null
+++ b/gcc/ada/gnatclean.adb
@@ -0,0 +1,42 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T C L E A N --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Gnatclean is a utility to delete files produced by the GNAT tools:
+-- ALI files, object files, tree files, expanded source files, library
+-- files, interface copy files, binder generated files and executable files.
+
+-- Gnatclean may be invoked for one or several executables, for a project
+-- file or a tree of project files with the optional specification of
+-- one of several executables.
+
+with Clean;
+
+procedure Gnatclean is
+begin
+ -- The real work is done in Package Clean
+
+ Clean.Gnatclean;
+end Gnatclean;
diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb
index b754aff0245..f1896d9da7c 100644
--- a/gcc/ada/gnatcmd.adb
+++ b/gcc/ada/gnatcmd.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -27,7 +27,7 @@
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Csets;
-with MLib.Tgt;
+with MLib.Tgt; use MLib.Tgt;
with MLib.Utl;
with Namet; use Namet;
with Opt;
@@ -38,9 +38,7 @@ with Prj.Env;
with Prj.Ext; use Prj.Ext;
with Prj.Pars;
with Prj.Util; use Prj.Util;
-with Sdefault; use Sdefault;
with Snames; use Snames;
-with Stringt; use Stringt;
with Table;
with Types; use Types;
with Hostparm; use Hostparm;
@@ -50,16 +48,13 @@ with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
-with Gnatvsn;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with Table;
-procedure GNATCmd is
-
- Ada_Include_Path : constant String := "ADA_INCLUDE_PATH";
- Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH";
+with VMS_Conv; use VMS_Conv;
+procedure GNATCmd is
Project_File : String_Access;
Project : Prj.Project_Id;
Current_Verbosity : Prj.Verbosity := Prj.Default;
@@ -71,16 +66,6 @@ procedure GNATCmd is
Old_Project_File_Used : Boolean := False;
- -- A table to keep the switches on the command line
-
- package Last_Switches is new Table.Table
- (Table_Component_Type => String_Access,
- Table_Index_Type => Integer,
- Table_Low_Bound => 1,
- Table_Initial => 20,
- Table_Increment => 100,
- Table_Name => "Gnatcmd.Last_Switches");
-
-- A table to keep the switches from the project file
package First_Switches is new Table.Table
@@ -91,1782 +76,93 @@ procedure GNATCmd is
Table_Increment => 100,
Table_Name => "Gnatcmd.First_Switches");
- ------------------
- -- SWITCH TABLE --
- ------------------
-
- -- The switch tables contain an entry for each switch recognized by the
- -- command processor. The syntax of entries is as follows:
-
- -- SWITCH_STRING ::= "/ command-qualifier-name TRANSLATION"
-
- -- TRANSLATION ::=
- -- DIRECT_TRANSLATION
- -- | DIRECTORIES_TRANSLATION
- -- | FILE_TRANSLATION
- -- | NO_SPACE_FILE_TRANSL
- -- | NUMERIC_TRANSLATION
- -- | STRING_TRANSLATION
- -- | OPTIONS_TRANSLATION
- -- | COMMANDS_TRANSLATION
- -- | ALPHANUMPLUS_TRANSLATION
- -- | OTHER_TRANSLATION
-
- -- DIRECT_TRANSLATION ::= space UNIX_SWITCHES
- -- DIRECTORIES_TRANSLATION ::= =* UNIX_SWITCH *
- -- DIRECTORY_TRANSLATION ::= =% UNIX_SWITCH %
- -- FILE_TRANSLATION ::= =@ UNIX_SWITCH @
- -- NO_SPACE_FILE_TRANSL ::= =< UNIX_SWITCH >
- -- NUMERIC_TRANSLATION ::= =# UNIX_SWITCH # | # number #
- -- STRING_TRANSLATION ::= =" UNIX_SWITCH "
- -- OPTIONS_TRANSLATION ::= =OPTION {space OPTION}
- -- COMMANDS_TRANSLATION ::= =? ARGS space command-name
- -- ALPHANUMPLUS_TRANSLATION ::= =| UNIX_SWITCH |
-
- -- UNIX_SWITCHES ::= UNIX_SWITCH {, UNIX_SWITCH}
-
- -- UNIX_SWITCH ::= unix-switch-string | !unix-switch-string | `string'
-
- -- OPTION ::= option-name space UNIX_SWITCHES
-
- -- ARGS ::= -cargs | -bargs | -largs
-
- -- Here command-qual is the name of the switch recognized by the GNATCmd.
- -- This is always given in upper case in the templates, although in the
- -- actual commands, either upper or lower case is allowed.
-
- -- The unix-switch-string always starts with a minus, and has no commas
- -- or spaces in it. Case is significant in the unix switch string. If a
- -- unix switch string is preceded by the not sign (!) it means that the
- -- effect of the corresponding command qualifer is to remove any previous
- -- occurrence of the given switch in the command line.
-
- -- The DIRECTORIES_TRANSLATION format is used where a list of directories
- -- is given. This possible corresponding formats recognized by GNATCmd are
- -- as shown by the following example for the case of PATH
-
- -- PATH=direc
- -- PATH=(direc,direc,direc,direc)
-
- -- When more than one directory is present for the DIRECTORIES case, then
- -- multiple instances of the corresponding unix switch are generated,
- -- with the file name being substituted for the occurrence of *.
-
- -- The FILE_TRANSLATION format is similar except that only a single
- -- file is allowed, not a list of files, and only one unix switch is
- -- generated as a result.
-
- -- the NO_SPACE_FILE_TRANSL is similar to FILE_TRANSLATION, except that
- -- no space is inserted between the switch and the file name.
-
- -- The NUMERIC_TRANSLATION format is similar to the FILE_TRANSLATION case
- -- except that the parameter is a decimal integer in the range 0 to 999.
-
- -- For the OPTIONS_TRANSLATION case, GNATCmd similarly permits one or
- -- more options to appear (although only in some cases does the use of
- -- multiple options make logical sense). For example, taking the
- -- case of ERRORS for GCC, the following are all allowed:
-
- -- /ERRORS=BRIEF
- -- /ERRORS=(FULL,VERBOSE)
- -- /ERRORS=(BRIEF IMMEDIATE)
+ package Library_Paths is new Table.Table (
+ Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Make.Library_Path");
- -- If no option is provided (e.g. just /ERRORS is written), then the
- -- first option in the list is the default option. For /ERRORS this
- -- is NORMAL, so /ERRORS with no option is equivalent to /ERRORS=NORMAL.
+ -- Packages of project files to pass to Prj.Pars.Parse, depending on the
+ -- tool. We allocate objects because we cannot declare aliased objects
+ -- as we are in a procedure, not a library level package.
- -- The COMMANDS_TRANSLATION case is only used for gnatmake, to correspond
- -- to the use of -cargs, -bargs and -largs (the ARGS string as indicated
- -- is one of these three possibilities). The name given by COMMAND is the
- -- corresponding command name to be used to interprete the switches to be
- -- passed on. Switches of this type set modes, e.g. /COMPILER_QUALIFIERS
- -- sets the mode so that all subsequent switches, up to another switch
- -- with COMMANDS_TRANSLATION apply to the corresponding commands issued
- -- by the make utility. For example
+ Naming_String : constant String_Access := new String'("naming");
+ Binder_String : constant String_Access := new String'("binder");
+ Eliminate_String : constant String_Access := new String'("eliminate");
+ Finder_String : constant String_Access := new String'("finder");
+ Linker_String : constant String_Access := new String'("linker");
+ Gnatls_String : constant String_Access := new String'("gnatls");
+ Pretty_String : constant String_Access := new String'("pretty_printer");
+ Gnatstub_String : constant String_Access := new String'("gnatstub");
+ Xref_String : constant String_Access := new String'("cross_reference");
- -- /COMPILER_QUALIFIERS /LIST /BINDER_QUALIFIERS /MAIN
- -- /COMPILER_QUALIFIERS /NOLIST /COMPILE_CHECKS=SYNTAX
+ Packages_To_Check_By_Binder : constant String_List_Access :=
+ new String_List'((Naming_String, Binder_String));
- -- Clearly these switches must come at the end of the list of switches
- -- since all subsequent switches apply to an issued command.
+ Packages_To_Check_By_Eliminate : constant String_List_Access :=
+ new String_List'((Naming_String, Eliminate_String));
- -- For the DIRECT_TRANSLATION case, an implicit additional entry is
- -- created by prepending NO to the name of the qualifer, and then
- -- inverting the sense of the UNIX_SWITCHES string. For example,
- -- given the entry:
+ Packages_To_Check_By_Finder : constant String_List_Access :=
+ new String_List'((Naming_String, Finder_String));
- -- "/LIST -gnatl"
+ Packages_To_Check_By_Linker : constant String_List_Access :=
+ new String_List'((Naming_String, Linker_String));
- -- An implicit entry is created:
-
- -- "/NOLIST !-gnatl"
-
- -- In the case where, a ! is already present, inverting the sense of the
- -- switch means removing it.
-
- subtype S is String;
- -- A synonym to shorten the table
-
- type String_Ptr is access constant String;
- -- String pointer type used throughout
-
- type Switches is array (Natural range <>) of String_Ptr;
- -- Type used for array of swtiches
-
- type Switches_Ptr is access constant Switches;
-
- --------------------------------
- -- Switches for project files --
- --------------------------------
-
- S_Ext_Ref : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
- "-X" & '"';
-
- S_Project_File : aliased constant S := "/PROJECT_FILE=<" &
- "-P>";
- S_Project_Verb : aliased constant S := "/PROJECT_FILE_VERBOSITY=" &
- "DEFAULT " &
- "-vP0 " &
- "MEDIUM " &
- "-vP1 " &
- "HIGH " &
- "-vP2";
-
- ----------------------------
- -- Switches for GNAT BIND --
- ----------------------------
-
- S_Bind_Bind : aliased constant S := "/BIND_FILE=" &
- "ADA " &
- "-A " &
- "C " &
- "-C";
-
- S_Bind_Build : aliased constant S := "/BUILD_LIBRARY=|" &
- "-L|";
-
- S_Bind_Current : aliased constant S := "/CURRENT_DIRECTORY " &
- "!-I-";
-
- S_Bind_Debug : aliased constant S := "/DEBUG=" &
- "TRACEBACK " &
- "-g2 " &
- "ALL " &
- "-g3 " &
- "NONE " &
- "-g0 " &
- "SYMBOLS " &
- "-g1 " &
- "NOSYMBOLS " &
- "!-g1 " &
- "LINK " &
- "-g3 " &
- "NOTRACEBACK " &
- "!-g2";
-
- S_Bind_DebugX : aliased constant S := "/NODEBUG " &
- "!-g";
-
- S_Bind_Elab : aliased constant S := "/ELABORATION_DEPENDENCIES " &
- "-e";
-
- S_Bind_Error : aliased constant S := "/ERROR_LIMIT=#" &
- "-m#";
-
- S_Bind_Help : aliased constant S := "/HELP " &
- "-h";
-
- S_Bind_Init : aliased constant S := "/INITIALIZE_SCALARS=" &
- "INVALID " &
- "-Sin " &
- "LOW " &
- "-Slo " &
- "HIGH " &
- "-Shi";
-
- S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
- "-aO*";
-
- S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " &
- "-K";
-
- S_Bind_List : aliased constant S := "/LIST_RESTRICTIONS " &
- "-r";
-
- S_Bind_Main : aliased constant S := "/MAIN " &
- "!-n";
-
- S_Bind_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_Bind_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
- "-nostdlib";
-
- S_Bind_No_Time : aliased constant S := "/NO_TIME_STAMP_CHECK " &
- "-t";
-
- S_Bind_Object : aliased constant S := "/OBJECT_LIST " &
- "-O";
-
- S_Bind_Order : aliased constant S := "/ORDER_OF_ELABORATION " &
- "-l";
-
- S_Bind_Output : aliased constant S := "/OUTPUT=@" &
- "-o@";
-
- S_Bind_OutputX : aliased constant S := "/NOOUTPUT " &
- "-c";
-
- S_Bind_Pess : aliased constant S := "/PESSIMISTIC_ELABORATION " &
- "-p";
-
- S_Bind_Read : aliased constant S := "/READ_SOURCES=" &
- "ALL " &
- "-s " &
- "NONE " &
- "-x " &
- "AVAILABLE " &
- "!-x,!-s";
-
- S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " &
- "-x";
-
- S_Bind_Rename : aliased constant S := "/RENAME_MAIN=<" &
- "-M>";
-
- S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" &
- "VERBOSE " &
- "-v " &
- "BRIEF " &
- "-b " &
- "DEFAULT " &
- "!-b,!-v";
-
- S_Bind_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
- "!-b,!-v";
-
- S_Bind_Restr : aliased constant S := "/RESTRICTION_LIST " &
- "-r";
-
- S_Bind_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" &
- "--RTS=|";
-
- S_Bind_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_Bind_Shared : aliased constant S := "/SHARED " &
- "-shared";
-
- S_Bind_Slice : aliased constant S := "/TIME_SLICE=#" &
- "-T#";
-
- S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
-
- S_Bind_Time : aliased constant S := "/TIME_STAMP_CHECK " &
- "!-t";
-
- S_Bind_Verbose : aliased constant S := "/VERBOSE " &
- "-v";
-
- S_Bind_Warn : aliased constant S := "/WARNINGS=" &
- "NORMAL " &
- "!-ws,!-we " &
- "SUPPRESS " &
- "-ws " &
- "ERROR " &
- "-we";
-
- S_Bind_WarnX : aliased constant S := "/NOWARNINGS " &
- "-ws";
-
- Bind_Switches : aliased constant Switches :=
- (S_Bind_Bind 'Access,
- S_Bind_Build 'Access,
- S_Bind_Current 'Access,
- S_Bind_Debug 'Access,
- S_Bind_DebugX 'Access,
- S_Bind_Elab 'Access,
- S_Bind_Error 'Access,
- S_Ext_Ref 'Access,
- S_Bind_Help 'Access,
- S_Bind_Init 'Access,
- S_Bind_Library 'Access,
- S_Bind_Linker 'Access,
- S_Bind_List 'Access,
- S_Bind_Main 'Access,
- S_Bind_Nostinc 'Access,
- S_Bind_Nostlib 'Access,
- S_Bind_No_Time 'Access,
- S_Bind_Object 'Access,
- S_Bind_Order 'Access,
- S_Bind_Output 'Access,
- S_Bind_OutputX 'Access,
- S_Bind_Pess 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Bind_Read 'Access,
- S_Bind_ReadX 'Access,
- S_Bind_Rename 'Access,
- S_Bind_Report 'Access,
- S_Bind_ReportX 'Access,
- S_Bind_Restr 'Access,
- S_Bind_RTS 'Access,
- S_Bind_Search 'Access,
- S_Bind_Shared 'Access,
- S_Bind_Slice 'Access,
- S_Bind_Source 'Access,
- S_Bind_Time 'Access,
- S_Bind_Verbose 'Access,
- S_Bind_Warn 'Access,
- S_Bind_WarnX 'Access);
-
- ----------------------------
- -- Switches for GNAT CHOP --
- ----------------------------
-
- S_Chop_Comp : aliased constant S := "/COMPILATION " &
- "-c";
-
- S_Chop_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
- "-k#";
-
- S_Chop_Help : aliased constant S := "/HELP " &
- "-h";
-
- S_Chop_Over : aliased constant S := "/OVERWRITE " &
- "-w";
-
- S_Chop_Pres : aliased constant S := "/PRESERVE " &
- "-p";
-
- S_Chop_Quiet : aliased constant S := "/QUIET " &
- "-q";
-
- S_Chop_Ref : aliased constant S := "/REFERENCE " &
- "-r";
-
- S_Chop_Verb : aliased constant S := "/VERBOSE " &
- "-v";
-
- Chop_Switches : aliased constant Switches :=
- (S_Chop_Comp 'Access,
- S_Chop_File 'Access,
- S_Chop_Help 'Access,
- S_Chop_Over 'Access,
- S_Chop_Pres 'Access,
- S_Chop_Quiet 'Access,
- S_Chop_Ref 'Access,
- S_Chop_Verb 'Access);
-
- -------------------------------
- -- Switches for GNAT COMPILE --
- -------------------------------
-
- S_GCC_Ada_83 : aliased constant S := "/83 " &
- "-gnat83";
-
- S_GCC_Ada_95 : aliased constant S := "/95 " &
- "!-gnat83";
-
- S_GCC_Asm : aliased constant S := "/ASM " &
- "-S,!-c";
-
- S_GCC_Checks : aliased constant S := "/CHECKS=" &
- "FULL " &
- "-gnato,!-gnatE,!-gnatp " &
- "OVERFLOW " &
- "-gnato " &
- "ELABORATION " &
- "-gnatE " &
- "ASSERTIONS " &
- "-gnata " &
- "DEFAULT " &
- "!-gnato,!-gnatp " &
- "SUPPRESS_ALL " &
- "-gnatp";
-
- S_GCC_ChecksX : aliased constant S := "/NOCHECKS " &
- "-gnatp,!-gnato,!-gnatE";
-
- S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " &
- "-gnatC";
-
- S_GCC_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" &
- "-gnatec>";
-
- S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " &
- "!-I-";
-
- S_GCC_Debug : aliased constant S := "/DEBUG=" &
- "SYMBOLS " &
- "-g2 " &
- "NOSYMBOLS " &
- "!-g2 " &
- "TRACEBACK " &
- "-g1 " &
- "ALL " &
- "-g3 " &
- "NONE " &
- "-g0 " &
- "NOTRACEBACK " &
- "-g0";
-
- S_GCC_DebugX : aliased constant S := "/NODEBUG " &
- "!-g";
-
- S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" &
- "RECEIVER " &
- "-gnatzr " &
- "CALLER " &
- "-gnatzc";
-
- S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " &
- "!-gnatzr,!-gnatzc";
-
- S_GCC_Error : aliased constant S := "/ERROR_LIMIT=#" &
- "-gnatm#";
-
- S_GCC_ErrorX : aliased constant S := "/NOERROR_LIMIT " &
- "-gnatm999";
-
- S_GCC_Expand : aliased constant S := "/EXPAND_SOURCE " &
- "-gnatG";
-
- S_GCC_Extend : aliased constant S := "/EXTENSIONS_ALLOWED " &
- "-gnatX";
-
- S_GCC_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
- "-gnatk#";
-
- S_GCC_Force : aliased constant S := "/FORCE_ALI " &
- "-gnatQ";
-
- S_GCC_Help : aliased constant S := "/HELP " &
- "-gnath";
-
- S_GCC_Ident : aliased constant S := "/IDENTIFIER_CHARACTER_SET=" &
- "DEFAULT " &
- "-gnati1 " &
- "1 " &
- "-gnati1 " &
- "2 " &
- "-gnati2 " &
- "3 " &
- "-gnati3 " &
- "4 " &
- "-gnati4 " &
- "5 " &
- "-gnati5 " &
- "PC " &
- "-gnatip " &
- "PC850 " &
- "-gnati8 " &
- "FULL_UPPER " &
- "-gnatif " &
- "NO_UPPER " &
- "-gnatin " &
- "WIDE " &
- "-gnatiw";
-
- S_GCC_IdentX : aliased constant S := "/NOIDENTIFIER_CHARACTER_SET " &
- "-gnati1";
-
- S_GCC_Immed : aliased constant S := "/IMMEDIATE_ERRORS " &
- "-gnatdO";
-
- S_GCC_Inline : aliased constant S := "/INLINE=" &
- "PRAGMA " &
- "-gnatn " &
- "FULL " &
- "-gnatN " &
- "SUPPRESS " &
- "-fno-inline";
-
- S_GCC_InlineX : aliased constant S := "/NOINLINE " &
- "!-gnatn";
-
- S_GCC_Jumps : aliased constant S := "/LONGJMP_SETJMP " &
- "-gnatL";
-
- S_GCC_Length : aliased constant S := "/MAX_LINE_LENGTH=#" &
- "-gnatyM#";
-
- S_GCC_List : aliased constant S := "/LIST " &
- "-gnatl";
-
- S_GCC_Noadc : aliased constant S := "/NO_GNAT_ADC " &
- "-gnatA";
-
- S_GCC_Noload : aliased constant S := "/NOLOAD " &
- "-gnatc";
-
- S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_GCC_Opt : aliased constant S := "/OPTIMIZE=" &
- "ALL " &
- "-O2,!-O0,!-O1,!-O3 " &
- "NONE " &
- "-O0,!-O1,!-O2,!-O3 " &
- "SOME " &
- "-O1,!-O0,!-O2,!-O3 " &
- "DEVELOPMENT " &
- "-O1,!-O0,!-O2,!-O3 " &
- "UNROLL_LOOPS " &
- "-funroll-loops " &
- "INLINING " &
- "-O3,!-O0,!-O1,!-O2";
-
- S_GCC_OptX : aliased constant S := "/NOOPTIMIZE " &
- "-O0,!-O1,!-O2,!-O3";
-
- S_GCC_Polling : aliased constant S := "/POLLING " &
- "-gnatP";
-
- S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" &
- "VERBOSE " &
- "-gnatv " &
- "BRIEF " &
- "-gnatb " &
- "FULL " &
- "-gnatf " &
- "IMMEDIATE " &
- "-gnate " &
- "DEFAULT " &
- "!-gnatb,!-gnatv";
-
- S_GCC_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
- "!-gnatb,!-gnatv";
-
- S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" &
- "ARRAYS " &
- "-gnatR1 " &
- "NONE " &
- "-gnatR0 " &
- "OBJECTS " &
- "-gnatR2 " &
- "SYMBOLIC " &
- "-gnatR3 " &
- "DEFAULT " &
- "-gnatR";
-
- S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " &
- "!-gnatR";
-
- S_GCC_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_GCC_Style : aliased constant S := "/STYLE_CHECKS=" &
- "ALL_BUILTIN " &
- "-gnaty " &
- "1 " &
- "-gnaty1 " &
- "2 " &
- "-gnaty2 " &
- "3 " &
- "-gnaty3 " &
- "4 " &
- "-gnaty4 " &
- "5 " &
- "-gnaty5 " &
- "6 " &
- "-gnaty6 " &
- "7 " &
- "-gnaty7 " &
- "8 " &
- "-gnaty8 " &
- "9 " &
- "-gnaty9 " &
- "ATTRIBUTE " &
- "-gnatya " &
- "BLANKS " &
- "-gnatyb " &
- "COMMENTS " &
- "-gnatyc " &
- "END " &
- "-gnatye " &
- "VTABS " &
- "-gnatyf " &
- "GNAT " &
- "-gnatg " &
- "HTABS " &
- "-gnatyh " &
- "IF_THEN " &
- "-gnatyi " &
- "KEYWORD " &
- "-gnatyk " &
- "LAYOUT " &
- "-gnatyl " &
- "LINE_LENGTH " &
- "-gnatym " &
- "STANDARD_CASING " &
- "-gnatyn " &
- "ORDERED_SUBPROGRAMS " &
- "-gnatyo " &
- "NONE " &
- "!-gnatg,!-gnatr " &
- "PRAGMA " &
- "-gnatyp " &
- "RM_COLUMN_LAYOUT " &
- "-gnatr " &
- "SPECS " &
- "-gnatys " &
- "TOKEN " &
- "-gnatyt ";
-
- S_GCC_StyleX : aliased constant S := "/NOSTYLE_CHECKS " &
- "!-gnatg,!-gnatr";
-
- S_GCC_Syntax : aliased constant S := "/SYNTAX_ONLY " &
- "-gnats";
-
- S_GCC_Trace : aliased constant S := "/TRACE_UNITS " &
- "-gnatdc";
-
- S_GCC_Tree : aliased constant S := "/TREE_OUTPUT " &
- "-gnatt";
-
- S_GCC_Trys : aliased constant S := "/TRY_SEMANTICS " &
- "-gnatq";
-
- S_GCC_Units : aliased constant S := "/UNITS_LIST " &
- "-gnatu";
-
- S_GCC_Unique : aliased constant S := "/UNIQUE_ERROR_TAG " &
- "-gnatU";
-
- S_GCC_Upcase : aliased constant S := "/UPPERCASE_EXTERNALS " &
- "-gnatF";
-
- S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" &
- "DEFAULT " &
- "-gnatVd " &
- "NODEFAULT " &
- "-gnatVD " &
- "COPIES " &
- "-gnatVc " &
- "NOCOPIES " &
- "-gnatVC " &
- "FLOATS " &
- "-gnatVf " &
- "NOFLOATS " &
- "-gnatVF " &
- "IN_PARAMS " &
- "-gnatVi " &
- "NOIN_PARAMS " &
- "-gnatVI " &
- "MOD_PARAMS " &
- "-gnatVm " &
- "NOMOD_PARAMS " &
- "-gnatVM " &
- "OPERANDS " &
- "-gnatVo " &
- "NOOPERANDS " &
- "-gnatVO " &
- "RETURNS " &
- "-gnatVr " &
- "NORETURNS " &
- "-gnatVR " &
- "SUBSCRIPTS " &
- "-gnatVs " &
- "NOSUBSCRIPTS " &
- "-gnatVS " &
- "TESTS " &
- "-gnatVt " &
- "NOTESTS " &
- "-gnatVT " &
- "ALL " &
- "-gnatVa " &
- "NONE " &
- "-gnatVn";
-
- S_GCC_Verbose : aliased constant S := "/VERBOSE " &
- "-v";
-
- S_GCC_Warn : aliased constant S := "/WARNINGS=" &
- "DEFAULT " &
- "!-gnatws,!-gnatwe " &
- "ALL_GCC " &
- "-Wall " &
- "BIASED_ROUNDING " &
- "-gnatwb " &
- "NOBIASED_ROUNDING " &
- "-gnatwB " &
- "CONDITIONALS " &
- "-gnatwc " &
- "NOCONDITIONALS " &
- "-gnatwC " &
- "IMPLICIT_DEREFERENCE " &
- "-gnatwd " &
- "NO_IMPLICIT_DEREFERENCE " &
- "-gnatwD " &
- "ELABORATION " &
- "-gnatwl " &
- "NOELABORATION " &
- "-gnatwL " &
- "ERRORS " &
- "-gnatwe " &
- "HIDING " &
- "-gnatwh " &
- "NOHIDING " &
- "-gnatwH " &
- "IMPLEMENTATION " &
- "-gnatwi " &
- "NOIMPLEMENTATION " &
- "-gnatwI " &
- "INEFFECTIVE_INLINE " &
- "-gnatwp " &
- "NOINEFFECTIVE_INLINE " &
- "-gnatwP " &
- "OPTIONAL " &
- "-gnatwa " &
- "NOOPTIONAL " &
- "-gnatwA " &
- "OVERLAYS " &
- "-gnatwo " &
- "NOOVERLAYS " &
- "-gnatwO " &
- "REDUNDANT " &
- "-gnatwr " &
- "NOREDUNDANT " &
- "-gnatwR " &
- "SUPPRESS " &
- "-gnatws " &
- "UNINITIALIZED " &
- "-Wuninitialized " &
- "UNREFERENCED_FORMALS " &
- "-gnatwf " &
- "NOUNREFERENCED_FORMALS " &
- "-gnatwF " &
- "UNUSED " &
- "-gnatwu " &
- "NOUNUSED " &
- "-gnatwU";
-
- S_GCC_WarnX : aliased constant S := "/NOWARNINGS " &
- "-gnatws";
-
- S_GCC_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" &
- "BRACKETS " &
- "-gnatWb " &
- "NONE " &
- "-gnatWn " &
- "HEX " &
- "-gnatWh " &
- "UPPER " &
- "-gnatWu " &
- "SHIFT_JIS " &
- "-gnatWs " &
- "UTF8 " &
- "-gnatW8 " &
- "EUC " &
- "-gnatWe";
-
- S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " &
- "-gnatWn";
-
- S_GCC_Xdebug : aliased constant S := "/XDEBUG " &
- "-gnatD";
-
- S_GCC_Xref : aliased constant S := "/XREF=" &
- "GENERATE " &
- "!-gnatx " &
- "SUPPRESS " &
- "-gnatx";
-
- GCC_Switches : aliased constant Switches :=
- (S_GCC_Ada_83 'Access,
- S_GCC_Ada_95 'Access,
- S_GCC_Asm 'Access,
- S_GCC_Checks 'Access,
- S_GCC_ChecksX 'Access,
- S_GCC_Compres 'Access,
- S_GCC_Config 'Access,
- S_GCC_Current 'Access,
- S_GCC_Debug 'Access,
- S_GCC_DebugX 'Access,
- S_GCC_Dist 'Access,
- S_GCC_DistX 'Access,
- S_GCC_Error 'Access,
- S_GCC_ErrorX 'Access,
- S_GCC_Expand 'Access,
- S_GCC_Extend 'Access,
- S_Ext_Ref 'Access,
- S_GCC_File 'Access,
- S_GCC_Force 'Access,
- S_GCC_Help 'Access,
- S_GCC_Ident 'Access,
- S_GCC_IdentX 'Access,
- S_GCC_Immed 'Access,
- S_GCC_Inline 'Access,
- S_GCC_InlineX 'Access,
- S_GCC_Jumps 'Access,
- S_GCC_Length 'Access,
- S_GCC_List 'Access,
- S_GCC_Noadc 'Access,
- S_GCC_Noload 'Access,
- S_GCC_Nostinc 'Access,
- S_GCC_Opt 'Access,
- S_GCC_OptX 'Access,
- S_GCC_Polling 'Access,
- S_Project_File'Access,
- S_Project_Verb'Access,
- S_GCC_Report 'Access,
- S_GCC_ReportX 'Access,
- S_GCC_Repinfo 'Access,
- S_GCC_RepinfX 'Access,
- S_GCC_Search 'Access,
- S_GCC_Style 'Access,
- S_GCC_StyleX 'Access,
- S_GCC_Syntax 'Access,
- S_GCC_Trace 'Access,
- S_GCC_Tree 'Access,
- S_GCC_Trys 'Access,
- S_GCC_Units 'Access,
- S_GCC_Unique 'Access,
- S_GCC_Upcase 'Access,
- S_GCC_Valid 'Access,
- S_GCC_Verbose 'Access,
- S_GCC_Warn 'Access,
- S_GCC_WarnX 'Access,
- S_GCC_Wide 'Access,
- S_GCC_WideX 'Access,
- S_GCC_Xdebug 'Access,
- S_GCC_Xref 'Access);
-
- ----------------------------
- -- Switches for GNAT ELIM --
- ----------------------------
-
- S_Elim_All : aliased constant S := "/ALL " &
- "-a";
-
- S_Elim_Bind : aliased constant S := "/BIND_FILE=<" &
- "-b>";
-
- S_Elim_Miss : aliased constant S := "/MISSED " &
- "-m";
-
- S_Elim_Quiet : aliased constant S := "/QUIET " &
- "-q";
-
- S_Elim_Tree : aliased constant S := "/TREE_DIRS=*" &
- "-T*";
-
- S_Elim_Verb : aliased constant S := "/VERBOSE " &
- "-v";
-
- Elim_Switches : aliased constant Switches :=
- (S_Elim_All 'Access,
- S_Elim_Bind 'Access,
- S_Elim_Miss 'Access,
- S_Elim_Quiet 'Access,
- S_Elim_Tree 'Access,
- S_Elim_Verb 'Access);
-
- ----------------------------
- -- Switches for GNAT FIND --
- ----------------------------
-
- S_Find_All : aliased constant S := "/ALL_FILES " &
- "-a";
-
- S_Find_Deriv : aliased constant S := "/DERIVED_TYPE_INFORMATION " &
- "-d";
-
- S_Find_Expr : aliased constant S := "/EXPRESSIONS " &
- "-e";
-
- S_Find_Full : aliased constant S := "/FULL_PATHNAME " &
- "-f";
-
- S_Find_Ignore : aliased constant S := "/IGNORE_LOCALS " &
- "-g";
-
- S_Find_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_Find_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
- "-nostdlib";
-
- S_Find_Object : aliased constant S := "/OBJECT_SEARCH=*" &
- "-aO*";
-
- S_Find_Print : aliased constant S := "/PRINT_LINES " &
- "-s";
-
- S_Find_Project : aliased constant S := "/PROJECT=@" &
- "-p@";
-
- S_Find_Ref : aliased constant S := "/REFERENCES " &
- "-r";
-
- S_Find_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
-
- S_Find_Types : aliased constant S := "/TYPE_HIERARCHY " &
- "-t";
-
- Find_Switches : aliased constant Switches :=
- (S_Find_All 'Access,
- S_Find_Deriv 'Access,
- S_Find_Expr 'Access,
- S_Ext_Ref 'Access,
- S_Find_Full 'Access,
- S_Find_Ignore 'Access,
- S_Find_Nostinc 'Access,
- S_Find_Nostlib 'Access,
- S_Find_Object 'Access,
- S_Find_Print 'Access,
- S_Find_Project 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Find_Ref 'Access,
- S_Find_Search 'Access,
- S_Find_Source 'Access,
- S_Find_Types 'Access);
-
- ------------------------------
- -- Switches for GNAT KRUNCH --
- ------------------------------
-
- S_Krunch_Count : aliased constant S := "/COUNT=#" &
- "`#";
-
- Krunch_Switches : aliased constant Switches :=
- (1 .. 1 => S_Krunch_Count 'Access);
-
- -------------------------------
- -- Switches for GNAT LIBRARY --
- -------------------------------
+ Packages_To_Check_By_Gnatls : constant String_List_Access :=
+ new String_List'((Naming_String, Gnatls_String));
- S_Lbr_Config : aliased constant S := "/CONFIG=@" &
- "--config=@";
-
- S_Lbr_Create : aliased constant S := "/CREATE=%" &
- "--create=%";
-
- S_Lbr_Delete : aliased constant S := "/DELETE=%" &
- "--delete=%";
-
- S_Lbr_Set : aliased constant S := "/SET=%" &
- "--set=%";
-
- Lbr_Switches : aliased constant Switches :=
- (S_Lbr_Config 'Access,
- S_Lbr_Create 'Access,
- S_Lbr_Delete 'Access,
- S_Lbr_Set 'Access);
-
- ----------------------------
- -- Switches for GNAT LINK --
- ----------------------------
-
- S_Link_Bind : aliased constant S := "/BIND_FILE=" &
- "ADA " &
- "-A " &
- "C " &
- "-C";
-
- S_Link_Debug : aliased constant S := "/DEBUG=" &
- "ALL " &
- "-g3 " &
- "NONE " &
- "-g0 " &
- "TRACEBACK " &
- "-g1 " &
- "NOTRACEBACK " &
- "-g0";
-
- S_Link_Execut : aliased constant S := "/EXECUTABLE=@" &
- "-o@";
-
- S_Link_Force : aliased constant S := "/FORCE_OBJECT_FILE_LIST " &
- "-f";
-
- S_Link_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
- "--for-linker=IDENT=" &
- '"';
-
- S_Link_Nocomp : aliased constant S := "/NOCOMPILE " &
- "-n";
-
- S_Link_Nofiles : aliased constant S := "/NOSTART_FILES " &
- "-nostartfiles";
-
- S_Link_Noinhib : aliased constant S := "/NOINHIBIT-EXEC " &
- "--for-linker=--noinhibit-exec";
-
- S_Link_Static : aliased constant S := "/STATIC " &
- "--for-linker=-static";
-
- S_Link_Verb : aliased constant S := "/VERBOSE " &
- "-v";
-
- S_Link_ZZZZZ : aliased constant S := "/<other> " &
- "--for-linker=";
-
- Link_Switches : aliased constant Switches :=
- (S_Link_Bind 'Access,
- S_Link_Debug 'Access,
- S_Link_Execut 'Access,
- S_Ext_Ref 'Access,
- S_Link_Force 'Access,
- S_Link_Ident 'Access,
- S_Link_Nocomp 'Access,
- S_Link_Nofiles 'Access,
- S_Link_Noinhib 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Link_Static 'Access,
- S_Link_Verb 'Access,
- S_Link_ZZZZZ 'Access);
-
- ----------------------------
- -- Switches for GNAT LIST --
- ----------------------------
-
- S_List_All : aliased constant S := "/ALL_UNITS " &
- "-a";
-
- S_List_Current : aliased constant S := "/CURRENT_DIRECTORY " &
- "!-I-";
-
- S_List_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_List_Object : aliased constant S := "/OBJECT_SEARCH=*" &
- "-aO*";
-
- S_List_Output : aliased constant S := "/OUTPUT=" &
- "SOURCES " &
- "-s " &
- "DEPEND " &
- "-d " &
- "OBJECTS " &
- "-o " &
- "UNITS " &
- "-u " &
- "OPTIONS " &
- "-h " &
- "VERBOSE " &
- "-v ";
-
- S_List_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_List_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
+ Packages_To_Check_By_Pretty : constant String_List_Access :=
+ new String_List'((Naming_String, Pretty_String));
- List_Switches : aliased constant Switches :=
- (S_List_All 'Access,
- S_List_Current 'Access,
- S_Ext_Ref 'Access,
- S_List_Nostinc 'Access,
- S_List_Object 'Access,
- S_List_Output 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_List_Search 'Access,
- S_List_Source 'Access);
+ Packages_To_Check_By_Gnatstub : constant String_List_Access :=
+ new String_List'((Naming_String, Gnatstub_String));
- ----------------------------
- -- Switches for GNAT MAKE --
- ----------------------------
+ Packages_To_Check_By_Xref : constant String_List_Access :=
+ new String_List'((Naming_String, Xref_String));
- S_Make_Actions : aliased constant S := "/ACTIONS=" &
- "COMPILE " &
- "-c " &
- "BIND " &
- "-b " &
- "LINK " &
- "-l ";
-
- S_Make_All : aliased constant S := "/ALL_FILES " &
- "-a";
-
- S_Make_Bind : aliased constant S := "/BINDER_QUALIFIERS=?" &
- "-bargs BIND";
-
- S_Make_Comp : aliased constant S := "/COMPILER_QUALIFIERS=?" &
- "-cargs COMPILE";
-
- S_Make_Cond : aliased constant S := "/CONDITIONAL_SOURCE_SEARCH=*" &
- "-A*";
-
- S_Make_Cont : aliased constant S := "/CONTINUE_ON_ERROR " &
- "-k";
-
- S_Make_Current : aliased constant S := "/CURRENT_DIRECTORY " &
- "!-I-";
-
- S_Make_Dep : aliased constant S := "/DEPENDENCIES_LIST " &
- "-M";
-
- S_Make_Doobj : aliased constant S := "/DO_OBJECT_CHECK " &
- "-n";
-
- S_Make_Execut : aliased constant S := "/EXECUTABLE=@" &
- "-o@";
-
- S_Make_Force : aliased constant S := "/FORCE_COMPILE " &
- "-f";
-
- S_Make_Inplace : aliased constant S := "/IN_PLACE " &
- "-i";
-
- S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
- "-L*";
-
- S_Make_Link : aliased constant S := "/LINKER_QUALIFIERS=?" &
- "-largs LINK";
-
- S_Make_Mapping : aliased constant S := "/MAPPING " &
- "-C";
-
- S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " &
- "-m";
-
- S_Make_Nolink : aliased constant S := "/NOLINK " &
- "-c";
-
- S_Make_Nomain : aliased constant S := "/NOMAIN " &
- "-z";
-
- S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_Make_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
- "-nostdlib";
-
- S_Make_Object : aliased constant S := "/OBJECT_SEARCH=*" &
- "-aO*";
-
- S_Make_Proc : aliased constant S := "/PROCESSES=#" &
- "-j#";
-
- S_Make_Nojobs : aliased constant S := "/NOPROCESSES " &
- "-j1";
-
- S_Make_Quiet : aliased constant S := "/QUIET " &
- "-q";
-
- S_Make_Reason : aliased constant S := "/REASONS " &
- "-v";
-
- S_Make_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" &
- "--RTS=|";
-
- S_Make_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_Make_Skip : aliased constant S := "/SKIP_MISSING=*" &
- "-aL*";
-
- S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
-
- S_Make_Switch : aliased constant S := "/SWITCH_CHECK " &
- "-s";
-
- S_Make_Unique : aliased constant S := "/UNIQUE " &
- "-u";
-
- S_Make_Verbose : aliased constant S := "/VERBOSE " &
- "-v";
-
- Make_Switches : aliased constant Switches :=
- (S_Make_Actions 'Access,
- S_Make_All 'Access,
- S_Make_Bind 'Access,
- S_Make_Comp 'Access,
- S_Make_Cond 'Access,
- S_Make_Cont 'Access,
- S_Make_Current 'Access,
- S_Make_Dep 'Access,
- S_Make_Doobj 'Access,
- S_Make_Execut 'Access,
- S_Ext_Ref 'Access,
- S_Make_Force 'Access,
- S_Make_Inplace 'Access,
- S_Make_Library 'Access,
- S_Make_Link 'Access,
- S_Make_Mapping 'Access,
- S_Make_Minimal 'Access,
- S_Make_Nolink 'Access,
- S_Make_Nomain 'Access,
- S_Make_Nostinc 'Access,
- S_Make_Nostlib 'Access,
- S_Make_Object 'Access,
- S_Make_Proc 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Make_Nojobs 'Access,
- S_Make_Quiet 'Access,
- S_Make_Reason 'Access,
- S_Make_RTS 'Access,
- S_Make_Search 'Access,
- S_Make_Skip 'Access,
- S_Make_Source 'Access,
- S_Make_Switch 'Access,
- S_Make_Unique 'Access,
- S_Make_Verbose 'Access);
-
- ----------------------------
- -- Switches for GNAT Name --
- ----------------------------
-
- S_Name_Conf : aliased constant S := "/CONFIG_FILE=<" &
- "-c>";
-
- S_Name_Dirs : aliased constant S := "/SOURCE_DIRS=*" &
- "-d*";
-
- S_Name_Dfile : aliased constant S := "/DIRS_FILE=<" &
- "-D>";
-
- S_Name_Help : aliased constant S := "/HELP" &
- " -h";
-
- S_Name_Proj : aliased constant S := "/PROJECT_FILE=<" &
- "-P>";
-
- S_Name_Verbose : aliased constant S := "/VERBOSE" &
- " -v";
-
- Name_Switches : aliased constant Switches :=
- (S_Name_Conf 'Access,
- S_Name_Dirs 'Access,
- S_Name_Dfile 'Access,
- S_Name_Help 'Access,
- S_Name_Proj 'Access,
- S_Name_Verbose 'Access);
-
- ----------------------------------
- -- Switches for GNAT PREPROCESS --
- ----------------------------------
-
- S_Prep_Assoc : aliased constant S := "/ASSOCIATE=" & '"' &
- "-D" & '"';
-
- S_Prep_Blank : aliased constant S := "/BLANK_LINES " &
- "-b";
-
- S_Prep_Com : aliased constant S := "/COMMENTS " &
- "-c";
-
- S_Prep_Ref : aliased constant S := "/REFERENCE " &
- "-r";
-
- S_Prep_Remove : aliased constant S := "/REMOVE " &
- "!-b,!-c";
-
- S_Prep_Symbols : aliased constant S := "/SYMBOLS " &
- "-s";
-
- S_Prep_Undef : aliased constant S := "/UNDEFINED " &
- "-u";
-
- Prep_Switches : aliased constant Switches :=
- (S_Prep_Assoc 'Access,
- S_Prep_Blank 'Access,
- S_Prep_Com 'Access,
- S_Prep_Ref 'Access,
- S_Prep_Remove 'Access,
- S_Prep_Symbols 'Access,
- S_Prep_Undef 'Access);
-
- ------------------------------
- -- Switches for GNAT SHARED --
- ------------------------------
-
- S_Shared_Debug : aliased constant S := "/DEBUG=" &
- "ALL " &
- "-g3 " &
- "NONE " &
- "-g0 " &
- "TRACEBACK " &
- "-g1 " &
- "NOTRACEBACK " &
- "-g0";
-
- S_Shared_Image : aliased constant S := "/IMAGE=@" &
- "-o@";
-
- S_Shared_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
- "--for-linker=IDENT=" &
- '"';
-
- S_Shared_Nofiles : aliased constant S := "/NOSTART_FILES " &
- "-nostartfiles";
-
- S_Shared_Noinhib : aliased constant S := "/NOINHIBIT-IMAGE " &
- "--for-linker=--noinhibit-exec";
-
- S_Shared_Verb : aliased constant S := "/VERBOSE " &
- "-v";
-
- S_Shared_ZZZZZ : aliased constant S := "/<other> " &
- "--for-linker=";
-
- Shared_Switches : aliased constant Switches :=
- (S_Shared_Debug 'Access,
- S_Shared_Image 'Access,
- S_Shared_Ident 'Access,
- S_Shared_Nofiles 'Access,
- S_Shared_Noinhib 'Access,
- S_Shared_Verb 'Access,
- S_Shared_ZZZZZ 'Access);
-
- --------------------------------
- -- Switches for GNAT STANDARD --
- --------------------------------
-
- Standard_Switches : aliased constant Switches := (1 .. 0 => null);
-
- ----------------------------
- -- Switches for GNAT STUB --
- ----------------------------
-
- S_Stub_Current : aliased constant S := "/CURRENT_DIRECTORY " &
- "!-I-";
-
- S_Stub_Full : aliased constant S := "/FULL " &
- "-f";
-
- S_Stub_Header : aliased constant S := "/HEADER=" &
- "GENERAL " &
- "-hg " &
- "SPEC " &
- "-hs";
-
- S_Stub_Indent : aliased constant S := "/INDENTATION=#" &
- "-i#";
-
- S_Stub_Length : aliased constant S := "/LINE_LENGTH=#" &
- "-l#";
-
- S_Stub_Quiet : aliased constant S := "/QUIET " &
- "-q";
-
- S_Stub_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_Stub_Tree : aliased constant S := "/TREE_FILE=" &
- "OVERWRITE " &
- "-t " &
- "SAVE " &
- "-k " &
- "REUSE " &
- "-r";
-
- S_Stub_Verbose : aliased constant S := "/VERBOSE " &
- "-v";
-
- Stub_Switches : aliased constant Switches :=
- (S_Stub_Current 'Access,
- S_Stub_Full 'Access,
- S_Stub_Header 'Access,
- S_Stub_Indent 'Access,
- S_Stub_Length 'Access,
- S_Stub_Quiet 'Access,
- S_Stub_Search 'Access,
- S_Stub_Tree 'Access,
- S_Stub_Verbose 'Access);
-
- ----------------------------
- -- Switches for GNAT XREF --
- ----------------------------
-
- S_Xref_All : aliased constant S := "/ALL_FILES " &
- "-a";
-
- S_Xref_Deriv : aliased constant S := "/DERIVED_TYPES " &
- "-d";
-
- S_Xref_Full : aliased constant S := "/FULL_PATHNAME " &
- "-f";
-
- S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " &
- "-g";
-
- S_Xref_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
- "-nostdinc";
-
- S_Xref_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
- "-nostdlib";
-
- S_Xref_Object : aliased constant S := "/OBJECT_SEARCH=*" &
- "-aO*";
-
- S_Xref_Project : aliased constant S := "/PROJECT=@" &
- "-p@";
-
- S_Xref_Search : aliased constant S := "/SEARCH=*" &
- "-I*";
-
- S_Xref_Source : aliased constant S := "/SOURCE_SEARCH=*" &
- "-aI*";
-
- S_Xref_Output : aliased constant S := "/UNUSED " &
- "-u";
-
- S_Xref_Tags : aliased constant S := "/TAGS " &
- "-v";
-
- Xref_Switches : aliased constant Switches :=
- (S_Xref_All 'Access,
- S_Xref_Deriv 'Access,
- S_Ext_Ref 'Access,
- S_Xref_Full 'Access,
- S_Xref_Global 'Access,
- S_Xref_Nostinc 'Access,
- S_Xref_Nostlib 'Access,
- S_Xref_Object 'Access,
- S_Xref_Project 'Access,
- S_Project_File 'Access,
- S_Project_Verb 'Access,
- S_Xref_Search 'Access,
- S_Xref_Source 'Access,
- S_Xref_Output 'Access,
- S_Xref_Tags 'Access);
-
- -------------------
- -- COMMAND TABLE --
- -------------------
-
- -- The command table contains an entry for each command recognized by
- -- GNATCmd. The entries are represented by an array of records.
-
- type Parameter_Type is
- -- A parameter is defined as a whitespace bounded string, not begining
- -- with a slash. (But see note under FILES_OR_WILDCARD).
- (File,
- -- A required file or directory parameter.
-
- Optional_File,
- -- An optional file or directory parameter.
-
- Other_As_Is,
- -- A parameter that's passed through as is (not canonicalized)
-
- Unlimited_Files,
- -- An unlimited number of whitespace separate file or directory
- -- parameters including wildcard specifications.
-
- Unlimited_As_Is,
- -- Un unlimited number of whitespace separated paameters that are
- -- passed through as is (not canonicalized).
-
- Files_Or_Wildcard);
- -- A comma separated list of files and/or wildcard file specifications.
- -- A comma preceded by or followed by whitespace is considered as a
- -- single comma character w/o whitespace.
-
- type Parameter_Array is array (Natural range <>) of Parameter_Type;
- type Parameter_Ref is access all Parameter_Array;
-
- type Command_Type is
- (Bind, Chop, Compile, Elim, Find, Krunch, Library, Link, List,
- Make, Name, Preprocess, Shared, Standard, Stub, Xref, Undefined);
-
- type Alternate_Command is (Comp, Ls, Kr, Prep, Psta);
- -- Alternate command libel for non VMS system
-
- Corresponding_To : constant array (Alternate_Command) of Command_Type :=
- (Comp => Compile,
- Ls => List,
- Kr => Krunch,
- Prep => Preprocess,
- Psta => Standard);
- -- Mapping of alternate commands to commands
-
- subtype Real_Command_Type is Command_Type range Bind .. Xref;
-
- type Command_Entry is record
- Cname : String_Ptr;
- -- Command name for GNAT xxx command
-
- Usage : String_Ptr;
- -- A usage string, used for error messages
-
- Unixcmd : String_Ptr;
- -- Corresponding Unix command
-
- Unixsws : Argument_List_Access;
- -- Switches for the Unix command
-
- VMS_Only : Boolean;
- -- When True, the command can only be used on VMS
-
- Switches : Switches_Ptr;
- -- Pointer to array of switch strings
-
- Params : Parameter_Ref;
- -- Describes the allowable types of parameters.
- -- Params (1) is the type of the first parameter, etc.
- -- An empty parameter array means this command takes no parameters.
-
- Defext : String (1 .. 3);
- -- Default extension. If non-blank, then this extension is supplied by
- -- default as the extension for any file parameter which does not have
- -- an extension already.
- end record;
-
- -------------------------
- -- INTERNAL STRUCTURES --
- -------------------------
-
- -- The switches and commands are defined by strings in the previous
- -- section so that they are easy to modify, but internally, they are
- -- kept in a more conveniently accessible form described in this
- -- section.
-
- -- Commands, command qualifers and options have a similar common format
- -- so that searching for matching names can be done in a common manner.
-
- type Item_Id is (Id_Command, Id_Switch, Id_Option);
-
- type Translation_Type is
- (
- T_Direct,
- -- A qualifier with no options.
- -- Example: GNAT MAKE /VERBOSE
-
- T_Directories,
- -- A qualifier followed by a list of directories
- -- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR])
-
- T_Directory,
- -- A qualifier followed by one directory
- -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB]
-
- T_File,
- -- A qualifier followed by a filename
- -- Example: GNAT LINK /EXECUTABLE=FOO.EXE
-
- T_No_Space_File,
- -- A qualifier followed by a filename
- -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR
-
- T_Numeric,
- -- A qualifier followed by a numeric value.
- -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39
-
- T_String,
- -- A qualifier followed by a quoted string. Only used by
- -- /IDENTIFICATION qualfier.
- -- Example: GNAT LINK /IDENTIFICATION="3.14a1 version"
-
- T_Options,
- -- A qualifier followed by a list of options.
- -- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS)
-
- T_Commands,
- -- A qualifier followed by a list. Only used for
- -- MAKE /COMPILER_QUALIFIERS /BINDER_QUALIFIERS /LINKER_QUALIFIERS
- -- (gnatmake -cargs -bargs -largs )
- -- Example: GNAT MAKE ... /LINKER_QUALIFIERS /VERBOSE FOOBAR.OBJ
-
- T_Other,
- -- A qualifier passed directly to the linker. Only used
- -- for LINK and SHARED if no other match is found.
- -- Example: GNAT LINK FOO.ALI /SYSSHR
-
- T_Alphanumplus
- -- A qualifier followed by a legal linker symbol prefix. Only used
- -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz).
- -- Example: GNAT BIND /BUILD_LIBRARY=foobar
- );
-
- type Item (Id : Item_Id);
- type Item_Ptr is access all Item;
-
- type Item (Id : Item_Id) is record
- Name : String_Ptr;
- -- Name of the command, switch (with slash) or option
-
- Next : Item_Ptr;
- -- Pointer to next item on list, always has the same Id value
-
- Command : Command_Type := Undefined;
-
- Unix_String : String_Ptr := null;
- -- Corresponding Unix string. For a command, this is the unix command
- -- name and possible default switches. For a switch or option it is
- -- the unix switch string.
-
- case Id is
-
- when Id_Command =>
-
- Switches : Item_Ptr;
- -- Pointer to list of switch items for the command, linked
- -- through the Next fields with null terminating the list.
-
- Usage : String_Ptr;
- -- Usage information, used only for errors and the default
- -- list of commands output.
-
- Params : Parameter_Ref;
- -- Array of parameters
-
- Defext : String (1 .. 3);
- -- Default extension. If non-blank, then this extension is
- -- supplied by default as the extension for any file parameter
- -- which does not have an extension already.
-
- when Id_Switch =>
-
- Translation : Translation_Type;
- -- Type of switch translation. For all cases, except Options,
- -- this is the only field needed, since the Unix translation
- -- is found in Unix_String.
-
- Options : Item_Ptr;
- -- For the Options case, this field is set to point to a list
- -- of options item (for this case Unix_String is null in the
- -- main switch item). The end of the list is marked by null.
-
- when Id_Option =>
-
- null;
- -- No special fields needed, since Name and Unix_String are
- -- sufficient to completely described an option.
-
- end case;
- end record;
-
- subtype Command_Item is Item (Id_Command);
- subtype Switch_Item is Item (Id_Switch);
- subtype Option_Item is Item (Id_Option);
+ Packages_To_Check : String_List_Access := Prj.All_Packages;
----------------------------------
-- Declarations for GNATCMD use --
----------------------------------
- Commands : Item_Ptr;
- -- Pointer to head of list of command items, one for each command, with
- -- the end of the list marked by a null pointer.
-
- Last_Command : Item_Ptr;
- -- Pointer to last item in Commands list
-
- Normal_Exit : exception;
- -- Raise this exception for normal program termination
-
- Error_Exit : exception;
- -- Raise this exception if error detected
-
- Errors : Natural := 0;
- -- Count errors detected
+ The_Command : Command_Type;
Command_Arg : Positive := 1;
- Command : Item_Ptr;
- -- Pointer to command item for current command
-
- Make_Commands_Active : Item_Ptr := null;
- -- Set to point to Command entry for COMPILE, BIND, or LINK as appropriate
- -- if a COMMANDS_TRANSLATION switch has been encountered while processing
- -- a MAKE Command.
-
My_Exit_Status : Exit_Status := Success;
- package Buffer is new Table.Table
- (Table_Component_Type => Character,
- Table_Index_Type => Integer,
- Table_Low_Bound => 1,
- Table_Initial => 4096,
- Table_Increment => 2,
- Table_Name => "Buffer");
-
- Param_Count : Natural := 0;
- -- Number of parameter arguments so far
-
- Arg_Num : Natural;
- -- Argument number
-
- Display_Command : Boolean := False;
- -- Set true if /? switch causes display of generated command (on VMS)
-
- The_Command : Command_Type;
- -- The command used
+ Current_Work_Dir : constant String := Get_Current_Dir;
-----------------------
-- Local Subprograms --
-----------------------
+ procedure Check_Relative_Executable (Name : in out String_Access);
+ -- Check if an executable is specified as a relative path.
+ -- If it is, and the path contains directory information, fail.
+ -- Otherwise, prepend the exec directory.
+ -- This procedure is only used for GNAT LINK when a project file
+ -- is specified.
+
+ function Configuration_Pragmas_File return Name_Id;
+ -- Return an argument, if there is a configuration pragmas file to be
+ -- specified for Project, otherwise return No_Name.
+ -- Used for gnatstub (GNAT STUB), gnatpp (GNAT PRETTY) and gnatelim
+ -- (GNAT ELIM).
+
+ procedure Delete_Temp_Config_Files;
+ -- Delete all temporary config files
+
function Index (Char : Character; Str : String) return Natural;
-- Returns the first occurrence of Char in Str.
-- Returns 0 if Char is not in Str.
- function Init_Object_Dirs return Argument_List;
-
- function Invert_Sense (S : String) return String_Ptr;
- -- Given a unix switch string S, computes the inverse (adding or
- -- removing ! characters as required), and returns a pointer to
- -- the allocated result on the heap.
-
- function Is_Extensionless (F : String) return Boolean;
- -- Returns true if the filename has no extension.
-
- function Match (S1, S2 : String) return Boolean;
- -- Determines whether S1 and S2 match. This is a case insensitive match.
-
- function Match_Prefix (S1, S2 : String) return Boolean;
- -- Determines whether S1 matches a prefix of S2. This is also a case
- -- insensitive match (for example Match ("AB","abc") is True).
-
- function Matching_Name
- (S : String;
- Itm : Item_Ptr;
- Quiet : Boolean := False)
- return Item_Ptr;
- -- Determines if the item list headed by Itm and threaded through the
- -- Next fields (with null marking the end of the list), contains an
- -- entry that uniquely matches the given string. The match is case
- -- insensitive and permits unique abbreviation. If the match succeeds,
- -- then a pointer to the matching item is returned. Otherwise, an
- -- appropriate error message is written. Note that the discriminant
- -- of Itm is used to determine the appropriate form of this message.
- -- Quiet is normally False as shown, if it is set to True, then no
- -- error message is generated in a not found situation (null is still
- -- returned to indicate the not-found situation).
-
procedure Non_VMS_Usage;
-- Display usage for platforms other than VMS
- function OK_Alphanumerplus (S : String) return Boolean;
- -- Checks that S is a string of alphanumeric characters,
- -- returning True if all alphanumeric characters,
- -- False if empty or a non-alphanumeric character is present.
-
- function OK_Integer (S : String) return Boolean;
- -- Checks that S is a string of digits, returning True if all digits,
- -- False if empty or a non-digit is present.
-
- procedure Output_Version;
- -- Output the version of this program
-
- procedure Place (C : Character);
- -- Place a single character in the buffer, updating Ptr
-
- procedure Place (S : String);
- -- Place a string character in the buffer, updating Ptr
-
- procedure Place_Lower (S : String);
- -- Place string in buffer, forcing letters to lower case, updating Ptr
-
- procedure Place_Unix_Switches (S : String_Ptr);
- -- Given a unix switch string, place corresponding switches in Buffer,
- -- updating Ptr appropriatelly. Note that in the case of use of ! the
- -- result may be to remove a previously placed switch.
-
procedure Set_Library_For
(Project : Project_Id;
There_Are_Libraries : in out Boolean);
@@ -1878,430 +174,99 @@ procedure GNATCmd is
-- Add the -L and -l switches to the linker for all
-- of the library projects.
- procedure Validate_Command_Or_Option (N : String_Ptr);
- -- Check that N is a valid command or option name, i.e. that it is of the
- -- form of an Ada identifier with upper case letters and underscores.
-
- procedure Validate_Unix_Switch (S : String_Ptr);
- -- Check that S is a valid switch string as described in the syntax for
- -- the switch table item UNIX_SWITCH or else begins with a backquote.
-
- procedure VMS_Conversion (The_Command : out Command_Type);
- -- Converts VMS command line to equivalent Unix command line
-
- -----------
- -- Index --
- -----------
-
- function Index (Char : Character; Str : String) return Natural is
- begin
- for Index in Str'Range loop
- if Str (Index) = Char then
- return Index;
- end if;
- end loop;
-
- return 0;
- end Index;
-
- ----------------------
- -- Init_Object_Dirs --
- ----------------------
-
- function Init_Object_Dirs return Argument_List is
- Object_Dirs : Integer;
- Object_Dir : Argument_List (1 .. 256);
- Object_Dir_Name : String_Access;
-
- begin
- Object_Dirs := 0;
- Object_Dir_Name := String_Access (Object_Dir_Default_Name);
- Get_Next_Dir_In_Path_Init (Object_Dir_Name);
-
- loop
- declare
- Dir : String_Access := String_Access
- (Get_Next_Dir_In_Path (Object_Dir_Name));
- begin
- exit when Dir = null;
- Object_Dirs := Object_Dirs + 1;
- Object_Dir (Object_Dirs) :=
- new String'("-L" &
- To_Canonical_Dir_Spec
- (To_Host_Dir_Spec
- (Normalize_Directory_Name (Dir.all).all,
- True).all, True).all);
- end;
- end loop;
-
- Object_Dirs := Object_Dirs + 1;
- Object_Dir (Object_Dirs) := new String'("-lgnat");
-
- if Hostparm.OpenVMS then
- Object_Dirs := Object_Dirs + 1;
- Object_Dir (Object_Dirs) := new String'("-ldecgnat");
- end if;
-
- return Object_Dir (1 .. Object_Dirs);
- end Init_Object_Dirs;
-
- ------------------
- -- Invert_Sense --
- ------------------
-
- function Invert_Sense (S : String) return String_Ptr is
- Sinv : String (1 .. S'Length * 2);
- -- Result (for sure long enough)
-
- Sinvp : Natural := 0;
- -- Pointer to output string
-
- begin
- for Sp in S'Range loop
- if Sp = S'First or else S (Sp - 1) = ',' then
- if S (Sp) = '!' then
- null;
- else
- Sinv (Sinvp + 1) := '!';
- Sinv (Sinvp + 2) := S (Sp);
- Sinvp := Sinvp + 2;
- end if;
-
- else
- Sinv (Sinvp + 1) := S (Sp);
- Sinvp := Sinvp + 1;
- end if;
- end loop;
-
- return new String'(Sinv (1 .. Sinvp));
- end Invert_Sense;
-
- ----------------------
- -- Is_Extensionless --
- ----------------------
+ procedure Test_If_Relative_Path
+ (Switch : in out String_Access;
+ Parent : String);
+ -- Test if Switch is a relative search path switch.
+ -- If it is and it includes directory information, prepend the path with
+ -- Parent.This subprogram is only called when using project files.
- function Is_Extensionless (F : String) return Boolean is
- begin
- for J in reverse F'Range loop
- if F (J) = '.' then
- return False;
- elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then
- return True;
- end if;
- end loop;
-
- return True;
- end Is_Extensionless;
-
- -----------
- -- Match --
- -----------
+ -------------------------------
+ -- Check_Relative_Executable --
+ -------------------------------
- function Match (S1, S2 : String) return Boolean is
- Dif : constant Integer := S2'First - S1'First;
+ procedure Check_Relative_Executable (Name : in out String_Access) is
+ Exec_File_Name : constant String := Name.all;
begin
-
- if S1'Length /= S2'Length then
- return False;
-
- else
- for J in S1'Range loop
- if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then
- return False;
+ if not Is_Absolute_Path (Exec_File_Name) then
+ for Index in Exec_File_Name'Range loop
+ if Exec_File_Name (Index) = Directory_Separator then
+ Fail ("relative executable (""" &
+ Exec_File_Name &
+ """) with directory part not allowed " &
+ "when using project files");
end if;
end loop;
- return True;
- end if;
- end Match;
-
- ------------------
- -- Match_Prefix --
- ------------------
+ Get_Name_String (Projects.Table
+ (Project).Exec_Directory);
- function Match_Prefix (S1, S2 : String) return Boolean is
- begin
- if S1'Length > S2'Length then
- return False;
- else
- return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1));
- end if;
- end Match_Prefix;
-
- -------------------
- -- Matching_Name --
- -------------------
-
- function Matching_Name
- (S : String;
- Itm : Item_Ptr;
- Quiet : Boolean := False)
- return Item_Ptr
- is
- P1, P2 : Item_Ptr;
-
- procedure Err;
- -- Little procedure to output command/qualifier/option as appropriate
- -- and bump error count.
-
- ---------
- -- Err --
- ---------
-
- procedure Err is
- begin
- if Quiet then
- return;
+ if Name_Buffer (Name_Len) /= Directory_Separator then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Directory_Separator;
end if;
- Errors := Errors + 1;
-
- if Itm /= null then
- case Itm.Id is
- when Id_Command =>
- Put (Standard_Error, "command");
-
- when Id_Switch =>
- if OpenVMS then
- Put (Standard_Error, "qualifier");
- else
- Put (Standard_Error, "switch");
- end if;
-
- when Id_Option =>
- Put (Standard_Error, "option");
-
- end case;
- else
- Put (Standard_Error, "input");
-
- end if;
-
- Put (Standard_Error, ": ");
- Put (Standard_Error, S);
- end Err;
-
- -- Start of processing for Matching_Name
-
- begin
- -- If exact match, that's the one we want
-
- P1 := Itm;
- while P1 /= null loop
- if Match (S, P1.Name.all) then
- return P1;
- else
- P1 := P1.Next;
- end if;
- end loop;
-
- -- Now check for prefix matches
-
- P1 := Itm;
- while P1 /= null loop
- if P1.Name.all = "/<other>" then
- return P1;
-
- elsif not Match_Prefix (S, P1.Name.all) then
- P1 := P1.Next;
-
- else
- -- Here we have found one matching prefix, so see if there is
- -- another one (which is an ambiguity)
-
- P2 := P1.Next;
- while P2 /= null loop
- if Match_Prefix (S, P2.Name.all) then
- if not Quiet then
- Put (Standard_Error, "ambiguous ");
- Err;
- Put (Standard_Error, " (matches ");
- Put (Standard_Error, P1.Name.all);
-
- while P2 /= null loop
- if Match_Prefix (S, P2.Name.all) then
- Put (Standard_Error, ',');
- Put (Standard_Error, P2.Name.all);
- end if;
-
- P2 := P2.Next;
- end loop;
-
- Put_Line (Standard_Error, ")");
- end if;
-
- return null;
- end if;
-
- P2 := P2.Next;
- end loop;
-
- -- If we fall through that loop, then there was only one match
-
- return P1;
- end if;
- end loop;
-
- -- If we fall through outer loop, there was no match
-
- if not Quiet then
- Put (Standard_Error, "unrecognized ");
- Err;
- New_Line (Standard_Error);
+ Name_Buffer (Name_Len + 1 ..
+ Name_Len + Exec_File_Name'Length) :=
+ Exec_File_Name;
+ Name_Len := Name_Len + Exec_File_Name'Length;
+ Name := new String'(Name_Buffer (1 .. Name_Len));
end if;
+ end Check_Relative_Executable;
- return null;
- end Matching_Name;
-
- -----------------------
- -- OK_Alphanumerplus --
- -----------------------
+ --------------------------------
+ -- Configuration_Pragmas_File --
+ --------------------------------
- function OK_Alphanumerplus (S : String) return Boolean is
+ function Configuration_Pragmas_File return Name_Id is
begin
- if S'Length = 0 then
- return False;
-
- else
- for J in S'Range loop
- if not (Is_Alphanumeric (S (J)) or else
- S (J) = '_' or else S (J) = '$')
- then
- return False;
- end if;
- end loop;
+ Prj.Env.Create_Config_Pragmas_File
+ (Project, Project, Include_Config_Files => False);
+ return Projects.Table (Project).Config_File_Name;
+ end Configuration_Pragmas_File;
- return True;
- end if;
- end OK_Alphanumerplus;
+ ------------------------------
+ -- Delete_Temp_Config_Files --
+ ------------------------------
- ----------------
- -- OK_Integer --
- ----------------
+ procedure Delete_Temp_Config_Files is
+ Success : Boolean;
- function OK_Integer (S : String) return Boolean is
begin
- if S'Length = 0 then
- return False;
+ if Project /= No_Project then
+ for Prj in 1 .. Projects.Last loop
+ if Projects.Table (Prj).Config_File_Temp then
+ if Opt.Verbose_Mode then
+ Output.Write_Str ("Deleting temp configuration file """);
+ Output.Write_Str (Get_Name_String
+ (Projects.Table (Prj).Config_File_Name));
+ Output.Write_Line ("""");
+ end if;
- else
- for J in S'Range loop
- if not Is_Digit (S (J)) then
- return False;
+ Delete_File
+ (Name => Get_Name_String
+ (Projects.Table (Prj).Config_File_Name),
+ Success => Success);
end if;
end loop;
-
- return True;
end if;
- end OK_Integer;
-
- --------------------
- -- Output_Version --
- --------------------
-
- procedure Output_Version is
- begin
- Put ("GNAT ");
- Put (Gnatvsn.Gnat_Version_String);
- Put_Line (" Copyright 1996-2002 Free Software Foundation, Inc.");
- end Output_Version;
+ end Delete_Temp_Config_Files;
-----------
- -- Place --
+ -- Index --
-----------
- procedure Place (C : Character) is
- begin
- Buffer.Increment_Last;
- Buffer.Table (Buffer.Last) := C;
-
- -- Do not put a space as the first character in the buffer
- if C = ' ' and then Buffer.Last = 1 then
- Buffer.Decrement_Last;
- end if;
- end Place;
-
- procedure Place (S : String) is
- begin
- for J in S'Range loop
- Place (S (J));
- end loop;
- end Place;
-
- -----------------
- -- Place_Lower --
- -----------------
-
- procedure Place_Lower (S : String) is
- begin
- for J in S'Range loop
- Place (To_Lower (S (J)));
- end loop;
- end Place_Lower;
-
- -------------------------
- -- Place_Unix_Switches --
- -------------------------
-
- procedure Place_Unix_Switches (S : String_Ptr) is
- P1, P2, P3 : Natural;
- Remove : Boolean;
- Slen : Natural;
-
+ function Index (Char : Character; Str : String) return Natural is
begin
- P1 := S'First;
- while P1 <= S'Last loop
- if S (P1) = '!' then
- P1 := P1 + 1;
- Remove := True;
- else
- Remove := False;
- end if;
-
- P2 := P1;
- pragma Assert (S (P1) = '-' or else S (P1) = '`');
-
- while P2 < S'Last and then S (P2 + 1) /= ',' loop
- P2 := P2 + 1;
- end loop;
-
- -- Switch is now in S (P1 .. P2)
-
- Slen := P2 - P1 + 1;
-
- if Remove then
- P3 := 2;
- while P3 <= Buffer.Last - Slen loop
- if Buffer.Table (P3) = ' '
- and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) =
- S (P1 .. P2)
- and then (P3 + Slen = Buffer.Last
- or else
- Buffer.Table (P3 + Slen + 1) = ' ')
- then
- Buffer.Table (P3 .. Buffer.Last - Slen - 1) :=
- Buffer.Table (P3 + Slen + 1 .. Buffer.Last);
- Buffer.Set_Last (Buffer.Last - Slen - 1);
-
- else
- P3 := P3 + 1;
- end if;
- end loop;
-
- else
- Place (' ');
-
- if S (P1) = '`' then
- P1 := P1 + 1;
- end if;
-
- Place (S (P1 .. P2));
+ for Index in Str'Range loop
+ if Str (Index) = Char then
+ return Index;
end if;
-
- P1 := P2 + 2;
end loop;
- end Place_Unix_Switches;
+
+ return 0;
+ end Index;
---------------------
-- Set_Library_For --
@@ -2311,6 +276,9 @@ procedure GNATCmd is
(Project : Project_Id;
There_Are_Libraries : in out Boolean)
is
+ Path_Option : constant String_Access :=
+ MLib.Tgt.Linker_Library_Path_Option;
+
begin
-- Case of library project
@@ -2333,250 +301,86 @@ procedure GNATCmd is
Get_Name_String
(Projects.Table (Project).Library_Name));
- -- Add the Wl,-rpath switch if library non static
-
- if Projects.Table (Project).Library_Kind /= Static then
- declare
- Option : constant String_Access :=
- MLib.Tgt.Linker_Library_Path_Option
- (Get_Name_String
- (Projects.Table (Project).Library_Dir));
-
- begin
- if Option /= null then
- Last_Switches.Increment_Last;
- Last_Switches.Table (Last_Switches.Last) :=
- Option;
- end if;
-
- end;
+ -- Add the directory to table Library_Paths, to be processed later
+ -- if library is not static and if Path_Option is not null.
+ if Projects.Table (Project).Library_Kind /= Static
+ and then Path_Option /= null
+ then
+ Library_Paths.Increment_Last;
+ Library_Paths.Table (Library_Paths.Last) :=
+ new String'(Get_Name_String
+ (Projects.Table (Project).Library_Dir));
end if;
end if;
end Set_Library_For;
- --------------------------------
- -- Validate_Command_Or_Option --
- --------------------------------
+ ---------------------------
+ -- Test_If_Relative_Path --
+ ---------------------------
- procedure Validate_Command_Or_Option (N : String_Ptr) is
+ procedure Test_If_Relative_Path
+ (Switch : in out String_Access;
+ Parent : String)
+ is
begin
- pragma Assert (N'Length > 0);
-
- for J in N'Range loop
- if N (J) = '_' then
- pragma Assert (N (J - 1) /= '_');
- null;
- else
- pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
- null;
- end if;
- end loop;
- end Validate_Command_Or_Option;
+ if Switch /= null then
+
+ declare
+ Sw : String (1 .. Switch'Length);
+ Start : Positive := 1;
- --------------------------
- -- Validate_Unix_Switch --
- --------------------------
+ begin
+ Sw := Switch.all;
- procedure Validate_Unix_Switch (S : String_Ptr) is
- begin
- if S (S'First) = '`' then
- return;
- end if;
+ if Sw (1) = '-' then
+ if Sw'Length >= 3
+ and then (Sw (2) = 'A'
+ or else Sw (2) = 'I'
+ or else Sw (2) = 'L')
+ then
+ Start := 3;
- pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
+ if Sw = "-I-" then
+ return;
+ end if;
- for J in S'First + 1 .. S'Last loop
- pragma Assert (S (J) /= ' ');
+ elsif Sw'Length >= 4
+ and then (Sw (2 .. 3) = "aL"
+ or else Sw (2 .. 3) = "aO"
+ or else Sw (2 .. 3) = "aI")
+ then
+ Start := 4;
- if S (J) = '!' then
- pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
- null;
- end if;
- end loop;
- end Validate_Unix_Switch;
-
- ----------------------
- -- List of Commands --
- ----------------------
-
- -- Note that we put this after all the local bodies (except Non_VMS_Usage
- -- and VMS_Conversion that use Command_List) to avoid some access before
- -- elaboration problems.
-
- Command_List : constant array (Real_Command_Type) of Command_Entry :=
- (Bind =>
- (Cname => new S'("BIND"),
- Usage => new S'("GNAT BIND file[.ali] /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatbind"),
- Unixsws => null,
- Switches => Bind_Switches'Access,
- Params => new Parameter_Array'(1 => File),
- Defext => "ali"),
-
- Chop =>
- (Cname => new S'("CHOP"),
- Usage => new S'("GNAT CHOP file [directory] /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatchop"),
- Unixsws => null,
- Switches => Chop_Switches'Access,
- Params => new Parameter_Array'(1 => File, 2 => Optional_File),
- Defext => " "),
-
- Compile =>
- (Cname => new S'("COMPILE"),
- Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatmake"),
- Unixsws => new Argument_List' (1 => new String'("-f"),
- 2 => new String'("-u"),
- 3 => new String'("-c")),
- Switches => GCC_Switches'Access,
- Params => new Parameter_Array'(1 => Files_Or_Wildcard),
- Defext => " "),
-
- Elim =>
- (Cname => new S'("ELIM"),
- Usage => new S'("GNAT ELIM name /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatelim"),
- Unixsws => null,
- Switches => Elim_Switches'Access,
- Params => new Parameter_Array'(1 => Other_As_Is),
- Defext => "ali"),
-
- Find =>
- (Cname => new S'("FIND"),
- Usage => new S'("GNAT FIND pattern[:sourcefile[:line"
- & "[:column]]] filespec[,...] /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatfind"),
- Unixsws => null,
- Switches => Find_Switches'Access,
- Params => new Parameter_Array'(1 => Other_As_Is,
- 2 => Files_Or_Wildcard),
- Defext => "ali"),
-
- Krunch =>
- (Cname => new S'("KRUNCH"),
- Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"),
- VMS_Only => False,
- Unixcmd => new S'("gnatkr"),
- Unixsws => null,
- Switches => Krunch_Switches'Access,
- Params => new Parameter_Array'(1 => File),
- Defext => " "),
-
- Library =>
- (Cname => new S'("LIBRARY"),
- Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]"
- & "=directory [/CONFIG=file]"),
- VMS_Only => True,
- Unixcmd => new S'("gnatlbr"),
- Unixsws => null,
- Switches => Lbr_Switches'Access,
- Params => new Parameter_Array'(1 .. 0 => File),
- Defext => " "),
-
- Link =>
- (Cname => new S'("LINK"),
- Usage => new S'("GNAT LINK file[.ali]"
- & " [extra obj_&_lib_&_exe_&_opt files]"
- & " /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatlink"),
- Unixsws => null,
- Switches => Link_Switches'Access,
- Params => new Parameter_Array'(1 => Unlimited_Files),
- Defext => "ali"),
-
- List =>
- (Cname => new S'("LIST"),
- Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"),
- VMS_Only => False,
- Unixcmd => new S'("gnatls"),
- Unixsws => null,
- Switches => List_Switches'Access,
- Params => new Parameter_Array'(1 => File),
- Defext => "ali"),
-
- Make =>
- (Cname => new S'("MAKE"),
- Usage => new S'("GNAT MAKE file /qualifiers (includes "
- & "COMPILE /qualifiers)"),
- VMS_Only => False,
- Unixcmd => new S'("gnatmake"),
- Unixsws => null,
- Switches => Make_Switches'Access,
- Params => new Parameter_Array'(1 => File),
- Defext => " "),
-
- Name =>
- (Cname => new S'("NAME"),
- Usage => new S'("GNAT NAME /qualifiers naming-pattern "
- & "[naming-patterns]"),
- VMS_Only => False,
- Unixcmd => new S'("gnatname"),
- Unixsws => null,
- Switches => Name_Switches'Access,
- Params => new Parameter_Array'(1 => Unlimited_As_Is),
- Defext => " "),
-
- Preprocess =>
- (Cname => new S'("PREPROCESS"),
- Usage => new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatprep"),
- Unixsws => null,
- Switches => Prep_Switches'Access,
- Params => new Parameter_Array'(1 .. 3 => File),
- Defext => " "),
-
- Shared =>
- (Cname => new S'("SHARED"),
- Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt"
- & "files] /qualifiers"),
- VMS_Only => True,
- Unixcmd => new S'("gcc"),
- Unixsws => new Argument_List'(new String'("-shared")
- & Init_Object_Dirs),
- Switches => Shared_Switches'Access,
- Params => new Parameter_Array'(1 => Unlimited_Files),
- Defext => " "),
-
- Standard =>
- (Cname => new S'("STANDARD"),
- Usage => new S'("GNAT STANDARD"),
- VMS_Only => False,
- Unixcmd => new S'("gnatpsta"),
- Unixsws => null,
- Switches => Standard_Switches'Access,
- Params => new Parameter_Array'(1 .. 0 => File),
- Defext => " "),
-
- Stub =>
- (Cname => new S'("STUB"),
- Usage => new S'("GNAT STUB file [directory]/qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatstub"),
- Unixsws => null,
- Switches => Stub_Switches'Access,
- Params => new Parameter_Array'(1 => File, 2 => Optional_File),
- Defext => " "),
-
- Xref =>
- (Cname => new S'("XREF"),
- Usage => new S'("GNAT XREF filespec[,...] /qualifiers"),
- VMS_Only => False,
- Unixcmd => new S'("gnatxref"),
- Unixsws => null,
- Switches => Xref_Switches'Access,
- Params => new Parameter_Array'(1 => Files_Or_Wildcard),
- Defext => "ali")
- );
+ elsif Sw'Length >= 7
+ and then Sw (2 .. 6) = "-RTS="
+ then
+ Start := 7;
+ else
+ return;
+ end if;
+ end if;
+
+ -- If the path is relative, test if it includes directory
+ -- information. If it does, prepend Parent to the path.
+
+ if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
+ for J in Start .. Sw'Last loop
+ if Sw (J) = Directory_Separator then
+ Switch :=
+ new String'
+ (Sw (1 .. Start - 1) &
+ Parent &
+ Directory_Separator &
+ Sw (Start .. Sw'Last));
+ return;
+ end if;
+ end loop;
+ end if;
+ end;
+ end if;
+ end Test_If_Relative_Path;
-------------------
-- Non_VMS_Usage --
@@ -2611,1209 +415,11 @@ procedure GNATCmd is
end loop;
New_Line;
- Put_Line ("Commands FIND, LIST and XREF accept project file " &
- "switches -vPx, -Pprj and -Xnam=val");
+ Put_Line ("Commands FIND, LIST, PRETTY, STUB and XREF accept " &
+ "project file switches -vPx, -Pprj and -Xnam=val");
New_Line;
end Non_VMS_Usage;
- --------------------
- -- VMS_Conversion --
- --------------------
-
- procedure VMS_Conversion (The_Command : out Command_Type) is
- begin
- Buffer.Init;
-
- -- First we must preprocess the string form of the command and options
- -- list into the internal form that we use.
-
- for C in Real_Command_Type loop
-
- declare
- Command : Item_Ptr := new Command_Item;
-
- Last_Switch : Item_Ptr;
- -- Last switch in list
-
- begin
- -- Link new command item into list of commands
-
- if Last_Command = null then
- Commands := Command;
- else
- Last_Command.Next := Command;
- end if;
-
- Last_Command := Command;
-
- -- Fill in fields of new command item
-
- Command.Name := Command_List (C).Cname;
- Command.Usage := Command_List (C).Usage;
- Command.Command := C;
-
- if Command_List (C).Unixsws = null then
- Command.Unix_String := Command_List (C).Unixcmd;
- else
- declare
- Cmd : String (1 .. 5_000);
- Last : Natural := 0;
- Sws : Argument_List_Access := Command_List (C).Unixsws;
-
- begin
- Cmd (1 .. Command_List (C).Unixcmd'Length) :=
- Command_List (C).Unixcmd.all;
- Last := Command_List (C).Unixcmd'Length;
-
- for J in Sws'Range loop
- Last := Last + 1;
- Cmd (Last) := ' ';
- Cmd (Last + 1 .. Last + Sws (J)'Length) :=
- Sws (J).all;
- Last := Last + Sws (J)'Length;
- end loop;
-
- Command.Unix_String := new String'(Cmd (1 .. Last));
- end;
- end if;
-
- Command.Params := Command_List (C).Params;
- Command.Defext := Command_List (C).Defext;
-
- Validate_Command_Or_Option (Command.Name);
-
- -- Process the switch list
-
- for S in Command_List (C).Switches'Range loop
- declare
- SS : constant String_Ptr := Command_List (C).Switches (S);
-
- P : Natural := SS'First;
- Sw : Item_Ptr := new Switch_Item;
-
- Last_Opt : Item_Ptr;
- -- Pointer to last option
-
- begin
- -- Link new switch item into list of switches
-
- if Last_Switch = null then
- Command.Switches := Sw;
- else
- Last_Switch.Next := Sw;
- end if;
-
- Last_Switch := Sw;
-
- -- Process switch string, first get name
-
- while SS (P) /= ' ' and SS (P) /= '=' loop
- P := P + 1;
- end loop;
-
- Sw.Name := new String'(SS (SS'First .. P - 1));
-
- -- Direct translation case
-
- if SS (P) = ' ' then
- Sw.Translation := T_Direct;
- Sw.Unix_String := new String'(SS (P + 1 .. SS'Last));
- Validate_Unix_Switch (Sw.Unix_String);
-
- if SS (P - 1) = '>' then
- Sw.Translation := T_Other;
-
- elsif SS (P + 1) = '`' then
- null;
-
- -- Create the inverted case (/NO ..)
-
- elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then
- Sw := new Switch_Item;
- Last_Switch.Next := Sw;
- Last_Switch := Sw;
-
- Sw.Name :=
- new String'("/NO" & SS (SS'First + 1 .. P - 1));
- Sw.Translation := T_Direct;
- Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last));
- Validate_Unix_Switch (Sw.Unix_String);
- end if;
-
- -- Directories translation case
-
- elsif SS (P + 1) = '*' then
- pragma Assert (SS (SS'Last) = '*');
- Sw.Translation := T_Directories;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- Directory translation case
-
- elsif SS (P + 1) = '%' then
- pragma Assert (SS (SS'Last) = '%');
- Sw.Translation := T_Directory;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- File translation case
-
- elsif SS (P + 1) = '@' then
- pragma Assert (SS (SS'Last) = '@');
- Sw.Translation := T_File;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- No space file translation case
-
- elsif SS (P + 1) = '<' then
- pragma Assert (SS (SS'Last) = '>');
- Sw.Translation := T_No_Space_File;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- Numeric translation case
-
- elsif SS (P + 1) = '#' then
- pragma Assert (SS (SS'Last) = '#');
- Sw.Translation := T_Numeric;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- Alphanumerplus translation case
-
- elsif SS (P + 1) = '|' then
- pragma Assert (SS (SS'Last) = '|');
- Sw.Translation := T_Alphanumplus;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- String translation case
-
- elsif SS (P + 1) = '"' then
- pragma Assert (SS (SS'Last) = '"');
- Sw.Translation := T_String;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
- Validate_Unix_Switch (Sw.Unix_String);
-
- -- Commands translation case
-
- elsif SS (P + 1) = '?' then
- Sw.Translation := T_Commands;
- Sw.Unix_String := new String'(SS (P + 2 .. SS'Last));
-
- -- Options translation case
-
- else
- Sw.Translation := T_Options;
- Sw.Unix_String := new String'("");
-
- P := P + 1; -- bump past =
- while P <= SS'Last loop
- declare
- Opt : Item_Ptr := new Option_Item;
- Q : Natural;
-
- begin
- -- Link new option item into options list
-
- if Last_Opt = null then
- Sw.Options := Opt;
- else
- Last_Opt.Next := Opt;
- end if;
-
- Last_Opt := Opt;
-
- -- Fill in fields of new option item
-
- Q := P;
- while SS (Q) /= ' ' loop
- Q := Q + 1;
- end loop;
-
- Opt.Name := new String'(SS (P .. Q - 1));
- Validate_Command_Or_Option (Opt.Name);
-
- P := Q + 1;
- Q := P;
-
- while Q <= SS'Last and then SS (Q) /= ' ' loop
- Q := Q + 1;
- end loop;
-
- Opt.Unix_String := new String'(SS (P .. Q - 1));
- Validate_Unix_Switch (Opt.Unix_String);
- P := Q + 1;
- end;
- end loop;
- end if;
- end;
- end loop;
- end;
- end loop;
-
- -- If no parameters, give complete list of commands
-
- if Argument_Count = 0 then
- Output_Version;
- New_Line;
- Put_Line ("List of available commands");
- New_Line;
-
- while Commands /= null loop
- Put (Commands.Usage.all);
- Set_Col (53);
- Put_Line (Commands.Unix_String.all);
- Commands := Commands.Next;
- end loop;
-
- raise Normal_Exit;
- end if;
-
- Arg_Num := 1;
-
- -- Loop through arguments
-
- while Arg_Num <= Argument_Count loop
-
- Process_Argument : declare
- Argv : String_Access;
- Arg_Idx : Integer;
-
- function Get_Arg_End
- (Argv : String;
- Arg_Idx : Integer)
- return Integer;
- -- Begins looking at Arg_Idx + 1 and returns the index of the
- -- last character before a slash or else the index of the last
- -- character in the string Argv.
-
- -----------------
- -- Get_Arg_End --
- -----------------
-
- function Get_Arg_End
- (Argv : String;
- Arg_Idx : Integer)
- return Integer
- is
- begin
- for J in Arg_Idx + 1 .. Argv'Last loop
- if Argv (J) = '/' then
- return J - 1;
- end if;
- end loop;
-
- return Argv'Last;
- end Get_Arg_End;
-
- -- Start of processing for Process_Argument
-
- begin
- Argv := new String'(Argument (Arg_Num));
- Arg_Idx := Argv'First;
-
- <<Tryagain_After_Coalesce>>
- loop
- declare
- Next_Arg_Idx : Integer;
- Arg : String_Access;
-
- begin
- Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
-
- -- The first one must be a command name
-
- if Arg_Num = 1 and then Arg_Idx = Argv'First then
-
- Command := Matching_Name (Arg.all, Commands);
-
- if Command = null then
- raise Error_Exit;
- end if;
-
- The_Command := Command.Command;
-
- -- Give usage information if only command given
-
- if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last
- and then Command.Command /= Standard
- then
- Output_Version;
- New_Line;
- Put_Line
- ("List of available qualifiers and options");
- New_Line;
-
- Put (Command.Usage.all);
- Set_Col (53);
- Put_Line (Command.Unix_String.all);
-
- declare
- Sw : Item_Ptr := Command.Switches;
-
- begin
- while Sw /= null loop
- Put (" ");
- Put (Sw.Name.all);
-
- case Sw.Translation is
-
- when T_Other =>
- Set_Col (53);
- Put_Line (Sw.Unix_String.all &
- "/<other>");
-
- when T_Direct =>
- Set_Col (53);
- Put_Line (Sw.Unix_String.all);
-
- when T_Directories =>
- Put ("=(direc,direc,..direc)");
- Set_Col (53);
- Put (Sw.Unix_String.all);
- Put (" direc ");
- Put (Sw.Unix_String.all);
- Put_Line (" direc ...");
-
- when T_Directory =>
- Put ("=directory");
- Set_Col (53);
- Put (Sw.Unix_String.all);
-
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
-
- Put_Line ("directory ");
-
- when T_File | T_No_Space_File =>
- Put ("=file");
- Set_Col (53);
- Put (Sw.Unix_String.all);
-
- if Sw.Translation = T_File
- and then Sw.Unix_String
- (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
-
- Put_Line ("file ");
-
- when T_Numeric =>
- Put ("=nnn");
- Set_Col (53);
-
- if Sw.Unix_String (Sw.Unix_String'First)
- = '`'
- then
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 1
- .. Sw.Unix_String'Last));
- else
- Put (Sw.Unix_String.all);
- end if;
-
- Put_Line ("nnn");
-
- when T_Alphanumplus =>
- Put ("=xyz");
- Set_Col (53);
-
- if Sw.Unix_String (Sw.Unix_String'First)
- = '`'
- then
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 1
- .. Sw.Unix_String'Last));
- else
- Put (Sw.Unix_String.all);
- end if;
-
- Put_Line ("xyz");
-
- when T_String =>
- Put ("=");
- Put ('"');
- Put ("<string>");
- Put ('"');
- Set_Col (53);
-
- Put (Sw.Unix_String.all);
-
- if Sw.Unix_String (Sw.Unix_String'Last)
- /= '='
- then
- Put (' ');
- end if;
-
- Put ("<string>");
- New_Line;
-
- when T_Commands =>
- Put (" (switches for ");
- Put (Sw.Unix_String
- (Sw.Unix_String'First + 7
- .. Sw.Unix_String'Last));
- Put (')');
- Set_Col (53);
- Put (Sw.Unix_String
- (Sw.Unix_String'First
- .. Sw.Unix_String'First + 5));
- Put_Line (" switches");
-
- when T_Options =>
- declare
- Opt : Item_Ptr := Sw.Options;
-
- begin
- Put_Line ("=(option,option..)");
-
- while Opt /= null loop
- Put (" ");
- Put (Opt.Name.all);
-
- if Opt = Sw.Options then
- Put (" (D)");
- end if;
-
- Set_Col (53);
- Put_Line (Opt.Unix_String.all);
- Opt := Opt.Next;
- end loop;
- end;
-
- end case;
-
- Sw := Sw.Next;
- end loop;
- end;
-
- raise Normal_Exit;
- end if;
-
- -- Place (Command.Unix_String.all);
-
- -- Special handling for internal debugging switch /?
-
- elsif Arg.all = "/?" then
- Display_Command := True;
-
- -- Copy -switch unchanged
-
- elsif Arg (Arg'First) = '-' then
- Place (' ');
- Place (Arg.all);
-
- -- Copy quoted switch with quotes stripped
-
- elsif Arg (Arg'First) = '"' then
- if Arg (Arg'Last) /= '"' then
- Put (Standard_Error, "misquoted argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- Place (' ');
- Place (Arg (Arg'First + 1 .. Arg'Last - 1));
- end if;
-
- -- Parameter Argument
-
- elsif Arg (Arg'First) /= '/'
- and then Make_Commands_Active = null
- then
- Param_Count := Param_Count + 1;
-
- if Param_Count <= Command.Params'Length then
-
- case Command.Params (Param_Count) is
-
- when File | Optional_File =>
- declare
- Normal_File : String_Access
- := To_Canonical_File_Spec (Arg.all);
- begin
- Place (' ');
- Place_Lower (Normal_File.all);
-
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
- end;
-
- when Unlimited_Files =>
- declare
- Normal_File : String_Access
- := To_Canonical_File_Spec (Arg.all);
-
- File_Is_Wild : Boolean := False;
- File_List : String_Access_List_Access;
- begin
- for I in Arg'Range loop
- if Arg (I) = '*'
- or else Arg (I) = '%'
- then
- File_Is_Wild := True;
- end if;
- end loop;
-
- if File_Is_Wild then
- File_List := To_Canonical_File_List
- (Arg.all, False);
-
- for I in File_List.all'Range loop
- Place (' ');
- Place_Lower (File_List.all (I).all);
- end loop;
- else
- Place (' ');
- Place_Lower (Normal_File.all);
-
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
- end if;
-
- Param_Count := Param_Count - 1;
- end;
-
- when Other_As_Is =>
- Place (' ');
- Place (Arg.all);
-
- when Unlimited_As_Is =>
- Place (' ');
- Place (Arg.all);
- Param_Count := Param_Count - 1;
-
- when Files_Or_Wildcard =>
-
- -- Remove spaces from a comma separated list
- -- of file names and adjust control variables
- -- accordingly.
-
- while Arg_Num < Argument_Count and then
- (Argv (Argv'Last) = ',' xor
- Argument (Arg_Num + 1)
- (Argument (Arg_Num + 1)'First) = ',')
- loop
- Argv := new String'
- (Argv.all & Argument (Arg_Num + 1));
- Arg_Num := Arg_Num + 1;
- Arg_Idx := Argv'First;
- Next_Arg_Idx :=
- Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
- end loop;
-
- -- Parse the comma separated list of VMS
- -- filenames and place them on the command
- -- line as space separated Unix style
- -- filenames. Lower case and add default
- -- extension as appropriate.
-
- declare
- Arg1_Idx : Integer := Arg'First;
-
- function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer;
- -- Begins looking at Arg_Idx + 1 and
- -- returns the index of the last character
- -- before a comma or else the index of the
- -- last character in the string Arg.
-
- function Get_Arg1_End
- (Arg : String; Arg_Idx : Integer)
- return Integer
- is
- begin
- for I in Arg_Idx + 1 .. Arg'Last loop
- if Arg (I) = ',' then
- return I - 1;
- end if;
- end loop;
-
- return Arg'Last;
- end Get_Arg1_End;
-
- begin
- loop
- declare
- Next_Arg1_Idx : Integer :=
- Get_Arg1_End (Arg.all, Arg1_Idx);
-
- Arg1 : String :=
- Arg (Arg1_Idx .. Next_Arg1_Idx);
-
- Normal_File : String_Access :=
- To_Canonical_File_Spec (Arg1);
-
- begin
- Place (' ');
- Place_Lower (Normal_File.all);
-
- if Is_Extensionless (Normal_File.all)
- and then Command.Defext /= " "
- then
- Place ('.');
- Place (Command.Defext);
- end if;
-
- Arg1_Idx := Next_Arg1_Idx + 1;
- end;
-
- exit when Arg1_Idx > Arg'Last;
-
- -- Don't allow two or more commas in
- -- a row
-
- if Arg (Arg1_Idx) = ',' then
- Arg1_Idx := Arg1_Idx + 1;
- if Arg1_Idx > Arg'Last or else
- Arg (Arg1_Idx) = ','
- then
- Put_Line
- (Standard_Error,
- "Malformed Parameter: " &
- Arg.all);
- Put (Standard_Error, "usage: ");
- Put_Line (Standard_Error,
- Command.Usage.all);
- raise Error_Exit;
- end if;
- end if;
-
- end loop;
- end;
- end case;
- end if;
-
- -- Qualifier argument
-
- else
- declare
- Sw : Item_Ptr;
- SwP : Natural;
- P2 : Natural;
- Endp : Natural := 0; -- avoid warning!
- Opt : Item_Ptr;
-
- begin
- SwP := Arg'First;
- while SwP < Arg'Last
- and then Arg (SwP + 1) /= '='
- loop
- SwP := SwP + 1;
- end loop;
-
- -- At this point, the switch name is in
- -- Arg (Arg'First..SwP) and if that is not the
- -- whole switch, then there is an equal sign at
- -- Arg (SwP + 1) and the rest of Arg is what comes
- -- after the equal sign.
-
- -- If make commands are active, see if we have
- -- another COMMANDS_TRANSLATION switch belonging
- -- to gnatmake.
-
- if Make_Commands_Active /= null then
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => True);
-
- if Sw /= null
- and then Sw.Translation = T_Commands
- then
- null;
-
- else
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Make_Commands_Active.Switches,
- Quiet => False);
- end if;
-
- -- For case of GNAT MAKE or CHOP, if we cannot
- -- find the switch, then see if it is a
- -- recognized compiler switch instead, and if
- -- so process the compiler switch.
-
- elsif Command.Name.all = "MAKE"
- or else Command.Name.all = "CHOP" then
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => True);
-
- if Sw = null then
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Matching_Name
- ("COMPILE", Commands).Switches,
- Quiet => False);
- end if;
-
- -- For all other cases, just search the relevant
- -- command.
-
- else
- Sw :=
- Matching_Name
- (Arg (Arg'First .. SwP),
- Command.Switches,
- Quiet => False);
- end if;
-
- if Sw /= null then
- case Sw.Translation is
-
- when T_Direct =>
- Place_Unix_Switches (Sw.Unix_String);
- if SwP < Arg'Last
- and then Arg (SwP + 1) = '='
- then
- Put (Standard_Error,
- "qualifier options ignored: ");
- Put_Line (Standard_Error, Arg.all);
- end if;
-
- when T_Directories =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing directories for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- elsif Arg (SwP + 2) /= '(' then
- SwP := SwP + 2;
- Endp := Arg'Last;
-
- elsif Arg (Arg'Last) /= ')' then
-
- -- Remove spaces from a comma separated
- -- list of file names and adjust
- -- control variables accordingly.
-
- if Arg_Num < Argument_Count and then
- (Argv (Argv'Last) = ',' xor
- Argument (Arg_Num + 1)
- (Argument (Arg_Num + 1)'First) = ',')
- then
- Argv :=
- new String'(Argv.all
- & Argument
- (Arg_Num + 1));
- Arg_Num := Arg_Num + 1;
- Arg_Idx := Argv'First;
- Next_Arg_Idx
- := Get_Arg_End (Argv.all, Arg_Idx);
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
- goto Tryagain_After_Coalesce;
- end if;
-
- Put (Standard_Error,
- "incorrectly parenthesized " &
- "or malformed argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- SwP := SwP + 3;
- Endp := Arg'Last - 1;
- end if;
-
- while SwP <= Endp loop
- declare
- Dir_Is_Wild : Boolean := False;
- Dir_Maybe_Is_Wild : Boolean := False;
- Dir_List : String_Access_List_Access;
- begin
- P2 := SwP;
-
- while P2 < Endp
- and then Arg (P2 + 1) /= ','
- loop
-
- -- A wildcard directory spec on
- -- VMS will contain either * or
- -- % or ...
-
- if Arg (P2) = '*' then
- Dir_Is_Wild := True;
-
- elsif Arg (P2) = '%' then
- Dir_Is_Wild := True;
-
- elsif Dir_Maybe_Is_Wild
- and then Arg (P2) = '.'
- and then Arg (P2 + 1) = '.'
- then
- Dir_Is_Wild := True;
- Dir_Maybe_Is_Wild := False;
-
- elsif Dir_Maybe_Is_Wild then
- Dir_Maybe_Is_Wild := False;
-
- elsif Arg (P2) = '.'
- and then Arg (P2 + 1) = '.'
- then
- Dir_Maybe_Is_Wild := True;
-
- end if;
-
- P2 := P2 + 1;
- end loop;
-
- if (Dir_Is_Wild) then
- Dir_List := To_Canonical_File_List
- (Arg (SwP .. P2), True);
-
- for I in Dir_List.all'Range loop
- Place_Unix_Switches
- (Sw.Unix_String);
- Place_Lower
- (Dir_List.all (I).all);
- end loop;
- else
- Place_Unix_Switches
- (Sw.Unix_String);
- Place_Lower
- (To_Canonical_Dir_Spec
- (Arg (SwP .. P2), False).all);
- end if;
-
- SwP := P2 + 2;
- end;
- end loop;
-
- when T_Directory =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing directory for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- Place_Unix_Switches (Sw.Unix_String);
-
- -- Some switches end in "=". No space
- -- here
-
- if Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
- end if;
-
- Place_Lower
- (To_Canonical_Dir_Spec
- (Arg (SwP + 2 .. Arg'Last),
- False).all);
- end if;
-
- when T_File | T_No_Space_File =>
- if SwP + 1 > Arg'Last then
- Put (Standard_Error,
- "missing file for: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
-
- else
- Place_Unix_Switches (Sw.Unix_String);
-
- -- Some switches end in "=". No space
- -- here.
-
- if Sw.Translation = T_File
- and then Sw.Unix_String
- (Sw.Unix_String'Last) /= '='
- then
- Place (' ');
- end if;
-
- Place_Lower
- (To_Canonical_File_Spec
- (Arg (SwP + 2 .. Arg'Last)).all);
- end if;
-
- when T_Numeric =>
- if
- OK_Integer (Arg (SwP + 2 .. Arg'Last))
- then
- Place_Unix_Switches (Sw.Unix_String);
- Place (Arg (SwP + 2 .. Arg'Last));
-
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line
- (Standard_Error, " must be numeric");
- Errors := Errors + 1;
- end if;
-
- when T_Alphanumplus =>
- if
- OK_Alphanumerplus
- (Arg (SwP + 2 .. Arg'Last))
- then
- Place_Unix_Switches (Sw.Unix_String);
- Place (Arg (SwP + 2 .. Arg'Last));
-
- else
- Put (Standard_Error, "argument for ");
- Put (Standard_Error, Sw.Name.all);
- Put_Line (Standard_Error,
- " must be alphanumeric");
- Errors := Errors + 1;
- end if;
-
- when T_String =>
-
- -- A String value must be extended to the
- -- end of the Argv, otherwise strings like
- -- "foo/bar" get split at the slash.
- --
- -- The begining and ending of the string
- -- are flagged with embedded nulls which
- -- are removed when building the Spawn
- -- call. Nulls are use because they won't
- -- show up in a /? output. Quotes aren't
- -- used because that would make it
- -- difficult to embed them.
-
- Place_Unix_Switches (Sw.Unix_String);
- if Next_Arg_Idx /= Argv'Last then
- Next_Arg_Idx := Argv'Last;
- Arg := new String'
- (Argv (Arg_Idx .. Next_Arg_Idx));
-
- SwP := Arg'First;
- while SwP < Arg'Last and then
- Arg (SwP + 1) /= '=' loop
- SwP := SwP + 1;
- end loop;
- end if;
- Place (ASCII.NUL);
- Place (Arg (SwP + 2 .. Arg'Last));
- Place (ASCII.NUL);
-
- when T_Commands =>
-
- -- Output -largs/-bargs/-cargs
-
- Place (' ');
- Place (Sw.Unix_String
- (Sw.Unix_String'First ..
- Sw.Unix_String'First + 5));
-
- -- Set source of new commands, also
- -- setting this non-null indicates that
- -- we are in the special commands mode
- -- for processing the -xargs case.
-
- Make_Commands_Active :=
- Matching_Name
- (Sw.Unix_String
- (Sw.Unix_String'First + 7 ..
- Sw.Unix_String'Last),
- Commands);
-
- when T_Options =>
- if SwP + 1 > Arg'Last then
- Place_Unix_Switches
- (Sw.Options.Unix_String);
- SwP := Endp + 1;
-
- elsif Arg (SwP + 2) /= '(' then
- SwP := SwP + 2;
- Endp := Arg'Last;
-
- elsif Arg (Arg'Last) /= ')' then
- Put
- (Standard_Error,
- "incorrectly parenthesized " &
- "argument: ");
- Put_Line (Standard_Error, Arg.all);
- Errors := Errors + 1;
- SwP := Endp + 1;
-
- else
- SwP := SwP + 3;
- Endp := Arg'Last - 1;
- end if;
-
- while SwP <= Endp loop
- P2 := SwP;
-
- while P2 < Endp
- and then Arg (P2 + 1) /= ','
- loop
- P2 := P2 + 1;
- end loop;
-
- -- Option name is in Arg (SwP .. P2)
-
- Opt := Matching_Name (Arg (SwP .. P2),
- Sw.Options);
-
- if Opt /= null then
- Place_Unix_Switches
- (Opt.Unix_String);
- end if;
-
- SwP := P2 + 2;
- end loop;
-
- when T_Other =>
- Place_Unix_Switches
- (new String'(Sw.Unix_String.all &
- Arg.all));
-
- end case;
- end if;
- end;
- end if;
-
- Arg_Idx := Next_Arg_Idx + 1;
- end;
-
- exit when Arg_Idx > Argv'Last;
-
- end loop;
- end Process_Argument;
-
- Arg_Num := Arg_Num + 1;
- end loop;
-
- if Display_Command then
- Put (Standard_Error, "generated command -->");
- Put (Standard_Error, Command_List (The_Command).Unixcmd.all);
-
- if Command_List (The_Command).Unixsws /= null then
- for J in Command_List (The_Command).Unixsws'Range loop
- Put (Standard_Error, " ");
- Put (Standard_Error,
- Command_List (The_Command).Unixsws (J).all);
- end loop;
- end if;
-
- Put (Standard_Error, " ");
- Put (Standard_Error, String (Buffer.Table (1 .. Buffer.Last)));
- Put (Standard_Error, "<--");
- New_Line (Standard_Error);
- raise Normal_Exit;
- end if;
-
- -- Gross error checking that the number of parameters is correct.
- -- Not applicable to Unlimited_Files parameters.
-
- if (Param_Count = Command.Params'Length - 1
- and then Command.Params (Param_Count + 1) = Unlimited_Files)
- or else Param_Count <= Command.Params'Length
- then
- null;
-
- else
- Put_Line (Standard_Error,
- "Parameter count of "
- & Integer'Image (Param_Count)
- & " not equal to expected "
- & Integer'Image (Command.Params'Length));
- Put (Standard_Error, "usage: ");
- Put_Line (Standard_Error, Command.Usage.all);
- Errors := Errors + 1;
- end if;
-
- if Errors > 0 then
- raise Error_Exit;
- else
- -- Prepare arguments for a call to spawn, filtering out
- -- embedded nulls place there to delineate strings.
-
- declare
- P1, P2 : Natural;
- Inside_Nul : Boolean := False;
- Arg : String (1 .. 1024);
- Arg_Ctr : Natural;
-
- begin
- P1 := 1;
-
- while P1 <= Buffer.Last and then Buffer.Table (P1) = ' ' loop
- P1 := P1 + 1;
- end loop;
-
- Arg_Ctr := 1;
- Arg (Arg_Ctr) := Buffer.Table (P1);
-
- while P1 <= Buffer.Last loop
-
- if Buffer.Table (P1) = ASCII.NUL then
- if Inside_Nul then
- Inside_Nul := False;
- else
- Inside_Nul := True;
- end if;
- end if;
-
- if Buffer.Table (P1) = ' ' and then not Inside_Nul then
- P1 := P1 + 1;
- Arg_Ctr := Arg_Ctr + 1;
- Arg (Arg_Ctr) := Buffer.Table (P1);
-
- else
- Last_Switches.Increment_Last;
- P2 := P1;
-
- while P2 < Buffer.Last
- and then (Buffer.Table (P2 + 1) /= ' ' or else
- Inside_Nul)
- loop
- P2 := P2 + 1;
- Arg_Ctr := Arg_Ctr + 1;
- Arg (Arg_Ctr) := Buffer.Table (P2);
- if Buffer.Table (P2) = ASCII.NUL then
- Arg_Ctr := Arg_Ctr - 1;
- if Inside_Nul then
- Inside_Nul := False;
- else
- Inside_Nul := True;
- end if;
- end if;
- end loop;
-
- Last_Switches.Table (Last_Switches.Last) :=
- new String'(String (Arg (1 .. Arg_Ctr)));
- P1 := P2 + 2;
- Arg_Ctr := 1;
- Arg (Arg_Ctr) := Buffer.Table (P1);
- end if;
- end loop;
- end;
- end if;
- end VMS_Conversion;
-
-------------------------------------
-- Start of processing for GNATCmd --
-------------------------------------
@@ -3834,6 +440,8 @@ begin
First_Switches.Init;
First_Switches.Set_Last (0);
+ VMS_Conv.Initialize;
+
-- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
-- filenames and pathnames to Unix style.
@@ -3859,13 +467,17 @@ begin
if Command_List (The_Command).VMS_Only then
Non_VMS_Usage;
- Fail ("Command """ & Command_List (The_Command).Cname.all &
- """ can only be used on VMS");
+ Fail
+ ("Command """,
+ Command_List (The_Command).Cname.all,
+ """ can only be used on VMS");
end if;
+
exception
when Constraint_Error =>
-- Check if it is an alternate command
+
declare
Alternate : Alternate_Command;
@@ -3877,7 +489,7 @@ begin
exception
when Constraint_Error =>
Non_VMS_Usage;
- Fail ("Unknown command: " & Argument (Command_Arg));
+ Fail ("Unknown command: ", Argument (Command_Arg));
end;
end;
@@ -3891,7 +503,7 @@ begin
declare
Program : constant String :=
- Program_Name (Command_List (The_Command).Unixcmd.all).all;
+ Program_Name (Command_List (The_Command).Unixcmd.all).all;
Exec_Path : String_Access;
@@ -3915,30 +527,51 @@ begin
end loop;
end if;
- -- For BIND, FIND, LINK, LIST and XREF, look for project file related
- -- switches.
+ -- For BIND, FIND, LINK, LIST, PRETTY ad XREF, look for project file
+ -- related switches.
if The_Command = Bind
+ or else The_Command = Elim
or else The_Command = Find
or else The_Command = Link
or else The_Command = List
or else The_Command = Xref
+ or else The_Command = Pretty
+ or else The_Command = Stub
then
case The_Command is
when Bind =>
Tool_Package_Name := Name_Binder;
+ Packages_To_Check := Packages_To_Check_By_Binder;
+ when Elim =>
+ Tool_Package_Name := Name_Eliminate;
+ Packages_To_Check := Packages_To_Check_By_Eliminate;
when Find =>
Tool_Package_Name := Name_Finder;
+ Packages_To_Check := Packages_To_Check_By_Finder;
when Link =>
Tool_Package_Name := Name_Linker;
+ Packages_To_Check := Packages_To_Check_By_Linker;
when List =>
Tool_Package_Name := Name_Gnatls;
+ Packages_To_Check := Packages_To_Check_By_Gnatls;
+ when Pretty =>
+ Tool_Package_Name := Name_Pretty_Printer;
+ Packages_To_Check := Packages_To_Check_By_Pretty;
+ when Stub =>
+ Tool_Package_Name := Name_Gnatstub;
+ Packages_To_Check := Packages_To_Check_By_Gnatstub;
when Xref =>
Tool_Package_Name := Name_Cross_Reference;
+ Packages_To_Check := Packages_To_Check_By_Xref;
when others =>
null;
end case;
+ -- Check that the switches are consistent.
+ -- Detect project file related switches.
+
+ Inspect_Switches :
declare
Arg_Num : Positive := 1;
Argv : String_Access;
@@ -3957,7 +590,7 @@ begin
Last_Switches.Decrement_Last;
end Remove_Switch;
- -- Start of processing for ??? (need block name here)
+ -- Start of processing for Inspect_Switches
begin
while Arg_Num <= Last_Switches.Last loop
@@ -3965,7 +598,8 @@ begin
if Argv (Argv'First) = '-' then
if Argv'Length = 1 then
- Fail ("switch character cannot be followed by a blank");
+ Fail
+ ("switch character cannot be followed by a blank");
end if;
-- The two style project files (-p and -P) cannot be used
@@ -3993,23 +627,22 @@ begin
when '2' =>
Current_Verbosity := Prj.High;
when others =>
- Fail ("Invalid switch: " & Argv.all);
+ Fail ("Invalid switch: ", Argv.all);
end case;
Remove_Switch (Arg_Num);
-- -Pproject_file Specify project file to be used
- elsif Argv'Length >= 3
- and then Argv (Argv'First + 1) = 'P'
- then
+ elsif Argv (Argv'First + 1) = 'P' then
-- Only one -P switch can be used
if Project_File /= null then
- Fail (Argv.all &
- ": second project file forbidden (first is """ &
- Project_File.all & """)");
+ Fail
+ (Argv.all,
+ ": second project file forbidden (first is """,
+ Project_File.all & """)");
-- The two style project files (-p and -P) cannot be
-- used together.
@@ -4017,7 +650,31 @@ begin
elsif Old_Project_File_Used then
Fail ("-p and -P cannot be used together");
+ elsif Argv'Length = 2 then
+ -- There is space between -P and the project file
+ -- name. -P cannot be the last option.
+
+ if Arg_Num = Last_Switches.Last then
+ Fail ("project file name missing after -P");
+
+ else
+ Remove_Switch (Arg_Num);
+ Argv := Last_Switches.Table (Arg_Num);
+
+ -- After -P, there must be a project file name,
+ -- not another switch.
+
+ if Argv (Argv'First) = '-' then
+ Fail ("project file name missing after -P");
+
+ else
+ Project_File := new String'(Argv.all);
+ end if;
+ end if;
+
else
+ -- No space between -P and project file name
+
Project_File :=
new String'(Argv (Argv'First + 2 .. Argv'Last));
end if;
@@ -4040,8 +697,9 @@ begin
Argv (Argv'First + 2 .. Equal_Pos - 1),
Value => Argv (Equal_Pos + 1 .. Argv'Last));
else
- Fail (Argv.all &
- " is not a valid external assignment.");
+ Fail
+ (Argv.all,
+ " is not a valid external assignment.");
end if;
end;
@@ -4055,7 +713,7 @@ begin
Arg_Num := Arg_Num + 1;
end if;
end loop;
- end;
+ end Inspect_Switches;
end if;
-- If there is a project file specified, parse it, get the switches
@@ -4066,21 +724,24 @@ begin
Prj.Pars.Parse
(Project => Project,
- Project_File_Name => Project_File.all);
+ Project_File_Name => Project_File.all,
+ Packages_To_Check => Packages_To_Check);
if Project = Prj.No_Project then
- Fail ("""" & Project_File.all & """ processing failed");
+ Fail ("""", Project_File.all, """ processing failed");
end if;
-- Check if a package with the name of the tool is in the project
-- file and if there is one, get the switches, if any, and scan them.
declare
- Data : Prj.Project_Data := Prj.Projects.Table (Project);
- Pkg : Prj.Package_Id :=
- Prj.Util.Value_Of
- (Name => Tool_Package_Name,
- In_Packages => Data.Decl.Packages);
+ Data : constant Prj.Project_Data :=
+ Prj.Projects.Table (Project);
+
+ Pkg : constant Prj.Package_Id :=
+ Prj.Util.Value_Of
+ (Name => Tool_Package_Name,
+ In_Packages => Data.Decl.Packages);
Element : Package_Element;
@@ -4104,19 +765,23 @@ begin
In_Variables => Element.Decl.Attributes);
-- Packages Binder (for gnatbind), Cross_Reference (for
- -- gnatxref), Linker (for gnatlink) and Finder
- -- (for gnatfind) have an attributed Default_Switches,
- -- an associative array, indexed by the name of the
- -- programming language.
- else
- Default_Switches_Array :=
- Prj.Util.Value_Of
- (Name => Name_Default_Switches,
- In_Arrays => Packages.Table (Pkg).Decl.Arrays);
- The_Switches := Prj.Util.Value_Of
- (Index => Name_Ada,
- In_Array => Default_Switches_Array);
+ -- gnatxref), Linker (for gnatlink) Finder (for gnatfind),
+ -- Pretty_Printer (for gnatpp) and Eliminate (for gnatelim)
+ -- have an attributed Switches, an associative array, indexed
+ -- by the name of the file.
+ -- They also have an attribute Default_Switches, indexed
+ -- by the name of the programming language.
+ else
+ if The_Switches.Kind = Prj.Undefined then
+ Default_Switches_Array :=
+ Prj.Util.Value_Of
+ (Name => Name_Default_Switches,
+ In_Arrays => Packages.Table (Pkg).Decl.Arrays);
+ The_Switches := Prj.Util.Value_Of
+ (Index => Name_Ada,
+ In_Array => Default_Switches_Array);
+ end if;
end if;
-- If there are switches specified in the package of the
@@ -4127,24 +792,34 @@ begin
null;
when Prj.Single =>
- if String_Length (The_Switches.Value) > 0 then
- String_To_Name_Buffer (The_Switches.Value);
- First_Switches.Increment_Last;
- First_Switches.Table (First_Switches.Last) :=
- new String'(Name_Buffer (1 .. Name_Len));
- end if;
+ declare
+ Switch : constant String :=
+ Get_Name_String (The_Switches.Value);
+
+ begin
+ if Switch'Length > 0 then
+ First_Switches.Increment_Last;
+ First_Switches.Table (First_Switches.Last) :=
+ new String'(Switch);
+ end if;
+ end;
when Prj.List =>
Current := The_Switches.Values;
while Current /= Prj.Nil_String loop
The_String := String_Elements.Table (Current);
- if String_Length (The_String.Value) > 0 then
- String_To_Name_Buffer (The_String.Value);
- First_Switches.Increment_Last;
- First_Switches.Table (First_Switches.Last) :=
- new String'(Name_Buffer (1 .. Name_Len));
- end if;
+ declare
+ Switch : constant String :=
+ Get_Name_String (The_String.Value);
+
+ begin
+ if Switch'Length > 0 then
+ First_Switches.Increment_Last;
+ First_Switches.Table (First_Switches.Last) :=
+ new String'(Switch);
+ end if;
+ end;
Current := The_String.Next;
end loop;
@@ -4152,23 +827,45 @@ begin
end if;
end;
- -- Set up the environment variables ADA_INCLUDE_PATH and
- -- ADA_OBJECTS_PATH.
-
- Setenv
- (Name => Ada_Include_Path,
- Value => Prj.Env.Ada_Include_Path (Project).all);
- Setenv
- (Name => Ada_Objects_Path,
- Value => Prj.Env.Ada_Objects_Path
- (Project, Including_Libraries => False).all);
-
- if The_Command = Bind or else The_Command = Link then
+ if The_Command = Bind
+ or else The_Command = Link
+ or else The_Command = Elim
+ then
Change_Dir
(Get_Name_String
(Projects.Table (Project).Object_Directory));
end if;
+ -- Set up the env vars for project path files
+
+ Prj.Env.Set_Ada_Paths (Project, Including_Libraries => False);
+
+ -- For gnatstub, gnatpp and gnatelim, create a configuration pragmas
+ -- file, if necessary.
+
+ if The_Command = Pretty
+ or else The_Command = Stub
+ or else The_Command = Elim
+ then
+ declare
+ CP_File : constant Name_Id := Configuration_Pragmas_File;
+
+ begin
+ if CP_File /= No_Name then
+ First_Switches.Increment_Last;
+
+ if The_Command = Elim then
+ First_Switches.Table (First_Switches.Last) :=
+ new String'("-C" & Get_Name_String (CP_File));
+
+ else
+ First_Switches.Table (First_Switches.Last) :=
+ new String'("-gnatec=" & Get_Name_String (CP_File));
+ end if;
+ end if;
+ end;
+ end if;
+
if The_Command = Link then
-- Add the default search directories, to be able to find
@@ -4178,11 +875,15 @@ begin
declare
There_Are_Libraries : Boolean := False;
+ Path_Option : constant String_Access :=
+ MLib.Tgt.Linker_Library_Path_Option;
begin
+ Library_Paths.Set_Last (0);
+
-- Check if there are library project files
- if MLib.Tgt.Libraries_Are_Supported then
+ if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then
Set_Libraries (Project, There_Are_Libraries);
end if;
@@ -4202,18 +903,366 @@ begin
Last_Switches.Table (Last_Switches.Last) :=
new String'("-lgnat");
- declare
- Option : constant String_Access :=
- MLib.Tgt.Linker_Library_Path_Option
- (MLib.Utl.Lib_Directory);
+ -- If Path_Option is not null, create the switch
+ -- ("-Wl,-rpath," or equivalent) with all the library dirs
+ -- plus the standard GNAT library dir.
+
+ if Path_Option /= null then
+ declare
+ Option : String_Access;
+ Length : Natural := Path_Option'Length;
+ Current : Natural;
+
+ begin
+ -- First, compute the exact length for the switch
+
+ for Index in
+ Library_Paths.First .. Library_Paths.Last
+ loop
+ -- Add the length of the library dir plus one
+ -- for the directory separator.
+
+ Length :=
+ Length +
+ Library_Paths.Table (Index)'Length + 1;
+ end loop;
+
+ -- Finally, add the length of the standard GNAT
+ -- library dir.
+
+ Length := Length + MLib.Utl.Lib_Directory'Length;
+ Option := new String (1 .. Length);
+ Option (1 .. Path_Option'Length) := Path_Option.all;
+ Current := Path_Option'Length;
+
+ -- Put each library dir followed by a dir separator
+
+ for Index in
+ Library_Paths.First .. Library_Paths.Last
+ loop
+ Option
+ (Current + 1 ..
+ Current +
+ Library_Paths.Table (Index)'Length) :=
+ Library_Paths.Table (Index).all;
+ Current :=
+ Current +
+ Library_Paths.Table (Index)'Length + 1;
+ Option (Current) := Path_Separator;
+ end loop;
+
+ -- Finally put the standard GNAT library dir
+
+ Option
+ (Current + 1 ..
+ Current + MLib.Utl.Lib_Directory'Length) :=
+ MLib.Utl.Lib_Directory;
+
+ -- And add the switch to the last switches
- begin
- if Option /= null then
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
Option;
+ end;
+ end if;
+ end if;
+ end;
+
+ -- Check if the first ALI file specified can be found, either
+ -- in the object directory of the main project or in an object
+ -- directory of a project file extended by the main project.
+ -- If the ALI file can be found, replace its name with its
+ -- absolute path.
+
+ declare
+ Skip_Executable : Boolean := False;
+
+ begin
+ Switch_Loop : for J in 1 .. Last_Switches.Last loop
+
+ -- If we have an executable just reset the flag
+
+ if Skip_Executable then
+ Skip_Executable := False;
+
+ -- If -o, set flag so that next switch is not processed
+
+ elsif Last_Switches.Table (J).all = "-o" then
+ Skip_Executable := True;
+
+ -- Normal case
+
+ else
+ declare
+ Switch : constant String :=
+ Last_Switches.Table (J).all;
+
+ ALI_File : constant String (1 .. Switch'Length + 4) :=
+ Switch & ".ali";
+
+ Last : Natural := Switch'Length;
+ Test_Existence : Boolean := False;
+
+ begin
+ -- Skip real switches
+
+ if Switch'Length /= 0 and then
+ Switch (Switch'First) /= '-'
+ then
+ -- Append ".ali" if file name does not end with it
+
+ if Switch'Length <= 4 or else
+ Switch (Switch'Last - 3 .. Switch'Last) /= ".ali"
+ then
+ Last := ALI_File'Last;
+ end if;
+
+ -- If file name includes directory information,
+ -- stop if ALI file exists.
+
+ if Is_Absolute_Path (ALI_File (1 .. Last)) then
+ Test_Existence := True;
+
+ else
+ for K in Switch'Range loop
+ if Switch (K) = '/' or else
+ Switch (K) = Directory_Separator
+ then
+ Test_Existence := True;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ if Test_Existence then
+ if Is_Regular_File (ALI_File (1 .. Last)) then
+ exit Switch_Loop;
+ end if;
+
+ else
+ -- Look in the object directories if the ALI
+ -- file exists.
+
+ declare
+ Prj : Project_Id := Project;
+ begin
+ Project_Loop :
+ loop
+ declare
+ Dir : constant String :=
+ Get_Name_String
+ (Projects.Table (Prj).
+ Object_Directory);
+ begin
+ if Is_Regular_File
+ (Dir & Directory_Separator &
+ ALI_File (1 .. Last))
+ then
+ -- We have found the correct
+ -- project, so we replace the file
+ -- with the absolute path.
+
+ Last_Switches.Table (J) :=
+ new String'
+ (Dir & Directory_Separator &
+ ALI_File (1 .. Last));
+
+ -- And we are done
+
+ exit Switch_Loop;
+ end if;
+ end;
+
+ -- Go to the project being extended,
+ -- if any.
+
+ Prj := Projects.Table (Prj).Extends;
+ exit Project_Loop when Prj = No_Project;
+ end loop Project_Loop;
+ end;
+ end if;
+ end if;
+ end;
+ end if;
+ end loop Switch_Loop;
+ end;
+
+ -- If a relative path output file has been specified, we add
+ -- the exec directory.
+
+ declare
+ Look_For_Executable : Boolean := True;
+
+ begin
+
+ for J in reverse 1 .. Last_Switches.Last - 1 loop
+ if Last_Switches.Table (J).all = "-o" then
+ Check_Relative_Executable
+ (Name => Last_Switches.Table (J + 1));
+ Look_For_Executable := False;
+ exit;
+ end if;
+ end loop;
+
+ if Look_For_Executable then
+ for J in reverse 1 .. First_Switches.Last - 1 loop
+ if First_Switches.Table (J).all = "-o" then
+ Look_For_Executable := False;
+ Check_Relative_Executable
+ (Name => First_Switches.Table (J + 1));
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ -- If no executable is specified, then find the name
+ -- of the first ALI file on the command line and issue
+ -- a -o switch with the absolute path of the executable
+ -- in the exec directory.
+
+ if Look_For_Executable then
+ for J in 1 .. Last_Switches.Last loop
+ declare
+ Arg : constant String_Access :=
+ Last_Switches.Table (J);
+ Last : Natural := 0;
+
+ begin
+ if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then
+ if Arg'Length > 4
+ and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
+ then
+ Last := Arg'Last - 4;
+
+ elsif Is_Regular_File (Arg.all & ".ali") then
+ Last := Arg'Last;
+ end if;
+
+ if Last /= 0 then
+ declare
+ Executable_Name : constant String :=
+ Base_Name (Arg (Arg'First .. Last));
+ begin
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'("-o");
+ Get_Name_String
+ (Projects.Table (Project).Exec_Directory);
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'(Name_Buffer (1 .. Name_Len) &
+ Directory_Separator &
+ Executable_Name &
+ Get_Executable_Suffix.all);
+ exit;
+ end;
+ end if;
+ end if;
+ end;
+ end loop;
+ end if;
+ end;
+ end if;
+
+ if The_Command = Link or The_Command = Bind then
+
+ -- For files that are specified as relative paths with directory
+ -- information, we convert them to absolute paths, with parent
+ -- being the current working directory if specified on the command
+ -- line and the project directory if specified in the project
+ -- file. This is what gnatmake is doing for linker and binder
+ -- arguments.
+
+ for J in 1 .. Last_Switches.Last loop
+ Test_If_Relative_Path
+ (Last_Switches.Table (J), Current_Work_Dir);
+ end loop;
+
+ Get_Name_String (Projects.Table (Project).Directory);
+
+ declare
+ Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
+
+ begin
+ for J in 1 .. First_Switches.Last loop
+ Test_If_Relative_Path
+ (First_Switches.Table (J), Project_Dir);
+ end loop;
+ end;
+
+ elsif The_Command = Stub then
+ declare
+ Data : constant Prj.Project_Data :=
+ Prj.Projects.Table (Project);
+ File_Index : Integer := 0;
+ Dir_Index : Integer := 0;
+ Last : constant Integer := Last_Switches.Last;
+
+ begin
+ for Index in 1 .. Last loop
+ if Last_Switches.Table (Index)
+ (Last_Switches.Table (Index)'First) /= '-'
+ then
+ File_Index := Index;
+ exit;
+ end if;
+ end loop;
+
+ -- If the naming scheme of the project file is not standard,
+ -- and if the file name ends with the spec suffix, then
+ -- indicate to gnatstub the name of the body file with
+ -- a -o switch.
+
+ if Data.Naming.Current_Spec_Suffix /=
+ Prj.Default_Ada_Spec_Suffix
+ then
+ if File_Index /= 0 then
+ declare
+ Spec : constant String :=
+ Base_Name (Last_Switches.Table (File_Index).all);
+ Last : Natural := Spec'Last;
+
+ begin
+ Get_Name_String (Data.Naming.Current_Spec_Suffix);
+
+ if Spec'Length > Name_Len
+ and then Spec (Last - Name_Len + 1 .. Last) =
+ Name_Buffer (1 .. Name_Len)
+ then
+ Last := Last - Name_Len;
+ Get_Name_String (Data.Naming.Current_Body_Suffix);
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'("-o");
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'(Spec (Spec'First .. Last) &
+ Name_Buffer (1 .. Name_Len));
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- Add the directory of the spec as the destination directory
+ -- of the body, if there is no destination directory already
+ -- specified.
+
+ if File_Index /= 0 then
+ for Index in File_Index + 1 .. Last loop
+ if Last_Switches.Table (Index)
+ (Last_Switches.Table (Index)'First) /= '-'
+ then
+ Dir_Index := Index;
+ exit;
end if;
- end;
+ end loop;
+
+ if Dir_Index = 0 then
+ Last_Switches.Increment_Last;
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'
+ (Dir_Name (Last_Switches.Table (File_Index).all));
+ end if;
end if;
end;
end if;
@@ -4236,6 +1285,22 @@ begin
The_Args (Arg_Num) := Last_Switches.Table (J);
end loop;
+ -- If Display_Command is on, only display the generated command
+
+ if Display_Command then
+ Put (Standard_Error, "generated command -->");
+ Put (Standard_Error, Exec_Path.all);
+
+ for Arg in The_Args'Range loop
+ Put (Standard_Error, " ");
+ Put (Standard_Error, The_Args (Arg).all);
+ end loop;
+
+ Put (Standard_Error, "<--");
+ New_Line (Standard_Error);
+ raise Normal_Exit;
+ end if;
+
if Opt.Verbose_Mode then
Output.Write_Str (Exec_Path.all);
@@ -4247,17 +1312,31 @@ begin
Output.Write_Eol;
end if;
- My_Exit_Status
- := Exit_Status (Spawn (Exec_Path.all, The_Args));
+ My_Exit_Status :=
+ Exit_Status (Spawn (Exec_Path.all, The_Args));
raise Normal_Exit;
end;
end;
exception
when Error_Exit =>
+ Prj.Env.Delete_All_Path_Files;
+ Delete_Temp_Config_Files;
Set_Exit_Status (Failure);
when Normal_Exit =>
- Set_Exit_Status (My_Exit_Status);
+ Prj.Env.Delete_All_Path_Files;
+ Delete_Temp_Config_Files;
+
+ -- Since GNATCmd is normally called from DCL (the VMS shell),
+ -- it must return an understandable VMS exit status. However
+ -- the exit status returned *to* GNATCmd is a Posix style code,
+ -- so we test it and return just a simple success or failure on VMS.
+
+ if Hostparm.OpenVMS and then My_Exit_Status /= Success then
+ Set_Exit_Status (Failure);
+ else
+ Set_Exit_Status (My_Exit_Status);
+ end if;
end GNATCmd;
diff --git a/gcc/ada/gnatfind.adb b/gcc/ada/gnatfind.adb
index 0b34519abe6..49fc1ed1a50 100644
--- a/gcc/ada/gnatfind.adb
+++ b/gcc/ada/gnatfind.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-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- --
@@ -19,6 +19,9 @@
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
------------------------------------------------------------------------------
with Xr_Tabls; use Xr_Tabls;
@@ -32,7 +35,7 @@ with Opt;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Command_Line; use GNAT.Command_Line;
-
+with GNAT.Strings; use GNAT.Strings;
---------------
-- Gnatfind --
---------------
@@ -58,6 +61,9 @@ procedure Gnatfind is
Has_File_In_Entity : Boolean := False;
-- Will be true if a file name was specified in the entity
+ RTS_Specified : String_Access := null;
+ -- Used to detect multiple use of --RTS= switch
+
procedure Parse_Cmd_Line;
-- Parse every switch on the command line
@@ -137,14 +143,23 @@ procedure Gnatfind is
-- Only switch starting with -- recognized is --RTS
when '-' =>
+ -- Check that it is the first time we see this switch
+
+ if RTS_Specified = null then
+ RTS_Specified := new String'(GNAT.Command_Line.Parameter);
+
+ elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then
+ Osint.Fail ("--RTS cannot be specified multiple times");
+ end if;
+
Opt.No_Stdinc := True;
Opt.RTS_Switch := True;
declare
- Src_Path_Name : String_Ptr :=
+ Src_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
(GNAT.Command_Line.Parameter, Include);
- Lib_Path_Name : String_Ptr :=
+ Lib_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
(GNAT.Command_Line.Parameter, Objects);
@@ -225,7 +240,7 @@ procedure Gnatfind is
procedure Write_Usage is
begin
Put_Line ("GNATFIND " & Gnatvsn.Gnat_Version_String
- & " Copyright 1998-2002, Ada Core Technologies Inc.");
+ & " Copyright 1998-2003, Ada Core Technologies Inc.");
Put_Line ("Usage: gnatfind pattern[:sourcefile[:line[:column]]] "
& "[file1 file2 ...]");
New_Line;
diff --git a/gcc/ada/gnatkr.adb b/gcc/ada/gnatkr.adb
index f99b51ec6d6..8035e606c3e 100644
--- a/gcc/ada/gnatkr.adb
+++ b/gcc/ada/gnatkr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -30,7 +30,6 @@ with Krunch;
with System.IO; use System.IO;
procedure Gnatkr is
-
Count : Natural;
Maxlen : Integer;
Exit_Program : exception;
@@ -91,29 +90,19 @@ begin
-- If extension is present, points to it (init to prevent warning)
begin
- -- Remove .adb or .ads extension if present (recognized only if the
+ -- Remove extension if present (an extension is defined as the
+ -- section of the file name after the last dot in the name. If
+ -- there is no dot in the name, then
-- name is all lower case and contains no other instances of dots)
- if Klen > 4
- and then Fname (Klen - 3 .. Klen - 1) = ".ad"
- and then (Fname (Klen) = 's' or else Fname (Klen) = 'b')
- then
- Extp := True;
-
- for J in 1 .. Klen - 4 loop
- if Is_Upper (Fname (J)) or else Fname (J) = '.' then
- Extp := False;
- end if;
- end loop;
-
- if Extp then
- Klen := Klen - 4;
- Ext := Klen + 1;
+ for J in reverse 1 .. Klen loop
+ if Fname (J) = '.' then
+ Extp := True;
+ Ext := J;
+ Klen := J - 1;
+ exit;
end if;
-
- else
- Extp := False;
- end if;
+ end loop;
-- Fold to lower case and replace dots by dashes
diff --git a/gcc/ada/gnatlbr.adb b/gcc/ada/gnatlbr.adb
index d5d0c8aaf5e..dd200508169 100644
--- a/gcc/ada/gnatlbr.adb
+++ b/gcc/ada/gnatlbr.adb
@@ -44,12 +44,14 @@
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Gnatvsn; use Gnatvsn;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with Osint; use Osint;
with Sdefault; use Sdefault;
with System;
procedure GnatLbr is
+ pragma Ident (Gnat_Version_String);
type Lib_Mode is (None, Create, Set, Delete);
Next_Arg : Integer;
diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb
index 6fa413a19d9..1a3407e55f2 100644
--- a/gcc/ada/gnatlink.adb
+++ b/gcc/ada/gnatlink.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -31,6 +31,7 @@ with ALI; use ALI;
with Gnatvsn; use Gnatvsn;
with Hostparm;
with Namet; use Namet;
+with Opt;
with Osint; use Osint;
with Output; use Output;
with Switch; use Switch;
@@ -124,8 +125,8 @@ procedure Gnatlink is
Read_Mode : constant String := "r" & ASCII.Nul;
- Begin_Info : String := "-- BEGIN Object file/option list";
- End_Info : String := "-- END Object file/option list ";
+ Begin_Info : String := "-- BEGIN Object file/option list";
+ End_Info : String := "-- END Object file/option list ";
-- Note: above lines are modified in C mode, see option processing
Gcc_Path : String_Access;
@@ -184,6 +185,9 @@ procedure Gnatlink is
function Value (chars : chars_ptr) return String;
-- Return NUL-terminated string chars as an Ada string.
+ procedure Write_Header;
+ -- Show user the program name, version and copyright.
+
procedure Write_Usage;
-- Show user the program options.
@@ -260,7 +264,10 @@ procedure Gnatlink is
------------------
procedure Process_Args is
- Next_Arg : Integer;
+ Next_Arg : Integer;
+ Skip_Next : Boolean := False;
+ -- Set to true if the next argument is to be added into the list of
+ -- linker's argument without parsing it.
begin
-- Loop through arguments of gnatlink command
@@ -270,14 +277,25 @@ procedure Gnatlink is
exit when Next_Arg > Argument_Count;
Process_One_Arg : declare
- Arg : String := Argument (Next_Arg);
+ Arg : constant String := Argument (Next_Arg);
begin
-- Case of argument which is a switch
-- We definitely need section by section comments here ???
- if Arg'Length /= 0 and then Arg (1) = '-' then
+ if Skip_Next then
+
+ -- This argument must not be parsed, just add it to the
+ -- list of linker's options.
+
+ Skip_Next := False;
+
+ Linker_Options.Increment_Last;
+ Linker_Options.Table (Linker_Options.Last) :=
+ new String'(Arg);
+
+ elsif Arg'Length /= 0 and then Arg (1) = '-' then
if Arg'Length > 4
and then Arg (2 .. 5) = "gnat"
then
@@ -285,7 +303,18 @@ procedure Gnatlink is
("invalid switch: """ & Arg & """ (gnat not needed here)");
end if;
- if Arg (2) = 'g'
+ if Arg = "-Xlinker" then
+
+ -- Next argument should be sent directly to the linker.
+ -- We do not want to parse it here.
+
+ Skip_Next := True;
+
+ Linker_Options.Increment_Last;
+ Linker_Options.Table (Linker_Options.Last) :=
+ new String'(Arg);
+
+ elsif Arg (2) = 'g'
and then (Arg'Length < 5 or else Arg (2 .. 5) /= "gnat")
then
Debug_Flag_Present := True;
@@ -302,8 +331,8 @@ procedure Gnatlink is
case Arg (2) is
when 'A' =>
Ada_Bind_File := True;
- Begin_Info := "-- BEGIN Object file/option list";
- End_Info := "-- END Object file/option list ";
+ Begin_Info := "-- BEGIN Object file/option list";
+ End_Info := "-- END Object file/option list ";
when 'b' =>
Linker_Options.Increment_Last;
@@ -321,7 +350,7 @@ procedure Gnatlink is
end if;
Get_Machine_Name : declare
- Name_Arg : String_Access :=
+ Name_Arg : constant String_Access :=
new String'(Argument (Next_Arg));
begin
@@ -337,8 +366,8 @@ procedure Gnatlink is
when 'C' =>
Ada_Bind_File := False;
- Begin_Info := "/* BEGIN Object file/option list";
- End_Info := " END Object file/option list */";
+ Begin_Info := "/* BEGIN Object file/option list";
+ End_Info := " END Object file/option list */";
when 'f' =>
if Object_List_File_Supported then
@@ -368,6 +397,9 @@ procedure Gnatlink is
Linker_Options.Table (Linker_Options.Last) :=
Output_File_Name;
+ when 'R' =>
+ Opt.Run_Path_Option := False;
+
when 'v' =>
-- Support "double" verbose mode. Second -v
@@ -399,7 +431,7 @@ procedure Gnatlink is
elsif Arg (2) = 'B' then
Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last) :=
- new String'(Arg);
+ new String'(Arg);
Binder_Options.Increment_Last;
Binder_Options.Table (Binder_Options.Last) :=
@@ -421,7 +453,7 @@ procedure Gnatlink is
elsif Arg'Length > 6 and then Arg (1 .. 6) = "--GCC=" then
declare
- Program_Args : Argument_List_Access :=
+ Program_Args : constant Argument_List_Access :=
Argument_String_To_List
(Arg (7 .. Arg'Last));
@@ -433,8 +465,8 @@ procedure Gnatlink is
for J in 2 .. Program_Args.all'Last loop
declare
- Arg : String := Program_Args.all (J).all;
- AF : Integer := Arg'First;
+ Arg : constant String := Program_Args.all (J).all;
+ AF : constant Integer := Arg'First;
begin
if Arg'Length /= 0 and then Arg (AF) = '-' then
@@ -480,6 +512,8 @@ procedure Gnatlink is
-- Here if argument is a file name rather than a switch
else
+ -- If explicit ali file, capture it
+
if Arg'Length > 4
and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
then
@@ -489,10 +523,7 @@ procedure Gnatlink is
Exit_With_Error ("cannot handle more than one ALI file");
end if;
- elsif Is_Regular_File (Arg & ".ali")
- and then Ali_File_Name = null
- then
- Ali_File_Name := new String'(Arg & ".ali");
+ -- If object file, record object file
elsif Arg'Length > Get_Object_Suffix.all'Length
and then Arg
@@ -503,14 +534,22 @@ procedure Gnatlink is
Linker_Objects.Table (Linker_Objects.Last) :=
new String'(Arg);
+ -- If corresponding ali file exists, capture it
+
+ elsif Ali_File_Name = null
+ and then Is_Regular_File (Arg & ".ali")
+ then
+ Ali_File_Name := new String'(Arg & ".ali");
+
+ -- Otherwise assume this is a linker options entry, but
+ -- see below for interesting adjustment to this assumption.
+
else
Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last) :=
new String'(Arg);
end if;
-
end if;
-
end Process_One_Arg;
Next_Arg := Next_Arg + 1;
@@ -523,6 +562,18 @@ procedure Gnatlink is
Binder_Options.Increment_Last;
Binder_Options.Table (Binder_Options.Last) := new String'("-gnatws");
end if;
+
+ -- If we did not get an ali file at all, and we had at least one
+ -- linker option, then assume that was the intended ali file after
+ -- all, so that we get a nicer message later on.
+
+ if Ali_File_Name = null
+ and then Linker_Options.Last >= Linker_Options.First
+ then
+ Ali_File_Name :=
+ new String'(Linker_Options.Table (Linker_Options.First).all &
+ ".ali");
+ end if;
end Process_Args;
-------------------------
@@ -530,26 +581,67 @@ procedure Gnatlink is
-------------------------
procedure Process_Binder_File (Name : in String) is
- Fd : FILEs;
- Link_Bytes : Integer := 0;
- Link_Max : Integer;
+ Fd : FILEs;
+ -- Binder file's descriptor
+
+ Link_Bytes : Integer := 0;
+ -- Projected number of bytes for the linker command line
+
+ Link_Max : Integer;
pragma Import (C, Link_Max, "link_max");
+ -- Maximum number of bytes on the command line supported by the OS
+ -- linker. Passed this limit the response file mechanism must be used
+ -- if supported.
+
+ Next_Line : String (1 .. 1000);
+ -- Current line value
- Next_Line : String (1 .. 1000);
- Nlast : Integer;
- Nfirst : Integer;
- Objs_Begin : Integer := 0;
- Objs_End : Integer := 0;
+ Nlast : Integer;
+ Nfirst : Integer;
+ -- Current line slice (the slice does not contain line terminator)
- Status : int;
- N : Integer;
+ Objs_Begin : Integer := 0;
+ -- First object file index in Linker_Objects table
- GNAT_Static : Boolean := False;
+ Objs_End : Integer := 0;
+ -- Last object file index in Linker_Objects table
+
+ Status : int;
+ -- Used for various Interfaces.C_Streams calls
+
+ Closing_Status : Boolean;
+ -- For call to Close
+
+ GNAT_Static : Boolean := False;
-- Save state of -static option.
- GNAT_Shared : Boolean := False;
+ GNAT_Shared : Boolean := False;
-- Save state of -shared option.
+ -- Rollback data
+
+ -- These data items are used to store current binder file context.
+ -- The context is composed of the file descriptor position and the
+ -- current line together with the slice indexes (first and last
+ -- position) for this line. The rollback data are used by the
+ -- Store_File_Context and Rollback_File_Context routines below.
+ -- The file context mechanism interact only with the Get_Next_Line
+ -- call. For example:
+
+ -- Store_File_Context;
+ -- Get_Next_Line;
+ -- Rollback_File_Context;
+ -- Get_Next_Line;
+
+ -- Both Get_Next_Line calls above will read the exact same data from
+ -- the file. In other words, Next_Line, Nfirst and Nlast variables
+ -- will be set with the exact same values.
+
+ RB_File_Pos : long; -- File position
+ RB_Next_Line : String (1 .. 1000); -- Current line content
+ RB_Nlast : Integer; -- Slice last index
+ RB_Nfirst : Integer; -- Slice first index
+
Run_Path_Option_Ptr : Address;
pragma Import (C, Run_Path_Option_Ptr, "run_path_option");
-- Pointer to string representing the native linker option which
@@ -575,10 +667,28 @@ procedure Gnatlink is
-- Read the next line from the binder file without the line
-- terminator.
+ function Index (S, Pattern : String) return Natural;
+ -- Return the first occurrence of Pattern in S, or 0 if none.
+
function Is_Option_Present (Opt : in String) return Boolean;
-- Return true if the option Opt is already present in
-- Linker_Options table.
+ procedure Store_File_Context;
+ -- Store current file context, Fd position and current line data.
+ -- The file context is stored into the rollback data above (RB_*).
+ -- Store_File_Context can be called at any time, only the last call
+ -- will be used (i.e. this routine overwrites the file context).
+
+ procedure Rollback_File_Context;
+ -- Restore file context from rollback data. This routine must be called
+ -- after Store_File_Context. The binder file context will be restored
+ -- with the data stored by the last Store_File_Context call.
+
+ -------------------
+ -- Get_Next_Line --
+ -------------------
+
procedure Get_Next_Line is
Fchars : chars;
@@ -601,6 +711,26 @@ procedure Gnatlink is
Nlast := Nlast - 1;
end Get_Next_Line;
+ -----------
+ -- Index --
+ -----------
+
+ function Index (S, Pattern : String) return Natural is
+ Len : constant Natural := Pattern'Length;
+ begin
+ for J in S'First .. S'Last - Len + 1 loop
+ if Pattern = S (J .. J + Len - 1) then
+ return J;
+ end if;
+ end loop;
+
+ return 0;
+ end Index;
+
+ -----------------------
+ -- Is_Option_Present --
+ -----------------------
+
function Is_Option_Present (Opt : in String) return Boolean is
begin
for I in 1 .. Linker_Options.Last loop
@@ -614,6 +744,38 @@ procedure Gnatlink is
return False;
end Is_Option_Present;
+ ---------------------------
+ -- Rollback_File_Context --
+ ---------------------------
+
+ procedure Rollback_File_Context is
+ begin
+ Next_Line := RB_Next_Line;
+ Nfirst := RB_Nfirst;
+ Nlast := RB_Nlast;
+ Status := fseek (Fd, RB_File_Pos, Interfaces.C_Streams.SEEK_SET);
+
+ if Status = -1 then
+ Exit_With_Error ("Error setting file position");
+ end if;
+ end Rollback_File_Context;
+
+ ------------------------
+ -- Store_File_Context --
+ ------------------------
+
+ procedure Store_File_Context is
+ begin
+ RB_Next_Line := Next_Line;
+ RB_Nfirst := Nfirst;
+ RB_Nlast := Nlast;
+ RB_File_Pos := ftell (Fd);
+
+ if RB_File_Pos = -1 then
+ Exit_With_Error ("Error getting file position");
+ end if;
+ end Store_File_Context;
+
-- Start of processing for Process_Binder_File
begin
@@ -634,7 +796,7 @@ procedure Gnatlink is
Get_Next_Line;
-- Go to end when end line is reached (this will happen in
- -- No_Run_Time mode where no -L switches are generated)
+ -- High_Integrity_Mode where no -L switches are generated)
exit when Next_Line (Nfirst .. Nlast) = End_Info;
@@ -663,11 +825,26 @@ procedure Gnatlink is
Linker_Objects.Table (Linker_Objects.Last) :=
new String'(Next_Line (Nfirst .. Nlast));
- Link_Bytes := Link_Bytes + Nlast - Nfirst;
+ Link_Bytes := Link_Bytes + Nlast - Nfirst + 2;
+ -- Nlast - Nfirst + 1, for the size, plus one for the space between
+ -- each arguments.
end loop;
Objs_End := Linker_Objects.Last;
+ -- Let's continue to compute the Link_Bytes, the linker options are
+ -- part of command line length.
+
+ Store_File_Context;
+
+ while Next_Line (Nfirst .. Nlast) /= End_Info loop
+ Link_Bytes := Link_Bytes + Nlast - Nfirst + 2;
+ -- See comment above
+ Get_Next_Line;
+ end loop;
+
+ Rollback_File_Context;
+
-- On systems that have limitations on handling very long linker lines
-- we make use of the system linker option which takes a list of object
-- file names from a file instead of the command line itself. What we do
@@ -687,6 +864,10 @@ procedure Gnatlink is
Create_Temp_File (Tname_FD, Tname);
+ -- ??? File descriptor should be checked to not be Invalid_FD.
+ -- ??? Status of Write and Close operations should be checked, and
+ -- failure should occur if a status is wrong.
+
-- If target is using the GNU linker we must add a special header
-- and footer in the response file.
-- The syntax is : INPUT (object1.o object2.o ... )
@@ -723,7 +904,7 @@ procedure Gnatlink is
end;
end if;
- Close (Tname_FD);
+ Close (Tname_FD, Closing_Status);
-- Add the special objects list file option together with the name
-- of the temporary file (removing the null character) to the objects
@@ -738,12 +919,17 @@ procedure Gnatlink is
-- are removed by moving up the linker options and non-Ada object
-- files appearing after the Ada object list in the table.
- N := Objs_End - Objs_Begin + 1;
- for J in Objs_End + 1 .. Linker_Objects.Last loop
- Linker_Objects.Table (J - N + 1) := Linker_Objects.Table (J);
- end loop;
+ declare
+ N : Integer;
+ begin
+ N := Objs_End - Objs_Begin + 1;
- Linker_Objects.Set_Last (Linker_Objects.Last - N + 1);
+ for J in Objs_End + 1 .. Linker_Objects.Last loop
+ Linker_Objects.Table (J - N + 1) := Linker_Objects.Table (J);
+ end loop;
+
+ Linker_Objects.Set_Last (Linker_Objects.Last - N + 1);
+ end;
end if;
-- Process switches and options
@@ -759,7 +945,9 @@ procedure Gnatlink is
-- Add binder options only if not already set on the command
-- line. This rule is a way to control the linker options order.
- elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast)) then
+ elsif not Is_Option_Present (Next_Line (Nfirst .. Nlast))
+ or else Next_Line (Nfirst .. Nlast) = "-Xlinker"
+ then
if Nlast > Nfirst + 2 and then
Next_Line (Nfirst .. Nfirst + 1) = "-L"
then
@@ -792,9 +980,13 @@ procedure Gnatlink is
File_Path : String_Access;
Object_Lib_Extension : constant String :=
Value (Object_Library_Ext_Ptr);
-
- File_Name : String := "lib" &
- Next_Line (Nfirst + 2 .. Nlast) & Object_Lib_Extension;
+ File_Name : constant String := "lib" &
+ Next_Line (Nfirst + 2 .. Nlast) &
+ Object_Lib_Extension;
+ Run_Path_Opt : constant String :=
+ Value (Run_Path_Option_Ptr);
+ GCC_Index : Natural;
+ Run_Path_Opt_Index : Natural := 0;
begin
File_Path :=
@@ -814,36 +1006,105 @@ procedure Gnatlink is
new String'(File_Path.all);
elsif GNAT_Shared then
+ if Opt.Run_Path_Option then
+ -- If shared gnatlib desired, add the
+ -- appropriate system specific switch
+ -- so that it can be located at runtime.
- -- If shared gnatlib desired, add the
- -- appropriate system specific switch
- -- so that it can be located at runtime.
-
- declare
- Run_Path_Opt : constant String :=
- Value (Run_Path_Option_Ptr);
-
- begin
if Run_Path_Opt'Length /= 0 then
-
- -- Output the system specific linker
- -- command that allows the image
- -- activator to find the shared library
- -- at runtime.
-
- Linker_Options.Increment_Last;
-
- Linker_Options.Table (Linker_Options.Last)
- := new String'(Run_Path_Opt
- & File_Path
- (1 .. File_Path'Length
- - File_Name'Length));
+ -- Output the system specific linker command
+ -- that allows the image activator to find
+ -- the shared library at runtime.
+ -- Also add path to find libgcc_s.so, if
+ -- relevant.
+
+ GCC_Index := Index (File_Path.all, "gcc-lib");
+
+ -- Look for an eventual run_path_option in
+ -- the linker switches.
+
+ for J in reverse 1 .. Linker_Options.Last loop
+ if Linker_Options.Table (J) /= null
+ and then
+ Linker_Options.Table (J)'Length
+ > Run_Path_Opt'Length
+ and then
+ Linker_Options.Table (J)
+ (1 .. Run_Path_Opt'Length) =
+ Run_Path_Opt
+ then
+ -- We have found a already specified
+ -- run_path_option: we will add to this
+ -- switch, because only one
+ -- run_path_option should be specified.
+
+ Run_Path_Opt_Index := J;
+ exit;
+ end if;
+ end loop;
+
+ -- If there is no run_path_option, we need
+ -- to add one.
+
+ if Run_Path_Opt_Index = 0 then
+ Linker_Options.Increment_Last;
+ end if;
+
+ if GCC_Index = 0 then
+ if Run_Path_Opt_Index = 0 then
+ Linker_Options.Table
+ (Linker_Options.Last) :=
+ new String'
+ (Run_Path_Opt
+ & File_Path
+ (1 .. File_Path'Length
+ - File_Name'Length));
+
+ else
+ Linker_Options.Table
+ (Run_Path_Opt_Index) :=
+ new String'
+ (Linker_Options.Table
+ (Run_Path_Opt_Index).all
+ & Path_Separator
+ & File_Path
+ (1 .. File_Path'Length
+ - File_Name'Length));
+ end if;
+
+ else
+ if Run_Path_Opt_Index = 0 then
+ Linker_Options.Table
+ (Linker_Options.Last) :=
+ new String'(Run_Path_Opt
+ & File_Path
+ (1 .. File_Path'Length
+ - File_Name'Length)
+ & Path_Separator
+ & File_Path (1 .. GCC_Index - 1));
+
+ else
+ Linker_Options.Table
+ (Run_Path_Opt_Index) :=
+ new String'
+ (Linker_Options.Table
+ (Run_Path_Opt_Index).all
+ & Path_Separator
+ & File_Path
+ (1 .. File_Path'Length
+ - File_Name'Length)
+ & Path_Separator
+ & File_Path (1 .. GCC_Index - 1));
+ end if;
+ end if;
end if;
+ end if;
+
+ -- Then we add the appropriate -l switch
- Linker_Options.Increment_Last;
- Linker_Options.Table (Linker_Options.Last)
- := new String'(Next_Line (Nfirst .. Nlast));
- end;
+ Linker_Options.Increment_Last;
+ Linker_Options.Table (Linker_Options.Last) :=
+ new String'(Next_Line (Nfirst .. Nlast));
end if;
else
@@ -852,14 +1113,14 @@ procedure Gnatlink is
-- mechanimsm may find it.
Linker_Options.Increment_Last;
- Linker_Options.Table (Linker_Options.Last)
- := new String'(Next_Line (Nfirst .. Nlast));
+ Linker_Options.Table (Linker_Options.Last) :=
+ new String'(Next_Line (Nfirst .. Nlast));
end if;
end;
else
Linker_Options.Increment_Last;
- Linker_Options.Table (Linker_Options.Last)
- := new String'(Next_Line (Nfirst .. Nlast));
+ Linker_Options.Table (Linker_Options.Last) :=
+ new String'(Next_Line (Nfirst .. Nlast));
end if;
end if;
@@ -867,8 +1128,8 @@ procedure Gnatlink is
exit when Next_Line (Nfirst .. Nlast) = End_Info;
if Ada_Bind_File then
- Next_Line (Nfirst .. Nlast - 8)
- := Next_Line (Nfirst + 8 .. Nlast);
+ Next_Line (Nfirst .. Nlast - 8) :=
+ Next_Line (Nfirst + 8 .. Nlast);
Nlast := Nlast - 8;
end if;
end loop;
@@ -902,12 +1163,29 @@ procedure Gnatlink is
end if;
end Value;
+ ------------------
+ -- Write_Header --
+ ------------------
+
+ procedure Write_Header is
+ begin
+ if Verbose_Mode then
+ Write_Eol;
+ Write_Str ("GNATLINK ");
+ Write_Str (Gnat_Version_String);
+ Write_Str (" Copyright 1995-2003 Free Software Foundation, Inc");
+ Write_Eol;
+ end if;
+ end Write_Header;
+
-----------------
-- Write_Usage --
-----------------
procedure Write_Usage is
begin
+ Write_Header;
+
Write_Str ("Usage: ");
Write_Str (Base_Name (Command_Name));
Write_Str (" switches mainprog.ali [non-Ada-objects] [linker-options]");
@@ -920,6 +1198,7 @@ procedure Gnatlink is
Write_Line (" -f force object file list to be generated");
Write_Line (" -g Compile binder source file with debug information");
Write_Line (" -n Do not compile the binder source file");
+ Write_Line (" -R Do not use a run_path_option");
Write_Line (" -v verbose mode");
Write_Line (" -v -v very verbose mode");
Write_Eol;
@@ -936,7 +1215,12 @@ procedure Gnatlink is
-- Start of processing for Gnatlink
begin
- if Argument_Count = 0 then
+ Process_Args;
+
+ if Argument_Count = 0
+ or else
+ (Verbose_Mode and then Argument_Count = 1)
+ then
Write_Usage;
Exit_Program (E_Fatal);
end if;
@@ -944,12 +1228,10 @@ begin
if Hostparm.Java_VM then
Gcc := new String'("jgnat");
Ada_Bind_File := True;
- Begin_Info := "-- BEGIN Object file/option list";
- End_Info := "-- END Object file/option list ";
+ Begin_Info := "-- BEGIN Object file/option list";
+ End_Info := "-- END Object file/option list ";
end if;
- Process_Args;
-
-- We always compile with -c
Binder_Options_From_ALI.Increment_Last;
@@ -993,21 +1275,18 @@ begin
end if;
if Ali_File_Name = null then
- Exit_With_Error ("Required 'name'.ali not present.");
+ Exit_With_Error ("no ali file given for link");
end if;
if not Is_Regular_File (Ali_File_Name.all) then
- Exit_With_Error (Ali_File_Name.all & " not found.");
+ Exit_With_Error (Ali_File_Name.all & " not found");
-- Read the ALI file of the main subprogram if the binder generated
- -- file is in Ada, it need to be compiled and no --GCC= switch has
- -- been specified. Fetch the back end switches from this ALI file and use
- -- these switches to compile the binder generated file
+ -- file needs to be compiled and no --GCC= switch has been specified.
+ -- Fetch the back end switches from this ALI file and use these switches
+ -- to compile the binder generated file
- elsif Ada_Bind_File
- and then Compile_Bind_File
- and then Standard_Gcc
- then
+ elsif Compile_Bind_File and then Standard_Gcc then
-- Do some initializations
Initialize_ALI;
@@ -1029,35 +1308,34 @@ begin
-- Read it
- A := Scan_ALI (F, T, False, False, False);
+ A := Scan_ALI (F, T, Ignore_ED => False, Err => False);
if A /= No_ALI_Id then
for
- Index in Units.Table (ALIs.Table (A).First_Unit).First_Arg
- .. Units.Table (ALIs.Table (A).First_Unit).Last_Arg
+ Index in Units.Table (ALIs.Table (A).First_Unit).First_Arg ..
+ Units.Table (ALIs.Table (A).First_Unit).Last_Arg
loop
- -- Do not compile with the front end switches
-
- if not Is_Front_End_Switch (Args.Table (Index).all) then
- Binder_Options_From_ALI.Increment_Last;
- Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last)
- := String_Access (Args.Table (Index));
- end if;
+ -- Do not compile with the front end switches except for --RTS
+
+ declare
+ Arg : String_Ptr renames Args.Table (Index);
+ begin
+ if not Is_Front_End_Switch (Arg.all)
+ or else Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
+ then
+ Binder_Options_From_ALI.Increment_Last;
+ Binder_Options_From_ALI.Table
+ (Binder_Options_From_ALI.Last) := String_Access (Arg);
+ end if;
+ end;
end loop;
end if;
end;
end if;
- if Verbose_Mode then
- Write_Eol;
- Write_Str ("GNATLINK ");
- Write_Str (Gnat_Version_String);
- Write_Str (" Copyright 1996-2002 Free Software Foundation, Inc.");
- Write_Eol;
- end if;
+ Write_Header;
- -- If there wasn't an output specified, then use the base name of
- -- the .ali file name.
+ -- If no output name specified, then use the base name of .ali file name
if Output_File_Name = null then
@@ -1094,14 +1372,15 @@ begin
-- Transform the .ali file name into the binder output file name.
Make_Binder_File_Names : declare
- Fname : String := Base_Name (Ali_File_Name.all);
+ Fname : constant String := Base_Name (Ali_File_Name.all);
Fname_Len : Integer := Fname'Length;
function Get_Maximum_File_Name_Length return Integer;
pragma Import (C, Get_Maximum_File_Name_Length,
"__gnat_get_maximum_file_name_length");
- Maximum_File_Name_Length : Integer := Get_Maximum_File_Name_Length;
+ Maximum_File_Name_Length : constant Integer :=
+ Get_Maximum_File_Name_Length;
Second_Char : Character;
-- Second character of name of files
@@ -1239,62 +1518,74 @@ begin
-- the stack size for tasking programs by a pragma in the NT
-- specific tasking package System.Task_Primitives.Oparations.
- for J in Linker_Options.First .. Linker_Options.Last loop
- if Linker_Options.Table (J).all = "-Xlinker"
- and then J < Linker_Options.Last
- and then Linker_Options.Table (J + 1)'Length > 8
- and then Linker_Options.Table (J + 1) (1 .. 8) = "--stack="
- then
- if Stack_Op then
- Linker_Options.Table (J .. Linker_Options.Last - 2) :=
- Linker_Options.Table (J + 2 .. Linker_Options.Last);
- Linker_Options.Decrement_Last;
- Linker_Options.Decrement_Last;
- Num_Args := Num_Args - 2;
+ -- Note: This is not a FOR loop that runs from Linker_Options.First
+ -- to Linker_Options.Last, since operations within the loop can
+ -- modify the length of the table.
- else
- Stack_Op := True;
+ Clean_Link_Option_Set : declare
+ J : Natural := Linker_Options.First;
+
+ begin
+ while J <= Linker_Options.Last loop
+
+ if Linker_Options.Table (J).all = "-Xlinker"
+ and then J < Linker_Options.Last
+ and then Linker_Options.Table (J + 1)'Length > 8
+ and then Linker_Options.Table (J + 1) (1 .. 8) = "--stack="
+ then
+ if Stack_Op then
+ Linker_Options.Table (J .. Linker_Options.Last - 2) :=
+ Linker_Options.Table (J + 2 .. Linker_Options.Last);
+ Linker_Options.Decrement_Last;
+ Linker_Options.Decrement_Last;
+ Num_Args := Num_Args - 2;
+
+ else
+ Stack_Op := True;
+ end if;
end if;
- end if;
- -- Here we just check for a canonical form that matches the
- -- pragma Linker_Options set in the NT runtime.
+ -- Here we just check for a canonical form that matches the
+ -- pragma Linker_Options set in the NT runtime.
- if (Linker_Options.Table (J)'Length > 17
- and then Linker_Options.Table (J) (1 .. 17)
- = "-Xlinker --stack=")
- or else
- (Linker_Options.Table (J)'Length > 12
- and then Linker_Options.Table (J) (1 .. 12)
- = "-Wl,--stack=")
- then
- if Stack_Op then
- Linker_Options.Table (J .. Linker_Options.Last - 1) :=
- Linker_Options.Table (J + 1 .. Linker_Options.Last);
- Linker_Options.Decrement_Last;
- Num_Args := Num_Args - 1;
+ if (Linker_Options.Table (J)'Length > 17
+ and then Linker_Options.Table (J) (1 .. 17)
+ = "-Xlinker --stack=")
+ or else
+ (Linker_Options.Table (J)'Length > 12
+ and then Linker_Options.Table (J) (1 .. 12)
+ = "-Wl,--stack=")
+ then
+ if Stack_Op then
+ Linker_Options.Table (J .. Linker_Options.Last - 1) :=
+ Linker_Options.Table (J + 1 .. Linker_Options.Last);
+ Linker_Options.Decrement_Last;
+ Num_Args := Num_Args - 1;
- else
- Stack_Op := True;
+ else
+ Stack_Op := True;
+ end if;
end if;
- end if;
- -- Remove duplicate IDENTIFICATION directives (VMS)
+ -- Remove duplicate IDENTIFICATION directives (VMS)
- if Linker_Options.Table (J)'Length > 27
- and then Linker_Options.Table (J) (1 .. 27)
- = "--for-linker=IDENTIFICATION="
- then
- if IDENT_Op then
- Linker_Options.Table (J .. Linker_Options.Last - 1) :=
- Linker_Options.Table (J + 1 .. Linker_Options.Last);
- Linker_Options.Decrement_Last;
- Num_Args := Num_Args - 1;
- else
- IDENT_Op := True;
+ if Linker_Options.Table (J)'Length > 27
+ and then Linker_Options.Table (J) (1 .. 27)
+ = "--for-linker=IDENTIFICATION="
+ then
+ if IDENT_Op then
+ Linker_Options.Table (J .. Linker_Options.Last - 1) :=
+ Linker_Options.Table (J + 1 .. Linker_Options.Last);
+ Linker_Options.Decrement_Last;
+ Num_Args := Num_Args - 1;
+ else
+ IDENT_Op := True;
+ end if;
end if;
- end if;
- end loop;
+
+ J := J + 1;
+ end loop;
+ end Clean_Link_Option_Set;
-- Prepare arguments for call to linker
@@ -1401,5 +1692,5 @@ begin
exception
when X : others =>
Write_Line (Exception_Information (X));
- Exit_With_Error ("INTERNAL ERROR. Please report.");
+ Exit_With_Error ("INTERNAL ERROR. Please report");
end Gnatlink;
diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb
index 81a6c4c7340..559f9acc06e 100644
--- a/gcc/ada/gnatls.adb
+++ b/gcc/ada/gnatls.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- --
@@ -28,6 +28,7 @@ with ALI; use ALI;
with ALI.Util; use ALI.Util;
with Binderr; use Binderr;
with Butil; use Butil;
+with Csets; use Csets;
with Fname; use Fname;
with Gnatvsn; use Gnatvsn;
with GNAT.OS_Lib; use GNAT.OS_Lib;
@@ -40,7 +41,6 @@ with Targparm; use Targparm;
with Types; use Types;
procedure Gnatls is
-
Max_Column : constant := 80;
type File_Status is (
@@ -103,6 +103,9 @@ procedure Gnatls is
Spaces : constant String (1 .. Max_Column) := (others => ' ');
+ RTS_Specified : String_Access := null;
+ -- Used to detect multiple use of --RTS= switch
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -640,26 +643,32 @@ procedure Gnatls is
-- Processing for --RTS=path
- elsif Argv (1 .. 5) = "--RTS" then
-
- if Argv (6) /= '=' or else
- (Argv (6) = '='
- and then Argv'Length = 6)
- then
+ elsif Argv'Length >= 5 and then Argv (1 .. 5) = "--RTS" then
+ if Argv'Length <= 6 or else Argv (6) /= '='then
Osint.Fail ("missing path for --RTS");
else
+ -- Check that it is the first time we see this switch or, if
+ -- it is not the first time, the same path is specified.
+
+ if RTS_Specified = null then
+ RTS_Specified := new String'(Argv (7 .. Argv'Last));
+
+ elsif RTS_Specified.all /= Argv (7 .. Argv'Last) then
+ Osint.Fail ("--RTS cannot be specified multiple times");
+ end if;
+
-- Valid --RTS switch
Opt.No_Stdinc := True;
Opt.RTS_Switch := True;
declare
- Src_Path_Name : String_Ptr :=
+ Src_Path_Name : constant String_Ptr :=
String_Ptr
(Get_RTS_Search_Dir
(Argv (7 .. Argv'Last), Include));
- Lib_Path_Name : String_Ptr :=
+ Lib_Path_Name : constant String_Ptr :=
String_Ptr
(Get_RTS_Search_Dir
(Argv (7 .. Argv'Last), Objects));
@@ -806,6 +815,10 @@ procedure Gnatls is
-- Start of processing for Gnatls
begin
+ -- Initialize standard packages
+
+ Namet.Initialize;
+ Csets.Initialize;
-- Use low level argument routines to avoid dragging in the secondary stack
@@ -841,7 +854,6 @@ begin
Osint.Add_Default_Search_Dirs;
if Verbose_Mode then
- Namet.Initialize;
Targparm.Get_Target_Parameters;
-- WARNING: the output of gnatls -v is used during the compilation
@@ -851,13 +863,8 @@ begin
Write_Eol;
Write_Str ("GNATLS ");
-
- if Targparm.High_Integrity_Mode_On_Target then
- Write_Str ("Pro High Integrity ");
- end if;
-
Write_Str (Gnat_Version_String);
- Write_Str (" Copyright 1997-2002 Free Software Foundation, Inc.");
+ Write_Str (" Copyright 1997-2003 Free Software Foundation, Inc.");
Write_Eol;
Write_Eol;
Write_Str ("Source Search Path:");
@@ -911,7 +918,6 @@ begin
Exit_Program (E_Fatal);
end if;
- Namet.Initialize;
Initialize_ALI;
Initialize_ALI_Source;
@@ -923,7 +929,7 @@ begin
if Ali_File = No_File then
Write_Str ("Can't find library info for ");
- Get_Decoded_Name_String (Main_File);
+ Get_Name_String (Main_File);
Write_Char ('"');
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Char ('"');
@@ -973,7 +979,7 @@ begin
Output_Unit (U);
-- Output source now, unless if it will be done as part of
- -- outputting dependencies.
+ -- outputing dependencies.
if not (Dependable and then Print_Source) then
Output_Source (Corresponding_Sdep_Entry (Id, U));
diff --git a/gcc/ada/gnatmake.adb b/gcc/ada/gnatmake.adb
index 34f51594f50..2f8adc1b524 100644
--- a/gcc/ada/gnatmake.adb
+++ b/gcc/ada/gnatmake.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1997 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- --
diff --git a/gcc/ada/gnatmem.adb b/gcc/ada/gnatmem.adb
index 624bf90f3bf..a852b26f8bc 100644
--- a/gcc/ada/gnatmem.adb
+++ b/gcc/ada/gnatmem.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2002, Ada Core Technologies, Inc. --
+-- Copyright (C) 1997-2003, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,40 +26,41 @@
-- GNATMEM is a utility that tracks memory leaks. It is based on a simple
-- idea:
--- - run the application under gdb
--- - set a breakpoint on __gnat_malloc and __gnat_free
--- - record a reference to the allocated memory on each allocation call
--- - suppress this reference on deallocation
--- - at the end of the program, remaining references are potential leaks.
+
+-- - Read the allocation log generated by the application linked using
+-- instrumented memory allocation and dealocation (see memtrack.adb for
+-- this circuitry). To get access to this functionality, the application
+-- must be relinked with library libgmem.a:
+
+-- $ gnatmake my_prog -largs -lgmem
+
+-- The running my_prog will produce a file named gmem.out that will be
+-- parsed by gnatmem.
+
+-- - Record a reference to the allocated memory on each allocation call.
+
+-- - Suppress this reference on deallocation.
+
+-- - At the end of the program, remaining references are potential leaks.
-- sort them out the best possible way in order to locate the root of
-- the leak.
---
--- GNATMEM can also be used with instrumented allocation/deallocation
--- routine (see a-raise.c with symbol GMEM defined). This is not supported
--- in all platforms, again refer to a-raise.c for further information.
--- In this case the application must be relinked with library libgmem.a:
---
--- $ gnatmake my_prog -largs -lgmem
---
--- The running my_prog will produce a file named gmem.out that will be
--- parsed by gnatmem.
---
+
+-- This capability is not supported on all platforms, please refer to
+-- memtrack.adb for further information.
+
-- In order to help finding out the real leaks, the notion of "allocation
-- root" is defined. An allocation root is a specific point in the program
-- execution generating memory allocation where data is collected (such as
--- number of allocations, quantify of memory allocated, high water mark,
--- etc.).
+-- number of allocations, amount of memory allocated, high water mark, etc.)
-with Ada.Command_Line; use Ada.Command_Line;
+with GNAT.Command_Line; use GNAT.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
-with Ada.Text_IO.C_Streams;
with Ada.Float_Text_IO;
with Ada.Integer_Text_IO;
with Gnatvsn; use Gnatvsn;
with GNAT.Heap_Sort_G;
-with GNAT.OS_Lib;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.HTable; use GNAT.HTable;
-with Interfaces.C_Streams; use Interfaces.C_Streams;
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;
@@ -67,61 +68,32 @@ with Memroot; use Memroot;
procedure Gnatmem is
- ------------------------------------------------
- -- Potentially Target Dependent Subprograms. --
- ------------------------------------------------
-
- function Get_Current_TTY return String;
- -- Give the current tty on which the program is run. This is needed to
- -- separate the output of the debugger from the output of the program.
- -- The output of this function will be used to call the gdb command "tty"
- -- in the gdb script in order to get the program output on the current tty
- -- while the gdb output is redirected and processed by gnatmem.
-
- function popen (File, Mode : System.Address) return FILEs;
- pragma Import (C, popen, "popen");
- -- Execute the program 'File'. If the mode is "r" the standard output
- -- of the program is redirected and the FILEs handler of the
- -- redirection is returned.
-
- procedure System_Cmd (X : System.Address);
- pragma Import (C, System_Cmd, "system");
- -- Execute the program "X".
-
- subtype Cstring is String (1 .. Integer'Last);
- type Cstring_Ptr is access all Cstring;
-
- function ttyname (Dec : Integer) return Cstring_Ptr;
- pragma Import (C, ttyname, "__gnat_ttyname");
- -- Return a null-terminated string containing the current tty
-
- Dir_Sep : constant Character := '/';
-
------------------------
-- Other Declarations --
------------------------
- type Gdb_Output_Elmt is (Eof, Alloc, Deall);
- -- Eof = End of gdb output file
- -- Alloc = found a ALLOC mark in the gdb output
- -- Deall = found a DEALL mark in the gdb output
- Gdb_Output_Format_Error : exception;
+ type Storage_Elmt is record
+ Elmt : Character;
+ -- * = End of log file
+ -- A = found a ALLOC mark in the log
+ -- D = found a DEALL mark in the log
+ Address : Integer_Address;
+ Size : Storage_Count;
+ end record;
+ -- This needs a comment ???
- function Read_Next return Gdb_Output_Elmt;
- -- Read the output of the debugger till it finds either the end of the
- -- output, or the 'ALLOC' mark or the 'DEALL' mark. In the second case,
- -- it sets the Tmp_Size and Tmp_Address global variables, in the
- -- third case it sets the Tmp_Address variable.
+ Log_Name, Program_Name : String_Access;
+ -- These need comments, and should be on separate lines ???
- procedure Create_Gdb_Script;
- -- Create the GDB script and save it in a temporary file
+ function Read_Next return Storage_Elmt;
+ -- Reads next dynamic storage operation from the log file.
function Mem_Image (X : Storage_Count) return String;
-- X is a size in storage_element. Returns a value
- -- in Megabytes, Kiloytes or Bytes as appropriate.
+ -- in Megabytes, Kilobytes or Bytes as appropriate.
procedure Process_Arguments;
- -- Read command line arguments;
+ -- Read command line arguments
procedure Usage;
-- Prints out the option help
@@ -135,19 +107,6 @@ procedure Gnatmem is
-- Initialises the convert_addresses interface by supplying it with
-- the name of the executable file Exename
- procedure Gmem_Read_Next (Buf : out String; Last : out Natural);
- -- Reads the next allocation/deallocation entry and its backtrace
- -- and prepares in the string Buf (up to the position of Last) the
- -- expression compatible with gnatmem parser:
- -- Allocation entry produces the expression "ALLOC^[size]^0x[address]^"
- -- Deallocation entry produces the expression "DEALLOC^0x[address]^"
-
- Argc : constant Integer := Argument_Count;
- Gnatmem_Tmp : aliased constant String := "gnatmem.tmp";
-
- Mode_R : aliased constant String (1 .. 2) := 'r' & ASCII.NUL;
- Mode_W : aliased constant String (1 .. 3) := "w+" & ASCII.NUL;
-
-----------------------------------
-- HTable address --> Allocation --
-----------------------------------
@@ -170,12 +129,8 @@ procedure Gnatmem is
Equal => "=");
BT_Depth : Integer := 1;
- FD : FILEs;
- FT : File_Type;
- File_Pos : Integer := 0;
- Exec_Pos : Integer := 0;
- Target_Pos : Integer := 0;
- Run_Gdb : Boolean := True;
+
+ -- The following need comments ???
Global_Alloc_Size : Storage_Count := 0;
Global_High_Water_Mark : Storage_Count := 0;
@@ -183,17 +138,21 @@ procedure Gnatmem is
Global_Nb_Dealloc : Integer := 0;
Nb_Root : Integer := 0;
Nb_Wrong_Deall : Integer := 0;
- Target_Name : String (1 .. 80);
- Target_Protocol : String (1 .. 80);
- Target_Name_Len : Integer;
- Target_Protocol_Len : Integer;
- Cross_Case : Boolean := False;
-
- Tmp_Size : Storage_Count := 0;
- Tmp_Address : Integer_Address;
+ Minimum_NB_Leaks : Integer := 1;
+
Tmp_Alloc : Allocation;
Quiet_Mode : Boolean := False;
+ -------------------------------
+ -- Allocation roots sorting --
+ -------------------------------
+
+ Sort_Order : String (1 .. 3) := "nwh";
+ -- This is the default order in which sorting criteria will be applied
+ -- n - Total number of unfreed allocations
+ -- w - Final watermark
+ -- h - High watermark
+
--------------------------------
-- GMEM functionality binding --
--------------------------------
@@ -201,7 +160,9 @@ procedure Gnatmem is
function Gmem_Initialize (Dumpname : String) return Boolean is
function Initialize (Dumpname : System.Address) return Boolean;
pragma Import (C, Initialize, "__gnat_gmem_initialize");
+
S : aliased String := Dumpname & ASCII.NUL;
+
begin
return Initialize (S'Address);
end Gmem_Initialize;
@@ -209,51 +170,23 @@ procedure Gnatmem is
procedure Gmem_A2l_Initialize (Exename : String) is
procedure A2l_Initialize (Exename : System.Address);
pragma Import (C, A2l_Initialize, "__gnat_gmem_a2l_initialize");
+
S : aliased String := Exename & ASCII.NUL;
+
begin
A2l_Initialize (S'Address);
end Gmem_A2l_Initialize;
- procedure Gmem_Read_Next (Buf : out String; Last : out Natural) is
+ function Read_Next return Storage_Elmt is
procedure Read_Next (buf : System.Address);
pragma Import (C, Read_Next, "__gnat_gmem_read_next");
- function Strlen (str : System.Address) return Natural;
- pragma Import (C, Strlen, "strlen");
-
- S : String (1 .. 1000);
- begin
- Read_Next (S'Address);
- Last := Strlen (S'Address);
- Buf (1 .. Last) := S (1 .. Last);
- end Gmem_Read_Next;
-
- ---------------------
- -- Get_Current_TTY --
- ---------------------
- function Get_Current_TTY return String is
- Res : Cstring_Ptr;
- stdout : constant Integer := 1;
- Max_TTY_Name : constant Integer := 500;
+ S : Storage_Elmt;
begin
- if isatty (stdout) /= 1 then
- return "";
- end if;
-
- Res := ttyname (1);
- if Res /= null then
- for J in Cstring'First .. Max_TTY_Name loop
- if Res (J) = ASCII.NUL then
- return Res (Cstring'First .. J - 1);
- end if;
- end loop;
- end if;
-
- -- if we fall thru the ttyname result was dubious. Just forget it.
-
- return "";
- end Get_Current_TTY;
+ Read_Next (S'Address);
+ return S;
+ end Read_Next;
-------
-- H --
@@ -264,141 +197,6 @@ procedure Gnatmem is
return Address_Range (A mod Integer_Address (Address_Range'Last));
end H;
- -----------------------
- -- Create_Gdb_Script --
- -----------------------
-
- procedure Create_Gdb_Script is
- FD : File_Type;
-
- begin
- begin
- Create (FD, Out_File, Gnatmem_Tmp);
- exception
- when others =>
- Put_Line ("Cannot create temporary file : " & Gnatmem_Tmp);
- GNAT.OS_Lib.OS_Exit (1);
- end;
-
- declare
- TTY : constant String := Get_Current_TTY;
- begin
- if TTY'Length > 0 then
- Put_Line (FD, "tty " & TTY);
- end if;
- end;
-
- if Cross_Case then
- Put (FD, "target ");
- Put (FD, Target_Protocol (1 .. Target_Protocol_Len));
- Put (FD, " ");
- Put (FD, Argument (Target_Pos));
- New_Line (FD);
- Put (FD, "load ");
- Put_Line (FD, Argument (Exec_Pos));
-
- else
- -- In the native case, run the program before setting the
- -- breakpoints so that gnatmem will also work with shared
- -- libraries.
-
- Put_Line (FD, "set lang c");
- Put_Line (FD, "break main");
- Put_Line (FD, "set lang auto");
- Put (FD, "run");
- for J in Exec_Pos + 1 .. Argc loop
- Put (FD, " ");
- Put (FD, Argument (J));
- end loop;
- New_Line (FD);
-
- -- At this point, gdb knows about __gnat_malloc and __gnat_free
- end if;
-
- -- Make sure that outputting long backtraces do not pause
-
- Put_Line (FD, "set height 0");
- Put_Line (FD, "set width 0");
-
- if Quiet_Mode then
- Put_Line (FD, "break __gnat_malloc");
- Put_Line (FD, "command");
- Put_Line (FD, " silent");
- Put_Line (FD, " set lang c");
- Put_Line (FD, " set print address on");
- Put_Line (FD, " up");
- Put_Line (FD, " set $gm_addr = $pc");
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " printf ""ALLOC^0x%x^\n"", $gm_addr");
- Put_Line (FD, " set print address off");
- Put_Line (FD, " set lang auto");
- else
- Put_Line (FD, "break __gnat_malloc");
- Put_Line (FD, "command");
- Put_Line (FD, " silent");
- Put_Line (FD, " set lang c");
- Put_Line (FD, " set $gm_size = size");
- Put_Line (FD, " set print address on");
- Put_Line (FD, " up");
- Put_Line (FD, " set $gm_addr = $pc");
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " printf ""ALLOC^%d^0x%x^\n"", $gm_size, $gm_addr");
- Put_Line (FD, " set print address off");
- Put_Line (FD, " set lang auto");
- end if;
-
- Put (FD, " backtrace");
-
- if BT_Depth /= 0 then
- Put (FD, Integer'Image (BT_Depth + 1));
- end if;
-
- New_Line (FD);
-
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " continue");
- Put_Line (FD, "end");
- Put_Line (FD, "#");
- Put_Line (FD, "#");
- Put_Line (FD, "break __gnat_free");
- Put_Line (FD, "command");
- Put_Line (FD, " silent");
- Put_Line (FD, " set print address on");
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " printf ""DEALL^0x%x^\n"", ptr");
- Put_Line (FD, " set print address off");
- Put_Line (FD, " up");
-
- Put (FD, " backtrace");
-
- if BT_Depth /= 0 then
- Put (FD, Integer'Image (BT_Depth + 1));
- end if;
-
- New_Line (FD);
-
- Put_Line (FD, " printf ""\n\n""");
- Put_Line (FD, " continue");
- Put_Line (FD, "end");
- Put_Line (FD, "#");
- Put_Line (FD, "#");
- Put_Line (FD, "#");
-
- if Cross_Case then
- Put (FD, "run ");
- Put_Line (FD, Argument (Exec_Pos));
-
- if Target_Protocol (1 .. Target_Protocol_Len) = "wtx" then
- Put (FD, "unload ");
- Put_Line (FD, Argument (Exec_Pos));
- end if;
- else
- Put_Line (FD, "continue");
- end if;
-
- Close (FD);
- end Create_Gdb_Script;
-
---------------
-- Mem_Image --
---------------
@@ -419,7 +217,7 @@ procedure Gnatmem is
else
Ada.Integer_Text_IO.Put (Buff (1 .. 4), Integer (X));
- return Buff (1 .. 4) & " Bytes";
+ return Buff (1 .. 4) & " Bytes";
end if;
end Mem_Image;
@@ -430,36 +228,26 @@ procedure Gnatmem is
procedure Usage is
begin
New_Line;
- Put ("GNATMEM ");
+ Put ("GNATMEM Pro ");
Put (Gnat_Version_String);
- Put_Line (" Copyright 1997-2002 Free Software Foundation, Inc.");
+ Put_Line (" Copyright 1997-2003 Free Software Foundation, Inc.");
New_Line;
- if Cross_Case then
- Put_Line (Command_Name
- & " [-q] [n] [-o file] target entry_point ...");
- Put_Line (Command_Name & " [-q] [n] [-i file]");
-
- else
- Put_Line ("GDB mode");
- Put_Line (" " & Command_Name
- & " [-q] [n] [-o file] program arg1 arg2 ...");
- Put_Line (" " & Command_Name
- & " [-q] [n] [-i file]");
- New_Line;
- Put_Line ("GMEM mode");
- Put_Line (" " & Command_Name
- & " [-q] [n] -i gmem.out program arg1 arg2 ...");
- New_Line;
- end if;
-
+ Put_Line ("Usage: gnatmem switches [depth] exename");
+ New_Line;
+ Put_Line (" depth backtrace depth to take into account, default is"
+ & Integer'Image (BT_Depth));
+ Put_Line (" exename the name of the executable to be analyzed");
+ New_Line;
+ Put_Line ("Switches:");
+ Put_Line (" -b n same as depth parameter");
+ Put_Line (" -i file read the allocation log from specific file");
+ Put_Line (" default is gmem.out in the current directory");
+ Put_Line (" -m n masks roots with less than n leaks, default is 1");
+ Put_Line (" specify 0 to see even released allocation roots");
Put_Line (" -q quiet, minimum output");
- Put_Line (" n number of frames for allocation root backtraces");
- Put_Line (" default is 1.");
- Put_Line (" -o file save gdb output in 'file' and process data");
- Put_Line (" post mortem. also keep the gdb script around");
- Put_Line (" -i file don't run gdb output. Do only post mortem");
- Put_Line (" processing from file");
+ Put_Line (" -s order sort allocation roots according to an order of");
+ Put_Line (" sort criteria");
GNAT.OS_Lib.OS_Exit (1);
end Usage;
@@ -468,365 +256,182 @@ procedure Gnatmem is
-----------------------
procedure Process_Arguments is
- Arg : Integer;
-
- procedure Check_File (Arg_Pos : Integer; For_Creat : Boolean := False);
- -- Check that Argument (Arg_Pos) is an existing file if For_Creat is
- -- false or if it is possible to create it if For_Creat is true
-
- procedure Check_File (Arg_Pos : Integer; For_Creat : Boolean := False) is
- Name : aliased constant String := Argument (Arg_Pos) & ASCII.NUL;
- X : int;
-
- begin
- if For_Creat then
- FD := fopen (Name'Address, Mode_W'Address);
- else
- FD := fopen (Name'Address, Mode_R'Address);
- end if;
-
- if FD = NULL_Stream then
- New_Line;
- if For_Creat then
- Put_Line ("Cannot create file : " & Argument (Arg_Pos));
- else
- Put_Line ("Cannot locate file : " & Argument (Arg_Pos));
- end if;
- New_Line;
- Usage;
- else
- X := fclose (FD);
- end if;
- end Check_File;
-
- -- Start of processing for Process_Arguments
-
begin
+ -- Parse the options first
- -- Is it a cross version?
-
- declare
- Std_Name : constant String := "gnatmem";
- Name : constant String := Command_Name;
- End_Pref : constant Integer := Name'Last - Std_Name'Length;
-
- begin
- if Name'Length > Std_Name'Length + 9
- and then
- Name (End_Pref + 1 .. Name'Last) = Std_Name
- and then
- Name (End_Pref - 8 .. End_Pref) = "-vxworks-"
- then
- Cross_Case := True;
-
- Target_Name_Len := End_Pref - 1;
- for J in reverse Name'First .. End_Pref - 1 loop
- if Name (J) = Dir_Sep then
- Target_Name_Len := Target_Name_Len - J;
- exit;
- end if;
- end loop;
-
- Target_Name (1 .. Target_Name_Len)
- := Name (End_Pref - Target_Name_Len .. End_Pref - 1);
-
- if Target_Name (1 .. 5) = "alpha" then
- Target_Protocol (1 .. 7) := "vxworks";
- Target_Protocol_Len := 7;
- else
- Target_Protocol (1 .. 3) := "wtx";
- Target_Protocol_Len := 3;
- end if;
- end if;
- end;
-
- Arg := 1;
-
- if Argc < Arg then
- Usage;
- end if;
-
- -- Deal with "-q"
-
- if Argument (Arg) = "-q" then
-
- Quiet_Mode := True;
- Arg := Arg + 1;
-
- if Argc < Arg then
- Usage;
- end if;
- end if;
-
- -- Deal with back trace depth
-
- if Argument (Arg) (1) in '0' .. '9' then
- begin
- BT_Depth := Integer'Value (Argument (Arg));
- exception
- when others =>
- Usage;
- end;
-
- Arg := Arg + 1;
-
- if Argc < Arg then
- Usage;
- end if;
- end if;
+ loop
+ case Getopt ("b: m: i: q s:") is
+ when ASCII.Nul => exit;
- -- Deal with "-o file" or "-i file"
+ when 'b' =>
+ begin
+ BT_Depth := Natural'Value (Parameter);
+ exception
+ when Constraint_Error =>
+ Usage;
+ end;
- while Arg <= Argc and then Argument (Arg) (1) = '-' loop
- Arg := Arg + 1;
+ when 'm' =>
+ begin
+ Minimum_NB_Leaks := Natural'Value (Parameter);
+ exception
+ when Constraint_Error =>
+ Usage;
+ end;
- if Argc < Arg then
- Usage;
- end if;
+ when 'i' =>
+ Log_Name := new String'(Parameter);
- case Argument (Arg - 1) (2) is
- when 'o' =>
- Check_File (Arg, For_Creat => True);
- File_Pos := Arg;
+ when 'q' =>
+ Quiet_Mode := True;
- when 'i' =>
- Check_File (Arg);
- File_Pos := Arg;
- Run_Gdb := False;
- if Gmem_Initialize (Argument (Arg)) then
- Gmem_Mode := True;
- end if;
+ when 's' =>
+ declare
+ S : String (Sort_Order'Range) := Parameter;
+ begin
+ for J in Sort_Order'Range loop
+ if S (J) = 'n' or else S (J) = 'w'
+ or else S (J) = 'h' then
+ Sort_Order (J) := S (J);
+ else
+ raise Constraint_Error;
+ end if;
+ end loop;
+ exception
+ when Constraint_Error =>
+ Put_Line ("Invalid sort criteria string.");
+ GNAT.OS_Lib.OS_Exit (1);
+ end;
when others =>
- Put_Line ("Unknown option : " & Argument (Arg));
- Usage;
+ null;
end case;
-
- Arg := Arg + 1;
-
- if Argc < Arg and then Run_Gdb then
- Usage;
- end if;
end loop;
- -- In the cross case, we first get the target
+ -- Set default log file if -i hasn't been specified
- if Cross_Case then
- Target_Pos := Arg;
- Arg := Arg + 1;
-
- if Argc < Arg and then Run_Gdb then
- Usage;
- end if;
+ if Log_Name = null then
+ Log_Name := new String'("gmem.out");
end if;
- -- Now all the following arguments are to be passed to gdb
+ -- Get the optional backtrace length and program name
- if Run_Gdb then
- Exec_Pos := Arg;
- Check_File (Exec_Pos);
+ declare
+ Str1 : constant String := GNAT.Command_Line.Get_Argument;
+ Str2 : constant String := GNAT.Command_Line.Get_Argument;
- elsif Gmem_Mode then
- if Arg > Argc then
+ begin
+ if Str1 = "" then
Usage;
- else
- Exec_Pos := Arg;
- Check_File (Exec_Pos);
- Gmem_A2l_Initialize (Argument (Exec_Pos));
end if;
- -- ... in other cases further arguments are disallowed
-
- elsif Arg <= Argc then
- Usage;
- end if;
- end Process_Arguments;
-
- ---------------
- -- Read_Next --
- ---------------
-
- function Read_Next return Gdb_Output_Elmt is
- Max_Line : constant Integer := 100;
- Line : String (1 .. Max_Line);
- Last : Integer := 0;
+ if Str2 = "" then
+ Program_Name := new String'(Str1);
+ else
+ BT_Depth := Natural'Value (Str1);
+ Program_Name := new String'(Str2);
+ end if;
- Curs1, Curs2 : Integer;
- Separator : constant Character := '^';
+ exception
+ when Constraint_Error =>
+ Usage;
+ end;
- function Next_Separator return Integer;
- -- Return the index of the next separator after Curs1 in Line
+ -- Ensure presence of executable suffix in Program_Name
- function Next_Separator return Integer is
- Curs : Integer := Curs1;
+ declare
+ Suffix : String_Access := Get_Executable_Suffix;
+ Tmp : String_Access;
begin
- loop
- if Curs > Last then
- raise Gdb_Output_Format_Error;
+ if Suffix.all /= ""
+ and then
+ Program_Name.all
+ (Program_Name.all'Last - Suffix.all'Length + 1 ..
+ Program_Name.all'Last) /= Suffix.all
+ then
+ Tmp := new String'(Program_Name.all & Suffix.all);
+ Free (Program_Name);
+ Program_Name := Tmp;
+ end if;
- elsif Line (Curs) = Separator then
- return Curs;
- end if;
+ Free (Suffix);
- Curs := Curs + 1;
- end loop;
- end Next_Separator;
+ -- Search the executable on the path. If not found in the PATH, we
+ -- default to the current directory. Otherwise, libaddr2line will
+ -- fail with an error:
- -- Start of processing for Read_Next
+ -- (null): Bad address
- begin
- Line (1) := ' ';
+ Tmp := Locate_Exec_On_Path (Program_Name.all);
- loop
- if Gmem_Mode then
- Gmem_Read_Next (Line, Last);
- else
- Get_Line (FT, Line, Last);
+ if Tmp = null then
+ Tmp := new String'('.' & Directory_Separator & Program_Name.all);
end if;
- if Line (1 .. 14) = "Program exited" then
- return Eof;
-
- elsif Line (1 .. 5) = "ALLOC" then
- -- ALLOC ^ <size> ^0x <addr> ^
-
- -- Read the size
-
- Curs1 := 7;
- Curs2 := Next_Separator - 1;
-
- if not Quiet_Mode then
- Tmp_Size := Storage_Count'Value (Line (Curs1 .. Curs2));
- end if;
+ Free (Program_Name);
+ Program_Name := Tmp;
+ end;
- -- Read the address, skip "^0x"
+ if not Is_Regular_File (Log_Name.all) then
+ Put_Line ("Couldn't find " & Log_Name.all);
+ GNAT.OS_Lib.OS_Exit (1);
+ end if;
- Curs1 := Curs2 + 4;
- Curs2 := Next_Separator - 1;
- Tmp_Address := Integer_Address'Value (
- "16#" & Line (Curs1 .. Curs2) & "#");
- return Alloc;
+ if not Gmem_Initialize (Log_Name.all) then
+ Put_Line ("File " & Log_Name.all & " is not a gnatmem log file");
+ GNAT.OS_Lib.OS_Exit (1);
+ end if;
- elsif Line (1 .. 5) = "DEALL" then
- -- DEALL ^ 0x <addr> ^
+ if not Is_Regular_File (Program_Name.all) then
+ Put_Line ("Couldn't find " & Program_Name.all);
+ end if;
- -- Read the address, skip "^0x"
+ Gmem_A2l_Initialize (Program_Name.all);
- Curs1 := 9;
- Curs2 := Next_Separator - 1;
- Tmp_Address := Integer_Address'Value (
- "16#" & Line (Curs1 .. Curs2) & "#");
- return Deall;
- end if;
- end loop;
exception
- when End_Error =>
- New_Line;
- Put_Line ("### incorrect user program termination detected.");
- Put_Line (" following data may not be meaningful");
- New_Line;
- return Eof;
- end Read_Next;
+ when GNAT.Command_Line.Invalid_Switch =>
+ Ada.Text_IO.Put_Line ("Invalid switch : "
+ & GNAT.Command_Line.Full_Switch);
+ Usage;
+ end Process_Arguments;
+
+ Cur_Elmt : Storage_Elmt;
-- Start of processing for Gnatmem
begin
Process_Arguments;
- if Run_Gdb then
- Create_Gdb_Script;
- end if;
-
- -- Now we start the gdb session using the following syntax
-
- -- gdb --nx --nw -batch -x gnatmem.tmp
-
- -- If there is a -o option we redirect the gdb output in the specified
- -- file, otherwise we just read directly from a pipe.
-
- if File_Pos /= 0 then
- declare
- Name : aliased String := Argument (File_Pos) & ASCII.NUL;
-
- begin
- if Run_Gdb then
- if Cross_Case then
- declare
- Cmd : aliased String := Target_Name (1 .. Target_Name_Len)
- & "-gdb --nx --nw -batch -x " & Gnatmem_Tmp & " > "
- & Name;
- begin
- System_Cmd (Cmd'Address);
- end;
- else
-
- declare
- Cmd : aliased String
- := "gdb --nx --nw " & Argument (Exec_Pos)
- & " -batch -x " & Gnatmem_Tmp & " > "
- & Name;
- begin
- System_Cmd (Cmd'Address);
- end;
- end if;
- end if;
-
- if not Gmem_Mode then
- FD := fopen (Name'Address, Mode_R'Address);
- end if;
- end;
-
- else
- if Cross_Case then
- declare
- Cmd : aliased String := Target_Name (1 .. Target_Name_Len)
- & "-gdb --nx --nw -batch -x " & Gnatmem_Tmp & ASCII.NUL;
- begin
- FD := popen (Cmd'Address, Mode_R'Address);
- end;
- else
- declare
- Cmd : aliased String := "gdb --nx --nw " & Argument (Exec_Pos)
- & " -batch -x " & Gnatmem_Tmp & ASCII.NUL;
-
- begin
- FD := popen (Cmd'Address, Mode_R'Address);
- end;
- end if;
- end if;
-
- -- Open the FD file as a regular Text_IO file
-
- if not Gmem_Mode then
- Ada.Text_IO.C_Streams.Open (FT, In_File, FD);
- end if;
-
- -- Main loop analysing the data generated by the debugger
- -- for each allocation, the backtrace is kept and stored in a htable
- -- whose entry is the address. Fore ach deallocation, we look for the
+ -- Main loop analysing the data generated by the instrumented routines.
+ -- For each allocation, the backtrace is kept and stored in a htable
+ -- whose entry is the address. For each deallocation, we look for the
-- corresponding allocation and cancel it.
Main : loop
- case Read_Next is
- when EOF =>
+ Cur_Elmt := Read_Next;
+
+ case Cur_Elmt.Elmt is
+ when '*' =>
exit Main;
- when Alloc =>
+ when 'A' =>
-- Update global counters if the allocated size is meaningful
if Quiet_Mode then
- Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
+ Tmp_Alloc.Root := Read_BT (BT_Depth);
+
if Nb_Alloc (Tmp_Alloc.Root) = 0 then
Nb_Root := Nb_Root + 1;
end if;
+
Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
- Address_HTable.Set (Tmp_Address, Tmp_Alloc);
+ Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
- elsif Tmp_Size > 0 then
+ elsif Cur_Elmt.Size > 0 then
- Global_Alloc_Size := Global_Alloc_Size + Tmp_Size;
+ Global_Alloc_Size := Global_Alloc_Size + Cur_Elmt.Size;
Global_Nb_Alloc := Global_Nb_Alloc + 1;
if Global_High_Water_Mark < Global_Alloc_Size then
@@ -835,7 +440,7 @@ begin
-- Read the corresponding back trace
- Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
+ Tmp_Alloc.Root := Read_BT (BT_Depth);
-- Update the number of allocation root if this is a new one
@@ -846,12 +451,12 @@ begin
-- Update allocation root specific counters
Set_Alloc_Size (Tmp_Alloc.Root,
- Alloc_Size (Tmp_Alloc.Root) + Tmp_Size);
+ Alloc_Size (Tmp_Alloc.Root) + Cur_Elmt.Size);
Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) + 1);
- if High_Water_Mark (Tmp_Alloc.Root)
- < Alloc_Size (Tmp_Alloc.Root)
+ if High_Water_Mark (Tmp_Alloc.Root) <
+ Alloc_Size (Tmp_Alloc.Root)
then
Set_High_Water_Mark (Tmp_Alloc.Root,
Alloc_Size (Tmp_Alloc.Root));
@@ -859,27 +464,27 @@ begin
-- Associate this allocation root to the allocated address
- Tmp_Alloc.Size := Tmp_Size;
- Address_HTable.Set (Tmp_Address, Tmp_Alloc);
+ Tmp_Alloc.Size := Cur_Elmt.Size;
+ Address_HTable.Set (Cur_Elmt.Address, Tmp_Alloc);
- -- non meaninful output, just consumes the backtrace
+ -- non meaningful output, just consumes the backtrace
else
- Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
+ Tmp_Alloc.Root := Read_BT (BT_Depth);
end if;
- when Deall =>
+ when 'D' =>
-- Get the corresponding Dealloc_Size and Root
- Tmp_Alloc := Address_HTable.Get (Tmp_Address);
+ Tmp_Alloc := Address_HTable.Get (Cur_Elmt.Address);
if Tmp_Alloc.Root = No_Root_Id then
-- There was no prior allocation at this address, something is
- -- very wrong. Mark this allocation root as problematic a
+ -- very wrong. Mark this allocation root as problematic
- Tmp_Alloc.Root := Read_BT (BT_Depth, FT);
+ Tmp_Alloc.Root := Read_BT (BT_Depth);
if Nb_Alloc (Tmp_Alloc.Root) = 0 then
Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
@@ -892,6 +497,7 @@ begin
if not Quiet_Mode then
Global_Alloc_Size := Global_Alloc_Size - Tmp_Alloc.Size;
end if;
+
Global_Nb_Dealloc := Global_Nb_Dealloc + 1;
-- Update allocation root specific counters
@@ -900,31 +506,26 @@ begin
Set_Alloc_Size (Tmp_Alloc.Root,
Alloc_Size (Tmp_Alloc.Root) - Tmp_Alloc.Size);
end if;
+
Set_Nb_Alloc (Tmp_Alloc.Root, Nb_Alloc (Tmp_Alloc.Root) - 1);
-- update the number of allocation root if this one disappear
- if Nb_Alloc (Tmp_Alloc.Root) = 0 then
+ if Nb_Alloc (Tmp_Alloc.Root) = 0
+ and then Minimum_NB_Leaks > 0 then
Nb_Root := Nb_Root - 1;
end if;
-- De-associate the deallocated address
- Address_HTable.Remove (Tmp_Address);
+ Address_HTable.Remove (Cur_Elmt.Address);
end if;
+
+ when others =>
+ raise Program_Error;
end case;
end loop Main;
- -- We can get rid of the temp file now
-
- if Run_Gdb and then File_Pos = 0 then
- declare
- X : int;
- begin
- X := unlink (Gnatmem_Tmp'Address);
- end;
- end if;
-
-- Print out general information about overall allocation
if not Quiet_Mode then
@@ -956,6 +557,7 @@ begin
Bogus_Dealls : Root_Array (1 .. Nb_Wrong_Deall);
Deall_Index : Natural := 0;
+ Nb_Alloc_J : Natural := 0;
procedure Move (From : Natural; To : Natural);
function Lt (Op1, Op2 : Natural) return Boolean;
@@ -967,14 +569,54 @@ begin
end Move;
function Lt (Op1, Op2 : Natural) return Boolean is
+ function Apply_Sort_Criterion (S : Character) return Integer;
+ -- Applies a specific sort criterion; returns -1, 0 or 1 if Op1 is
+ -- smaller than, equal, or greater than Op2 according to criterion
+
+ function Apply_Sort_Criterion (S : Character) return Integer is
+ LOp1, LOp2 : Integer;
+ begin
+ case S is
+ when 'n' =>
+ LOp1 := Nb_Alloc (Leaks (Op1));
+ LOp2 := Nb_Alloc (Leaks (Op2));
+
+ when 'w' =>
+ LOp1 := Integer (Alloc_Size (Leaks (Op1)));
+ LOp2 := Integer (Alloc_Size (Leaks (Op2)));
+
+ when 'h' =>
+ LOp1 := Integer (High_Water_Mark (Leaks (Op1)));
+ LOp2 := Integer (High_Water_Mark (Leaks (Op2)));
+
+ when others =>
+ return 0; -- Can't actually happen
+ end case;
+
+ if LOp1 < LOp2 then
+ return -1;
+ elsif LOp1 > LOp2 then
+ return 1;
+ else
+ return 0;
+ end if;
+ exception
+ when Constraint_Error =>
+ return 0;
+ end Apply_Sort_Criterion;
+
+ Result : Integer;
+
begin
- if Nb_Alloc (Leaks (Op1)) > Nb_Alloc (Leaks (Op2)) then
- return True;
- elsif Nb_Alloc (Leaks (Op1)) = Nb_Alloc (Leaks (Op2)) then
- return Alloc_Size (Leaks (Op1)) > Alloc_Size (Leaks (Op2));
- else
- return False;
- end if;
+ for S in Sort_Order'Range loop
+ Result := Apply_Sort_Criterion (Sort_Order (S));
+ if Result = -1 then
+ return False;
+ elsif Result = 1 then
+ return True;
+ end if;
+ end loop;
+ return False;
end Lt;
-- Start of processing for Print_Back_Traces
@@ -985,7 +627,7 @@ begin
Tmp_Alloc.Root := Get_First;
while Tmp_Alloc.Root /= No_Root_Id loop
- if Nb_Alloc (Tmp_Alloc.Root) = 0 then
+ if Nb_Alloc (Tmp_Alloc.Root) = 0 and then Minimum_NB_Leaks > 0 then
null;
elsif Nb_Alloc (Tmp_Alloc.Root) < 0 then
@@ -1009,7 +651,7 @@ begin
end if;
for J in 1 .. Bogus_Dealls'Last loop
- Print_BT (Bogus_Dealls (J));
+ Print_BT (Bogus_Dealls (J), Short => Quiet_Mode);
New_Line;
end loop;
end if;
@@ -1023,34 +665,38 @@ begin
Root_Sort.Sort (Nb_Root);
for J in 1 .. Leaks'Last loop
- if Quiet_Mode then
- if Nb_Alloc (Leaks (J)) = 1 then
- Put_Line (Integer'Image (Nb_Alloc (Leaks (J)))
- & " leak at :");
+ Nb_Alloc_J := Nb_Alloc (Leaks (J));
+ if Nb_Alloc_J >= Minimum_NB_Leaks then
+ if Quiet_Mode then
+ if Nb_Alloc_J = 1 then
+ Put_Line (" 1 leak at :");
+ else
+ Put_Line (Integer'Image (Nb_Alloc_J) & " leaks at :");
+ end if;
+
else
- Put_Line (Integer'Image (Nb_Alloc (Leaks (J)))
- & " leaks at :");
- end if;
- else
- Put_Line ("Allocation Root #" & Integer'Image (J));
- Put_Line ("-------------------");
+ Put_Line ("Allocation Root #" & Integer'Image (J));
+ Put_Line ("-------------------");
- Put (" Number of non freed allocations :");
- Ada.Integer_Text_IO.Put (Nb_Alloc (Leaks (J)), 4);
- New_Line;
+ Put (" Number of non freed allocations :");
+ Ada.Integer_Text_IO.Put (Nb_Alloc_J, 4);
+ New_Line;
+
+ Put_Line
+ (" Final Water Mark (non freed mem) :"
+ & Mem_Image (Alloc_Size (Leaks (J))));
- Put_Line (" Final Water Mark (non freed mem) :"
- & Mem_Image (Alloc_Size (Leaks (J))));
+ Put_Line
+ (" High Water Mark :"
+ & Mem_Image (High_Water_Mark (Leaks (J))));
- Put_Line (" High Water Mark :"
- & Mem_Image (High_Water_Mark (Leaks (J))));
+ Put_Line (" Backtrace :");
+ end if;
- Put_Line (" Backtrace :");
+ Print_BT (Leaks (J), Short => Quiet_Mode);
+ New_Line;
end if;
- Print_BT (Leaks (J));
- New_Line;
end loop;
end if;
end Print_Back_Traces;
-
end Gnatmem;
diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb
index 831edd50f17..5a56728bc74 100644
--- a/gcc/ada/gnatname.adb
+++ b/gcc/ada/gnatname.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -68,6 +68,15 @@ procedure Gnatname is
Table_Name => "Gnatname.Excluded_Patterns");
-- Table to accumulate the negative patterns.
+ package Foreign_Patterns is new Table.Table
+ (Table_Component_Type => String_Access,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 0,
+ Table_Initial => 10,
+ Table_Increment => 10,
+ Table_Name => "Gnatname.Foreign_Patterns");
+ -- Table to accumulate the foreign patterns.
+
package Patterns is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Natural,
@@ -87,6 +96,16 @@ procedure Gnatname is
-- Table to accumulate the source directories specified directly with -d
-- or indirectly with -D.
+ package Preprocessor_Switches is new Table.Table
+ (Table_Component_Type => String_Access,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 0,
+ Table_Initial => 2,
+ Table_Increment => 50,
+ Table_Name => "Gnatname.Preprocessor_Switches");
+ -- Table to store the preprocessor switches to be used in the call
+ -- to the compiler.
+
procedure Output_Version;
-- Print name and version
@@ -151,7 +170,7 @@ procedure Gnatname is
Output.Write_Str ("GNATNAME ");
Output.Write_Str (Gnatvsn.Gnat_Version_String);
Output.Write_Line
- (" Copyright 2001-2002 Free Software Foundation, Inc.");
+ (" Copyright 2001-2003 Free Software Foundation, Inc.");
end if;
end Output_Version;
@@ -166,7 +185,7 @@ procedure Gnatname is
-- Scan options first
loop
- case Getopt ("c: d: D: h P: v x:") is
+ case Getopt ("c: d: gnatep=! gnatep! gnateD! D: h P: v x: f:") is
when ASCII.NUL =>
exit;
@@ -185,6 +204,16 @@ procedure Gnatname is
when 'D' =>
Get_Directories (Parameter);
+ when 'f' =>
+ Foreign_Patterns.Increment_Last;
+ Foreign_Patterns.Table (Foreign_Patterns.Last) :=
+ new String'(Parameter);
+
+ when 'g' =>
+ Preprocessor_Switches.Increment_Last;
+ Preprocessor_Switches.Table (Preprocessor_Switches.Last) :=
+ new String'('-' & Full_Switch & Parameter);
+
when 'h' =>
Usage_Needed := True;
@@ -219,10 +248,11 @@ procedure Gnatname is
loop
declare
- S : constant String := Get_Argument (Do_Expansion => False);
+ S : String := Get_Argument (Do_Expansion => False);
begin
exit when S = "";
+ Canonical_Case_File_Name (S);
Patterns.Increment_Last;
Patterns.Table (Patterns.Last) := new String'(S);
end;
@@ -249,14 +279,18 @@ procedure Gnatname is
Write_Eol;
Write_Line ("switches:");
- Write_Line (" -cfile create configuration pragmas file");
- Write_Line (" -ddir use dir as one of the source directories");
- Write_Line (" -Dfile get source directories from file");
- Write_Line (" -h output this help message");
- Write_Line (" -Pproj update or create project file proj");
- Write_Line (" -v verbose output");
- Write_Line (" -v -v very verbose output");
- Write_Line (" -xpat exclude pattern pat");
+ Write_Line (" -cfile create configuration pragmas file");
+ Write_Line (" -ddir use dir as one of the source " &
+ "directories");
+ Write_Line (" -Dfile get source directories from file");
+ Write_Line (" -fpat foreign pattern");
+ Write_Line (" -gnateDsym=v preprocess with symbol definition");
+ Write_Line (" -gnatep=data preprocess files with data file");
+ Write_Line (" -h output this help message");
+ Write_Line (" -Pproj update or create project file proj");
+ Write_Line (" -v verbose output");
+ Write_Line (" -v -v very verbose output");
+ Write_Line (" -xpat exclude pattern pat");
end if;
end Usage;
@@ -266,8 +300,10 @@ begin
-- Initialize tables
Excluded_Patterns.Set_Last (0);
+ Foreign_Patterns.Set_Last (0);
Patterns.Set_Last (0);
Source_Directories.Set_Last (0);
+ Preprocessor_Switches.Set_Last (0);
-- Get the arguments
@@ -283,7 +319,7 @@ begin
-- If no pattern was specified, print the usage and return
- if Patterns.Last = 0 then
+ if Patterns.Last = 0 and Foreign_Patterns.Last = 0 then
Usage;
return;
end if;
@@ -302,6 +338,9 @@ begin
Directories : Argument_List (1 .. Integer (Source_Directories.Last));
Name_Patterns : Argument_List (1 .. Integer (Patterns.Last));
Excl_Patterns : Argument_List (1 .. Integer (Excluded_Patterns.Last));
+ Frgn_Patterns : Argument_List (1 .. Integer (Foreign_Patterns.Last));
+ Prep_Switches : Argument_List
+ (1 .. Integer (Preprocessor_Switches.Last));
begin
-- Build the Directories and Name_Patterns arguments
@@ -318,6 +357,14 @@ begin
Excl_Patterns (Index) := Excluded_Patterns.Table (Index);
end loop;
+ for Index in Frgn_Patterns'Range loop
+ Frgn_Patterns (Index) := Foreign_Patterns.Table (Index);
+ end loop;
+
+ for Index in Prep_Switches'Range loop
+ Prep_Switches (Index) := Preprocessor_Switches.Table (Index);
+ end loop;
+
-- Call Prj.Makr.Make where the real work is done
Prj.Makr.Make
@@ -326,6 +373,8 @@ begin
Directories => Directories,
Name_Patterns => Name_Patterns,
Excluded_Patterns => Excl_Patterns,
+ Foreign_Patterns => Frgn_Patterns,
+ Preproc_Switches => Prep_Switches,
Very_Verbose => Very_Verbose);
end;
diff --git a/gcc/ada/gnatprep.adb b/gcc/ada/gnatprep.adb
index 2502db7cee2..08c15ae56aa 100644
--- a/gcc/ada/gnatprep.adb
+++ b/gcc/ada/gnatprep.adb
@@ -24,1534 +24,11 @@
-- --
------------------------------------------------------------------------------
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Ada.Strings.Fixed;
-with Ada.Command_Line; use Ada.Command_Line;
-with Ada.Text_IO; use Ada.Text_IO;
-
-with GNAT.Heap_Sort_G;
-with GNAT.Command_Line;
-
-with Gnatvsn;
+with GPrep;
procedure GNATprep is
-
- type Strptr is access String;
-
- Usage_Error : exception;
- -- Raised if a usage error is detected, causes termination of processing
- -- with an appropriate error message and error exit status set.
-
- Fatal_Error : exception;
- -- Exception raised if fatal error detected
-
- Expression_Error : exception;
- -- Exception raised when an invalid boolean expression is found
- -- on a preprocessor line
-
- ------------------------
- -- Argument Line Data --
- ------------------------
-
- Outfile_Name : Strptr;
- Deffile_Name : Strptr;
- -- Names of files
-
- type Input;
- type Input_Ptr is access Input;
- type Input is record
- File : File_Type;
- Next : Input_Ptr;
- Prev : Input_Ptr;
- Name : Strptr;
- Line_Num : Natural := 0;
- end record;
- -- Data for the current input file (main input file or included file
- -- or definition file).
-
- Infile : Input_Ptr := new Input;
- Outfile : File_Type;
- Deffile : File_Type;
-
- Opt_Comment_Deleted_Lines : Boolean := False; -- Set if -c switch set
- Blank_Deleted_Lines : Boolean := False; -- Set if -b switch set
- List_Symbols : Boolean := False; -- Set if -s switch set
- Source_Ref_Pragma : Boolean := False; -- Set if -r switch set
- Undefined_Is_False : Boolean := False; -- Set if -u switch set
- -- Record command line options
-
- ---------------------------
- -- Definitions File Data --
- ---------------------------
-
- Num_Syms : Natural := 0;
- -- Number of symbols defined in definitions file
-
- Symbols : array (0 .. 10_000) of Strptr;
- Values : array (0 .. 10_000) of Strptr;
- -- Symbol names and values. Note that the zero'th element is used only
- -- during the call to Sort (to hold a temporary value, as required by
- -- the GNAT.Heap_Sort_G interface).
-
- ---------------------
- -- Input File Data --
- ---------------------
-
- Current_File_Name : Strptr;
- -- Holds name of file being read (definitions file or input file)
-
- Line_Buffer : String (1 .. 20_000);
- -- Hold one line
-
- Line_Length : Natural;
- -- Length of line in Line_Buffer
-
- Ptr : Natural;
- -- Input scan pointer for line in Line_Buffer
-
- type Keyword is (K_Not, K_Then, K_If, K_Else, K_End, K_Elsif,
- K_And, K_Or, K_Open_Paren, K_Close_Paren,
- K_Defined, K_Andthen, K_Orelse, K_Equal, K_Include,
- K_None);
- -- Keywords that are recognized on preprocessor lines. K_None indicates
- -- that no keyword was present.
-
- K : Keyword;
- -- Scanned keyword
-
- Start_Sym, End_Sym : Natural;
- -- First and last positions of scanned symbol
-
- Num_Errors : Natural := 0;
- -- Number of errors detected
-
- -----------------------
- -- Preprocessor Data --
- -----------------------
-
- -- The following record represents the state of an #if structure:
-
- type PP_Rec is record
- If_Line : Positive;
- -- Line number for #if line
-
- If_Name : Strptr;
- -- File name of #if line
-
- Else_Line : Natural;
- -- Line number for #else line, zero = no else seen yet
-
- Deleting : Boolean;
- -- True if lines currently being deleted
-
- Match_Seen : Boolean;
- -- True if either the #if condition or one of the previously seen
- -- #elsif lines was true, meaning that any future #elsif sections
- -- or the #else section, is to be deleted.
-
- end record;
-
- PP_Depth : Natural;
- -- Preprocessor #if nesting level. A value of zero means that we are
- -- outside any #if structure.
-
- PP : array (0 .. 100) of PP_Rec;
- -- Stack of records showing state of #if structures. PP (1) is the
- -- outer level entry, and PP (PP_Depth) is the active entry. PP (0)
- -- contains a dummy entry whose Deleting flag is always set to False.
-
- -----------------
- -- Subprograms --
- -----------------
-
- function At_End_Of_Line return Boolean;
- -- First advances Ptr using Skip_Spaces. Then returns True if Ptr is
- -- either at the end of the line, or at a -- comment sequence.
-
- procedure Error (Msg : String);
- -- Post error message with given text. The line number is taken from
- -- Infile.Line_Num, and the column number from Ptr.
-
- function Eval_Condition
- (Parenthesis : Natural := 0;
- Do_Eval : Boolean := True)
- return Boolean;
- -- Eval the condition found in the current Line. The condition can
- -- include any of the 'and', 'or', 'not', and parenthesis subexpressions.
- -- If Line is an invalid expression, then Expression_Error is raised,
- -- after an error message has been printed. Line can include 'then'
- -- followed by a comment, which is automatically ignored. If Do_Eval
- -- is False, then the expression is not evaluated at all, and symbols
- -- are just skipped.
-
- function Eval_Symbol (Do_Eval : Boolean) return Boolean;
- -- Read and evaluate the next symbol or expression (A, A'Defined, A=...)
- -- If it is followed by 'Defined or an equality test, read as many symbols
- -- as needed. Do_Eval has the same meaning as in Eval_Condition
-
- procedure Help_Page;
- -- Print a help page to summarize the usage of gnatprep
-
- function Image (N : Natural) return String;
- -- Returns Natural'Image (N) without the initial space
-
- function Is_Preprocessor_Line return Boolean;
- -- Tests if current line is a preprocessor line, i.e. that its first
- -- non-blank character is a # character. If so, then a result of True
- -- is returned, and Ptr is set to point to the character following the
- -- # character. If not, False is returned and Ptr is undefined.
-
- procedure No_Junk;
- -- Make sure no junk is present on a preprocessor line. Ptr points past
- -- the scanned preprocessor syntax.
-
- function OK_Identifier (S : String) return Boolean;
- -- Tests if given referenced string is valid Ada identifier
-
- function Matching_Strings (S1, S2 : String) return Boolean;
- -- Check if S1 and S2 are the same string (this is a case independent
- -- comparison, lower and upper case letters are considered to match).
- -- Duplicate quotes in S2 are considered as a single quote ("" => ")
-
- procedure Parse_Def_File;
- -- Parse the deffile given by the user
-
- function Scan_Keyword return Keyword;
- -- Advances Ptr to end of line or next non-blank using Skip_Spaces. Then
- -- attempts to scan out a recognized keyword. if a recognized keyword is
- -- found, sets Ptr past it, and returns the code for the keyword, if not,
- -- then Ptr is left unchanged pointing to a non-blank character or to the
- -- end of the line.
-
- function Symbol_Scanned return Boolean;
- -- On entry, Start_Sym is set to the first character of an identifier
- -- symbol to be scanned out. On return, End_Sym is set to the last
- -- character of the identifier, and the result indicates if the scanned
- -- symbol is a valid identifier (True = valid). Ptr is not changed.
-
- procedure Skip_Spaces;
- -- Skips Ptr past tabs and spaces to next non-blank, or one character
- -- past the end of line.
-
- function Variable_Index (Name : String) return Natural;
- -- Returns the index of the variable in the table. If the variable is not
- -- found, returns Natural'Last
-
- --------------------
- -- At_End_Of_Line --
- --------------------
-
- function At_End_Of_Line return Boolean is
- begin
- Skip_Spaces;
-
- return Ptr > Line_Length
- or else
- (Ptr < Line_Length and then Line_Buffer (Ptr .. Ptr + 1) = "--");
- end At_End_Of_Line;
-
- -----------
- -- Error --
- -----------
-
- procedure Error (Msg : String) is
- L : constant String := Natural'Image (Infile.Line_Num);
- C : constant String := Natural'Image (Ptr);
-
- begin
- Put (Standard_Error, Current_File_Name.all);
- Put (Standard_Error, ':');
- Put (Standard_Error, L (2 .. L'Length));
- Put (Standard_Error, ':');
- Put (Standard_Error, C (2 .. C'Length));
- Put (Standard_Error, ": ");
-
- Put_Line (Standard_Error, Msg);
- Num_Errors := Num_Errors + 1;
- end Error;
-
- --------------------
- -- Eval_Condition --
- --------------------
-
- function Eval_Condition
- (Parenthesis : Natural := 0;
- Do_Eval : Boolean := True)
- return Boolean
- is
- Symbol_Is_True : Boolean := False; -- init to avoid warning
- K : Keyword;
-
- begin
- -- Find the next subexpression
-
- K := Scan_Keyword;
-
- case K is
- when K_None =>
- Symbol_Is_True := Eval_Symbol (Do_Eval);
-
- when K_Not =>
-
- -- Not applies to the next subexpression (either a simple
- -- evaluation like A or A'Defined, or a parenthesis expression)
-
- K := Scan_Keyword;
-
- if K = K_Open_Paren then
- Symbol_Is_True := not Eval_Condition (Parenthesis + 1, Do_Eval);
-
- elsif K = K_None then
- Symbol_Is_True := not Eval_Symbol (Do_Eval);
-
- else
- Ptr := Start_Sym; -- Puts the keyword back
- end if;
-
- when K_Open_Paren =>
- Symbol_Is_True := Eval_Condition (Parenthesis + 1, Do_Eval);
-
- when others =>
- Ptr := Start_Sym;
- Error ("invalid syntax in preprocessor line");
- raise Expression_Error;
- end case;
-
- -- Do we have a compound expression with AND, OR, ...
-
- K := Scan_Keyword;
- case K is
- when K_None =>
- if not At_End_Of_Line then
- Error ("Invalid Syntax at end of line");
- raise Expression_Error;
- end if;
-
- if Parenthesis /= 0 then
- Error ("Unmatched opening parenthesis");
- raise Expression_Error;
- end if;
-
- return Symbol_Is_True;
-
- when K_Then =>
- if Parenthesis /= 0 then
- Error ("Unmatched opening parenthesis");
- raise Expression_Error;
- end if;
-
- return Symbol_Is_True;
-
- when K_Close_Paren =>
- if Parenthesis = 0 then
- Error ("Unmatched closing parenthesis");
- raise Expression_Error;
- end if;
-
- return Symbol_Is_True;
-
- when K_And =>
- return Symbol_Is_True and Eval_Condition (Parenthesis, Do_Eval);
-
- when K_Andthen =>
- if not Symbol_Is_True then
-
- -- Just skip the symbols for the remaining part
-
- Symbol_Is_True := Eval_Condition (Parenthesis, False);
- return False;
-
- else
- return Eval_Condition (Parenthesis, Do_Eval);
- end if;
-
- when K_Or =>
- return Symbol_Is_True or Eval_Condition (Parenthesis, Do_Eval);
-
- when K_Orelse =>
- if Symbol_Is_True then
-
- -- Just skip the symbols for the remaining part
-
- Symbol_Is_True := Eval_Condition (Parenthesis, False);
- return True;
-
- else
- return Eval_Condition (Parenthesis, Do_Eval);
- end if;
-
- when others =>
- Error ("invalid syntax in preprocessor line");
- raise Expression_Error;
- end case;
-
- end Eval_Condition;
-
- -----------------
- -- Eval_Symbol --
- -----------------
-
- function Eval_Symbol (Do_Eval : Boolean) return Boolean is
- Sym : constant String := Line_Buffer (Start_Sym .. End_Sym);
- K : Keyword;
- Index : Natural;
- Symbol_Defined : Boolean := False;
- Symbol_Is_True : Boolean := False;
-
- begin
- -- Read the symbol
-
- Skip_Spaces;
- Start_Sym := Ptr;
-
- if not Symbol_Scanned then
- Error ("invalid symbol name");
- raise Expression_Error;
- end if;
-
- Ptr := End_Sym + 1;
-
- -- Test if we have a simple test (A) or a more complicated one
- -- (A'Defined)
-
- K := Scan_Keyword;
-
- if K /= K_Defined and then K /= K_Equal then
- Ptr := Start_Sym; -- Puts the keyword back
- end if;
-
- Index := Variable_Index (Sym);
-
- case K is
- when K_Defined =>
- Symbol_Defined := Index /= Natural'Last;
- Symbol_Is_True := Symbol_Defined;
-
- when K_Equal =>
-
- -- Read the second part of the statement
-
- Skip_Spaces;
- Start_Sym := Ptr;
-
- if not Symbol_Scanned
- and then End_Sym < Start_Sym
- then
- Error ("No right part for the equality test");
- raise Expression_Error;
- end if;
-
- Ptr := End_Sym + 1;
-
- -- If the variable was not found
-
- if Do_Eval then
- if Index = Natural'Last then
- if not Undefined_Is_False then
- Error ("symbol name """ & Sym &
- """ is not defined in definitions file");
- end if;
-
- else
- declare
- Right : constant String
- := Line_Buffer (Start_Sym .. End_Sym);
- Index_R : Natural;
- begin
- if Right (Right'First) = '"' then
- Symbol_Is_True :=
- Matching_Strings
- (Values (Index).all,
- Right (Right'First + 1 .. Right'Last - 1));
- else
- Index_R := Variable_Index (Right);
- if Index_R = Natural'Last then
- Error ("Variable " & Right & " in test is "
- & "not defined");
- raise Expression_Error;
- else
- Symbol_Is_True :=
- Matching_Strings (Values (Index).all,
- Values (Index_R).all);
- end if;
- end if;
- end;
- end if;
- end if;
-
- when others =>
-
- if Index = Natural'Last then
-
- Symbol_Defined := False;
- if Do_Eval and then not Symbol_Defined then
- if Undefined_Is_False then
- Symbol_Defined := True;
- Symbol_Is_True := False;
-
- else
- Error
- ("symbol name """ & Sym &
- """ is not defined in definitions file");
- end if;
- end if;
-
- elsif not Do_Eval then
- Symbol_Is_True := True;
-
- elsif Matching_Strings (Values (Index).all, "True") then
- Symbol_Is_True := True;
-
- elsif Matching_Strings (Values (Index).all, "False") then
- Symbol_Is_True := False;
-
- else
- Error ("symbol value is not True or False");
- Symbol_Is_True := False;
- end if;
-
- end case;
-
- return Symbol_Is_True;
- end Eval_Symbol;
-
- ---------------
- -- Help_Page --
- ---------------
-
- procedure Help_Page is
- begin
- Put_Line (Standard_Error,
- "GNAT Preprocessor " &
- Gnatvsn.Gnat_Version_String &
- " Copyright 1996-2002 Free Software Foundation, Inc.");
- Put_Line (Standard_Error,
- "Usage: gnatprep [-bcrsu] [-Dsymbol=value] infile " &
- "outfile [deffile]");
- New_Line (Standard_Error);
- Put_Line (Standard_Error, " infile Name of the input file");
- Put_Line (Standard_Error, " outfile Name of the output file");
- Put_Line (Standard_Error, " deffile Name of the definition file");
- New_Line (Standard_Error);
- Put_Line (Standard_Error, "gnatprep switches:");
- Put_Line (Standard_Error, " -b Replace preprocessor lines by " &
- "blank lines");
- Put_Line (Standard_Error, " -c Keep preprocessor lines as comments");
- Put_Line (Standard_Error, " -D Associate symbol with value");
- Put_Line (Standard_Error, " -r Generate Source_Reference pragma");
- Put_Line (Standard_Error, " -s Print a sorted list of symbol names " &
- "and values");
- Put_Line (Standard_Error, " -u Treat undefined symbols as FALSE");
- New_Line (Standard_Error);
- end Help_Page;
-
- -----------
- -- Image --
- -----------
-
- function Image (N : Natural) return String is
- Result : constant String := Natural'Image (N);
- begin
- return Result (Result'First + 1 .. Result'Last);
- end Image;
-
- --------------------------
- -- Is_Preprocessor_Line --
- --------------------------
-
- function Is_Preprocessor_Line return Boolean is
- begin
- Ptr := 1;
-
- while Ptr <= Line_Length loop
- if Line_Buffer (Ptr) = '#' then
- Ptr := Ptr + 1;
- return True;
-
- elsif Line_Buffer (Ptr) > ' ' then
- return False;
-
- else
- Ptr := Ptr + 1;
- end if;
- end loop;
-
- return False;
- end Is_Preprocessor_Line;
-
- ----------------------
- -- Matching_Strings --
- ----------------------
-
- function Matching_Strings (S1, S2 : String) return Boolean is
- S2_Index : Integer := S2'First;
-
- begin
- for S1_Index in S1'Range loop
-
- if To_Upper (S1 (S1_Index)) /= To_Upper (S2 (S2_Index)) then
- return False;
-
- else
- if S2 (S2_Index) = '"'
- and then S2_Index < S2'Last
- and then S2 (S2_Index + 1) = '"'
- then
- S2_Index := S2_Index + 2;
- else
- S2_Index := S2_Index + 1;
- end if;
-
- -- If S2 was too short then
-
- if S2_Index > S2'Last and then S1_Index < S1'Last then
- return False;
- end if;
- end if;
- end loop;
-
- return S2_Index = S2'Last + 1;
- end Matching_Strings;
-
- -------------
- -- No_Junk --
- -------------
-
- procedure No_Junk is
- begin
- Skip_Spaces;
-
- if Ptr = Line_Length
- or else (Ptr < Line_Length
- and then Line_Buffer (Ptr .. Ptr + 1) /= "--")
- then
- Error ("extraneous text on preprocessor line ignored");
- end if;
- end No_Junk;
-
- -------------------
- -- OK_Identifier --
- -------------------
-
- function OK_Identifier (S : String) return Boolean is
- P : Natural := S'First;
-
- begin
- if S'Length /= 0 and then S (P) = Character'Val (39) then -- '''
- P := P + 1;
- end if;
-
- if S'Length = 0
- or else not Is_Letter (S (P))
- then
- return False;
-
- else
- while P <= S'Last loop
- if Is_Letter (S (P)) or Is_Digit (S (P)) then
- null;
-
- elsif S (P) = '_'
- and then P < S'Last
- and then S (P + 1) /= '_'
- then
- null;
-
- else
- return False;
- end if;
-
- P := P + 1;
- end loop;
-
- return True;
- end if;
- end OK_Identifier;
-
- --------------------
- -- Parse_Def_File --
- --------------------
-
- procedure Parse_Def_File is
- begin
- Open (Deffile, In_File, Deffile_Name.all);
-
- -- Initialize data for procedure Error
-
- Infile.Line_Num := 0;
- Current_File_Name := Deffile_Name;
-
- -- Loop through lines in symbol definitions file
-
- while not End_Of_File (Deffile) loop
- Get_Line (Deffile, Line_Buffer, Line_Length);
- Infile.Line_Num := Infile.Line_Num + 1;
-
- Ptr := 1;
- Skip_Spaces;
-
- if Ptr > Line_Length
- or else (Ptr < Line_Length
- and then
- Line_Buffer (Ptr .. Ptr + 1) = "--")
- then
- goto Continue;
- end if;
-
- Start_Sym := Ptr;
-
- if not Symbol_Scanned then
- Error ("invalid symbol identifier """ &
- Line_Buffer (Start_Sym .. End_Sym) &
- '"');
- goto Continue;
- end if;
-
- Ptr := End_Sym + 1;
- Skip_Spaces;
-
- if Ptr >= Line_Length
- or else Line_Buffer (Ptr .. Ptr + 1) /= ":="
- then
- Error ("missing "":="" in symbol definition line");
- goto Continue;
- end if;
-
- Ptr := Ptr + 2;
- Skip_Spaces;
-
- Num_Syms := Num_Syms + 1;
- Symbols (Num_Syms) := new String'(Line_Buffer (Start_Sym .. End_Sym));
-
- Start_Sym := Ptr;
- End_Sym := Ptr - 1;
-
- if At_End_Of_Line then
- null;
-
- elsif Line_Buffer (Start_Sym) = '"' then
- End_Sym := End_Sym + 1;
- loop
- End_Sym := End_Sym + 1;
-
- if End_Sym > Line_Length then
- Error ("no closing quote for string constant");
- goto Continue;
-
- elsif End_Sym < Line_Length
- and then Line_Buffer (End_Sym .. End_Sym + 1) = """"""
- then
- End_Sym := End_Sym + 1;
-
- elsif Line_Buffer (End_Sym) = '"' then
- exit;
- end if;
- end loop;
-
- else
- End_Sym := Ptr - 1;
-
- while End_Sym < Line_Length
- and then (Is_Alphanumeric (Line_Buffer (End_Sym + 1))
- or else
- Line_Buffer (End_Sym + 1) = '_'
- or else
- Line_Buffer (End_Sym + 1) = '.')
- loop
- End_Sym := End_Sym + 1;
- end loop;
-
- Ptr := End_Sym + 1;
-
- if not At_End_Of_Line then
- Error ("incorrect symbol value syntax");
- goto Continue;
- end if;
- end if;
-
- Values (Num_Syms) := new String'(Line_Buffer (Start_Sym .. End_Sym));
-
- <<Continue>>
- null;
- end loop;
-
- exception
- -- Could not open the file
-
- when Name_Error =>
- Put_Line (Standard_Error, "cannot open " & Deffile_Name.all);
- raise Fatal_Error;
- end Parse_Def_File;
-
- ------------------
- -- Scan_Keyword --
- ------------------
-
- function Scan_Keyword return Keyword is
- Kptr : constant Natural := Ptr;
-
- begin
- Skip_Spaces;
- Start_Sym := Ptr;
-
- if Symbol_Scanned then
-
- -- If the symbol was the last thing on the line, End_Sym will
- -- point too far in Line_Buffer
-
- if End_Sym > Line_Length then
- End_Sym := Line_Length;
- end if;
-
- Ptr := End_Sym + 1;
-
- declare
- Sym : constant String := Line_Buffer (Start_Sym .. End_Sym);
-
- begin
- if Matching_Strings (Sym, "not") then
- return K_Not;
-
- elsif Matching_Strings (Sym, "then") then
- return K_Then;
-
- elsif Matching_Strings (Sym, "if") then
- return K_If;
-
- elsif Matching_Strings (Sym, "else") then
- return K_Else;
-
- elsif Matching_Strings (Sym, "end") then
- return K_End;
-
- elsif Matching_Strings (Sym, "elsif") then
- return K_Elsif;
-
- elsif Matching_Strings (Sym, "and") then
- if Scan_Keyword = K_Then then
- Start_Sym := Kptr;
- return K_Andthen;
- else
- Ptr := Start_Sym; -- Put back the last keyword read
- Start_Sym := Kptr;
- return K_And;
- end if;
-
- elsif Matching_Strings (Sym, "or") then
- if Scan_Keyword = K_Else then
- Start_Sym := Kptr;
- return K_Orelse;
- else
- Ptr := Start_Sym; -- Put back the last keyword read
- Start_Sym := Kptr;
- return K_Or;
- end if;
-
- elsif Matching_Strings (Sym, "'defined") then
- return K_Defined;
-
- elsif Matching_Strings (Sym, "include") then
- return K_Include;
-
- elsif Sym = "(" then
- return K_Open_Paren;
-
- elsif Sym = ")" then
- return K_Close_Paren;
-
- elsif Sym = "=" then
- return K_Equal;
- end if;
- end;
- end if;
-
- Ptr := Kptr;
- return K_None;
- end Scan_Keyword;
-
- -----------------
- -- Skip_Spaces --
- -----------------
-
- procedure Skip_Spaces is
- begin
- while Ptr <= Line_Length loop
- if Line_Buffer (Ptr) /= ' '
- and then Line_Buffer (Ptr) /= ASCII.HT
- then
- return;
- else
- Ptr := Ptr + 1;
- end if;
- end loop;
- end Skip_Spaces;
-
- --------------------
- -- Symbol_Scanned --
- --------------------
-
- function Symbol_Scanned return Boolean is
- begin
- End_Sym := Start_Sym - 1;
-
- case Line_Buffer (End_Sym + 1) is
-
- when '(' | ')' | '=' =>
- End_Sym := End_Sym + 1;
- return True;
-
- when '"' =>
- End_Sym := End_Sym + 1;
- while End_Sym < Line_Length loop
-
- if Line_Buffer (End_Sym + 1) = '"' then
-
- if End_Sym + 2 < Line_Length
- and then Line_Buffer (End_Sym + 2) = '"'
- then
- End_Sym := End_Sym + 2;
- else
- exit;
- end if;
- else
- End_Sym := End_Sym + 1;
- end if;
- end loop;
-
- if End_Sym >= Line_Length then
- Error ("Invalid string ");
- raise Expression_Error;
- end if;
-
- End_Sym := End_Sym + 1;
- return False;
-
- when ''' =>
- End_Sym := End_Sym + 1;
-
- when others =>
- null;
- end case;
-
- while End_Sym < Line_Length
- and then (Is_Alphanumeric (Line_Buffer (End_Sym + 1))
- or else Line_Buffer (End_Sym + 1) = '_')
- loop
- End_Sym := End_Sym + 1;
- end loop;
-
- return OK_Identifier (Line_Buffer (Start_Sym .. End_Sym));
- end Symbol_Scanned;
-
- --------------------
- -- Variable_Index --
- --------------------
-
- function Variable_Index (Name : String) return Natural is
- begin
- for J in 1 .. Num_Syms loop
- if Matching_Strings (Symbols (J).all, Name) then
- return J;
- end if;
- end loop;
-
- return Natural'Last;
- end Variable_Index;
-
--- Start of processing for GNATprep
-
begin
+ -- Everything is done in GPrep
- -- Parse the switches
-
- loop
- case GNAT.Command_Line.Getopt ("D: b c r s u") is
- when ASCII.NUL =>
- exit;
-
- when 'D' =>
- declare
- S : String := GNAT.Command_Line.Parameter;
- Index : Natural;
-
- begin
- Index := Ada.Strings.Fixed.Index (S, "=");
-
- if Index = 0 then
- Num_Syms := Num_Syms + 1;
- Symbols (Num_Syms) := new String'(S);
- Values (Num_Syms) := new String'("True");
-
- else
- Num_Syms := Num_Syms + 1;
- Symbols (Num_Syms) := new String'(S (S'First .. Index - 1));
- Values (Num_Syms) := new String'(S (Index + 1 .. S'Last));
- end if;
- end;
-
- when 'b' =>
- Blank_Deleted_Lines := True;
-
- when 'c' =>
- Opt_Comment_Deleted_Lines := True;
-
- when 'r' =>
- Source_Ref_Pragma := True;
-
- when 's' =>
- List_Symbols := True;
-
- when 'u' =>
- Undefined_Is_False := True;
-
- when others =>
- raise Usage_Error;
- end case;
- end loop;
-
- -- Get the file names
-
- loop
- declare
- S : constant String := GNAT.Command_Line.Get_Argument;
-
- begin
- exit when S'Length = 0;
-
- if Infile.Name = null then
- Infile.Name := new String'(S);
- elsif Outfile_Name = null then
- Outfile_Name := new String'(S);
- elsif Deffile_Name = null then
- Deffile_Name := new String'(S);
- else
- raise Usage_Error;
- end if;
- end;
- end loop;
-
- -- Test we had all the arguments needed
-
- if Infile.Name = null
- or else Outfile_Name = null
- then
- raise Usage_Error;
- end if;
-
- if Source_Ref_Pragma and (not Opt_Comment_Deleted_Lines) then
- Blank_Deleted_Lines := True;
- end if;
-
- -- Get symbol definitions
-
- if Deffile_Name /= null then
- Parse_Def_File;
- end if;
-
- if Num_Errors > 0 then
- raise Fatal_Error;
-
- elsif List_Symbols and then Num_Syms > 0 then
- List_Symbols_Case : declare
-
- function Lt (Op1, Op2 : Natural) return Boolean;
- -- Comparison routine for sort call
-
- procedure Move (From : Natural; To : Natural);
- -- Move routine for sort call
-
- function Lt (Op1, Op2 : Natural) return Boolean is
- L1 : constant Natural := Symbols (Op1)'Length;
- L2 : constant Natural := Symbols (Op2)'Length;
- MinL : constant Natural := Natural'Min (L1, L2);
-
- C1, C2 : Character;
-
- begin
- for J in 0 .. MinL - 1 loop
- C1 := To_Upper (Symbols (Op1).all (Symbols (Op1)'First + J));
- C2 := To_Upper (Symbols (Op2).all (Symbols (Op2)'First + J));
-
- if C1 < C2 then
- return True;
-
- elsif C1 > C2 then
- return False;
- end if;
- end loop;
-
- return L1 < L2;
- end Lt;
-
- procedure Move (From : Natural; To : Natural) is
- begin
- Symbols (To) := Symbols (From);
- Values (To) := Values (From);
- end Move;
-
- package Sort_Syms is new GNAT.Heap_Sort_G (Move, Lt);
-
- Max_L : Natural;
- -- Maximum length of any symbol
-
- -- Start of processing for List_Symbols_Case
-
- begin
- Sort_Syms.Sort (Num_Syms);
-
- Max_L := 7;
- for J in 1 .. Num_Syms loop
- Max_L := Natural'Max (Max_L, Symbols (J)'Length);
- end loop;
-
- New_Line;
- Put ("Symbol");
-
- for J in 1 .. Max_L - 5 loop
- Put (' ');
- end loop;
-
- Put_Line ("Value");
-
- Put ("------");
-
- for J in 1 .. Max_L - 5 loop
- Put (' ');
- end loop;
-
- Put_Line ("------");
-
- for J in 1 .. Num_Syms loop
- Put (Symbols (J).all);
-
- for K in 1 .. Max_L - Symbols (J)'Length + 1 loop
- Put (' ');
- end loop;
-
- Put_Line (Values (J).all);
- end loop;
-
- New_Line;
- end List_Symbols_Case;
- end if;
-
- -- Open files and initialize preprocessing
-
- begin
- Open (Infile.File, In_File, Infile.Name.all);
-
- exception
- when Name_Error =>
- Put_Line (Standard_Error, "cannot open " & Infile.Name.all);
- raise Fatal_Error;
- end;
-
- begin
- Create (Outfile, Out_File, Outfile_Name.all);
-
- exception
- when Name_Error =>
- Put_Line (Standard_Error, "cannot create " & Outfile_Name.all);
- raise Fatal_Error;
- end;
-
- Infile.Line_Num := 0;
- Current_File_Name := Infile.Name;
-
- PP_Depth := 0;
- PP (0).Deleting := False;
-
- -- We return here after we start reading an include file and after
- -- we have finished reading an include file.
-
- <<Read_In_File>>
-
- -- If we generate Source_Reference pragmas, then generate one
- -- either with line number 1 for a newly included file, or
- -- with the number of the next line when we have returned to the
- -- including file.
-
- if Source_Ref_Pragma then
- Put_Line
- (Outfile, "pragma Source_Reference (" &
- Image (Infile.Line_Num + 1) &
- ", """ & Infile.Name.all & """);");
- end if;
-
- -- Loop through lines in input file
-
- while not End_Of_File (Infile.File) loop
- Get_Line (Infile.File, Line_Buffer, Line_Length);
- Infile.Line_Num := Infile.Line_Num + 1;
-
- -- Handle preprocessor line
-
- if Is_Preprocessor_Line then
- K := Scan_Keyword;
-
- case K is
-
- -- Include file
-
- when K_Include =>
- -- Ignore if Deleting is True
-
- if PP (PP_Depth).Deleting then
- goto Output;
- end if;
-
- Skip_Spaces;
-
- if Ptr >= Line_Length then
- Error ("no file to include");
-
- elsif Line_Buffer (Ptr) /= '"' then
- Error
- ("file to include must be specified as a literal string");
-
- else
- declare
- Start_File : constant Positive := Ptr + 1;
-
- begin
- Ptr := Line_Length;
-
- while Line_Buffer (Ptr) = ' '
- or else Line_Buffer (Ptr) = ASCII.HT
- loop
- Ptr := Ptr - 1;
- end loop;
-
- if Ptr <= Start_File
- or else Line_Buffer (Ptr) /= '"'
- then
- Error ("no string literal for included file");
-
- else
- if Infile.Next = null then
- Infile.Next := new Input;
- Infile.Next.Prev := Infile;
- end if;
-
- Infile := Infile.Next;
- Infile.Name :=
- new String'(Line_Buffer (Start_File .. Ptr - 1));
-
- -- Check for circularity: an file including itself,
- -- either directly or indirectly.
-
- declare
- File : Input_Ptr := Infile.Prev;
-
- begin
- while File /= null
- and then File.Name.all /= Infile.Name.all
- loop
- File := File.Prev;
- end loop;
-
- if File /= null then
- Infile := Infile.Prev;
- Error ("circularity in included files");
-
- while File.Prev /= null loop
- File := File.Prev;
- end loop;
-
- while File /= Infile.Next loop
- Error ('"' & File.Name.all &
- """ includes """ &
- File.Next.Name.all & '"');
- File := File.Next;
- end loop;
-
- else
- -- We have a file name and no circularity.
- -- Open the file and record an error if the
- -- file cannot be opened.
-
- begin
- Open (Infile.File, In_File, Infile.Name.all);
- Current_File_Name := Infile.Name;
- Infile.Line_Num := 0;
-
- -- If we use Source_Reference pragma,
- -- we need to output one for this new file.
- goto Read_In_File;
-
- exception
- when Name_Error =>
-
- -- We need to set the input file to
- -- the including file, so that the
- -- line number is correct when reporting
- -- the error.
-
- Infile := Infile.Prev;
- Error ("cannot open """ &
- Infile.Next.Name.all & '"');
- end;
- end if;
- end;
- end if;
- end;
- end if;
-
- -- If/Elsif processing
-
- when K_If | K_Elsif =>
-
- -- If differs from elsif only in that an initial stack entry
- -- must be made for the new if range. We set the match seen
- -- entry to a copy of the deleting status in the range above
- -- us. If we are deleting in the range above us, then we want
- -- all the branches of the nested #if to delete.
-
- if K = K_If then
- PP_Depth := PP_Depth + 1;
- PP (PP_Depth) :=
- (If_Line => Infile.Line_Num,
- If_Name => Infile.Name,
- Else_Line => 0,
- Deleting => False,
- Match_Seen => PP (PP_Depth - 1).Deleting);
-
- elsif PP_Depth = 0 then
- Error ("no matching #if for this #elsif");
- goto Output;
-
- end if;
-
- PP (PP_Depth).Deleting := True;
-
- if not PP (PP_Depth).Match_Seen
- and then Eval_Condition = True
- then
-
- -- Case of match and no match yet in this #if
-
- PP (PP_Depth).Deleting := False;
- PP (PP_Depth).Match_Seen := True;
- No_Junk;
- end if;
-
- -- Processing for #else
-
- when K_Else =>
-
- if PP_Depth = 0 then
- Error ("no matching #if for this #else");
-
- elsif PP (PP_Depth).Else_Line /= 0 then
- Error ("duplicate #else line (previous was on line" &
- Natural'Image (PP (PP_Depth).Else_Line) &
- ")");
-
- else
- PP (PP_Depth).Else_Line := Infile.Line_Num;
- PP (PP_Depth).Deleting := PP (PP_Depth).Match_Seen;
- end if;
-
- No_Junk;
-
- -- Process for #end
-
- when K_End =>
-
- if PP_Depth = 0 then
- Error ("no matching #if for this #end");
-
- else
- Skip_Spaces;
-
- if Scan_Keyword /= K_If then
- Error ("expected if after #end");
- Ptr := Line_Length + 1;
- end if;
-
- Skip_Spaces;
-
- if Ptr > Line_Length
- or else Line_Buffer (Ptr) /= ';'
- then
- Error ("missing semicolon after #end if");
- else
- Ptr := Ptr + 1;
- end if;
-
- No_Junk;
-
- PP_Depth := PP_Depth - 1;
- end if;
-
- when others =>
- Error ("invalid preprocessor keyword syntax");
-
- end case;
-
- -- Handle symbol substitution
-
- -- Substitution is not allowed in string (which we simply skip),
- -- but is allowed inside character constants. The last case is
- -- because there is no way to know whether the user want to
- -- substitute the name of an attribute ('Min or 'Max for instance)
- -- or actually meant to substitue a character ('$name' is probably
- -- a character constant, but my_type'$name'Min is probably an
- -- attribute, with $name=Base)
-
- else
- Ptr := 1;
-
- while Ptr < Line_Length loop
- exit when At_End_Of_Line;
-
- case Line_Buffer (Ptr) is
-
- when ''' =>
-
- -- Two special cases here:
- -- '"' => we don't want the " sign to appear as belonging
- -- to a string.
- -- '$' => this is obviously not a substitution, just skip it
-
- if Ptr < Line_Length - 1
- and then Line_Buffer (Ptr + 1) = '"'
- then
- Ptr := Ptr + 2;
- elsif Ptr < Line_Length - 2
- and then Line_Buffer (Ptr + 1 .. Ptr + 2) = "$'"
- then
- Ptr := Ptr + 2;
- end if;
-
- when '"' =>
-
- -- The special case of "" inside the string is easy to
- -- handle: just ignore them. The second one will be seen
- -- as the beginning of a second string
-
- Ptr := Ptr + 1;
- while Ptr < Line_Length
- and then Line_Buffer (Ptr) /= '"'
- loop
- Ptr := Ptr + 1;
- end loop;
-
- when '$' =>
-
- -- $ found, so scan out possible following symbol
-
- Start_Sym := Ptr + 1;
-
- if Symbol_Scanned then
-
- -- Look up symbol in table and if found do replacement
-
- for J in 1 .. Num_Syms loop
- if Matching_Strings
- (Symbols (J).all, Line_Buffer (Start_Sym .. End_Sym))
- then
- declare
- OldL : constant Positive :=
- End_Sym - Start_Sym + 2;
- NewL : constant Positive := Values (J)'Length;
- AdjL : constant Integer := NewL - OldL;
- NewP : constant Positive := Ptr + NewL - 1;
-
- begin
- Line_Buffer (NewP + 1 .. Line_Length + AdjL) :=
- Line_Buffer (End_Sym + 1 .. Line_Length);
- Line_Buffer (Ptr .. NewP) := Values (J).all;
-
- Ptr := NewP;
- Line_Length := Line_Length + AdjL;
- end;
-
- exit;
- end if;
- end loop;
- end if;
-
- when others =>
- null;
-
- end case;
- Ptr := Ptr + 1;
- end loop;
- end if;
-
- -- Here after dealing with preprocessor line, output current line
-
- <<Output>>
-
- if Is_Preprocessor_Line or else PP (PP_Depth).Deleting then
- if Blank_Deleted_Lines then
- New_Line (Outfile);
-
- elsif Opt_Comment_Deleted_Lines then
- if Line_Length = 0 then
- Put_Line (Outfile, "--!");
- else
- Put (Outfile, "--! ");
- Put_Line (Outfile, Line_Buffer (1 .. Line_Length));
- end if;
- end if;
-
- else
- Put_Line (Outfile, Line_Buffer (1 .. Line_Length));
- end if;
- end loop;
-
- -- If we have finished reading an included file, close it and continue
- -- with the next line of the including file.
-
- if Infile.Prev /= null then
- Close (Infile.File);
- Infile := Infile.Prev;
- Current_File_Name := Infile.Name;
- goto Read_In_File;
- end if;
-
- for J in 1 .. PP_Depth loop
- if PP (J).If_Name = Infile.Name then
- Error ("no matching #end for #if at line" &
- Natural'Image (PP (J).If_Line));
- else
- Error ("no matching #end for #if at line" &
- Natural'Image (PP (J).If_Line) &
- " of file """ & PP (J).If_Name.all & '"');
- end if;
- end loop;
-
- if Num_Errors = 0 then
- Close (Outfile);
- Set_Exit_Status (0);
- else
- Delete (Outfile);
- Set_Exit_Status (1);
- end if;
-
-exception
- when Usage_Error =>
- Help_Page;
- Set_Exit_Status (1);
-
- when GNAT.Command_Line.Invalid_Parameter =>
- Put_Line (Standard_Error, "No parameter given for -"
- & GNAT.Command_Line.Full_Switch);
- Help_Page;
- Set_Exit_Status (1);
-
- when GNAT.Command_Line.Invalid_Switch =>
- Put_Line (Standard_Error, "Invalid Switch: -"
- & GNAT.Command_Line.Full_Switch);
- Help_Page;
- Set_Exit_Status (1);
-
- when Fatal_Error =>
- Set_Exit_Status (1);
-
- when Expression_Error =>
- Set_Exit_Status (1);
-
+ GPrep.Gnatprep;
end GNATprep;
diff --git a/gcc/ada/gnatprep.ads b/gcc/ada/gnatprep.ads
index 0808d2cff9c..99381e1bc68 100644
--- a/gcc/ada/gnatprep.ads
+++ b/gcc/ada/gnatprep.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1998, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,7 +30,7 @@
-- To call gnatprep use
--- gnatprep infile outfile [deffile] [-c] [-b] [-r] [-s] [-u]
+-- gnatprep infile outfile [deffile] [-v] [-c] [-b] [-r] [-s] [-u]
-- [-Dsymbol=value]
-- where
@@ -43,7 +43,8 @@
-- normally have an ads or adb suffix.
-- deffile is the full name of a text file containing definitions of
--- symbols to be referenced by the preprocessor. This argument is optional
+-- symbols to be referenced by the preprocessor. This argument is
+-- optional.
-- The -c switch, causes both preprocessor lines and the lines deleted
-- by preprocessing to be retained in the output source as comments marked
@@ -65,8 +66,13 @@
-- The -s switch causes a sorted list of symbol names and values to be
-- listed on the standard output file.
+-- The -v switch causes a Copyright notice to be displayed, and
+-- lines containing errors in the input file or the definition file
+-- to be displayed before the errors.
+
-- The -D switch causes symbol 'symbol' to be associated with 'value'.
--- This symbols can then be referenced by the preprocessor
+-- This symbols can then be referenced by the preprocessor. Several
+-- -D switches may be specified.
-- Note: if neither -b nor -c is present, then preprocessor lines and
-- deleted lines are completely removed from the output, unless -r is
@@ -117,6 +123,9 @@
-- expression ::= <expression> or else <expression>
-- expression ::= ( <expression> )
+-- "or" and "and" may not be used in the same expression without
+-- using parentheses.
+
-- For these Boolean tests, the symbol must have either the value True or
-- False. If the value is True, then the corresponding lines are included,
-- and if the value is False, they are excluded. It is an error to
diff --git a/gcc/ada/gnatpsta.adb b/gcc/ada/gnatpsta.adb
index 12a38fcf6a8..36833670839 100644
--- a/gcc/ada/gnatpsta.adb
+++ b/gcc/ada/gnatpsta.adb
@@ -38,7 +38,6 @@ with Ttypes; use Ttypes;
with Types; use Types;
procedure GnatPsta is
-
procedure P (Item : String) renames Ada.Text_IO.Put_Line;
procedure P_Int_Range (Size : Pos; Put_First : Boolean := True);
diff --git a/gcc/ada/gnatsym.adb b/gcc/ada/gnatsym.adb
new file mode 100644
index 00000000000..b5523f87da1
--- /dev/null
+++ b/gcc/ada/gnatsym.adb
@@ -0,0 +1,239 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T S Y M --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This utility application creates symbol files in a format that is
+-- platform-dependent.
+
+-- A symbol file is a text file that lists the symbols to be exported from
+-- a shared library. The format of a symbol file depends on the platform;
+-- it may be a simple enumeration of the symbol (one per line) or a more
+-- elaborate format (on VMS, for example). A symbol file may be used as an
+-- input to the platform linker when building a shared library.
+
+-- This utility is not available on all platforms. It is currently supported
+-- only on OpenVMS.
+
+-- gnatsym takes as parameters:
+-- - the name of the symbol file to create or update
+-- - the names of one or more object files where the symbols are found
+
+with GNAT.Command_Line; use GNAT.Command_Line;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with Gnatvsn; use Gnatvsn;
+with Osint; use Osint;
+with Output; use Output;
+
+with Symbols; use Symbols;
+with Table;
+
+procedure Gnatsym is
+
+ Copyright_Displayed : Boolean := False;
+ -- A flag to prevent multiple display of the Copyright notice
+
+ Success : Boolean := True;
+
+ Force : Boolean := False;
+ -- True when -f switcxh is used
+
+ Verbose : Boolean := False;
+ -- True when -v switch is used
+
+ Quiet : Boolean := False;
+ -- True when -q switch is used
+
+ Symbol_File_Name : String_Access;
+ -- The name of the symbol file
+
+ package Object_Files is new Table.Table
+ (Table_Component_Type => String_Access,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 0,
+ Table_Initial => 10,
+ Table_Increment => 10,
+ Table_Name => "Gnatsymb.Object_Files");
+ -- A table to store the object file names
+
+ Object_File : Natural := 0;
+ -- An index to traverse the Object_Files table
+
+ procedure Display_Copyright;
+ -- Display Copyright notice
+
+ procedure Parse_Cmd_Line;
+ -- Parse the command line switches and file names
+
+ procedure Usage;
+ -- Display the usage
+
+ -----------------------
+ -- Display_Copyright --
+ -----------------------
+
+ procedure Display_Copyright is
+ begin
+ if not Copyright_Displayed then
+ Write_Eol;
+ Write_Str ("GNATSYMB ");
+ Write_Str (Gnat_Version_String);
+ Write_Str (" Copyright 2003 Free Software Foundation, Inc");
+ Write_Eol;
+ Copyright_Displayed := True;
+ end if;
+ end Display_Copyright;
+
+ --------------------
+ -- Parse_Cmd_Line --
+ --------------------
+
+ procedure Parse_Cmd_Line is
+ begin
+ loop
+ case GNAT.Command_Line.Getopt ("f q v") is
+ when ASCII.NUL =>
+ exit;
+
+ when 'f' =>
+ Force := True;
+
+ when 'q' =>
+ Quiet := True;
+
+ when 'v' =>
+ Verbose := True;
+
+ when others =>
+ Fail ("invalid switch: ", Full_Switch);
+ end case;
+ end loop;
+
+ -- Get the file names
+
+ loop
+ declare
+ S : constant String_Access :=
+ new String'(GNAT.Command_Line.Get_Argument);
+
+ begin
+ exit when S'Length = 0;
+
+ if Symbol_File_Name = null then
+ Symbol_File_Name := S;
+
+ else
+ Object_Files.Increment_Last;
+ Object_Files.Table (Object_Files.Last) := S;
+ end if;
+ end;
+ end loop;
+ exception
+ when Invalid_Switch =>
+ Usage;
+ Fail ("invalid switch : ", Full_Switch);
+ end Parse_Cmd_Line;
+
+ -----------
+ -- Usage --
+ -----------
+
+ procedure Usage is
+ begin
+ Write_Line ("gnatsym [options] sym_file object_file {object_file}");
+ Write_Eol;
+ Write_Line (" -f Force generation of symbol file");
+ Write_Line (" -q Quiet mode");
+ Write_Line (" -v Verbose mode");
+ Write_Eol;
+ end Usage;
+
+-- Start of processing of Gnatsym
+
+begin
+ -- Initialize Object_Files table
+
+ Object_Files.Set_Last (0);
+
+ -- Parse the command line
+
+ Parse_Cmd_Line;
+
+ if Verbose then
+ Display_Copyright;
+ end if;
+
+ -- If there is no symbol file or no object files on the command line,
+ -- display the usage and exit with an error status.
+
+ if Object_Files.Last = 0 then
+ Usage;
+ OS_Exit (1);
+
+ else
+ if Verbose then
+ Write_Str ("Initializing symbol file """);
+ Write_Str (Symbol_File_Name.all);
+ Write_Line ("""");
+ end if;
+
+ -- Initialize the symbol file
+
+ Symbols.Initialize (Symbol_File_Name.all, Force, Quiet, Success);
+
+ -- Process the object files in order. Stop as soon as there is
+ -- something wrong.
+
+ Object_File := 0;
+
+ while Success and then Object_File < Object_Files.Last loop
+ Object_File := Object_File + 1;
+
+ if Verbose then
+ Write_Str ("Processing object file """);
+ Write_Str (Object_Files.Table (Object_File).all);
+ Write_Line ("""");
+ end if;
+
+ Process (Object_Files.Table (Object_File).all, Success);
+ end loop;
+
+ -- Finalize the object file
+
+ if Success then
+ if Verbose then
+ Write_Str ("Finalizing """);
+ Write_Str (Symbol_File_Name.all);
+ Write_Line ("""");
+ end if;
+
+ Finalize (Quiet, Success);
+ end if;
+
+ if not Success then
+ Fail ("unable to build symbol file");
+ end if;
+ end if;
+end Gnatsym;
diff --git a/gcc/ada/gnatvsn.adb b/gcc/ada/gnatvsn.adb
index ebada983ed8..cbeadd5d3f6 100644
--- a/gcc/ada/gnatvsn.adb
+++ b/gcc/ada/gnatvsn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-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- --
@@ -27,55 +27,33 @@
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body Gnatvsn is
- -- Import the string constant defined in the (language-independent)
- -- source file version.c.
-
- -- The size is a lie; we have no way of writing the truth (the size
- -- is variable and depends on the actual text of the constant).
-
- -- FIXME: It should be possible to declare this to be a constant, but
- -- that is rejected by the compiler ("invalid context for deferred
- -- constant declaration"). Per Ada95 this constraint only applies to
- -- deferred constants completed by a full constant declaration, not
- -- deferred constants completed by a pragma Import.
-
- Version_String : array (0 .. Ver_Len_Max) of aliased Character;
+ Version_String : String (1 .. Ver_Len_Max);
+ -- Import the C string defined in the (language-independent) source file
+ -- version.c.
+ -- The size is not the real one, which does not matter since we will
+ -- check for the nul character in Gnat_Version_String.
pragma Import (C, Version_String, "version_string");
- -- Convert that string constant to an Ada String and return it.
- -- This is essentially the same as the To_Ada routine in
- -- Interfaces.C; that package is not linked into gnat1 so
- -- we cannot use it.
-
- function Gnat_Version_String return String
- is
- Count : Natural := 0;
+ -------------------------
+ -- Gnat_Version_String --
+ -------------------------
+ function Gnat_Version_String return String is
+ NUL_Pos : Positive := 1;
begin
loop
- if Version_String (Count) = Character'First then
- exit;
- else
- Count := Count + 1;
- end if;
- end loop;
-
- declare
- R : String (1 .. Count);
+ exit when Version_String (NUL_Pos) = ASCII.NUL;
- begin
- for J in R'Range loop
- R (J) := Version_String (J - 1);
- end loop;
+ NUL_Pos := NUL_Pos + 1;
+ end loop;
- return R;
- end;
+ return Version_String (1 .. NUL_Pos - 1);
end Gnat_Version_String;
end Gnatvsn;
diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads
index a6b8371c31f..82996cf0483 100644
--- a/gcc/ada/gnatvsn.ads
+++ b/gcc/ada/gnatvsn.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -36,23 +36,17 @@
package Gnatvsn is
- function Gnat_Version_String
- return String;
+ function Gnat_Version_String return String;
-- Version output when GNAT (compiler), or its related tools, including
-- GNATBIND, GNATCHOP, GNATFIND, GNATLINK, GNATMAKE, GNATXREF, are run
-- (with appropriate verbose option switch set).
Gnat_Version_Type : constant String := "FSF ";
- -- This string is set to one of three values:
- --
- -- "FSF "
- -- GNAT FSF version. This version of GNAT is part of a Free Software
- -- Foundation release of the GNU Compiler Collection (GCC). The binder
- -- will not output informational messages regarding intended use.
- -- and the bug box generated by Comperr will give information on
- -- how to report bugs and list the "no warranty" information.
- --
- -- These are the only allowable settings for this string
+ -- GNAT FSF version. This version of GNAT is part of a Free Software
+ -- Foundation release of the GNU Compiler Collection (GCC). The binder
+ -- will not output informational messages regarding intended use,
+ -- and the bug box generated by Comperr will give information on
+ -- how to report bugs and list the "no warranty" information.
Ver_Len_Max : constant := 32;
-- Longest possible length for Gnat_Version_String in this or any
@@ -61,7 +55,7 @@ package Gnatvsn is
-- value should never be decreased in the future, but it would be
-- OK to increase it if absolutely necessary.
- Library_Version : constant String := "GNAT Lib v3.15";
+ Library_Version : constant String := "GNAT Lib v3.4";
-- Library version. This value must be updated whenever any change to the
-- compiler affects the library formats in such a way as to obsolete
-- previously compiled library modules.
@@ -69,4 +63,11 @@ package Gnatvsn is
-- Note: Makefile.in relies on the precise format of the library version
-- string in order to correctly construct the soname value.
+ ASIS_Version_Number : constant := 2;
+ -- ASIS Version. This is used to check for consistency between the compiler
+ -- used to generate trees, and an ASIS application that is reading the
+ -- trees. It must be updated (incremented) whenever a change is made to
+ -- the tree format that would result in a compiler being incompatible with
+ -- an older version of ASIS, or vice versa.
+
end Gnatvsn;
diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb
index 3f688738fcb..7e429585b93 100644
--- a/gcc/ada/gnatxref.adb
+++ b/gcc/ada/gnatxref.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-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- --
@@ -19,6 +19,9 @@
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
------------------------------------------------------------------------------
with Xr_Tabls; use Xr_Tabls;
@@ -32,6 +35,7 @@ with Opt;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Command_Line; use GNAT.Command_Line;
+with GNAT.Strings; use GNAT.Strings;
procedure Gnatxref is
@@ -46,6 +50,9 @@ procedure Gnatxref is
Have_File : Boolean := False;
Der_Info : Boolean := False;
+ RTS_Specified : String_Access := null;
+ -- Used to detect multiple use of --RTS= switch
+
procedure Parse_Cmd_Line;
-- Parse every switch on the command line
@@ -120,15 +127,24 @@ procedure Gnatxref is
-- The only switch starting with -- recognized is --RTS
when '-' =>
+ -- Check that it is the first time we see this switch
+
+ if RTS_Specified = null then
+ RTS_Specified := new String'(GNAT.Command_Line.Parameter);
+
+ elsif RTS_Specified.all /= GNAT.Command_Line.Parameter then
+ Osint.Fail ("--RTS cannot be specified multiple times");
+ end if;
+
Opt.No_Stdinc := True;
Opt.RTS_Switch := True;
declare
- Src_Path_Name : String_Ptr :=
+ Src_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
(GNAT.Command_Line.Parameter, Include);
- Lib_Path_Name : String_Ptr :=
+ Lib_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
(GNAT.Command_Line.Parameter, Objects);
@@ -197,7 +213,7 @@ procedure Gnatxref is
begin
Put_Line ("GNATXREF " & Gnatvsn.Gnat_Version_String
- & " Copyright 1998-2002, Ada Core Technologies Inc.");
+ & " Copyright 1998-2003, Ada Core Technologies Inc.");
Put_Line ("Usage: gnatxref [switches] file1 file2 ...");
New_Line;
Put_Line (" file ... list of source files to xref, " &
diff --git a/gcc/ada/gpr2make.adb b/gcc/ada/gpr2make.adb
new file mode 100644
index 00000000000..eb93f345fc3
--- /dev/null
+++ b/gcc/ada/gpr2make.adb
@@ -0,0 +1,34 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G P R 2 M A K E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Bld;
+
+procedure Gpr2make is
+begin
+ -- The real work is done in package Bld.
+
+ Bld.Gpr2make;
+end Gpr2make;
diff --git a/gcc/ada/gpr2make.ads b/gcc/ada/gpr2make.ads
new file mode 100644
index 00000000000..0f05e9046d7
--- /dev/null
+++ b/gcc/ada/gpr2make.ads
@@ -0,0 +1,30 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G P R 2 M A K E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+procedure Gpr2make;
+-- The driver for the gpr2make tool. This utility is a Makefile generator
+-- to help building multi-language applications, using multi-language
+-- GNAT project files.
diff --git a/gcc/ada/gprcmd.adb b/gcc/ada/gprcmd.adb
new file mode 100644
index 00000000000..3d5766df703
--- /dev/null
+++ b/gcc/ada/gprcmd.adb
@@ -0,0 +1,423 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G P R C M D --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- A utility used by Makefile.generic to handle multi-language builds.
+-- gprcmd provides a set of commands so that the makefiles do not need
+-- to depend on unix utilities not available on all targets.
+
+-- The list of commands recognized by gprcmd are:
+
+-- pwd display current directory
+-- to_lower display next argument in lower case
+-- to_absolute convert pathnames to absolute directories when needed
+-- cat dump contents of a given file
+-- extend handle recursive directories ("/**" notation)
+-- deps post process dependency makefiles
+-- stamp copy file time stamp from file1 to file2
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Text_IO; use Ada.Text_IO;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.Regpat; use GNAT.Regpat;
+with Gnatvsn;
+
+procedure Gprcmd is
+
+ -- ??? comments are thin throughout this unit
+
+ Version : constant String :=
+ "GPRCMD " & Gnatvsn.Gnat_Version_String &
+ " Copyright 2002-2003, Ada Core Technologies Inc.";
+
+ procedure Cat (File : String);
+ -- Print the contents of file on standard output.
+ -- If the file cannot be read, exit the process with an error code.
+
+ procedure Check_Args (Condition : Boolean);
+ -- If Condition is false, print the usage, and exit the process.
+
+ procedure Deps (Objext : String; File : String; GCC : Boolean);
+ -- Process $(CC) dependency file. If GCC is True, add a rule so that make
+ -- will not complain when a file is removed/added. If GCC is False, add a
+ -- rule to recompute the dependency file when needed
+
+ procedure Extend (Dir : String);
+ -- If Dir ends with /**, Put all subdirs recursively on standard output,
+ -- otherwise put Dir.
+
+ procedure Usage;
+ -- Display the command line options and exit the process.
+
+ procedure Copy_Time_Stamp (From, To : String);
+ -- Copy file time stamp from file From to file To.
+
+ ---------
+ -- Cat --
+ ---------
+
+ procedure Cat (File : String) is
+ FD : File_Descriptor;
+ Buffer : String_Access;
+ Length : Integer;
+
+ begin
+ FD := Open_Read (File, Fmode => Binary);
+
+ if FD = Invalid_FD then
+ OS_Exit (2);
+ end if;
+
+ Length := Integer (File_Length (FD));
+ Buffer := new String (1 .. Length);
+ Length := Read (FD, Buffer.all'Address, Length);
+ Close (FD);
+ Put (Buffer.all);
+ Free (Buffer);
+ end Cat;
+
+ ----------------
+ -- Check_Args --
+ ----------------
+
+ procedure Check_Args (Condition : Boolean) is
+ begin
+ if not Condition then
+ Usage;
+ end if;
+ end Check_Args;
+
+ ---------------------
+ -- Copy_Time_Stamp --
+ ---------------------
+
+ procedure Copy_Time_Stamp (From, To : String) is
+ function Copy_Attributes
+ (From, To : String;
+ Mode : Integer) return Integer;
+ pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
+ -- Mode = 0 - copy only time stamps.
+ -- Mode = 1 - copy time stamps and read/write/execute attributes
+
+ FD : File_Descriptor;
+
+ begin
+ if not Is_Regular_File (From) then
+ return;
+ end if;
+
+ FD := Create_File (To, Fmode => Binary);
+
+ if FD = Invalid_FD then
+ OS_Exit (2);
+ end if;
+
+ Close (FD);
+
+ if Copy_Attributes (From & ASCII.NUL, To & ASCII.NUL, 0) /= 0 then
+ OS_Exit (2);
+ end if;
+ end Copy_Time_Stamp;
+
+ ----------
+ -- Deps --
+ ----------
+
+ procedure Deps (Objext : String; File : String; GCC : Boolean) is
+ Colon : constant String := ':' & ASCII.LF;
+ NL : constant String := (1 => ASCII.LF);
+ Base : constant String := ' ' & Base_Name (File) & ": ";
+ FD : File_Descriptor;
+ Buffer : String_Access;
+ Length : Integer;
+ Obj_Regexp : constant Pattern_Matcher :=
+ Compile ("^.*\" & Objext & ": ");
+ Matched : Match_Array (0 .. 0);
+ Start : Natural;
+ First : Natural;
+ Last : Natural;
+
+ begin
+ FD := Open_Read_Write (File, Fmode => Binary);
+
+ if FD = Invalid_FD then
+ return;
+ end if;
+
+ Length := Integer (File_Length (FD));
+ Buffer := new String (1 .. Length);
+ Length := Read (FD, Buffer.all'Address, Length);
+
+ if GCC then
+ Lseek (FD, 0, Seek_End);
+ else
+ Close (FD);
+ FD := Create_File (File, Fmode => Binary);
+ end if;
+
+ Start := Buffer'First;
+
+ while Start <= Buffer'Last loop
+
+ -- Parse Buffer line by line
+
+ while Start < Buffer'Last
+ and then (Buffer (Start) = ASCII.CR
+ or else Buffer (Start) = ASCII.LF)
+ loop
+ Start := Start + 1;
+ end loop;
+
+ Last := Start;
+
+ while Last < Buffer'Last
+ and then Buffer (Last + 1) /= ASCII.CR
+ and then Buffer (Last + 1) /= ASCII.LF
+ loop
+ Last := Last + 1;
+ end loop;
+
+ Match (Obj_Regexp, Buffer (Start .. Last), Matched);
+
+ if GCC then
+ if Matched (0) = No_Match then
+ First := Start;
+ else
+ First := Matched (0).Last + 1;
+ end if;
+
+ Length := Write (FD, Buffer (First)'Address, Last - First + 1);
+
+ if Start = Last or else Buffer (Last) = '\' then
+ Length := Write (FD, NL (1)'Address, NL'Length);
+ else
+ Length := Write (FD, Colon (1)'Address, Colon'Length);
+ end if;
+
+ else
+ if Matched (0) = No_Match then
+ First := Start;
+ else
+ Length :=
+ Write (FD, Buffer (Start)'Address,
+ Matched (0).Last - Start - 1);
+ Length := Write (FD, Base (Base'First)'Address, Base'Length);
+ First := Matched (0).Last + 1;
+ end if;
+
+ Length := Write (FD, Buffer (First)'Address, Last - First + 1);
+ Length := Write (FD, NL (1)'Address, NL'Length);
+ end if;
+
+ Start := Last + 1;
+ end loop;
+
+ Close (FD);
+ Free (Buffer);
+ end Deps;
+
+ ------------
+ -- Extend --
+ ------------
+
+ procedure Extend (Dir : String) is
+
+ procedure Recursive_Extend (D : String);
+ -- Recursively display all subdirectories of D.
+
+ ----------------------
+ -- Recursive_Extend --
+ ----------------------
+
+ procedure Recursive_Extend (D : String) is
+ Iter : Dir_Type;
+ Buffer : String (1 .. 8192);
+ Last : Natural;
+
+ begin
+ Open (Iter, D);
+
+ loop
+ Read (Iter, Buffer, Last);
+
+ exit when Last = 0;
+
+ if Buffer (1 .. Last) /= "."
+ and then Buffer (1 .. Last) /= ".."
+ then
+ declare
+ Abs_Dir : constant String := D & Buffer (1 .. Last);
+
+ begin
+ if Is_Directory (Abs_Dir)
+ and then not Is_Symbolic_Link (Abs_Dir)
+ then
+ Put (' ' & Abs_Dir);
+ Recursive_Extend (Abs_Dir & '/');
+ end if;
+ end;
+ end if;
+ end loop;
+
+ Close (Iter);
+
+ exception
+ when Directory_Error =>
+ null;
+ end Recursive_Extend;
+
+ -- Start of processing for Extend
+
+ begin
+ if Dir'Length < 3
+ or else (Dir (Dir'Last - 2) /= '/'
+ and then Dir (Dir'Last - 2) /= Directory_Separator)
+ or else Dir (Dir'Last - 1 .. Dir'Last) /= "**"
+ then
+ Put (Dir);
+ return;
+ end if;
+
+ declare
+ D : constant String := Dir (Dir'First .. Dir'Last - 2);
+ begin
+ Put (D);
+ Recursive_Extend (D);
+ end;
+ end Extend;
+
+ -----------
+ -- Usage --
+ -----------
+
+ procedure Usage is
+ begin
+ Put_Line (Standard_Error, "usage: gprcmd cmd [arguments]");
+ Put_Line (Standard_Error, "where cmd is one of the following commands:");
+ Put_Line (Standard_Error, " pwd " &
+ "display current directory");
+ Put_Line (Standard_Error, " to_lower " &
+ "display next argument in lower case");
+ Put_Line (Standard_Error, " to_absolute " &
+ "convert pathnames to absolute " &
+ "directories when needed");
+ Put_Line (Standard_Error, " cat " &
+ "dump contents of a given file");
+ Put_Line (Standard_Error, " extend " &
+ "handle recursive directories " &
+ "(""/**"" notation)");
+ Put_Line (Standard_Error, " deps " &
+ "post process dependency makefiles");
+ Put_Line (Standard_Error, " stamp " &
+ "copy file time stamp from file1 to file2");
+ OS_Exit (1);
+ end Usage;
+
+-- Start of processing for Gprcmd
+
+begin
+ Check_Args (Argument_Count > 0);
+
+ declare
+ Cmd : constant String := Argument (1);
+
+ begin
+ if Cmd = "-v" then
+ Put_Line (Standard_Error, Version);
+ Usage;
+
+ elsif Cmd = "pwd" then
+ Put (Format_Pathname (Get_Current_Dir, UNIX));
+
+ elsif Cmd = "cat" then
+ Check_Args (Argument_Count = 2);
+ Cat (Argument (2));
+
+ elsif Cmd = "to_lower" then
+ Check_Args (Argument_Count >= 2);
+
+ for J in 2 .. Argument_Count loop
+ Put (To_Lower (Argument (J)));
+
+ if J < Argument_Count then
+ Put (' ');
+ end if;
+ end loop;
+
+ elsif Cmd = "to_absolute" then
+ Check_Args (Argument_Count > 2);
+
+ declare
+ Dir : constant String := Argument (2);
+
+ begin
+ for J in 3 .. Argument_Count loop
+ if Is_Absolute_Path (Argument (J)) then
+ Put (Format_Pathname (Argument (J), UNIX));
+ else
+ Put (Format_Pathname (Normalize_Pathname (Argument (J), Dir),
+ UNIX));
+ end if;
+
+ if J < Argument_Count then
+ Put (' ');
+ end if;
+ end loop;
+ end;
+
+ elsif Cmd = "extend" then
+ Check_Args (Argument_Count >= 2);
+
+ declare
+ Dir : constant String := Argument (2);
+
+ begin
+ for J in 3 .. Argument_Count loop
+ if Is_Absolute_Path (Argument (J)) then
+ Extend (Format_Pathname (Argument (J), UNIX));
+ else
+ Extend
+ (Format_Pathname (Normalize_Pathname (Argument (J), Dir),
+ UNIX));
+ end if;
+
+ if J < Argument_Count then
+ Put (' ');
+ end if;
+ end loop;
+ end;
+
+ elsif Cmd = "deps" then
+ Check_Args (Argument_Count in 3 .. 4);
+ Deps (Argument (2), Argument (3), GCC => Argument_Count = 4);
+
+ elsif Cmd = "stamp" then
+ Check_Args (Argument_Count = 3);
+ Copy_Time_Stamp (Argument (2), Argument (3));
+ end if;
+ end;
+end Gprcmd;
diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb
new file mode 100644
index 00000000000..635d0df8b2b
--- /dev/null
+++ b/gcc/ada/gprep.adb
@@ -0,0 +1,439 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G P R E P --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Text_IO; use Ada.Text_IO;
+
+with Csets;
+with Err_Vars; use Err_Vars;
+with Errutil;
+with Gnatvsn;
+with Namet; use Namet;
+with Opt;
+with Osint; use Osint;
+with Output; use Output;
+with Prep; use Prep;
+with Scng;
+with Sinput.C;
+with Snames;
+with Stringt; use Stringt;
+with Types; use Types;
+
+with GNAT.Command_Line;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+package body GPrep is
+
+ Copyright_Displayed : Boolean := False;
+ -- Used to prevent multiple displays of the copyright notice
+
+ ------------------------
+ -- Argument Line Data --
+ ------------------------
+
+ Infile_Name : String_Access;
+ Outfile_Name : String_Access;
+ Deffile_Name : String_Access;
+
+ Source_Ref_Pragma : Boolean := False; -- Set if -r switch set
+ -- Record command line options
+
+ Text_Outfile : aliased Ada.Text_IO.File_Type;
+ Outfile : File_Access := Text_Outfile'Access;
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ procedure Display_Copyright;
+ -- Display the copyright notice
+
+ procedure Post_Scan;
+ -- Null procedure, needed by instantiation of Scng below
+
+ package Scanner is new Scng
+ (Post_Scan,
+ Errutil.Error_Msg,
+ Errutil.Error_Msg_S,
+ Errutil.Error_Msg_SC,
+ Errutil.Error_Msg_SP,
+ Errutil.Style);
+ -- The scanner for the preprocessor
+
+ procedure Process_Command_Line_Symbol_Definition (S : String);
+ -- Process a -D switch on ther command line
+
+ procedure Put_Char_To_Outfile (C : Character);
+ -- Output one character to the output file.
+ -- Used to initialize the preprocessor..
+
+ procedure New_EOL_To_Outfile;
+ -- Output a new line to the output file.
+ -- used to initialize the preprocessor.
+
+ procedure Scan_Command_Line;
+ -- Scan the switches and the file names
+
+ procedure Usage;
+ -- Display the usage
+
+ -----------------------
+ -- Display_Copyright --
+ -----------------------
+
+ procedure Display_Copyright is
+ begin
+ if not Copyright_Displayed then
+ Write_Line ("GNAT Preprocessor " &
+ Gnatvsn.Gnat_Version_String &
+ " Copyright 1996-2003 Free Software Foundation, Inc.");
+ Copyright_Displayed := True;
+ end if;
+ end Display_Copyright;
+
+ --------------
+ -- Gnatprep --
+ --------------
+
+ procedure Gnatprep is
+ Infile : Source_File_Index;
+
+ begin
+ -- Do some initializations (order is important here!)
+
+ Csets.Initialize;
+ Namet.Initialize;
+ Snames.Initialize;
+ Stringt.Initialize;
+
+ -- Initialize the preprocessor
+
+ Prep.Initialize
+ (Error_Msg => Errutil.Error_Msg'Access,
+ Scan => Scanner.Scan'Access,
+ Set_Ignore_Errors => Errutil.Set_Ignore_Errors'Access,
+ Put_Char => Put_Char_To_Outfile'Access,
+ New_EOL => New_EOL_To_Outfile'Access);
+
+ -- Set the scanner characteristics for the preprocessor
+
+ Scanner.Set_Special_Character ('#');
+ Scanner.Set_Special_Character ('$');
+ Scanner.Set_End_Of_Line_As_Token (True);
+
+ -- Initialize the mapping table of symbols to values
+
+ Prep.Symbol_Table.Init (Prep.Mapping);
+
+ -- Parse the switches and arguments
+
+ Scan_Command_Line;
+
+ if Opt.Verbose_Mode then
+ Display_Copyright;
+ end if;
+
+ -- Test we had all the arguments needed
+
+ if Infile_Name = null then
+ -- No input file specified, just output the usage and exit
+
+ Usage;
+ return;
+ elsif Outfile_Name = null then
+ -- No output file specified, just output the usage and exit
+
+ Usage;
+ return;
+ end if;
+
+ -- If a pragma Source_File_Name, we need to keep line numbers.
+ -- So, if the deleted lines are not put as comment, we must output them
+ -- as blank lines.
+
+ if Source_Ref_Pragma and (not Opt.Comment_Deleted_Lines) then
+ Opt.Blank_Deleted_Lines := True;
+ end if;
+
+ -- If we have a definition file, parse it
+
+ if Deffile_Name /= null then
+ declare
+ Deffile : Source_File_Index;
+
+ begin
+ Errutil.Initialize;
+ Deffile := Sinput.C.Load_File (Deffile_Name.all);
+
+ -- Set Main_Source_File to the definition file for the benefit of
+ -- Errutil.Finalize.
+
+ Sinput.Main_Source_File := Deffile;
+
+ if Deffile = No_Source_File then
+ Fail ("unable to find definition file """,
+ Deffile_Name.all,
+ """");
+ end if;
+
+ Scanner.Initialize_Scanner (No_Unit, Deffile);
+
+ Prep.Parse_Def_File;
+ end;
+ end if;
+
+ -- If there are errors in the definition file, output these errors
+ -- and exit.
+
+ if Total_Errors_Detected > 0 then
+ Errutil.Finalize (Source_Type => "definition");
+ Fail ("errors in definition file """, Deffile_Name.all, """");
+ end if;
+
+ -- If -s switch was specified, print a sorted list of symbol names and
+ -- values, if any.
+
+ if Opt.List_Preprocessing_Symbols then
+ Prep.List_Symbols (Foreword => "");
+ end if;
+
+ -- Load the input file
+
+ Infile := Sinput.C.Load_File (Infile_Name.all);
+
+ if Infile = No_Source_File then
+ Fail ("unable to find input file """, Infile_Name.all, """");
+ end if;
+
+ -- Set Main_Source_File to the input file for the benefit of
+ -- Errutil.Finalize.
+
+ Sinput.Main_Source_File := Infile;
+
+ Scanner.Initialize_Scanner (No_Unit, Infile);
+
+ -- If an output file were specified, create it; fails if this did not
+ -- work.
+
+ if Outfile_Name /= null then
+ begin
+ Create (Text_Outfile, Out_File, Outfile_Name.all);
+
+ exception
+ when others =>
+ Fail
+ ("unable to create output file """, Outfile_Name.all, """");
+ end;
+ end if;
+
+ -- Output the SFN pragma if asked to
+
+ if Source_Ref_Pragma then
+ Put_Line (Outfile.all, "pragma Source_Reference (1, """ &
+ Get_Name_String (Sinput.File_Name (Infile)) &
+ """);");
+ end if;
+
+ -- Preprocess the input file
+
+ Prep.Preprocess;
+
+ -- In verbose mode, if there is no error, report it
+
+ if Opt.Verbose_Mode and then Err_Vars.Total_Errors_Detected = 0 then
+ Errutil.Finalize (Source_Type => "input");
+ end if;
+
+ -- If we had some errors, delete the output file, and report the errors,
+
+ if Err_Vars.Total_Errors_Detected > 0 then
+ if Outfile /= Standard_Output then
+ Delete (Text_Outfile);
+ end if;
+
+ Errutil.Finalize (Source_Type => "input");
+
+ -- otherwise, close the output file, and we are done.
+
+ elsif Outfile /= Standard_Output then
+ Close (Text_Outfile);
+ end if;
+ end Gnatprep;
+
+ ------------------------
+ -- New_EOL_To_Outfile --
+ ------------------------
+
+ procedure New_EOL_To_Outfile is
+ begin
+ New_Line (Outfile.all);
+ end New_EOL_To_Outfile;
+
+ ---------------
+ -- Post_Scan --
+ ---------------
+
+ procedure Post_Scan is
+ begin
+ null;
+ end Post_Scan;
+
+ --------------------------------------------
+ -- Process_Command_Line_Symbol_Definition --
+ --------------------------------------------
+
+ procedure Process_Command_Line_Symbol_Definition (S : String) is
+ Data : Symbol_Data;
+ Symbol : Symbol_Id;
+
+ begin
+ -- Check the symbol definition and get the symbol and its value.
+ -- Fail if symbol definition is illegal.
+
+ Check_Command_Line_Symbol_Definition (S, Data);
+
+ Symbol := Index_Of (Data.Symbol);
+
+ -- If symbol does not alrady exist, create a new entry in the mapping
+ -- table.
+
+ if Symbol = No_Symbol then
+ Symbol_Table.Increment_Last (Mapping);
+ Symbol := Symbol_Table.Last (Mapping);
+ end if;
+
+ Mapping.Table (Symbol) := Data;
+ end Process_Command_Line_Symbol_Definition;
+
+ -------------------------
+ -- Put_Char_To_Outfile --
+ -------------------------
+
+ procedure Put_Char_To_Outfile (C : Character) is
+ begin
+ Put (Outfile.all, C);
+ end Put_Char_To_Outfile;
+
+ -----------------------
+ -- Scan_Command_Line --
+ -----------------------
+
+ procedure Scan_Command_Line is
+ Switch : Character;
+
+ begin
+ -- Parse the switches
+
+ loop
+ begin
+ Switch := GNAT.Command_Line.Getopt ("D: b c r s u v");
+ case Switch is
+
+ when ASCII.NUL =>
+ exit;
+
+ when 'D' =>
+ Process_Command_Line_Symbol_Definition
+ (S => GNAT.Command_Line.Parameter);
+
+ when 'b' =>
+ Opt.Blank_Deleted_Lines := True;
+
+ when 'c' =>
+ Opt.Comment_Deleted_Lines := True;
+
+ when 'r' =>
+ Source_Ref_Pragma := True;
+
+ when 's' =>
+ Opt.List_Preprocessing_Symbols := True;
+
+ when 'u' =>
+ Opt.Undefined_Symbols_Are_False := True;
+
+ when 'v' =>
+ Opt.Verbose_Mode := True;
+
+ when others =>
+ Fail ("Invalid Switch: -" & Switch);
+ end case;
+
+ exception
+ when GNAT.Command_Line.Invalid_Switch =>
+ Write_Str ("Invalid Switch: -");
+ Write_Line (GNAT.Command_Line.Full_Switch);
+ Usage;
+ OS_Exit (1);
+ end;
+ end loop;
+
+ -- Get the file names
+
+ loop
+ declare
+ S : constant String := GNAT.Command_Line.Get_Argument;
+
+ begin
+ exit when S'Length = 0;
+
+ if Infile_Name = null then
+ Infile_Name := new String'(S);
+ elsif Outfile_Name = null then
+ Outfile_Name := new String'(S);
+ elsif Deffile_Name = null then
+ Deffile_Name := new String'(S);
+ else
+ Fail ("too many arguments specifed");
+ end if;
+ end;
+ end loop;
+ end Scan_Command_Line;
+
+ -----------
+ -- Usage --
+ -----------
+
+ procedure Usage is
+ begin
+ Display_Copyright;
+ Write_Line ("Usage: gnatprep [-bcrsuv] [-Dsymbol=value] " &
+ "infile outfile [deffile]");
+ Write_Eol;
+ Write_Line (" infile Name of the input file");
+ Write_Line (" outfile Name of the output file");
+ Write_Line (" deffile Name of the definition file");
+ Write_Eol;
+ Write_Line ("gnatprep switches:");
+ Write_Line (" -b Replace preprocessor lines by blank lines");
+ Write_Line (" -c Keep preprocessor lines as comments");
+ Write_Line (" -D Associate symbol with value");
+ Write_Line (" -r Generate Source_Reference pragma");
+ Write_Line (" -s Print a sorted list of symbol names and values");
+ Write_Line (" -u Treat undefined symbols as FALSE");
+ Write_Line (" -v Verbose mode");
+ Write_Eol;
+ end Usage;
+
+end GPrep;
diff --git a/gcc/ada/gprep.ads b/gcc/ada/gprep.ads
new file mode 100644
index 00000000000..e77e7dff21d
--- /dev/null
+++ b/gcc/ada/gprep.ads
@@ -0,0 +1,34 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G P R E P --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package is the implementation of GNATPREP.
+
+package GPrep is
+
+ procedure Gnatprep;
+ -- Called by gnatprep
+
+end GPrep;
diff --git a/gcc/ada/hostparm.ads b/gcc/ada/hostparm.ads
index 688dd0b6527..6166244f6a8 100644
--- a/gcc/ada/hostparm.ads
+++ b/gcc/ada/hostparm.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -66,7 +66,8 @@ package Hostparm is
-- 2**15 - 1, a limit imposed by the assumption that column numbers
-- can be stored in 16 bits (see Types.Column_Number). A value of
-- 200 is the minimum value required (RM 2.2(15)), but we use 255
- -- for most GNAT targets since this is DEC Ada compatible.
+ -- for most GNAT targets since this is DEC Ada compatible. The value
+ -- set here can be overridden by the explicit use of -gnatyM.
Max_Name_Length : constant := 1024;
-- Maximum length of unit name (including all dots, and " (spec)") and
diff --git a/gcc/ada/i-c.ads b/gcc/ada/i-c.ads
index 48b37656b72..9b97258c181 100644
--- a/gcc/ada/i-c.ads
+++ b/gcc/ada/i-c.ads
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
@@ -6,10 +6,32 @@
-- --
-- S p e c --
-- --
--- This specification is adapted from the Ada Reference Manual for use with --
--- GNAT. In accordance with the copyright of that document, you can freely --
--- copy and modify this specification, provided that if you redistribute a --
--- modified version, any changes that you have made are clearly indicated. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -135,4 +157,6 @@ pragma Pure (C);
Terminator_Error : exception;
+private
+ -- No private declarations required
end Interfaces.C;
diff --git a/gcc/ada/i-cobol.adb b/gcc/ada/i-cobol.adb
index b25028e9ec7..7dc1f851bed 100644
--- a/gcc/ada/i-cobol.adb
+++ b/gcc/ada/i-cobol.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -984,6 +984,7 @@ package body Interfaces.COBOL is
return Boolean
is
Val : Num;
+ pragma Unreferenced (Val);
begin
Val := To_Decimal (Item, Format);
diff --git a/gcc/ada/i-cpp.adb b/gcc/ada/i-cpp.adb
index 42ab384e18b..b54d6d98e9c 100644
--- a/gcc/ada/i-cpp.adb
+++ b/gcc/ada/i-cpp.adb
@@ -320,7 +320,7 @@ package body Interfaces.CPP is
-------------------
function Expanded_Name (T : Vtable_Ptr) return String is
- Result : Cstring_Ptr := T.TSD.Expanded_Name;
+ Result : constant Cstring_Ptr := T.TSD.Expanded_Name;
begin
return Result (1 .. Length (Result));
@@ -331,7 +331,7 @@ package body Interfaces.CPP is
------------------
function External_Tag (T : Vtable_Ptr) return String is
- Result : Cstring_Ptr := T.TSD.External_Tag;
+ Result : constant Cstring_Ptr := T.TSD.External_Tag;
begin
return Result (1 .. Length (Result));
diff --git a/gcc/ada/i-cstrea.ads b/gcc/ada/i-cstrea.ads
index c6227298381..4650cdbde83 100644
--- a/gcc/ada/i-cstrea.ads
+++ b/gcc/ada/i-cstrea.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1995-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- --
diff --git a/gcc/ada/i-cstrin.adb b/gcc/ada/i-cstrin.adb
index 6849db2ee91..0b7805bae74 100644
--- a/gcc/ada/i-cstrin.adb
+++ b/gcc/ada/i-cstrin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,11 +32,17 @@
------------------------------------------------------------------------------
with System; use System;
-with System.Address_To_Access_Conversions;
+with System.Storage_Elements; use System.Storage_Elements;
+
+with Unchecked_Conversion;
package body Interfaces.C.Strings is
- package Char_Access is new Address_To_Access_Conversions (char);
+ function To_chars_ptr is
+ new Unchecked_Conversion (Address, chars_ptr);
+
+ function To_Address is
+ new Unchecked_Conversion (chars_ptr, Address);
-----------------------
-- Local Subprograms --
@@ -72,7 +78,7 @@ package body Interfaces.C.Strings is
function "+" (Left : chars_ptr; Right : size_t) return chars_ptr is
begin
- return Left + chars_ptr (Right);
+ return To_chars_ptr (To_Address (Left) + Storage_Offset (Right));
end "+";
----------
@@ -119,7 +125,7 @@ package body Interfaces.C.Strings is
Offset => 0,
Chars => Chars,
Check => False);
- Poke (nul, into => Pointer + size_t '(Chars'Length));
+ Poke (nul, into => Pointer + size_t'(Chars'Length));
end if;
return Pointer;
@@ -139,9 +145,8 @@ package body Interfaces.C.Strings is
----------
function Peek (From : chars_ptr) return char is
- use Char_Access;
begin
- return To_Pointer (Address (To_Address (From))).all;
+ return char (From.all);
end Peek;
----------
@@ -149,9 +154,8 @@ package body Interfaces.C.Strings is
----------
procedure Poke (Value : char; Into : chars_ptr) is
- use Char_Access;
begin
- To_Pointer (Address (To_Address (Into))).all := Value;
+ Into.all := Character (Value);
end Poke;
---------------------
@@ -207,7 +211,8 @@ package body Interfaces.C.Strings is
then
raise Terminator_Error;
else
- return To_Integer (Item (Item'First)'Address);
+ return To_chars_ptr (Item (Item'First)'Address);
+
end if;
end To_Chars_Ptr;
diff --git a/gcc/ada/i-cstrin.ads b/gcc/ada/i-cstrin.ads
index 9ec673c724a..2f42cdea7d4 100644
--- a/gcc/ada/i-cstrin.ads
+++ b/gcc/ada/i-cstrin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1993-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1993-2002 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -35,8 +35,6 @@
-- --
------------------------------------------------------------------------------
-with System.Storage_Elements;
-
package Interfaces.C.Strings is
pragma Preelaborate (Strings);
@@ -92,12 +90,7 @@ pragma Preelaborate (Strings);
Update_Error : exception;
private
- type chars_ptr is new System.Storage_Elements.Integer_Address;
-
- Null_Ptr : constant chars_ptr := 0;
- -- A little cleaner might be To_Integer (System.Null_Address) but this is
- -- non-preelaborable, and in fact we jolly well know this value is zero.
- -- Indeed, given the C interface nature, it is probably more correct to
- -- write zero here (even if Null_Address were non-zero).
+ type chars_ptr is access all Character;
+ Null_Ptr : constant chars_ptr := null;
end Interfaces.C.Strings;
diff --git a/gcc/ada/i-pacdec.ads b/gcc/ada/i-pacdec.ads
index 0cf952889a8..089435f7e7e 100644
--- a/gcc/ada/i-pacdec.ads
+++ b/gcc/ada/i-pacdec.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Version for IBM Mainframe Packed Decimal Format) --
-- --
--- Copyright (C) 1992,1993,1994,1995 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- --
@@ -30,6 +30,7 @@
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
+------------------------------------------------------------------------------
-- This unit defines the packed decimal format used by GNAT in response to
-- a specication of Machine_Radix 10 for a decimal fixed-point type. The
diff --git a/gcc/ada/i-vthrea.adb b/gcc/ada/i-vthrea.adb
new file mode 100644
index 00000000000..049e1c4bf68
--- /dev/null
+++ b/gcc/ada/i-vthrea.adb
@@ -0,0 +1,386 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- I N T E R F A C E S . V T H R E A D S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2003, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Implement APEX process registration for AE653
+
+with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Unchecked_Conversion;
+
+with Interfaces.C;
+
+with System.Secondary_Stack;
+with System.Soft_Links;
+with System.Task_Primitives.Ae_653;
+with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
+with System.Tasking; use System.Tasking;
+with System.Task_Info;
+with System.Tasking.Initialization;
+
+package body Interfaces.Vthreads is
+
+ use System.OS_Interface;
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Enter_Task (T : Task_ID; Thread : Thread_Id);
+ -- Duplicate and generalize
+ -- System.Task_Primitives.Operations.Enter_Task
+
+ procedure GNAT_Error_Handler (Sig : Signal);
+ -- Signal handler for ARINC processes
+
+ procedure Init_Float;
+ pragma Import (C, Init_Float, "__gnat_init_float");
+ -- Properly initializes the FPU for PPC systems.
+
+ procedure Install_Handler;
+ -- Install signal handlers for the calling ARINC process
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID;
+ -- Duplicate and generalize
+ -- System.Task_Primitives.Operations.Register_Foreign_Thread
+
+ -----------------------------
+ -- Install_Signal_Handlers --
+ -----------------------------
+
+ function Install_Signal_Handlers return Interfaces.C.int is
+ begin
+ Install_Handler;
+ Init_Float;
+ return 0;
+ end Install_Signal_Handlers;
+
+ ----------------------
+ -- Register_Foreign --
+ ----------------------
+
+ -- Create Ada task data structures for an ARINC process. All dynamic
+ -- allocation of related data structures must be done via this routine.
+
+ function Register_Foreign (T : OSI.Thread_Id) return OSI.STATUS is
+ use Interfaces.C;
+ use System.Task_Primitives.Ae_653;
+
+ pragma Assert (taskVarGet (T, ATCB_Key_Addr) = ERROR);
+ -- "T" is not yet registered
+
+ Result : OSI.STATUS := taskIdVerify (T);
+ Status : OSI.STATUS := OK;
+ Temp_Id : Task_ID;
+
+ begin
+ if Result = OK then
+ Status := taskVarGet (T, ATCB_Key_Addr);
+
+ -- Error of already registered
+
+ if Status /= ERROR then
+ Result := ERROR;
+
+ else
+ -- Create a TCB
+
+ declare
+ -- Make sure the caller has a TCB, since it's possible to have
+ -- pure C APEX processes that create ones calling Ada code
+
+ Caller : Task_ID;
+
+ begin
+ Status := taskVarGet (taskIdSelf, ATCB_Key_Addr);
+
+ if Status = ERROR then
+ Caller := Register_Foreign_Thread (taskIdSelf);
+ end if;
+ end;
+
+ if taskIdSelf /= T then
+ Temp_Id := Register_Foreign_Thread (T);
+ end if;
+
+ Result := OK;
+ end if;
+ end if;
+
+ return Result;
+ end Register_Foreign;
+
+ -------------------
+ -- Reset_Foreign --
+ -------------------
+
+ -- Reinitialize Ada task data structures. No dynamic allocation
+ -- may occur via this routine.
+
+ function Reset_Foreign (T : Thread_Id) return STATUS is
+ use Interfaces.C;
+ use System.Secondary_Stack;
+ use System.Task_Primitives.Ae_653;
+ use type System.Address;
+
+ pragma Assert (taskVarGet (T, ATCB_Key_Addr) /= ERROR);
+ -- "T" has already been registered
+
+ Result : STATUS := taskVarGet (T, ATCB_Key_Addr);
+ function To_Address is new Ada.Unchecked_Conversion
+ (Interfaces.C.int, System.Address);
+
+ pragma Assert (
+ To_Task_Id
+ (To_Address (Result)).Common.Compiler_Data.Sec_Stack_Addr
+ /= System.Null_Address);
+ -- "T" already has a secondary stack
+
+ begin
+ if Result /= ERROR then
+
+ -- Just reset the secondary stack pointer. The implementation here
+ -- assumes that the fixed secondary stack implementation is used.
+ -- If not, there will be a memory leak (along with allocation, which
+ -- is prohibited for ARINC processes once the system enters "normal"
+ -- mode).
+
+ SS_Init
+ (To_Task_Id
+ (To_Address (Result)).Common.Compiler_Data.Sec_Stack_Addr);
+ Result := OK;
+ end if;
+
+ return Result;
+ end Reset_Foreign;
+
+ ------------------
+ -- Setup_Thread --
+ ------------------
+
+ function Setup_Thread return System.Address is
+ Result : System.Address := System.Null_Address;
+ Status : OSI.STATUS;
+
+ begin
+ if Is_Valid_Task then
+ Status := Reset_Foreign (taskIdSelf);
+ Result :=
+ To_Address (System.Task_Primitives.Operations.Self);
+ else
+ Status := Register_Foreign (taskIdSelf);
+ Install_Handler;
+ Init_Float;
+ Result :=
+ To_Address (System.Task_Primitives.Operations.Self);
+ end if;
+
+ return Result;
+ end Setup_Thread;
+
+ ----------------
+ -- Enter_Task --
+ ----------------
+
+ procedure Enter_Task (T : Task_ID; Thread : Thread_Id) is
+ use System.Task_Primitives.Ae_653;
+
+ begin
+ Set_Task_Thread (T, Thread);
+ end Enter_Task;
+
+ ------------------------
+ -- GNAT_Error_Handler --
+ ------------------------
+
+ procedure GNAT_Error_Handler (Sig : Signal) is
+ Mask : aliased sigset_t;
+ Result : int;
+
+ begin
+ -- This code is the Ada replacement for init.c in the
+ -- AE653 level B runtime.
+
+ -- VxWorks will always mask out the signal during the signal
+ -- handler and will reenable it on a longjmp. GNAT does not
+ -- generate a longjmp to return from a signal handler so the
+ -- signal will still be masked unless we unmask it.
+
+ Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
+ Result := sigdelset (Mask'Access, Sig);
+ Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null);
+
+ case Sig is
+ when SIGFPE =>
+ Raise_Exception (Constraint_Error'Identity, "SIGFPE");
+ when SIGILL =>
+ Raise_Exception (Constraint_Error'Identity, "SIGILL");
+ when SIGSEGV =>
+ Raise_Exception
+ (Program_Error'Identity,
+ "erroneous memory access");
+ when SIGBUS =>
+ -- SIGBUS indicates stack overflow when it occurs
+ -- in an application domain (but not in the Core
+ -- OS under AE653, or in the kernel domain under
+ -- AE 1.1).
+ Raise_Exception
+ (Storage_Error'Identity,
+ "stack overflow or SIGBUS");
+ when others =>
+ Raise_Exception (Program_Error'Identity, "unhandled signal");
+ end case;
+ end GNAT_Error_Handler;
+
+ ---------------------
+ -- Install_Handler --
+ ---------------------
+
+ procedure Install_Handler is
+ Mask : aliased sigset_t;
+ Signal_Action : aliased struct_sigaction;
+ Result : Interfaces.C.int;
+
+ begin
+ -- Set up signal handler to map synchronous signals to appropriate
+ -- exceptions. Make sure that the handler isn't interrupted by
+ -- another signal that might cause a scheduling event!
+
+ -- This code is the Ada replacement for init.c in the
+ -- AE653 level B runtime.
+ Signal_Action.sa_handler := GNAT_Error_Handler'Address;
+ Signal_Action.sa_flags := SA_ONSTACK;
+ Result := sigemptyset (Mask'Access);
+ Signal_Action.sa_mask := Mask;
+
+ Result := sigaction
+ (Signal (SIGFPE), Signal_Action'Unchecked_Access, null);
+
+ Result := sigaction
+ (Signal (SIGILL), Signal_Action'Unchecked_Access, null);
+
+ Result := sigaction
+ (Signal (SIGSEGV), Signal_Action'Unchecked_Access, null);
+
+ Result := sigaction
+ (Signal (SIGBUS), Signal_Action'Unchecked_Access, null);
+
+ end Install_Handler;
+
+ -----------------------------
+ -- Register_Foreign_Thread --
+ -----------------------------
+
+ Foreign_Task_Elaborated : aliased Boolean := True;
+
+ function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID is
+ pragma Assert (Thread = taskIdSelf or else Is_Valid_Task);
+ -- Ensure that allocation will work
+
+ Local_ATCB : aliased Ada_Task_Control_Block (0);
+ New_Id : Task_ID;
+ Succeeded : Boolean;
+
+ use type Interfaces.C.unsigned;
+ use type System.Address;
+ use System.Task_Info;
+ use System.Task_Primitives.Ae_653;
+
+ begin
+ if taskIdSelf = Thread then
+ declare
+ Self : Task_ID := Local_ATCB'Unchecked_Access;
+ -- Temporarily record this as the Task_ID for the thread
+
+ begin
+ Set_Current_Priority (Self, System.Priority'First);
+ Set_Task_Thread (Self, Thread);
+ end;
+ end if;
+
+ pragma Assert (Is_Valid_Task);
+ -- It is now safe to use an allocator for the real TCB
+
+ New_Id := new Ada_Task_Control_Block (0);
+
+ -- Finish initialization
+
+ System.Tasking.Initialize_ATCB
+ (New_Id, null, System.Null_Address, Null_Task,
+ Foreign_Task_Elaborated'Access,
+ System.Priority'First,
+ System.Task_Info.Unspecified_Task_Info, 0, New_Id,
+ Succeeded);
+ pragma Assert (Succeeded);
+
+ New_Id.Master_of_Task := 0;
+ New_Id.Master_Within := New_Id.Master_of_Task + 1;
+
+ for L in New_Id.Entry_Calls'Range loop
+ New_Id.Entry_Calls (L).Self := New_Id;
+ New_Id.Entry_Calls (L).Level := L;
+ end loop;
+
+ New_Id.Common.State := Runnable;
+ New_Id.Awake_Count := 1;
+
+ -- Since this is not an ordinary Ada task, we will start out undeferred
+
+ New_Id.Deferral_Level := 0;
+
+ System.Soft_Links.Create_TSD (New_Id.Common.Compiler_Data);
+
+ -- Allocate a fixed secondary stack
+
+ pragma Assert
+ (New_Id.Common.Compiler_Data.Sec_Stack_Addr = System.Null_Address);
+ System.Secondary_Stack.SS_Init
+ (New_Id.Common.Compiler_Data.Sec_Stack_Addr);
+
+ Enter_Task (New_Id, Thread);
+
+ return New_Id;
+ end Register_Foreign_Thread;
+
+ -- Force use of tasking versions of secondary stack routines:
+
+ procedure Force_Closure renames
+ System.Tasking.Initialization.Defer_Abortion;
+ pragma Unreferenced (Force_Closure);
+
+-- Package elaboration code
+
+begin
+ -- Register the exported routines with the vThreads ARINC API
+
+ procCreateHookAdd (Register_Foreign'Access);
+ procStartHookAdd (Reset_Foreign'Access);
+end Interfaces.Vthreads;
diff --git a/gcc/ada/i-vthrea.ads b/gcc/ada/i-vthrea.ads
new file mode 100644
index 00000000000..d4a79757cfe
--- /dev/null
+++ b/gcc/ada/i-vthrea.ads
@@ -0,0 +1,93 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- I N T E R F A C E S . V T H R E A D S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002-2003, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Implement APEX process registration for AE653. The routines exported
+-- by this package are only called from the APEX CREATE and START routines
+-- in the AE653 vThreads API. A context clause for this unit must appear in
+-- the Ada APEX binding.
+--
+-- If this package appears in a context clause for an application that will
+-- be run in a non-AE653 version of VxWorks, or in a non-vThreads AE653
+-- partition, link or load errors for the symbols procCreateHookAdd and
+-- procStartHookAdd will occur, unless these routines are defined
+-- in the application. This is used when simulating AE653 in AE 1.1.
+
+with System.OS_Interface;
+with Interfaces.C;
+
+package Interfaces.Vthreads is
+
+ function Setup_Thread return System.Address;
+ -- Register an existing vxWorks task. This routine is used
+ -- under AE 1.1 when simulating AE 653.
+
+ function Install_Signal_Handlers return Interfaces.C.int;
+ pragma Export (C, Install_Signal_Handlers,
+ "__gnat_install_signal_handlers");
+ -- Map the synchronous signals SIGSEGV, SIGFPE, SIGILL and
+ -- SIGBUS to Ada exceptions for the calling ARINC process.
+ -- This routine should be called as early as possible in
+ -- each ARINC process body.
+ -- C declaration:
+ -- extern int __gnat_install_signal_handlers ();
+ -- This call is unnecessary on AE 1.1.
+
+private
+ package OSI renames System.OS_Interface;
+
+ function Register_Foreign (T : OSI.Thread_Id) return OSI.STATUS;
+ -- Create runtime structures necessary for Ada language support for
+ -- an ARINC process. Called from APEX CREATE routine.
+
+ function Reset_Foreign (T : OSI.Thread_Id) return OSI.STATUS;
+ -- Reset runtime structures upon an AE653 process restart. Called from
+ -- APEX START routine.
+
+ -- When defining the following routines for export in an AE 1.1
+ -- simulation of AE653, Interfaces.C.int may be used for the
+ -- parameters of FUNCPTR.
+ type FUNCPTR is access function (T : OSI.Thread_Id) return OSI.STATUS;
+
+ --------------------------------
+ -- Imported vThreads Routines --
+ --------------------------------
+
+ procedure procCreateHookAdd (createHookFunction : FUNCPTR);
+ pragma Import (C, procCreateHookAdd, "procCreateHookAdd");
+ -- Registers task registration routine for AE653
+
+ procedure procStartHookAdd (StartHookFunction : FUNCPTR);
+ pragma Import (C, procStartHookAdd, "procStartHookAdd");
+ -- Registers task restart routine for AE653
+
+end Interfaces.Vthreads;
diff --git a/gcc/ada/i-vxwoio.adb b/gcc/ada/i-vxwoio.adb
new file mode 100644
index 00000000000..f4ca3a8592a
--- /dev/null
+++ b/gcc/ada/i-vxwoio.adb
@@ -0,0 +1,80 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- I N T E R F A C E S . V X W O R K S . I O --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body Interfaces.VxWorks.IO is
+
+ --------------------------
+ -- Enable_Get_Immediate --
+ --------------------------
+
+ procedure Enable_Get_Immediate
+ (File : Interfaces.C_Streams.FILEs;
+ Success : out Boolean)
+ is
+ Status : int;
+ Fd : int;
+
+ begin
+ Fd := fileno (File);
+ Status := ioctl (Fd, FIOSETOPTIONS, OPT_RAW);
+
+ if Status /= int (ERROR) then
+ Success := True;
+ else
+ Success := False;
+ end if;
+ end Enable_Get_Immediate;
+
+ ---------------------------
+ -- Disable_Get_Immediate --
+ ---------------------------
+
+ procedure Disable_Get_Immediate
+ (File : Interfaces.C_Streams.FILEs;
+ Success : out Boolean)
+ is
+ Status : int;
+ Fd : int;
+
+ begin
+ Fd := fileno (File);
+ Status := ioctl (Fd, FIOSETOPTIONS, OPT_TERMINAL);
+
+ if Status /= int (ERROR) then
+ Success := True;
+ else
+ Success := False;
+ end if;
+ end Disable_Get_Immediate;
+
+end Interfaces.VxWorks.IO;
diff --git a/gcc/ada/i-vxwoio.ads b/gcc/ada/i-vxwoio.ads
new file mode 100644
index 00000000000..fca40cef3a7
--- /dev/null
+++ b/gcc/ada/i-vxwoio.ads
@@ -0,0 +1,228 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- I N T E R F A C E S . V X W O R K S . I O --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides a binding to the functions fileno and ioctl
+-- in VxWorks, providing a set of definitions of ioctl function codes
+-- and options for the use of these functions.
+
+-- A particular use of this interface is to enable use of Get_Immediate
+-- in Ada.Text_IO. There is no way in VxWorks to provide the desired
+-- functionality of Get_Immediate (no buffering and no waiting for a
+-- line return) without flushing the buffer, which violates the Ada
+-- semantic requirements for Ada.Text_IO.
+
+with Interfaces.C_Streams;
+
+package Interfaces.VxWorks.IO is
+
+ -------------------------
+ -- The ioctl Interface --
+ --------------------------
+
+ type FUNCODE is new int;
+ -- Type of the function codes in ioctl
+
+ type IOOPT is mod 2 ** int'Size;
+ -- Type of the option codes in ioctl
+
+ -- ioctl function codes
+ -- For more information see ioLib.h
+
+ FIONREAD : constant FUNCODE := 1;
+ FIOFLUSH : constant FUNCODE := 2;
+ FIOOPTIONS : constant FUNCODE := 3;
+ FIOBAUDRATE : constant FUNCODE := 4;
+ FIODISKFORMAT : constant FUNCODE := 5;
+ FIODISKINIT : constant FUNCODE := 6;
+ FIOSEEK : constant FUNCODE := 7;
+ FIOWHERE : constant FUNCODE := 8;
+ FIODIRENTRY : constant FUNCODE := 9;
+ FIORENAME : constant FUNCODE := 10;
+ FIOREADYCHANGE : constant FUNCODE := 11;
+ FIONWRITE : constant FUNCODE := 12;
+ FIODISKCHANGE : constant FUNCODE := 13;
+ FIOCANCEL : constant FUNCODE := 14;
+ FIOSQUEEZE : constant FUNCODE := 15;
+ FIONBIO : constant FUNCODE := 16;
+ FIONMSGS : constant FUNCODE := 17;
+ FIOGETNAME : constant FUNCODE := 18;
+ FIOGETOPTIONS : constant FUNCODE := 19;
+ FIOSETOPTIONS : constant FUNCODE := FIOOPTIONS;
+ FIOISATTY : constant FUNCODE := 20;
+ FIOSYNC : constant FUNCODE := 21;
+ FIOPROTOHOOK : constant FUNCODE := 22;
+ FIOPROTOARG : constant FUNCODE := 23;
+ FIORBUFSET : constant FUNCODE := 24;
+ FIOWBUFSET : constant FUNCODE := 25;
+ FIORFLUSH : constant FUNCODE := 26;
+ FIOWFLUSH : constant FUNCODE := 27;
+ FIOSELECT : constant FUNCODE := 28;
+ FIOUNSELECT : constant FUNCODE := 29;
+ FIONFREE : constant FUNCODE := 30;
+ FIOMKDIR : constant FUNCODE := 31;
+ FIORMDIR : constant FUNCODE := 32;
+ FIOLABELGET : constant FUNCODE := 33;
+ FIOLABELSET : constant FUNCODE := 34;
+ FIOATTRIBSE : constant FUNCODE := 35;
+ FIOCONTIG : constant FUNCODE := 36;
+ FIOREADDIR : constant FUNCODE := 37;
+ FIOFSTATGET : constant FUNCODE := 38;
+ FIOUNMOUNT : constant FUNCODE := 39;
+ FIOSCSICOMMAND : constant FUNCODE := 40;
+ FIONCONTIG : constant FUNCODE := 41;
+ FIOTRUNC : constant FUNCODE := 42;
+ FIOGETFL : constant FUNCODE := 43;
+ FIOTIMESET : constant FUNCODE := 44;
+ FIOINODETONAM : constant FUNCODE := 45;
+ FIOFSTATFSGE : constant FUNCODE := 46;
+
+ -- ioctl option values
+
+ OPT_ECHO : constant IOOPT := 16#0001#;
+ OPT_CRMOD : constant IOOPT := 16#0002#;
+ OPT_TANDEM : constant IOOPT := 16#0004#;
+ OPT_7_BIT : constant IOOPT := 16#0008#;
+ OPT_MON_TRAP : constant IOOPT := 16#0010#;
+ OPT_ABORT : constant IOOPT := 16#0020#;
+ OPT_LINE : constant IOOPT := 16#0040#;
+ OPT_RAW : constant IOOPT := 16#0000#;
+ OPT_TERMINAL : constant IOOPT := OPT_ECHO or
+ OPT_CRMOD or
+ OPT_TANDEM or
+ OPT_MON_TRAP or
+ OPT_7_BIT or
+ OPT_ABORT or
+ OPT_LINE;
+
+ function fileno (Fp : Interfaces.C_Streams.FILEs) return int;
+ pragma Import (C, fileno, "fileno");
+ -- Binding to the C routine fileno
+
+ function ioctl (Fd : int; Function_Code : FUNCODE; Arg : IOOPT) return int;
+ pragma Import (C, ioctl, "ioctl");
+ -- Binding to the C routine ioctl
+
+ ------------------------------
+ -- Control of Get_Immediate --
+ ------------------------------
+
+ -- The procedures in this section make use of the interface to ioctl
+ -- and fileno to provide a mechanism for enabling unbuffered behavior
+ -- for Get_Immediate in VxWorks.
+
+ -- The situation is that the RM requires that the use of Get_Immediate
+ -- be identical to Get except that it is desirable (not required) that
+ -- there be no buffering or line editing.
+
+ -- Unfortunately, in VxWorks, the only way to enable this desired
+ -- unbuffered behavior involves changing into raw mode. But this
+ -- transition into raw mode flushes the input buffer, a behavior
+ -- not permitted by the RM semantics for Get_Immediate.
+
+ -- Given that Get_Immediate cannot be accurately implemented in
+ -- raw mode, it seems best not to enable it by default, and instead
+ -- to require specific programmer action, with the programmer being
+ -- aware that input may be lost.
+
+ -- The following is an example of the use of the two procedures
+ -- in this section (Enable_Get_Immediate and Disable_Get_Immediate)
+
+ -- with Ada.Text_IO; use Ada.Text_IO;
+ -- with Ada.Text_IO.C_Streams; use Ada.Text_IO.C_Streams;
+ -- with Interfaces.VxWorks.IO; use Interfaces.VxWorks.IO;
+
+ -- procedure Example_IO is
+ -- Input : Character;
+ -- Available : Boolean;
+ -- Success : Boolean;
+
+ -- begin
+ -- Enable_Get_Immediate (C_Stream (Current_Input), Success);
+
+ -- if Success = False then
+ -- raise Device_Error;
+ -- end if;
+
+ -- -- Example with the first type of Get_Immediate
+ -- -- Waits for an entry on the input. Immediately returns
+ -- -- after having received an character on the input
+
+ -- Put ("Input -> ");
+ -- Get_Immediate (Input);
+ -- New_Line;
+ -- Put_Line ("Character read: " & Input);
+
+ -- -- Example with the second type of Get_Immediate
+ -- -- This is equivalent to a non blocking read
+
+ -- for J in 1 .. 10 loop
+ -- Put ("Input -> ");
+ -- Get_Immediate (Input, Available);
+ -- New_Line;
+
+ -- if Available = True then
+ -- Put_Line ("Character read: " & Input);
+ -- end if;
+
+ -- delay 1.0;
+ -- end loop;
+
+ -- Disable_Get_Immediate (C_Stream (Current_Input), Success);
+
+ -- if Success = False then
+ -- raise Device_Error;
+ -- end if;
+
+ -- exception
+ -- when Device_Error =>
+ -- Put_Line ("Device Error. Check your configuration");
+ -- end Example_IO;
+
+ procedure Enable_Get_Immediate
+ (File : Interfaces.C_Streams.FILEs;
+ Success : out Boolean);
+ -- On VxWorks, a call to this procedure is required before subsequent calls
+ -- to Get_Immediate have the desired effect of not waiting for a line
+ -- return. The reason that this call is not automatic on this target is
+ -- that the call flushes the input buffer, discarding any previous input.
+ -- Note: Following a call to Enable_Get_Immediate, the only permitted
+ -- operations on the relevant file are Get_Immediate operations. Any
+ -- other operations have undefined behavior.
+
+ procedure Disable_Get_Immediate
+ (File : Interfaces.C_Streams.FILEs;
+ Success : out Boolean);
+ -- This procedure resets File to standard mode, and permits subsequent
+ -- use of the full range of Ada.Text_IO functions
+
+end Interfaces.VxWorks.IO;
diff --git a/gcc/ada/i-vxwork.ads b/gcc/ada/i-vxwork.ads
index 1ab458558a8..fc1acb11e3b 100644
--- a/gcc/ada/i-vxwork.ads
+++ b/gcc/ada/i-vxwork.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999 - 2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2003 Ada Core Technologies, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -36,14 +35,15 @@
-- In particular, it interfaces with the VxWorks hardware interrupt
-- facilities, allowing the use of low-latency direct-vectored
-- interrupt handlers. Note that such handlers have a variety of
--- restrictions regarding system calls. Less restrictive, but higher-
--- latency handlers can be written using Ada protected procedures,
--- Ada 83 style interrupt entries, or by signalling an Ada task
--- from within an interrupt handler using a binary semaphore as
--- described in the VxWorks Programmer's Manual
+-- restrictions regarding system calls and language constructs. In particular,
+-- the use of exception handlers and functions returning variable-length
+-- objects cannot be used. Less restrictive, but higher-latency handlers can
+-- be written using Ada protected procedures, Ada 83 style interrupt entries,
+-- or by signalling an Ada task from within an interrupt handler using a
+-- binary semaphore as described in the VxWorks Programmer's Manual.
--
-- For complete documentation of the operations in this package, please
--- consult the VxWorks Programmer's Manual and VxWorks Reference Manual
+-- consult the VxWorks Programmer's Manual and VxWorks Reference Manual.
with System.VxWorks;
diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
index 248d3d3d55f..fcc174b8a33 100644
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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- --
@@ -40,7 +40,7 @@ package body Impunit is
-- Note that this list should match the list of units documented in
-- the "GNAT Library" section of the GNAT Reference Manual.
- Non_Imp_File_Names : File_List := (
+ Non_Imp_File_Names : constant File_List := (
-----------------------------------------------
-- Ada Hierarchy Units from Reference Manual --
@@ -137,11 +137,13 @@ package body Impunit is
-----------------------------------
"a-chlat9", -- Ada.Characters.Latin_9
+ "a-colien", -- Ada.Command_Line.Environment
"a-colire", -- Ada.Command_Line.Remove
"a-cwila1", -- Ada.Characters.Wide_Latin_1
"a-cwila9", -- Ada.Characters.Wide_Latin_9
"a-diocst", -- Ada.Direct_IO.C_Streams
"a-einuoc", -- Ada.Exceptions.Is_Null_Occurrence
+ "a-exctra", -- Ada.Exceptions.Traceback
"a-siocst", -- Ada.Sequential_IO.C_Streams
"a-ssicst", -- Ada.Streams.Stream_IO.C_Streams
"a-suteio", -- Ada.Strings.Unbounded.Text_IO
@@ -181,51 +183,68 @@ package body Impunit is
-- GNAT Library Units --
------------------------
+ "g-arrspl", -- GNAT.Array_Split
"g-awk ", -- GNAT.AWK
+ "g-boubuf", -- GNAT.Bounded_Buffers
+ "g-boumai", -- GNAT.Bounded_Mailboxes
+ "g-bubsor", -- GNAT.Bubble_Sort
"g-busora", -- GNAT.Bubble_Sort_A
"g-busorg", -- GNAT.Bubble_Sort_G
"g-calend", -- GNAT.Calendar
- "g-catiio", -- GNAT.Calendar.Time_IO
"g-casuti", -- GNAT.Case_Util
+ "g-catiio", -- GNAT.Calendar.Time_IO
"g-cgi ", -- GNAT.CGI
"g-cgicoo", -- GNAT.CGI.Cookie
"g-cgideb", -- GNAT.CGI.Debug
"g-comlin", -- GNAT.Command_Line
+ "g-comver", -- GNAT.Compiler_Version
"g-crc32 ", -- GNAT.CRC32
+ "g-ctrl_c", -- GNAT.Ctrl_C
"g-curexc", -- GNAT.Current_Exception
"g-debpoo", -- GNAT.Debug_Pools
"g-debuti", -- GNAT.Debug_Utilities
"g-diopit", -- GNAT.Directory_Operations.Iteration
"g-dirope", -- GNAT.Directory_Operations
+ "g-dynhta", -- GNAT.Dynamic_HTables
"g-dyntab", -- GNAT.Dynamic_Tables
+ "g-excact", -- GNAT.Exception_Actions
+ "g-except", -- GNAT.Exceptions
"g-exctra", -- GNAT.Exception_Traces
"g-expect", -- GNAT.Expect
"g-flocon", -- GNAT.Float_Control
- "g-htable", -- GNAT.Htable
+ "g-heasor", -- GNAT.Heap_Sort
"g-hesora", -- GNAT.Heap_Sort_A
"g-hesorg", -- GNAT.Heap_Sort_G
+ "g-htable", -- GNAT.Htable
"g-io ", -- GNAT.IO
"g-io_aux", -- GNAT.IO_Aux
"g-locfil", -- GNAT.Lock_Files
"g-md5 ", -- GNAT.MD5
+ "g-memdum", -- GNAT.Memory_Dump
"g-moreex", -- GNAT.Most_Recent_Exception
"g-os_lib", -- GNAT.Os_Lib
+ "g-pehage", -- GNAT.Perfect_Hash.Generators
+ "g-perhas", -- GNAT.Perfect_Hash
"g-regexp", -- GNAT.Regexp
"g-regist", -- GNAT.Registry
"g-regpat", -- GNAT.Regpat
+ "g-semaph", -- GNAT.Semaphores
"g-socket", -- GNAT.Sockets
- "g-sptabo", -- GNAT.Spitbol.Table_Boolean
- "g-sptain", -- GNAT.Spitbol.Table_Integer
- "g-sptavs", -- GNAT.Spitbol.Table_Vstring
"g-souinf", -- GNAT.Source_Info
"g-speche", -- GNAT.Spell_Checker
- "g-spitbo", -- GNAT.Spitbol
"g-spipat", -- GNAT.Spitbol.Patterns
+ "g-spitbo", -- GNAT.Spitbol
+ "g-sptabo", -- GNAT.Spitbol.Table_Boolean
+ "g-sptain", -- GNAT.Spitbol.Table_Integer
+ "g-sptavs", -- GNAT.Spitbol.Table_Vstring
+ "g-string", -- GNAT.Strings
+ "g-strspl", -- GNAT.String_Split
"g-table ", -- GNAT.Table
"g-tasloc", -- GNAT.Task_Lock
"g-thread", -- GNAT.Threads
"g-traceb", -- GNAT.Traceback
"g-trasym", -- GNAT.Traceback.Symbolic
+ "g-wistsp", -- GNAT.Wide_String_Split
-----------------------------------------------------
-- Interface Hierarchy Units from Reference Manual --
@@ -242,21 +261,21 @@ package body Impunit is
------------------------------------------
"i-cexten", -- Interfaces.C.Extensions
- "i-csthre", -- Interfaces.C.Sthreads
- "i-cstrea", -- Interfaces.C.Streams
"i-cpp ", -- Interfaces.CPP
- "i-java ", -- Interfaces.Java
- "i-javlan", -- Interfaces.Java.Lang
+ "i-cstrea", -- Interfaces.C.Streams
"i-jalaob", -- Interfaces.Java.Lang.Object
"i-jalasy", -- Interfaces.Java.Lang.System
"i-jalath", -- Interfaces.Java.Lang.Thread
+ "i-java ", -- Interfaces.Java
+ "i-javlan", -- Interfaces.Java.Lang
"i-os2err", -- Interfaces.Os2lib.Errors
"i-os2lib", -- Interfaces.Os2lib
"i-os2syn", -- Interfaces.Os2lib.Synchronization
"i-os2thr", -- Interfaces.Os2lib.Threads
"i-pacdec", -- Interfaces.Packed_Decimal
- "i-vxwork", -- Interfaces.VxWorks
+ "i-vthrea", -- Interfaces.Vthreads
"i-vxwoio", -- Interfaces.VxWorks.IO
+ "i-vxwork", -- Interfaces.VxWorks
--------------------------------------------------
-- System Hierarchy Units from Reference Manual --
@@ -274,6 +293,7 @@ package body Impunit is
"s-addima", -- System.Address_Image
"s-assert", -- System.Assertions
+ "s-memory", -- System.Memory
"s-parint", -- System.Partition_Interface
"s-tasinf", -- System.Task_Info
"s-wchcnv", -- System.Wch_Cnv
diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index a57409933a0..786c7915d84 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -4,7 +4,6 @@
* *
* I N I T *
* *
- * *
* C Implementation File *
* *
* Copyright (C) 1992-2003 Free Software Foundation, Inc. *
@@ -101,13 +100,15 @@ int __gl_time_slice_val = -1;
char __gl_wc_encoding = 'n';
char __gl_locking_policy = ' ';
char __gl_queuing_policy = ' ';
-char *__gl_restrictions = 0;
char __gl_task_dispatching_policy = ' ';
+char *__gl_restrictions = 0;
+char *__gl_interrupt_states = 0;
+int __gl_num_interrupt_states = 0;
int __gl_unreserve_all_interrupts = 0;
int __gl_exception_tracebacks = 0;
int __gl_zero_cost_exceptions = 0;
-/* Indication of whether synchronous signal handler has already been
+/* Indication of whether synchronous signal handler has already been
installed by a previous call to adainit */
int __gnat_handler_installed = 0;
@@ -116,6 +117,32 @@ int __gnat_handler_installed = 0;
at the end of this unit. */
#undef HAVE_GNAT_INIT_FLOAT
+/******************************/
+/* __gnat_get_interrupt_state */
+/******************************/
+
+char __gnat_get_interrupt_state (int);
+
+/* This routine is called from the runtime as needed to determine the state
+ of an interrupt, as set by an Interrupt_State pragma appearing anywhere
+ in the current partition. The input argument is the interrupt number,
+ and the result is one of the following:
+
+ 'n' this interrupt not set by any Interrupt_State pragma
+ 'u' Interrupt_State pragma set state to User
+ 'r' Interrupt_State pragma set state to Runtime
+ 's' Interrupt_State pragma set state to System */
+
+char
+__gnat_get_interrupt_state (intrup)
+ int intrup;
+{
+ if (intrup >= __gl_num_interrupt_states)
+ return 'n';
+ else
+ return __gl_interrupt_states [intrup];
+}
+
/**********************/
/* __gnat_set_globals */
/**********************/
@@ -129,16 +156,30 @@ int __gnat_handler_installed = 0;
boundaries like this are not handled correctly in all systems. */
void
-__gnat_set_globals (main_priority, time_slice_val, wc_encoding, locking_policy,
- queuing_policy, task_dispatching_policy, restrictions,
- unreserve_all_interrupts, exception_tracebacks,
+__gnat_set_globals (main_priority,
+ time_slice_val,
+ wc_encoding,
+ locking_policy,
+ queuing_policy,
+ task_dispatching_policy,
+ restrictions,
+ interrupt_states,
+ num_interrupt_states,
+ unreserve_all_interrupts,
+ exception_tracebacks,
zero_cost_exceptions)
int main_priority;
int time_slice_val;
char wc_encoding;
- char locking_policy, queuing_policy, task_dispatching_policy;
+ char locking_policy;
+ char queuing_policy;
+ char task_dispatching_policy;
char *restrictions;
- int unreserve_all_interrupts, exception_tracebacks, zero_cost_exceptions;
+ char *interrupt_states;
+ int num_interrupt_states;
+ int unreserve_all_interrupts;
+ int exception_tracebacks;
+ int zero_cost_exceptions;
{
static int already_called = 0;
@@ -150,7 +191,12 @@ __gnat_set_globals (main_priority, time_slice_val, wc_encoding, locking_policy,
method. This default affects only Wide_Text_IO where no explicit
coding method is given, and there is no particular reason to let
this default be affected by the source representation of a library
- in any case.
+ in any case.
+
+ We do not check either for the consistency of exception tracebacks,
+ because exception tracebacks are not normally set in Stand-Alone
+ libraries. If a library or the main program set the exception
+ tracebacks, then they are never reset afterwards (see below).
The value of main_priority is meaningful only when we are invoked
from the main program elaboration routine of an Ada application.
@@ -172,10 +218,15 @@ __gnat_set_globals (main_priority, time_slice_val, wc_encoding, locking_policy,
|| __gl_queuing_policy != queuing_policy
|| __gl_task_dispatching_policy != task_dispatching_policy
|| __gl_unreserve_all_interrupts != unreserve_all_interrupts
- || __gl_exception_tracebacks != exception_tracebacks
|| __gl_zero_cost_exceptions != zero_cost_exceptions)
__gnat_raise_program_error (__FILE__, __LINE__);
+ /* If either a library or the main program set the exception traceback
+ flag, it is never reset later */
+
+ if (exception_tracebacks != 0)
+ __gl_exception_tracebacks = exception_tracebacks;
+
return;
}
already_called = 1;
@@ -186,6 +237,8 @@ __gnat_set_globals (main_priority, time_slice_val, wc_encoding, locking_policy,
__gl_locking_policy = locking_policy;
__gl_queuing_policy = queuing_policy;
__gl_restrictions = restrictions;
+ __gl_interrupt_states = interrupt_states;
+ __gl_num_interrupt_states = num_interrupt_states;
__gl_task_dispatching_policy = task_dispatching_policy;
__gl_unreserve_all_interrupts = unreserve_all_interrupts;
__gl_exception_tracebacks = exception_tracebacks;
@@ -216,21 +269,26 @@ __gnat_set_globals (main_priority, time_slice_val, wc_encoding, locking_policy,
code where initialization is required. */
/***********************************/
-/* __gnat_initialize (AIX version) */
+/* __gnat_initialize (AIX Version) */
/***********************************/
#if defined (_AIX)
-/* AiX doesn't have SA_NODEFER */
+#include <signal.h>
+#include <sys/time.h>
+
+/* Some versions of AIX don't define SA_NODEFER. */
+#ifndef SA_NODEFER
#define SA_NODEFER 0
+#endif /* SA_NODEFER */
-#include <sys/time.h>
+/* Versions of AIX before 4.3 don't have nanosleep but provide
+ nsleep instead. */
-/* AiX doesn't have nanosleep, but provides nsleep instead */
+#ifndef _AIXVERSION_430
extern int nanosleep PARAMS ((struct timestruc_t *, struct timestruc_t *));
-static void __gnat_error_handler PARAMS ((int));
int
nanosleep (Rqtp, Rmtp)
@@ -239,7 +297,9 @@ nanosleep (Rqtp, Rmtp)
return nsleep (Rqtp, Rmtp);
}
-#include <signal.h>
+#endif /* _AIXVERSION_430 */
+
+static void __gnat_error_handler PARAMS ((int));
static void
__gnat_error_handler (sig)
@@ -285,13 +345,20 @@ __gnat_install_handler ()
act.sa_handler = __gnat_error_handler;
act.sa_flags = SA_NODEFER | SA_RESTART;
- (void) sigemptyset (&act.sa_mask);
+ sigemptyset (&act.sa_mask);
+
+ /* Do not install handlers if interrupt state is "System" */
+ if (__gnat_get_interrupt_state (SIGABRT) != 's')
+ sigaction (SIGABRT, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGFPE) != 's')
+ sigaction (SIGFPE, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGILL) != 's')
+ sigaction (SIGILL, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGSEGV) != 's')
+ sigaction (SIGSEGV, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGBUS) != 's')
+ sigaction (SIGBUS, &act, NULL);
- (void) sigaction (SIGABRT, &act, NULL);
- (void) sigaction (SIGFPE, &act, NULL);
- (void) sigaction (SIGILL, &act, NULL);
- (void) sigaction (SIGSEGV, &act, NULL);
- (void) sigaction (SIGBUS, &act, NULL);
__gnat_handler_installed = 1;
}
@@ -301,7 +368,7 @@ __gnat_initialize ()
}
/****************************************/
-/* __gnat_initialize (Dec Unix version) */
+/* __gnat_initialize (Dec Unix Version) */
/****************************************/
#elif defined(__alpha__) && defined(__osf__) && ! defined(__alpha_vxworks)
@@ -406,13 +473,19 @@ __gnat_install_handler ()
act.sa_handler = (void (*) PARAMS ((int))) __gnat_error_handler;
act.sa_flags = SA_ONSTACK | SA_RESTART | SA_NODEFER | SA_SIGINFO;
- (void) sigemptyset (&act.sa_mask);
-
- (void) sigaction (SIGABRT, &act, NULL);
- (void) sigaction (SIGFPE, &act, NULL);
- (void) sigaction (SIGILL, &act, NULL);
- (void) sigaction (SIGSEGV, &act, NULL);
- (void) sigaction (SIGBUS, &act, NULL);
+ sigemptyset (&act.sa_mask);
+
+ /* Do not install handlers if interrupt state is "System" */
+ if (__gnat_get_interrupt_state (SIGABRT) != 's')
+ sigaction (SIGABRT, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGFPE) != 's')
+ sigaction (SIGFPE, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGILL) != 's')
+ sigaction (SIGILL, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGSEGV) != 's')
+ sigaction (SIGSEGV, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGBUS) != 's')
+ sigaction (SIGBUS, &act, NULL);
__gnat_handler_installed = 1;
}
@@ -449,9 +522,9 @@ __gnat_machine_state_length ()
return sizeof (struct sigcontext);
}
-/***********************************/
-/* __gnat_initialize (HPUX version) */
-/***********************************/
+/************************************/
+/* __gnat_initialize (HPUX Version) */
+/************************************/
#elif defined (hpux)
@@ -514,17 +587,23 @@ __gnat_install_handler ()
stack.ss_size = sizeof (handler_stack);
stack.ss_flags = 0;
- (void) sigaltstack (&stack, NULL);
+ sigaltstack (&stack, NULL);
act.sa_handler = __gnat_error_handler;
act.sa_flags = SA_NODEFER | SA_RESTART | SA_ONSTACK;
- (void) sigemptyset (&act.sa_mask);
-
- (void) sigaction (SIGABRT, &act, NULL);
- (void) sigaction (SIGFPE, &act, NULL);
- (void) sigaction (SIGILL, &act, NULL);
- (void) sigaction (SIGSEGV, &act, NULL);
- (void) sigaction (SIGBUS, &act, NULL);
+ sigemptyset (&act.sa_mask);
+
+ /* Do not install handlers if interrupt state is "System" */
+ if (__gnat_get_interrupt_state (SIGABRT) != 's')
+ sigaction (SIGABRT, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGFPE) != 's')
+ sigaction (SIGFPE, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGILL) != 's')
+ sigaction (SIGILL, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGSEGV) != 's')
+ sigaction (SIGSEGV, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGBUS) != 's')
+ sigaction (SIGBUS, &act, NULL);
__gnat_handler_installed = 1;
}
@@ -534,9 +613,9 @@ __gnat_initialize ()
{
}
-/*************************************/
-/* __gnat_initialize (GNU/Linux version) */
-/*************************************/
+/*****************************************/
+/* __gnat_initialize (GNU/Linux Version) */
+/*****************************************/
#elif defined (linux) && defined (i386) && !defined (__RT__)
@@ -662,13 +741,19 @@ __gnat_install_handler ()
act.sa_handler = __gnat_error_handler;
act.sa_flags = SA_NODEFER | SA_RESTART;
- (void) sigemptyset (&act.sa_mask);
-
- (void) sigaction (SIGABRT, &act, NULL);
- (void) sigaction (SIGFPE, &act, NULL);
- (void) sigaction (SIGILL, &act, NULL);
- (void) sigaction (SIGSEGV, &act, NULL);
- (void) sigaction (SIGBUS, &act, NULL);
+ sigemptyset (&act.sa_mask);
+
+ /* Do not install handlers if interrupt state is "System" */
+ if (__gnat_get_interrupt_state (SIGABRT) != 's')
+ sigaction (SIGABRT, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGFPE) != 's')
+ sigaction (SIGFPE, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGILL) != 's')
+ sigaction (SIGILL, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGSEGV) != 's')
+ sigaction (SIGSEGV, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGBUS) != 's')
+ sigaction (SIGBUS, &act, NULL);
__gnat_handler_installed = 1;
}
@@ -679,23 +764,23 @@ __gnat_initialize ()
}
/******************************************/
-/* __gnat_initialize (NT-mingw32 version) */
+/* __gnat_initialize (NT-mingw32 Version) */
/******************************************/
#elif defined (__MINGW32__)
#include <windows.h>
-static LONG __gnat_error_handler PARAMS ((PEXCEPTION_POINTERS));
+static LONG WINAPI __gnat_error_handler PARAMS ((PEXCEPTION_POINTERS));
/* __gnat_initialize (mingw32). */
-static LONG
+static LONG WINAPI
__gnat_error_handler (info)
PEXCEPTION_POINTERS info;
{
static int recurse;
struct Exception_Data *exception;
- char *msg;
+ const char *msg;
switch (info->ExceptionRecord->ExceptionCode)
{
@@ -802,6 +887,7 @@ __gnat_error_handler (info)
recurse = 0;
Raise_From_Signal_Handler (exception, msg);
+ return 0; /* This is never reached, avoid compiler warning */
}
void
@@ -827,9 +913,9 @@ __gnat_initialize ()
__gnat_plist_init();
}
-/**************************************/
-/* __gnat_initialize (Interix version) */
-/**************************************/
+/***************************************/
+/* __gnat_initialize (Interix Version) */
+/***************************************/
#elif defined (__INTERIX)
@@ -880,15 +966,17 @@ __gnat_install_handler ()
act.sa_handler = __gnat_error_handler;
act.sa_flags = 0;
- (void) sigemptyset (&act.sa_mask);
+ sigemptyset (&act.sa_mask);
/* Handlers for signals besides SIGSEGV cause c974013 to hang */
-/* (void) sigaction (SIGILL, &act, NULL); */
-/* (void) sigaction (SIGABRT, &act, NULL); */
-/* (void) sigaction (SIGFPE, &act, NULL); */
-/* (void) sigaction (SIGBUS, &act, NULL); */
+/* sigaction (SIGILL, &act, NULL); */
+/* sigaction (SIGABRT, &act, NULL); */
+/* sigaction (SIGFPE, &act, NULL); */
+/* sigaction (SIGBUS, &act, NULL); */
- (void) sigaction (SIGSEGV, &act, NULL);
+ /* Do not install handlers if interrupt state is "System" */
+ if (__gnat_get_interrupt_state (SIGSEGV) != 's')
+ sigaction (SIGSEGV, &act, NULL);
__gnat_handler_installed = 1;
}
@@ -900,7 +988,7 @@ __gnat_initialize ()
}
/**************************************/
-/* __gnat_initialize (LynxOS version) */
+/* __gnat_initialize (LynxOS Version) */
/**************************************/
#elif defined (__Lynx__)
@@ -943,7 +1031,7 @@ __gnat_install_handler ()
}
/***********************************/
-/* __gnat_initialize (SGI version) */
+/* __gnat_initialize (SGI Version) */
/***********************************/
#elif defined (sgi)
@@ -1049,7 +1137,6 @@ __gnat_error_handler (sig, code, sc)
memcpy ((void *) mstate, (const void *) sc, sizeof (sigcontext_t));
Raise_From_Signal_Handler (exception, msg);
-
}
void
@@ -1064,15 +1151,23 @@ __gnat_install_handler ()
act.sa_handler = __gnat_error_handler;
act.sa_flags = SA_NODEFER + SA_RESTART;
- (void) sigfillset (&act.sa_mask);
- (void) sigemptyset (&act.sa_mask);
-
- (void) sigaction (SIGABRT, &act, NULL);
- (void) sigaction (SIGFPE, &act, NULL);
- (void) sigaction (SIGILL, &act, NULL);
- (void) sigaction (SIGSEGV, &act, NULL);
- (void) sigaction (SIGBUS, &act, NULL);
- (void) sigaction (SIGADAABORT, &act, NULL);
+ sigfillset (&act.sa_mask);
+ sigemptyset (&act.sa_mask);
+
+ /* Do not install handlers if interrupt state is "System" */
+ if (__gnat_get_interrupt_state (SIGABRT) != 's')
+ sigaction (SIGABRT, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGFPE) != 's')
+ sigaction (SIGFPE, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGILL) != 's')
+ sigaction (SIGILL, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGSEGV) != 's')
+ sigaction (SIGSEGV, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGBUS) != 's')
+ sigaction (SIGBUS, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGADAABORT) != 's')
+ sigaction (SIGADAABORT, &act, NULL);
+
__gnat_handler_installed = 1;
}
@@ -1082,7 +1177,7 @@ __gnat_initialize ()
}
/*************************************************/
-/* __gnat_initialize (Solaris and SunOS version) */
+/* __gnat_initialize (Solaris and SunOS Version) */
/*************************************************/
#elif defined (sun) && defined (__SVR4) && !defined (__vxworks)
@@ -1099,7 +1194,7 @@ __gnat_error_handler (sig, sip)
{
struct Exception_Data *exception;
static int recurse = 0;
- const char *msg;
+ char *msg;
/* If this was an explicit signal from a "kill", just resignal it. */
if (SI_FROMUSER (sip))
@@ -1171,95 +1266,17 @@ __gnat_install_handler ()
act.sa_handler = __gnat_error_handler;
act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO;
- (void) sigemptyset (&act.sa_mask);
-
- (void) sigaction (SIGABRT, &act, NULL);
- (void) sigaction (SIGFPE, &act, NULL);
- (void) sigaction (SIGSEGV, &act, NULL);
- (void) sigaction (SIGBUS, &act, NULL);
-
- __gnat_handler_installed = 1;
-}
-
-void
-__gnat_initialize ()
-{
-}
-
-/***********************************/
-/* __gnat_initialize (SNI version) */
-/***********************************/
-
-#elif defined (__sni__)
-
-/* SNI needs special defines and includes */
-
-#define _XOPEN_SOURCE
-#define _POSIX_SOURCE
-#include <signal.h>
-
-extern size_t __gnat_getpagesize PARAMS ((void));
-static void __gnat_error_handler PARAMS ((int));
-
-/* The run time needs this function which is a #define in SNI */
-
-size_t
-__gnat_getpagesize ()
-{
- return getpagesize ();
-}
-
-static void
-__gnat_error_handler (sig)
- int sig;
-{
- struct Exception_Data *exception;
- char *msg;
-
- switch (sig)
- {
- case SIGSEGV:
- /* FIXME: we need to detect the case of a *real* SIGSEGV */
- exception = &storage_error;
- msg = "stack overflow or erroneous memory access";
- break;
-
- case SIGBUS:
- exception = &constraint_error;
- msg = "SIGBUS";
- break;
-
- case SIGFPE:
- exception = &constraint_error;
- msg = "SIGFPE";
- break;
-
- default:
- exception = &program_error;
- msg = "unhandled signal";
- }
-
- Raise_From_Signal_Handler (exception, msg);
-}
-
-void
-__gnat_install_handler ()
-{
- struct sigaction act;
-
- /* Set up signal handler to map synchronous signals to appropriate
- exceptions. Make sure that the handler isn't interrupted by another
- signal that might cause a scheduling event! */
-
- act.sa_handler = __gnat_error_handler;
- act.sa_flags = SA_NODEFER | SA_RESTART;
- (void) sigemptyset (&act.sa_mask);
-
- (void) sigaction (SIGABRT, &act, NULL);
- (void) sigaction (SIGFPE, &act, NULL);
- (void) sigaction (SIGILL, &act, NULL);
- (void) sigaction (SIGSEGV, &act, NULL);
- (void) sigaction (SIGBUS, &act, NULL);
+ sigemptyset (&act.sa_mask);
+
+ /* Do not install handlers if interrupt state is "System" */
+ if (__gnat_get_interrupt_state (SIGABRT) != 's')
+ sigaction (SIGABRT, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGFPE) != 's')
+ sigaction (SIGFPE, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGSEGV) != 's')
+ sigaction (SIGSEGV, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGBUS) != 's')
+ sigaction (SIGBUS, &act, NULL);
__gnat_handler_installed = 1;
}
@@ -1270,7 +1287,7 @@ __gnat_initialize ()
}
/***********************************/
-/* __gnat_initialize (VMS version) */
+/* __gnat_initialize (VMS Version) */
/***********************************/
#elif defined (VMS)
@@ -1333,7 +1350,7 @@ __gnat_error_handler (sigargs, mechargs)
long curr_invo_handle;
long *mstate;
- /* Resignaled conditions aren't effected by by pragma Import_Exception */
+ /* Resignaled condtions aren't effected by by pragma Import_Exception */
switch (sigargs[1])
{
@@ -1476,7 +1493,7 @@ __gnat_initialize()
}
/***************************************/
-/* __gnat_initialize (VXWorks version) */
+/* __gnat_initialize (VXWorks Version) */
/***************************************/
#elif defined(__vxworks)
@@ -1486,24 +1503,8 @@ __gnat_initialize()
#include <intLib.h>
#include <iv.h>
-static void __gnat_init_handler PARAMS ((int));
-extern int __gnat_inum_to_ivec PARAMS ((int));
-static void __gnat_error_handler PARAMS ((int, int, struct sigcontext *));
-
-static void
-__gnat_int_handler (interr)
- int interr;
-{
- /* Note that we should use something like Raise_From_Int_Handler here, but
- for now Raise_From_Signal_Handler will do the job. ??? */
-
- Raise_From_Signal_Handler (&storage_error, "stack overflow");
-}
-
-/* Used for stack-checking on VxWorks. Must be task-local in
- tasking programs */
-
-void *__gnat_stack_limit = NULL;
+extern int __gnat_inum_to_ivec (int);
+static void __gnat_error_handler (int, int, struct sigcontext *);
#ifndef __alpha_vxworks
@@ -1542,14 +1543,14 @@ __gnat_error_handler (sig, code, sc)
will reenable it on a longjmp. GNAT does not generate a longjmp to
return from a signal handler so the signal will still be masked unless
we unmask it. */
- (void) sigprocmask (SIG_SETMASK, NULL, &mask);
+ sigprocmask (SIG_SETMASK, NULL, &mask);
sigdelset (&mask, sig);
- (void) sigprocmask (SIG_SETMASK, &mask, NULL);
+ sigprocmask (SIG_SETMASK, &mask, NULL);
/* VxWorks will suspend the task when it gets a hardware exception. We
take the liberty of resuming the task for the application. */
if (taskIsSuspended (taskIdSelf ()) != 0)
- (void) taskResume (taskIdSelf ());
+ taskResume (taskIdSelf ());
switch (sig)
{
@@ -1588,12 +1589,14 @@ __gnat_install_handler ()
act.sa_handler = __gnat_error_handler;
act.sa_flags = SA_SIGINFO | SA_ONSTACK;
- (void) sigemptyset (&act.sa_mask);
+ sigemptyset (&act.sa_mask);
- (void) sigaction (SIGFPE, &act, NULL);
- (void) sigaction (SIGILL, &act, NULL);
- (void) sigaction (SIGSEGV, &act, NULL);
- (void) sigaction (SIGBUS, &act, NULL);
+ /* For VxWorks, install all signal handlers, since pragma Interrupt_State
+ applies to vectored hardware interrupts, not signals */
+ sigaction (SIGFPE, &act, NULL);
+ sigaction (SIGILL, &act, NULL);
+ sigaction (SIGSEGV, &act, NULL);
+ sigaction (SIGBUS, &act, NULL);
__gnat_handler_installed = 1;
}
@@ -1603,26 +1606,137 @@ __gnat_install_handler ()
void
__gnat_init_float ()
{
-#if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT)
/* Disable overflow/underflow exceptions on the PPC processor, this is needed
- to get correct Ada semantic */
+ to get correct Ada semantic. */
+#if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT)
asm ("mtfsb0 25");
asm ("mtfsb0 26");
#endif
+
+ /* Similarily for sparc64. Achieved by masking bits in the Trap Enable Mask
+ field of the Floating-point Status Register (see the Sparc Architecture
+ Manual Version 9, p 48). */
+#if defined (sparc64)
+
+#define FSR_TEM_NVM (1 << 27) /* Invalid operand */
+#define FSR_TEM_OFM (1 << 26) /* Overflow */
+#define FSR_TEM_UFM (1 << 25) /* Underflow */
+#define FSR_TEM_DZM (1 << 24) /* Division by Zero */
+#define FSR_TEM_NXM (1 << 23) /* Inexact result */
+ {
+ unsigned int fsr;
+
+ __asm__("st %%fsr, %0" : "=m" (fsr));
+ fsr &= ~(FSR_TEM_OFM | FSR_TEM_UFM);
+ __asm__("ld %0, %%fsr" : : "m" (fsr));
+ }
+#endif
}
void
__gnat_initialize ()
{
- TASK_DESC pTaskDesc;
+ __gnat_init_float ();
+
+ /* Assume an environment task stack size of 20kB.
+
+ Using a constant is necessary because we do not want each Ada application
+ to depend on the optional taskShow library,
+ which is required to get the actual stack information.
+
+ The consequence of this is that with -fstack-check
+ the environment task must have an actual stack size
+ of at least 20kB and the usable size will be about 14kB.
+ */
+
+ __gnat_set_stack_size (14336);
+ /* Allow some head room for the stack checking code, and for
+ stack space consumed during initialization */
+}
+
+/********************************/
+/* __gnat_initialize for NetBSD */
+/********************************/
+
+#elif defined(__NetBSD__)
+
+#include <signal.h>
+#include <unistd.h>
+
+static void
+__gnat_error_handler (sig)
+ int sig;
+{
+ struct Exception_Data *exception;
+ const char *msg;
+
+ switch(sig)
+ {
+ case SIGFPE:
+ exception = &constraint_error;
+ msg = "SIGFPE";
+ break;
+ case SIGILL:
+ exception = &constraint_error;
+ msg = "SIGILL";
+ break;
+ case SIGSEGV:
+ exception = &storage_error;
+ msg = "stack overflow or erroneous memory access";
+ break;
+ case SIGBUS:
+ exception = &constraint_error;
+ msg = "SIGBUS";
+ break;
+ default:
+ exception = &program_error;
+ msg = "unhandled signal";
+ }
- if (taskInfoGet (taskIdSelf (), &pTaskDesc) != OK)
- printErr ("Cannot get task info");
+ Raise_From_Signal_Handler(exception, msg);
+}
+
+void
+__gnat_install_handler()
+{
+ struct sigaction act;
- __gnat_stack_limit = (void *) pTaskDesc.td_pStackLimit;
+ act.sa_handler = __gnat_error_handler;
+ act.sa_flags = SA_NODEFER | SA_RESTART;
+ sigemptyset (&act.sa_mask);
+
+ /* Do not install handlers if interrupt state is "System" */
+ if (__gnat_get_interrupt_state (SIGFPE) != 's')
+ sigaction (SIGFPE, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGILL) != 's')
+ sigaction (SIGILL, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGSEGV) != 's')
+ sigaction (SIGSEGV, &act, NULL);
+ if (__gnat_get_interrupt_state (SIGBUS) != 's')
+ sigaction (SIGBUS, &act, NULL);
+}
+void
+__gnat_initialize ()
+{
+ __gnat_install_handler ();
__gnat_init_float ();
+}
+/***************************************/
+/* __gnat_initialize (RTEMS version) */
+/***************************************/
+
+#elif defined(__rtems__)
+
+extern void __gnat_install_handler ();
+
+/* For RTEMS, each bsp will provide a custom __gnat_install_handler (). */
+
+void
+__gnat_initialize ()
+{
+ __gnat_install_handler ();
}
/***************************************/
@@ -1647,7 +1761,7 @@ __gnat_initialize ()
installation do nothing */
/***************************************/
-/* __gnat_initialize (default version) */
+/* __gnat_initialize (Default Version) */
/***************************************/
void
@@ -1656,7 +1770,7 @@ __gnat_initialize ()
}
/********************************************/
-/* __gnat_install_handler (default version) */
+/* __gnat_install_handler (Default Version) */
/********************************************/
void
@@ -1676,7 +1790,7 @@ __gnat_install_handler ()
WIN32 and could be used under OS/2 */
#if defined (_WIN32) || defined (__INTERIX) || defined (__EMX__) \
- || defined (__Lynx__)
+ || defined (__Lynx__) || defined(__NetBSD__)
#define HAVE_GNAT_INIT_FLOAT
diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb
index 2b2769069eb..cec090f23ac 100644
--- a/gcc/ada/inline.adb
+++ b/gcc/ada/inline.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -193,7 +193,7 @@ package body Inline is
--------------
procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is
- P1 : Subp_Index := Add_Subp (Called);
+ P1 : constant Subp_Index := Add_Subp (Called);
P2 : Subp_Index;
J : Succ_Index;
@@ -237,18 +237,21 @@ package body Inline is
procedure Add_Inlined_Body (E : Entity_Id) is
Pack : Entity_Id;
- Comp_Unit : Node_Id;
function Must_Inline return Boolean;
-- Inlining is only done if the call statement N is in the main unit,
-- or within the body of another inlined subprogram.
+ -----------------
+ -- Must_Inline --
+ -----------------
+
function Must_Inline return Boolean is
Scop : Entity_Id := Current_Scope;
Comp : Node_Id;
begin
- -- Check if call is in main unit.
+ -- Check if call is in main unit
while Scope (Scop) /= Standard_Standard
and then not Is_Child_Unit (Scop)
@@ -262,8 +265,8 @@ package body Inline is
Comp := Parent (Comp);
end loop;
- if (Comp = Cunit (Main_Unit)
- or else Comp = Library_Unit (Cunit (Main_Unit)))
+ if Comp = Cunit (Main_Unit)
+ or else Comp = Library_Unit (Cunit (Main_Unit))
then
Add_Call (E);
return True;
@@ -315,7 +318,6 @@ package body Inline is
and then Ekind (Pack) = E_Package
then
Set_Is_Called (E);
- Comp_Unit := Parent (Pack);
if Pack = Standard_Standard then
@@ -349,21 +351,89 @@ package body Inline is
Succ : Succ_Index;
Subp : Subp_Index;
+ function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean;
+ -- There are various conditions under which back-end inlining cannot
+ -- be done reliably:
+ --
+ -- a) If a body has handlers, it must not be inlined, because this
+ -- may violate program semantics, and because in zero-cost exception
+ -- mode it will lead to undefined symbols at link time.
+ --
+ -- b) If a body contains inlined function instances, it cannot be
+ -- inlined under ZCX because the numerix suffix generated by gigi
+ -- will be different in the body and the place of the inlined call.
+ --
+ -- This procedure must be carefully coordinated with the back end
+
+ ----------------------------
+ -- Back_End_Cannot_Inline --
+ ----------------------------
+
+ function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is
+ Decl : Node_Id := Unit_Declaration_Node (Subp);
+ Body_Ent : Entity_Id;
+ Ent : Entity_Id;
+
+ begin
+ if Nkind (Decl) = N_Subprogram_Declaration
+ and then Present (Corresponding_Body (Decl))
+ then
+ Body_Ent := Corresponding_Body (Decl);
+ else
+ return False;
+ end if;
+
+ -- If subprogram is marked Inline_Always, inlining is mandatory
+
+ if Is_Always_Inlined (Subp) then
+ return False;
+ end if;
+
+ if Present
+ (Exception_Handlers
+ (Handled_Statement_Sequence
+ (Unit_Declaration_Node (Corresponding_Body (Decl)))))
+ then
+ return True;
+ end if;
+
+ Ent := First_Entity (Body_Ent);
+
+ while Present (Ent) loop
+ if Is_Subprogram (Ent)
+ and then Is_Generic_Instance (Ent)
+ then
+ return True;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ return False;
+ end Back_End_Cannot_Inline;
+
+ -- Start of processing for Add_Inlined_Subprogram
+
begin
- -- Insert the current subprogram in the list of inlined subprograms
+ -- Insert the current subprogram in the list of inlined subprograms,
+ -- if it can actually be inlined by the back-end.
if not Scope_In_Main_Unit (E)
and then Is_Inlined (E)
and then not Is_Nested (E)
and then not Has_Initialized_Type (E)
then
- if No (Last_Inlined) then
- Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
+ if Back_End_Cannot_Inline (E) then
+ Set_Is_Inlined (E, False);
+
else
- Set_Next_Inlined_Subprogram (Last_Inlined, E);
- end if;
+ if No (Last_Inlined) then
+ Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
+ else
+ Set_Next_Inlined_Subprogram (Last_Inlined, E);
+ end if;
- Last_Inlined := E;
+ Last_Inlined := E;
+ end if;
end if;
Inlined.Table (Index).Listed := True;
@@ -386,8 +456,8 @@ package body Inline is
------------------------
procedure Add_Scope_To_Clean (Inst : Entity_Id) is
+ Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst);
Elmt : Elmt_Id;
- Scop : Entity_Id := Enclosing_Dynamic_Scope (Inst);
begin
-- If the instance appears in a library-level package declaration,
@@ -632,13 +702,85 @@ package body Inline is
E := First_Entity (P);
while Present (E) loop
- if Has_Pragma_Inline (E) then
+ if Is_Always_Inlined (E)
+ or else (Front_End_Inlining and then Has_Pragma_Inline (E))
+ then
if not Is_Loaded (Bname) then
Load_Needed_Body (N, OK);
- if not OK
- and then Ineffective_Inline_Warnings
- then
+ if OK then
+
+ -- Check that we are not trying to inline a parent
+ -- whose body depends on a child, when we are compiling
+ -- the body of the child. Otherwise we have a potential
+ -- elaboration circularity with inlined subprograms and
+ -- with Taft-Amendment types.
+
+ declare
+ Comp : Node_Id; -- Body just compiled
+ Child_Spec : Entity_Id; -- Spec of main unit
+ Ent : Entity_Id; -- For iteration
+ With_Clause : Node_Id; -- Context of body.
+
+ begin
+ if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
+ and then Present (Body_Entity (P))
+ then
+ Child_Spec :=
+ Defining_Entity (
+ (Unit (Library_Unit (Cunit (Main_Unit)))));
+
+ Comp :=
+ Parent (Unit_Declaration_Node (Body_Entity (P)));
+
+ With_Clause := First (Context_Items (Comp));
+
+ -- Check whether the context of the body just
+ -- compiled includes a child of itself, and that
+ -- child is the spec of the main compilation.
+
+ while Present (With_Clause) loop
+ if Nkind (With_Clause) = N_With_Clause
+ and then
+ Scope (Entity (Name (With_Clause))) = P
+ and then
+ Entity (Name (With_Clause)) = Child_Spec
+ then
+ Error_Msg_Node_2 := Child_Spec;
+ Error_Msg_NE
+ ("body of & depends on child unit&?",
+ With_Clause, P);
+ Error_Msg_N
+ ("\subprograms in body cannot be inlined?",
+ With_Clause);
+
+ -- Disable further inlining from this unit,
+ -- and keep Taft-amendment types incomplete.
+
+ Ent := First_Entity (P);
+
+ while Present (Ent) loop
+ if Is_Type (Ent)
+ and then Has_Completion_In_Body (Ent)
+ then
+ Set_Full_View (Ent, Empty);
+
+ elsif Is_Subprogram (Ent) then
+ Set_Is_Inlined (Ent, False);
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+
+ return;
+ end if;
+
+ Next (With_Clause);
+ end loop;
+ end if;
+ end;
+
+ elsif Ineffective_Inline_Warnings then
Error_Msg_Unit_1 := Bname;
Error_Msg_N
("unable to inline subprograms defined in $?", P);
@@ -672,6 +814,21 @@ package body Inline is
if Ekind (Scop) = E_Entry then
Scop := Protected_Body_Subprogram (Scop);
+
+ elsif Is_Subprogram (Scop)
+ and then Is_Protected_Type (Scope (Scop))
+ and then Present (Protected_Body_Subprogram (Scop))
+ then
+ -- If a protected operation contains an instance, its
+ -- cleanup operations have been delayed, and the subprogram
+ -- has been rewritten in the expansion of the enclosing
+ -- protected body. It is the corresponding subprogram that
+ -- may require the cleanup operations.
+
+ Set_Uses_Sec_Stack
+ (Protected_Body_Subprogram (Scop),
+ Uses_Sec_Stack (Scop));
+ Scop := Protected_Body_Subprogram (Scop);
end if;
if Ekind (Scop) = E_Block then
@@ -762,7 +919,7 @@ package body Inline is
begin
if Serious_Errors_Detected = 0 then
- Expander_Active := (Operating_Mode = Opt.Generate_Code);
+ Expander_Active := (Operating_Mode = Opt.Generate_Code);
New_Scope (Standard_Standard);
To_Clean := New_Elmt_List;
@@ -779,16 +936,15 @@ package body Inline is
while J <= Pending_Instantiations.Last
and then Serious_Errors_Detected = 0
loop
-
Info := Pending_Instantiations.Table (J);
- -- If the instantiation node is absent, it has been removed
+ -- If the instantiation node is absent, it has been removed
-- as part of unreachable code.
if No (Info.Inst_Node) then
null;
- elsif Nkind (Info. Act_Decl) = N_Package_Declaration then
+ elsif Nkind (Info.Act_Decl) = N_Package_Declaration then
Instantiate_Package_Body (Info);
Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
diff --git a/gcc/ada/interfac.ads b/gcc/ada/interfac.ads
index 10ade18b73e..dab89ecda9d 100644
--- a/gcc/ada/interfac.ads
+++ b/gcc/ada/interfac.ads
@@ -6,17 +6,39 @@
-- --
-- S p e c --
-- --
--- This specification is adapted from the Ada Reference Manual for use with --
--- GNAT. In accordance with the copyright of that document, you can freely --
--- copy and modify this specification, provided that if you redistribute a --
--- modified version, any changes that you have made are clearly indicated. --
+-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the implementation dependent additions to thie file. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Assumes integer sizes of 8, 16, 32 and 64 are available, and that the
-- floating-point formats are IEEE compatible.
--- There is a specialized version of this package for OpenVMS.
+-- Note: There is a specialized version of this package for OpenVMS.
package Interfaces is
pragma Pure (Interfaces);
diff --git a/gcc/ada/io-aux.c b/gcc/ada/io-aux.c
deleted file mode 100644
index 3b132447c25..00000000000
--- a/gcc/ada/io-aux.c
+++ /dev/null
@@ -1,53 +0,0 @@
-/****************************************************************************
- * *
- * GNAT RUN-TIME COMPONENTS *
- * *
- * A - T R A N S *
- * *
- * C Implementation File *
- * *
- * *
- * Copyright (C) 1992-2001 Free Software Foundation, Inc. *
- * *
- * GNAT is free software; you can redistribute it and/or modify it under *
- * terms of the GNU General Public License as published by the Free Soft- *
- * ware Foundation; either version 2, or (at your option) any later ver- *
- * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
- * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
- * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
- * for more details. You should have received a copy of the GNU General *
- * Public License distributed with GNAT; see file COPYING. If not, write *
- * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
- * MA 02111-1307, USA. *
- * *
- * As a special exception, if you link this file with other files to *
- * produce an executable, this file does not by itself cause the resulting *
- * executable to be covered by the GNU General Public License. This except- *
- * ion does not however invalidate any other reasons why the executable *
- * file might be covered by the GNU Public License. *
- * *
- * GNAT was originally developed by the GNAT team at New York University. *
- * Extensive contributions were provided by Ada Core Technologies Inc. *
- * *
- ****************************************************************************/
-
-#include <stdio.h>
-
-/* Function wrappers are needed to access the values from Ada which are */
-/* defined as C macros. */
-
-FILE *c_stdin (void) { return stdin; }
-FILE *c_stdout (void) { return stdout;}
-FILE *c_stderr (void) { return stderr;}
-
-#ifndef SEEK_SET /* Symbolic constants for the "fseek" function: */
-#define SEEK_SET 0 /* Set file pointer to offset */
-#define SEEK_CUR 1 /* Set file pointer to its current value plus offset */
-#define SEEK_END 2 /* Set file pointer to the size of the file plus offset */
-#endif
-
-int seek_set_function (void) { return SEEK_SET; }
-int seek_end_function (void) { return SEEK_END; }
-void *null_function (void) { return NULL; }
-
-int c_fileno (FILE *s) { return fileno (s); }
diff --git a/gcc/ada/itypes.adb b/gcc/ada/itypes.adb
index 7c973347538..12864b84be2 100644
--- a/gcc/ada/itypes.adb
+++ b/gcc/ada/itypes.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2000 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- --
@@ -26,6 +26,7 @@
with Atree; use Atree;
with Einfo; use Einfo;
+with Sem; use Sem;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
@@ -62,6 +63,11 @@ package body Itypes is
Set_Etype (Typ, Any_Type);
Set_Is_Itype (Typ);
Set_Associated_Node_For_Itype (Typ, Related_Nod);
+
+ if In_Deleted_Code then
+ Set_Is_Frozen (Typ);
+ end if;
+
return Typ;
end Create_Itype;
diff --git a/gcc/ada/itypes.ads b/gcc/ada/itypes.ads
index a2e25ed5319..362a35b4208 100644
--- a/gcc/ada/itypes.ads
+++ b/gcc/ada/itypes.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994,1995,1996 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- --
@@ -72,7 +72,7 @@ package Itypes is
-- or not to copy a referenced Itype. If the associated node is part of
-- the tree to be copied by New_Copy_Tree, then (since the idea of the
-- call to New_Copy_Tree is to create a complete duplicate of a tree,
- -- as though it had appeared separately int he source), the Itype in
+ -- as though it had appeared separately in the source), the Itype in
-- question is duplicated as part of the New_Copy_Tree processing.
-----------------
diff --git a/gcc/ada/lang-specs.h b/gcc/ada/lang-specs.h
index 1c41f87d56a..0ab33ff0201 100644
--- a/gcc/ada/lang-specs.h
+++ b/gcc/ada/lang-specs.h
@@ -6,8 +6,7 @@
* *
* C Header File *
* *
- * *
- * Copyright (C) 1992-2001 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- *
@@ -33,11 +32,11 @@
{"@ada",
"\
%{pg:%{fomit-frame-pointer:%e-pg and -fomit-frame-pointer are incompatible}}\
- %{!gnatc:%{!gnatz:%{!gnats:%{!S:%{!c:\
+ %{!gnatc*:%{!gnatz*:%{!gnats*:%{!S:%{!c:\
%eone of -c, -S, -gnatc, -gnatz, or -gnats is required for Ada}}}}}\
gnat1 %{I*} %{k8:-gnatk8} %{w:-gnatws} %1 %{!Q:-quiet} %{nostdinc*}\
-dumpbase %{.adb:%b.adb}%{.ads:%b.ads}%{!.adb:%{!.ads:%b.ada}}\
%{g*} %{O*} %{W*} %{w} %{p} %{pg:-p} %{m*} %{a} %{f*} %{d*}\
%{!S:%{o*:%w%*-gnatO}} \
%i %{S:%W{o*}%{!o*:-o %b.s}} \
- %{!gnatc:%{!gnatz:%{!gnats:%(invoke_as)}}}", 0},
+ %{!gnatc*:%{!gnatz*:%{!gnats*:%(invoke_as)}}}", 0},
diff --git a/gcc/ada/lang.opt b/gcc/ada/lang.opt
index 393c72d14e7..e38af20b2e8 100644
--- a/gcc/ada/lang.opt
+++ b/gcc/ada/lang.opt
@@ -33,6 +33,26 @@ Wall
Ada
; Documented for C
+Wmissing-prototypes
+Ada
+; Documented for C
+
+Wstrict-prototypes
+Ada
+; Documented for C
+
+Wwrite-strings
+Ada
+; Documented for C
+
+Wno-long-long
+Ada
+; Documented for C
+
+nostdinc
+Ada RejectNegative
+; Don't look for source files
+
fRTS
Ada RejectNegative
@@ -42,6 +62,6 @@ Ada Joined Undocumented
gnat
Ada Joined
--gnat<option> Specify options to GNAT
+-gnat<options> Specify options to GNAT
; This comment is to ensure we retain the blank line above.
diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb
index 0128bf267d3..df310323931 100644
--- a/gcc/ada/layout.adb
+++ b/gcc/ada/layout.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -33,6 +33,7 @@ with Exp_Ch3; use Exp_Ch3;
with Exp_Util; use Exp_Util;
with Nlists; use Nlists;
with Nmake; use Nmake;
+with Opt; use Opt;
with Repinfo; use Repinfo;
with Sem; use Sem;
with Sem_Ch13; use Sem_Ch13;
@@ -101,6 +102,13 @@ package body Layout is
-- knowing that associative rearrangement is allowed for constant
-- folding if one of the operands is a compile time known value
+ function Bits_To_SU (N : Node_Id) return Node_Id;
+ -- This is used when we cross the boundary from static sizes in bits to
+ -- dynamic sizes in storage units. If the argument N is anything other
+ -- than an integer literal, it is returned unchanged, but if it is an
+ -- integer literal, then it is taken as a size in bits, and is replaced
+ -- by the corresponding size in bytes.
+
function Compute_Length (Lo : Node_Id; Hi : Node_Id) return Node_Id;
-- Given expressions for the low bound (Lo) and the high bound (Hi),
-- Build an expression for the value hi-lo+1, converted to type
@@ -110,32 +118,41 @@ package body Layout is
function Expr_From_SO_Ref
(Loc : Source_Ptr;
- D : SO_Ref)
+ D : SO_Ref;
+ Comp : Entity_Id := Empty)
return Node_Id;
-- Given a value D from a size or offset field, return an expression
-- representing the value stored. If the value is known at compile time,
-- then an N_Integer_Literal is returned with the appropriate value. If
-- the value references a constant entity, then an N_Identifier node
- -- referencing this entity is returned. The Loc value is used for the
- -- Sloc value of constructed notes.
+ -- referencing this entity is returned. If the value denotes a size
+ -- function, then returns a call node denoting the given function, with
+ -- a single actual parameter that either refers to the parameter V of
+ -- an enclosing size function (if Comp is Empty or its type doesn't match
+ -- the function's formal), or else is a selected component V.c when Comp
+ -- denotes a component c whose type matches that of the function formal.
+ -- The Loc value is used for the Sloc value of constructed notes.
function SO_Ref_From_Expr
(Expr : Node_Id;
Ins_Type : Entity_Id;
- Vtype : Entity_Id := Empty)
+ Vtype : Entity_Id := Empty;
+ Make_Func : Boolean := False)
return Dynamic_SO_Ref;
-- This routine is used in the case where a size/offset value is dynamic
-- and is represented by the expression Expr. SO_Ref_From_Expr checks if
-- the Expr contains a reference to the identifier V, and if so builds
-- a function depending on discriminants of the formal parameter V which
- -- is of type Vtype. If not, then a constant entity with the value Expr
- -- is built. The result is a Dynamic_SO_Ref to the created entity. Note
- -- that Vtype can be omitted if Expr does not contain any reference to V.
- -- the created entity. The declaration created is inserted in the freeze
- -- actions of Ins_Type, which also supplies the Sloc for created nodes.
- -- This function also takes care of making sure that the expression is
- -- properly analyzed and resolved (which may not be the case yet if we
- -- build the expression in this unit).
+ -- is of type Vtype. Otherwise, if the parameter Make_Func is True, then
+ -- Expr will be encapsulated in a parameterless function; if Make_Func is
+ -- False, then a constant entity with the value Expr is built. The result
+ -- is a Dynamic_SO_Ref to the created entity. Note that Vtype can be
+ -- omitted if Expr does not contain any reference to V, the created entity.
+ -- The declaration created is inserted in the freeze actions of Ins_Type,
+ -- which also supplies the Sloc for created nodes. This function also takes
+ -- care of making sure that the expression is properly analyzed and
+ -- resolved (which may not be the case yet if we build the expression
+ -- in this unit).
function Get_Max_Size (E : Entity_Id) return Node_Id;
-- E is an array type or subtype that has at least one index bound that
@@ -143,14 +160,13 @@ package body Layout is
-- computes an expression that yields the maximum possible size of the
-- array in storage units. The result is not defined for any other type,
-- or for arrays that do not depend on discriminants, and it is a fatal
- -- error to call this unless Size_Depends_On_Discrminant (E) is True.
+ -- error to call this unless Size_Depends_On_Discriminant (E) is True.
procedure Layout_Array_Type (E : Entity_Id);
- -- Front end layout of non-bit-packed array type or subtype
+ -- Front-end layout of non-bit-packed array type or subtype
procedure Layout_Record_Type (E : Entity_Id);
- -- Front end layout of record type
- -- Variant records not handled yet ???
+ -- Front-end layout of record type
procedure Rewrite_Integer (N : Node_Id; V : Uint);
-- Rewrite node N with an integer literal whose value is V. The Sloc
@@ -496,17 +512,67 @@ package body Layout is
return Make_Op_Subtract (Loc, Left_Opnd, Right_Opnd);
end Assoc_Subtract;
+ ----------------
+ -- Bits_To_SU --
+ ----------------
+
+ function Bits_To_SU (N : Node_Id) return Node_Id is
+ begin
+ if Nkind (N) = N_Integer_Literal then
+ Set_Intval (N, (Intval (N) + (SSU - 1)) / SSU);
+ end if;
+
+ return N;
+ end Bits_To_SU;
+
--------------------
-- Compute_Length --
--------------------
function Compute_Length (Lo : Node_Id; Hi : Node_Id) return Node_Id is
- Loc : constant Source_Ptr := Sloc (Lo);
- Typ : constant Entity_Id := Etype (Lo);
- Lo_Op : Node_Id;
- Hi_Op : Node_Id;
+ Loc : constant Source_Ptr := Sloc (Lo);
+ Typ : constant Entity_Id := Etype (Lo);
+ Lo_Op : Node_Id;
+ Hi_Op : Node_Id;
+ Lo_Dim : Uint;
+ Hi_Dim : Uint;
begin
+ -- If the bounds are First and Last attributes for the same dimension
+ -- and both have prefixes that denotes the same entity, then we create
+ -- and return a Length attribute. This may allow the back end to
+ -- generate better code in cases where it already has the length.
+
+ if Nkind (Lo) = N_Attribute_Reference
+ and then Attribute_Name (Lo) = Name_First
+ and then Nkind (Hi) = N_Attribute_Reference
+ and then Attribute_Name (Hi) = Name_Last
+ and then Is_Entity_Name (Prefix (Lo))
+ and then Is_Entity_Name (Prefix (Hi))
+ and then Entity (Prefix (Lo)) = Entity (Prefix (Hi))
+ then
+ Lo_Dim := Uint_1;
+ Hi_Dim := Uint_1;
+
+ if Present (First (Expressions (Lo))) then
+ Lo_Dim := Expr_Value (First (Expressions (Lo)));
+ end if;
+
+ if Present (First (Expressions (Hi))) then
+ Hi_Dim := Expr_Value (First (Expressions (Hi)));
+ end if;
+
+ if Lo_Dim = Hi_Dim then
+ return
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of
+ (Entity (Prefix (Lo)), Loc),
+ Attribute_Name => Name_Length,
+ Expressions => New_List
+ (Make_Integer_Literal (Loc, Lo_Dim)));
+ end if;
+ end if;
+
Lo_Op := New_Copy_Tree (Lo);
Hi_Op := New_Copy_Tree (Hi);
@@ -542,7 +608,8 @@ package body Layout is
function Expr_From_SO_Ref
(Loc : Source_Ptr;
- D : SO_Ref)
+ D : SO_Ref;
+ Comp : Entity_Id := Empty)
return Node_Id
is
Ent : Entity_Id;
@@ -552,11 +619,29 @@ package body Layout is
Ent := Get_Dynamic_SO_Entity (D);
if Is_Discrim_SO_Function (Ent) then
- return
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Ent, Loc),
- Parameter_Associations => New_List (
- Make_Identifier (Loc, Chars => Vname)));
+ -- If a component is passed in whose type matches the type
+ -- of the function formal, then select that component from
+ -- the "V" parameter rather than passing "V" directly.
+
+ if Present (Comp)
+ and then Base_Type (Etype (Comp))
+ = Base_Type (Etype (First_Formal (Ent)))
+ then
+ return
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Ent, Loc),
+ Parameter_Associations => New_List (
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Chars => Vname),
+ Selector_Name => New_Occurrence_Of (Comp, Loc))));
+
+ else
+ return
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Ent, Loc),
+ Parameter_Associations => New_List (
+ Make_Identifier (Loc, Chars => Vname)));
+ end if;
else
return New_Occurrence_Of (Ent, Loc);
@@ -818,13 +903,13 @@ package body Layout is
Insert_Typ : Entity_Id;
-- This is the type with which any generated constants or functions
-- will be associated (i.e. inserted into the freeze actions). This
- -- is normally the type being layed out. The exception occurs when
+ -- is normally the type being laid out. The exception occurs when
-- we are laying out Itype's which are local to a record type, and
-- whose scope is this record type. Such types do not have freeze
-- nodes (because we have no place to put them).
------------------------------------
- -- How An Array Type is Layed Out --
+ -- How An Array Type is Laid Out --
------------------------------------
-- Here is what goes on. We need to multiply the component size of
@@ -875,6 +960,16 @@ package body Layout is
-- This is set to True if the final result must be converted from
-- bits to storage units (rounding up to a storage unit boundary).
+ Storage_Divisor : Uint := UI_From_Int (SSU);
+ -- This is the amount that a nonstatic computed size will be divided
+ -- by to convert it from bits to storage units. This is normally
+ -- equal to SSU, but can be reduced in the case of packed components
+ -- that fit evenly into a storage unit.
+
+ Make_Size_Function : Boolean := False;
+ -- Indicates whether to request that SO_Ref_From_Expr should
+ -- encapsulate the array size expresion in a function.
+
procedure Discrimify (N : in out Node_Id);
-- If N represents a discriminant, then the Size.Status is set to
-- Discrim, and Vtyp is set. The parameter N is replaced with the
@@ -934,6 +1029,13 @@ package body Layout is
Insert_Typ := E;
end if;
+ -- If the component type is a generic formal type then there's no point
+ -- in determining a size for the array type.
+
+ if Is_Generic_Type (Ctyp) then
+ return;
+ end if;
+
-- Deal with component size if base type
if Ekind (E) = E_Array_Type then
@@ -973,6 +1075,14 @@ package body Layout is
Indx := First_Index (E);
while Present (Indx) loop
Ityp := Etype (Indx);
+
+ -- If an index of the array is a generic formal type then there's
+ -- no point in determining a size for the array type.
+
+ if Is_Generic_Type (Ityp) then
+ return;
+ end if;
+
Lo := Type_Low_Bound (Ityp);
Hi := Type_High_Bound (Ityp);
@@ -1041,6 +1151,15 @@ package body Layout is
(Dynamic, Make_Integer_Literal (Loc, Size.Val / SSU));
SU_Convert_Required := False;
+ -- If the current value is a factor of the storage unit,
+ -- then we can use a value of one for the size and reduce
+ -- the strength of the later division.
+
+ elsif SSU mod Size.Val = 0 then
+ Storage_Divisor := SSU / Size.Val;
+ Size := (Dynamic, Make_Integer_Literal (Loc, Uint_1));
+ SU_Convert_Required := True;
+
-- Otherwise, we go ahead and convert the value in bits,
-- and set SU_Convert_Required to True to ensure that the
-- final value is indeed properly converted.
@@ -1058,41 +1177,50 @@ package body Layout is
Len := Compute_Length (Lo, Hi);
- -- Check possible range of Len
+ -- If Len isn't a Length attribute, then its range needs to
+ -- be checked a possible Max with zero needs to be computed.
- declare
- OK : Boolean;
- LLo : Uint;
- LHi : Uint;
+ if Nkind (Len) /= N_Attribute_Reference
+ or else Attribute_Name (Len) /= Name_Length
+ then
+ declare
+ OK : Boolean;
+ LLo : Uint;
+ LHi : Uint;
- begin
- Set_Parent (Len, E);
- Determine_Range (Len, OK, LLo, LHi);
+ begin
+ -- Check possible range of Len
- Len := Convert_To (Standard_Unsigned, Len);
+ Set_Parent (Len, E);
+ Determine_Range (Len, OK, LLo, LHi);
- -- If range definitely flat or superflat, result size is zero
+ Len := Convert_To (Standard_Unsigned, Len);
- if OK and then LHi <= 0 then
- Set_Esize (E, Uint_0);
- Set_RM_Size (E, Uint_0);
- return;
- end if;
+ -- If range definitely flat or superflat,
+ -- result size is zero
- -- If we cannot verify that range cannot be super-flat, we
- -- need a maximum with zero, since length cannot be negative.
+ if OK and then LHi <= 0 then
+ Set_Esize (E, Uint_0);
+ Set_RM_Size (E, Uint_0);
+ return;
+ end if;
- if not OK or else LLo < 0 then
- Len :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Standard_Unsigned, Loc),
- Attribute_Name => Name_Max,
- Expressions => New_List (
- Make_Integer_Literal (Loc, 0),
- Len));
- end if;
- end;
+ -- If we cannot verify that range cannot be super-flat,
+ -- we need a maximum with zero, since length cannot be
+ -- negative.
+
+ if not OK or else LLo < 0 then
+ Len :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Standard_Unsigned, Loc),
+ Attribute_Name => Name_Max,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, 0),
+ Len));
+ end if;
+ end;
+ end if;
-- At this stage, Len has the expression for the length
@@ -1120,15 +1248,42 @@ package body Layout is
if SU_Convert_Required then
- -- The expression required is (Size.Nod + SU - 1) / SU
+ -- The expression required is:
+ -- (Size.Nod + Storage_Divisor - 1) / Storage_Divisor
Size.Nod :=
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Op_Add (Loc,
Left_Opnd => Size.Nod,
- Right_Opnd => Make_Integer_Literal (Loc, SSU - 1)),
- Right_Opnd => Make_Integer_Literal (Loc, SSU));
+ Right_Opnd => Make_Integer_Literal
+ (Loc, Storage_Divisor - 1)),
+ Right_Opnd => Make_Integer_Literal (Loc, Storage_Divisor));
+ end if;
+
+ -- If the array entity is not declared at the library level and its
+ -- not nested within a subprogram that is marked for inlining, then
+ -- we request that the size expression be encapsulated in a function.
+ -- Since this expression is not needed in most cases, we prefer not
+ -- to incur the overhead of the computation on calls to the enclosing
+ -- subprogram except for subprograms that require the size.
+
+ if not Is_Library_Level_Entity (E) then
+ Make_Size_Function := True;
+
+ declare
+ Parent_Subp : Entity_Id := Enclosing_Subprogram (E);
+
+ begin
+ while Present (Parent_Subp) loop
+ if Is_Inlined (Parent_Subp) then
+ Make_Size_Function := False;
+ exit;
+ end if;
+
+ Parent_Subp := Enclosing_Subprogram (Parent_Subp);
+ end loop;
+ end;
end if;
-- Now set the dynamic size (the Value_Size is always the same
@@ -1138,7 +1293,10 @@ package body Layout is
-- The added initialization sets it to Empty now, but is this
-- correct?
- Set_Esize (E, SO_Ref_From_Expr (Size.Nod, Insert_Typ, Vtyp));
+ Set_Esize
+ (E,
+ SO_Ref_From_Expr
+ (Size.Nod, Insert_Typ, Vtyp, Make_Func => Make_Size_Function));
Set_RM_Size (E, Esize (E));
end if;
end Layout_Array_Type;
@@ -1199,10 +1357,10 @@ package body Layout is
Decl : Node_Id;
Comp : Entity_Id;
- -- Current component being layed out
+ -- Current component being laid out
Prev_Comp : Entity_Id;
- -- Previous layed out component
+ -- Previous laid out component
procedure Get_Next_Component_Location
(Prev_Comp : Entity_Id;
@@ -1229,10 +1387,7 @@ package body Layout is
-- Lays out component Comp, given Prev_Comp, the previously laid-out
-- component (Prev_Comp = Empty if no components laid out yet). The
-- alignment of the record itself is also updated if needed. Both
- -- Comp and Prev_Comp can be either components or discriminants. A
- -- special case is when Comp is Empty, this is used at the end
- -- to determine the size of the entire record. For this special
- -- call the resulting offset is placed in Final_Offset.
+ -- Comp and Prev_Comp can be either components or discriminants.
procedure Layout_Components
(From : Entity_Id;
@@ -1240,25 +1395,25 @@ package body Layout is
Esiz : out SO_Ref;
RM_Siz : out SO_Ref);
-- This procedure lays out the components of the given component list
- -- which contains the components starting with From, and ending with To.
- -- The Next_Entity chain is used to traverse the components. On entry
+ -- which contains the components starting with From and ending with To.
+ -- The Next_Entity chain is used to traverse the components. On entry,
-- Prev_Comp is set to the component preceding the list, so that the
- -- list is layed out after this component. Prev_Comp is set to Empty if
- -- the component list is to be layed out starting at the start of the
- -- record. On return, the components are all layed out, and Prev_Comp is
- -- set to the last layed out component. On return, Esiz is set to the
+ -- list is laid out after this component. Prev_Comp is set to Empty if
+ -- the component list is to be laid out starting at the start of the
+ -- record. On return, the components are all laid out, and Prev_Comp is
+ -- set to the last laid out component. On return, Esiz is set to the
-- resulting Object_Size value, which is the length of the record up
- -- to and including the last layed out entity. For Esiz, the value is
+ -- to and including the last laid out entity. For Esiz, the value is
-- adjusted to match the alignment of the record. RM_Siz is similarly
-- set to the resulting Value_Size value, which is the same length, but
-- not adjusted to meet the alignment. Note that in the case of variant
-- records, Esiz represents the maximum size.
procedure Layout_Non_Variant_Record;
- -- Procedure called to layout a non-variant record type or subtype
+ -- Procedure called to lay out a non-variant record type or subtype
procedure Layout_Variant_Record;
- -- Procedure called to layout a variant record type. Decl is set to the
+ -- Procedure called to lay out a variant record type. Decl is set to the
-- full type declaration for the variant record.
---------------------------------
@@ -1315,8 +1470,10 @@ package body Layout is
New_Npos :=
SO_Ref_From_Expr
(Assoc_Add (Loc,
- Left_Opnd => Expr_From_SO_Ref (Loc, Old_Npos),
- Right_Opnd => Expr_From_SO_Ref (Loc, Old_Esiz)),
+ Left_Opnd =>
+ Expr_From_SO_Ref (Loc, Old_Npos),
+ Right_Opnd =>
+ Expr_From_SO_Ref (Loc, Old_Esiz, Prev_Comp)),
Ins_Type => E,
Vtype => E);
@@ -1325,7 +1482,7 @@ package body Layout is
if Size_Depends_On_Discriminant (Etype (Prev_Comp)) then
Old_Maxsz := Get_Max_Size (Etype (Prev_Comp));
else
- Old_Maxsz := Expr_From_SO_Ref (Loc, Old_Esiz);
+ Old_Maxsz := Expr_From_SO_Ref (Loc, Old_Esiz, Prev_Comp);
end if;
-- Now we can compute the new max position. If the max size
@@ -1373,7 +1530,7 @@ package body Layout is
-- Bump alignment if stricter than prev
- if Align > Alignment (Prev_Comp) then
+ if Align > Alignment (Etype (Prev_Comp)) then
New_Npos := (New_Npos + Align - 1) / Align * Align;
end if;
@@ -1452,7 +1609,7 @@ package body Layout is
-- Check case of type of component has a scope of the record we
-- are laying out. When this happens, the type in question is an
- -- Itype that has not yet been layed out (that's because such
+ -- Itype that has not yet been laid out (that's because such
-- types do not get frozen in the normal manner, because there
-- is no place for the freeze nodes).
@@ -1564,20 +1721,35 @@ package body Layout is
End_NPMax : SO_Ref;
begin
- -- Only layout components if there are some to layout!
+ -- Only lay out components if there are some to lay out!
if Present (From) then
- -- Layout components with no component clauses
+ -- Lay out components with no component clauses
Comp := From;
loop
- if (Ekind (Comp) = E_Component
- or else Ekind (Comp) = E_Discriminant)
- and then No (Component_Clause (Comp))
+ if Ekind (Comp) = E_Component
+ or else Ekind (Comp) = E_Discriminant
then
- Layout_Component (Comp, Prev_Comp);
- Prev_Comp := Comp;
+ -- The compatibility of component clauses with composite
+ -- types isn't checked in Sem_Ch13, so we check it here.
+
+ if Present (Component_Clause (Comp)) then
+ if Is_Composite_Type (Etype (Comp))
+ and then Esize (Comp) < RM_Size (Etype (Comp))
+ then
+ Error_Msg_Uint_1 := RM_Size (Etype (Comp));
+ Error_Msg_NE
+ ("size for & too small, minimum allowed is ^",
+ Component_Clause (Comp),
+ Comp);
+ end if;
+
+ else
+ Layout_Component (Comp, Prev_Comp);
+ Prev_Comp := Comp;
+ end if;
end if;
exit when Comp = To;
@@ -1630,7 +1802,7 @@ package body Layout is
Esiz := End_NPMax;
if Is_Packed (E)
- or else Alignment (Prev_Comp) < Align
+ or else Alignment (Etype (Prev_Comp)) < Align
then
-- The expression we build is
-- (expr + align - 1) / align * align
@@ -1731,7 +1903,7 @@ package body Layout is
(Clist : Node_Id;
Esiz : out SO_Ref;
RM_Siz_Expr : out Node_Id);
- -- Recursive procedure, called to layout one component list
+ -- Recursive procedure, called to lay out one component list
-- Esiz and RM_Siz_Expr are set to the Object_Size and Value_Size
-- values respectively representing the record size up to and
-- including the last component in the component list (including
@@ -1875,7 +2047,7 @@ package body Layout is
-- care of the others case.
if No (RM_Siz_Expr) then
- RM_Siz_Expr := RM_SizV;
+ RM_Siz_Expr := Bits_To_SU (RM_SizV);
-- Otherwise construct the appropriate test
@@ -1905,19 +2077,28 @@ package body Layout is
Left_Opnd => Discrim,
Right_Opnd => New_Copy (Dchoice));
+ -- Generate a call to the discriminant-checking
+ -- function for the variant. Note that the result
+ -- has to be complemented since the function returns
+ -- False when the passed discriminant value matches.
+
else
Dtest :=
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of
- (Dcheck_Function (Var), Loc),
- Parameter_Associations => New_List (Discrim));
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Dcheck_Function (Var), Loc),
+ Parameter_Associations =>
+ New_List (Discrim)));
end if;
RM_Siz_Expr :=
Make_Conditional_Expression (Loc,
Expressions =>
- New_List (Dtest, RM_SizV, RM_Siz_Expr));
+ New_List
+ (Dtest, Bits_To_SU (RM_SizV), RM_Siz_Expr));
end if;
Prev (Var);
@@ -1935,7 +2116,7 @@ package body Layout is
Build_Discr_Checking_Funcs (Decl);
- -- Layout the discriminants
+ -- Lay out the discriminants
Layout_Components
(From => Defining_Identifier (First (Dlist)),
@@ -1943,8 +2124,8 @@ package body Layout is
Esiz => Esiz,
RM_Siz => RM_Siz);
- -- Layout the main component list (this will make recursive calls
- -- to layout all component lists nested within variants).
+ -- Lay out the main component list (this will make recursive calls
+ -- to lay out all component lists nested within variants).
Layout_Component_List (Component_List (Tdef), Esiz, RM_Siz_Expr);
Set_Esize (E, Esiz);
@@ -1991,7 +2172,7 @@ package body Layout is
-- All other cases
else
- -- Initialize aligment conservatively to 1. This value will
+ -- Initialize alignment conservatively to 1. This value will
-- be increased as necessary during processing of the record.
if Unknown_Alignment (E) then
@@ -2000,8 +2181,8 @@ package body Layout is
-- Initialize previous component. This is Empty unless there
-- are components which have already been laid out by component
- -- clauses. If there are such components, we start our layout of
- -- the remaining components following the last such component
+ -- clauses. If there are such components, we start our lay out of
+ -- the remaining components following the last such component.
Prev_Comp := Empty;
@@ -2042,6 +2223,7 @@ package body Layout is
if Nkind (Decl) = N_Full_Type_Declaration
and then Has_Discriminants (E)
and then Nkind (Type_Definition (Decl)) = N_Record_Definition
+ and then Present (Component_List (Type_Definition (Decl)))
and then
Present (Variant_Part (Component_List (Type_Definition (Decl))))
then
@@ -2112,18 +2294,20 @@ package body Layout is
Desig := Full_View (Desig);
end if;
- if (Is_Array_Type (Desig)
+ if Is_Array_Type (Desig)
and then not Is_Constrained (Desig)
and then not Has_Completion_In_Body (Desig)
- and then not Debug_Flag_6)
+ and then not Debug_Flag_6
then
Init_Size (E, 2 * System_Address_Size);
-- Check for bad convention set
- if Convention (E) = Convention_C
- or else
- Convention (E) = Convention_CPP
+ if Warn_On_Export_Import
+ and then
+ (Convention (E) = Convention_C
+ or else
+ Convention (E) = Convention_CPP)
then
Error_Msg_N
("?this access type does not " &
@@ -2144,7 +2328,7 @@ package body Layout is
-- For discrete types, the RM_Size and Esize must be set
-- already, since this is part of the earlier processing
- -- and the front end is always required to layout the
+ -- and the front end is always required to lay out the
-- sizes of such types (since they are available as static
-- attributes). All we do is to check that this rule is
-- indeed obeyed!
@@ -2267,35 +2451,114 @@ package body Layout is
end if;
end if;
- -- Layout array and record types if front end layout set
+ -- Lay out array and record types if front end layout set
if Frontend_Layout_On_Target then
if Is_Array_Type (E) and then not Is_Bit_Packed_Array (E) then
Layout_Array_Type (E);
- return;
elsif Is_Record_Type (E) then
Layout_Record_Type (E);
- return;
end if;
- -- Special remaining processing for record types with a known size
- -- of 16, 32, or 64 bits whose alignment is not yet set. For these
- -- types, we set a corresponding alignment matching the size if
- -- possible, or as large as possible if not.
+ -- Case of backend layout, we still do a little in the front end
- elsif Is_Record_Type (E) and not Debug_Flag_Q then
- Set_Composite_Alignment (E);
+ else
+ -- Processing for record types
- -- For arrays, we only do this processing for arrays that are
- -- required to be atomic. Here, we really need to have proper
- -- alignment, but for the normal case of non-atomic arrays it
- -- seems better to use the component alignment as the default.
+ if Is_Record_Type (E) then
- elsif Is_Array_Type (E)
- and then Is_Atomic (E)
- and then not Debug_Flag_Q
- then
- Set_Composite_Alignment (E);
+ -- Special remaining processing for record types with a known
+ -- size of 16, 32, or 64 bits whose alignment is not yet set.
+ -- For these types, we set a corresponding alignment matching
+ -- the size if possible, or as large as possible if not.
+
+ if Convention (E) = Convention_Ada
+ and then not Debug_Flag_Q
+ then
+ Set_Composite_Alignment (E);
+ end if;
+
+ -- Procressing for array types
+
+ elsif Is_Array_Type (E) then
+
+ -- For arrays that are required to be atomic, we do the same
+ -- processing as described above for short records, since we
+ -- really need to have the alignment set for the whole array.
+
+ if Is_Atomic (E) and then not Debug_Flag_Q then
+ Set_Composite_Alignment (E);
+ end if;
+
+ -- For unpacked array types, set an alignment of 1 if we know
+ -- that the component alignment is not greater than 1. The reason
+ -- we do this is to avoid unnecessary copying of slices of such
+ -- arrays when passed to subprogram parameters (see special test
+ -- in Exp_Ch6.Expand_Actuals).
+
+ if not Is_Packed (E)
+ and then Unknown_Alignment (E)
+ then
+ if Known_Static_Component_Size (E)
+ and then Component_Size (E) = 1
+ then
+ Set_Alignment (E, Uint_1);
+ end if;
+ end if;
+ end if;
+ end if;
+
+ -- Final step is to check that Esize and RM_Size are compatible
+
+ if Known_Static_Esize (E) and then Known_Static_RM_Size (E) then
+ if Esize (E) < RM_Size (E) then
+
+ -- Esize is less than RM_Size. That's not good. First we test
+ -- whether this was set deliberately with an Object_Size clause
+ -- and if so, object to the clause.
+
+ if Has_Object_Size_Clause (E) then
+ Error_Msg_Uint_1 := RM_Size (E);
+ Error_Msg_F
+ ("object size is too small, minimum is ^",
+ Expression (Get_Attribute_Definition_Clause
+ (E, Attribute_Object_Size)));
+ end if;
+
+ -- Adjust Esize up to RM_Size value
+
+ declare
+ Size : constant Uint := RM_Size (E);
+
+ begin
+ Set_Esize (E, RM_Size (E));
+
+ -- For scalar types, increase Object_Size to power of 2,
+ -- but not less than a storage unit in any case (i.e.,
+ -- normally this means it will be byte addressable).
+
+ if Is_Scalar_Type (E) then
+ if Size <= System_Storage_Unit then
+ Init_Esize (E, System_Storage_Unit);
+ elsif Size <= 16 then
+ Init_Esize (E, 16);
+ elsif Size <= 32 then
+ Init_Esize (E, 32);
+ else
+ Set_Esize (E, (Size + 63) / 64 * 64);
+ end if;
+
+ -- Finally, make sure that alignment is consistent with
+ -- the newly assigned size.
+
+ while Alignment (E) * System_Storage_Unit < Esize (E)
+ and then Alignment (E) < Maximum_Alignment
+ loop
+ Set_Alignment (E, 2 * Alignment (E));
+ end loop;
+ end if;
+ end;
+ end if;
end if;
end Layout_Type;
@@ -2433,29 +2696,102 @@ package body Layout is
-- Size is known, alignment is not set
- if Siz = System_Storage_Unit then
- Align := 1;
- elsif Siz = 2 * System_Storage_Unit then
+ -- Reset alignment to match size if size is exactly 2, 4, or 8 bytes
+
+ if Siz = 2 * System_Storage_Unit then
Align := 2;
elsif Siz = 4 * System_Storage_Unit then
Align := 4;
elsif Siz = 8 * System_Storage_Unit then
Align := 8;
+
+ -- On VMS, also reset for odd "in between" sizes, e.g. a 17-bit
+ -- record is given an alignment of 4. This is more consistent with
+ -- what DEC Ada does.
+
+ elsif OpenVMS_On_Target and then Siz > System_Storage_Unit then
+
+ if Siz <= 2 * System_Storage_Unit then
+ Align := 2;
+ elsif Siz <= 4 * System_Storage_Unit then
+ Align := 4;
+ elsif Siz <= 8 * System_Storage_Unit then
+ Align := 8;
+ else
+ return;
+ end if;
+
+ -- No special alignment fiddling needed
+
else
return;
end if;
+ -- Here Align is set to the proposed improved alignment
+
if Align > Maximum_Alignment then
Align := Maximum_Alignment;
end if;
- if Align > System_Word_Size / System_Storage_Unit then
- Align := System_Word_Size / System_Storage_Unit;
+ -- Further processing for record types only to reduce the alignment
+ -- set by the above processing in some specific cases. We do not
+ -- do this for atomic records, since we need max alignment there.
+
+ if Is_Record_Type (E) then
+
+ -- For records, there is generally no point in setting alignment
+ -- higher than word size since we cannot do better than move by
+ -- words in any case
+
+ if Align > System_Word_Size / System_Storage_Unit then
+ Align := System_Word_Size / System_Storage_Unit;
+ end if;
+
+ -- Check components. If any component requires a higher
+ -- alignment, then we set that higher alignment in any case.
+
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Component (E);
+ while Present (Comp) loop
+ if Known_Alignment (Etype (Comp)) then
+ declare
+ Calign : constant Uint := Alignment (Etype (Comp));
+
+ begin
+ -- The cases to worry about are when the alignment
+ -- of the component type is larger than the alignment
+ -- we have so far, and either there is no component
+ -- clause for the alignment, or the length set by
+ -- the component clause matches the alignment set.
+
+ if Calign > Align
+ and then
+ (Unknown_Esize (Comp)
+ or else (Known_Static_Esize (Comp)
+ and then
+ Esize (Comp) =
+ Calign * System_Storage_Unit))
+ then
+ Align := UI_To_Int (Calign);
+ end if;
+ end;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+ end;
end if;
+ -- Set chosen alignment
+
Set_Alignment (E, UI_From_Int (Align));
- if Unknown_Esize (E) then
+ if Known_Static_Esize (E)
+ and then Esize (E) < Align * System_Storage_Unit
+ then
Set_Esize (E, UI_From_Int (Align * System_Storage_Unit));
end if;
end if;
@@ -2519,7 +2855,7 @@ package body Layout is
return;
-- If the size is not set, then don't attempt to set the alignment. This
- -- happens in the backend layout case for access to subprogram types.
+ -- happens in the backend layout case for access-to-subprogram types.
elsif not Known_Static_Esize (E) then
return;
@@ -2576,8 +2912,9 @@ package body Layout is
function SO_Ref_From_Expr
(Expr : Node_Id;
Ins_Type : Entity_Id;
- Vtype : Entity_Id := Empty)
- return Dynamic_SO_Ref
+ Vtype : Entity_Id := Empty;
+ Make_Func : Boolean := False)
+ return Dynamic_SO_Ref
is
Loc : constant Source_Ptr := Sloc (Ins_Type);
@@ -2653,7 +2990,27 @@ package body Layout is
Make_Return_Statement (Loc,
Expression => Expr))));
- -- No reference to V, create constant
+ -- The caller requests that the expression be encapsulated in
+ -- a parameterless function.
+
+ elsif Make_Func then
+ Decl :=
+ Make_Subprogram_Body (Loc,
+
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => K,
+ Parameter_Specifications => Empty_List,
+ Subtype_Mark => New_Occurrence_Of (Standard_Unsigned, Loc)),
+
+ Declarations => Empty_List,
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Return_Statement (Loc, Expression => Expr))));
+
+ -- No reference to V and function not requested, so create a constant
else
Decl :=
diff --git a/gcc/ada/lib-list.adb b/gcc/ada/lib-list.adb
index ccc667ea499..261f08cf0c4 100644
--- a/gcc/ada/lib-list.adb
+++ b/gcc/ada/lib-list.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,9 +42,6 @@ procedure List (File_Names_Only : Boolean := False) is
Sorted_Units : Unit_Ref_Table (1 .. Num_Units);
-- Table of unit numbers that we will sort
- Unit_Node : Node_Id;
- -- Compilation unit node for current unit
-
Unit_Hed : constant String := "Unit name ";
Unit_Und : constant String := "--------- ";
Unit_Bln : constant String := " ";
@@ -84,8 +81,6 @@ begin
end if;
for R in Sorted_Units'Range loop
- Unit_Node := Cunit (Sorted_Units (R));
-
if File_Names_Only then
if not Is_Internal_File_Name
(File_Name (Source_Index (Sorted_Units (R))))
diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb
index 5943ffe1b79..285e2512027 100644
--- a/gcc/ada/lib-load.adb
+++ b/gcc/ada/lib-load.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -26,6 +26,7 @@
with Atree; use Atree;
with Debug; use Debug;
+with Einfo; use Einfo;
with Errout; use Errout;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
@@ -41,6 +42,7 @@ with Scn; use Scn;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Sinput.L; use Sinput.L;
+with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uname; use Uname;
@@ -76,6 +78,7 @@ package body Lib.Load is
is
Unum : Unit_Number_Type;
Cunit_Entity : Entity_Id;
+ Scope_Entity : Entity_Id;
Cunit : Node_Id;
Du_Name : Node_Or_Entity_Id;
End_Lab : Node_Id;
@@ -95,6 +98,8 @@ package body Lib.Load is
Du_Name := Cunit_Entity;
End_Lab := New_Occurrence_Of (Cunit_Entity, No_Location);
+ Scope_Entity := Standard_Standard;
+
-- Child package
else -- Nkind (Name (With_Node)) = N_Expanded_Name
@@ -105,12 +110,23 @@ package body Lib.Load is
Make_Defining_Program_Unit_Name (No_Location,
Name => New_Copy_Tree (Prefix (Name (With_Node))),
Defining_Identifier => Cunit_Entity);
+
+ Set_Is_Child_Unit (Cunit_Entity);
+
+ if Nkind (Du_Name) = N_Defining_Program_Unit_Name then
+ Scope_Entity := Defining_Identifier (Du_Name);
+ else
+ Scope_Entity := Du_Name;
+ end if;
+
End_Lab :=
Make_Designator (No_Location,
Name => New_Copy_Tree (Prefix (Name (With_Node))),
Identifier => New_Occurrence_Of (Cunit_Entity, No_Location));
end if;
+ Set_Scope (Cunit_Entity, Scope_Entity);
+
Cunit :=
Make_Compilation_Unit (No_Location,
Context_Items => Empty_List,
@@ -124,6 +140,13 @@ package body Lib.Load is
Aux_Decls_Node =>
Make_Compilation_Unit_Aux (No_Location));
+ -- Mark the dummy package as analyzed to prevent analysis of this
+ -- (non-existent) unit in -gnatQ mode because at the moment the
+ -- structure and attributes of this dummy package does not allow
+ -- a normal analysis of this unit
+
+ Set_Analyzed (Cunit);
+
Units.Increment_Last;
Unum := Units.Last;
@@ -158,11 +181,28 @@ package body Lib.Load is
----------------
procedure Initialize is
- Fname : File_Name_Type;
-
begin
Units.Init;
Load_Stack.Init;
+ end Initialize;
+
+ ------------------------
+ -- Initialize_Version --
+ ------------------------
+
+ procedure Initialize_Version (U : Unit_Number_Type) is
+ begin
+ Units.Table (U).Version := Source_Checksum (Source_Index (U));
+ end Initialize_Version;
+
+ ----------------------
+ -- Load_Main_Source --
+ ----------------------
+
+ procedure Load_Main_Source is
+ Fname : File_Name_Type;
+
+ begin
Load_Stack.Increment_Last;
Load_Stack.Table (Load_Stack.Last) := Main_Unit;
@@ -202,16 +242,7 @@ package body Lib.Load is
Unit_Name => No_Name,
Version => Source_Checksum (Main_Source_File));
end if;
- end Initialize;
-
- ------------------------
- -- Initialize_Version --
- ------------------------
-
- procedure Initialize_Version (U : Unit_Number_Type) is
- begin
- Units.Table (U).Version := Source_Checksum (Source_Index (U));
- end Initialize_Version;
+ end Load_Main_Source;
---------------
-- Load_Unit --
@@ -232,11 +263,10 @@ package body Lib.Load is
Unump : Unit_Number_Type;
Fname : File_Name_Type;
Src_Ind : Source_File_Index;
- Discard : List_Id;
procedure Set_Load_Unit_Dependency (U : Unit_Number_Type);
-- Sets the Dependent_Unit flag unless we have a predefined unit
- -- being loaded in No_Run_Time mode. In this case we do not want
+ -- being loaded in High_Integrity_Mode. In this case we do not want
-- to create a dependency, since we have loaded the unit only
-- to inline stuff from it. If this is not the case, an error
-- message will be issued in Rtsfind in any case.
@@ -247,19 +277,18 @@ package body Lib.Load is
procedure Set_Load_Unit_Dependency (U : Unit_Number_Type) is
begin
- -- Differentiate between pragma No_Run_Time (that can be used
- -- with a standard installation), and HI-E mode which comes
+ -- Differentiate between pragma No_Run_Time mode (that can be
+ -- used with a standard installation), and HI-E mode which comes
-- with a special installation.
- --
- -- For No_Run_Time mode, we do not want to create a dependency
- -- since the binder would generate references to these units.
- -- In the case of HI-E, a special run time is provided that do
- -- not have any elaboration, so it is safe (and useful) to add
- -- the dependency. In particular, this allows the user to
- -- recompile run time units, e.g GNAT.IO.
-
- if No_Run_Time
- and then not High_Integrity_Mode_On_Target
+
+ -- For Configurable_Run_Time_Mode set by a pragma, we do not want to
+ -- create a dependency since the binder would generate references to
+ -- these units. In the case of configurable run-time, we do want to
+ -- establish this dependency.
+
+ if Configurable_Run_Time_Mode
+ and then not Configurable_Run_Time_On_Target
+ and then not Debug_Flag_YY
and then Is_Internal_File_Name (Unit_File_Name (U))
then
null;
@@ -366,9 +395,11 @@ package body Lib.Load is
-- Capture error location if it is for the main unit. The idea is to
-- post errors on the main unit location, not the most recent unit.
+ -- Note: Unit_Name (Main_Unit) is not set if we are parsing gnat.adc.
- if Present (Error_Node) then
-
+ if Present (Error_Node)
+ and then Unit_Name (Main_Unit) /= No_Name
+ then
-- It seems like In_Extended_Main_Source_Unit (Error_Node) would
-- do the trick here, but that's wrong, it is much too early to
-- call this routine. We are still in the parser, and the required
@@ -493,9 +524,15 @@ package body Lib.Load is
-- legitimately occurs (e.g. two package bodies that contain
-- inlined subprogram referenced by the other).
+ -- We also ignore limited_with clauses, because their purpose is
+ -- precisely to create legal circular structures.
+
if Loading (Unum)
and then (Is_Spec_Name (Units.Table (Unum).Unit_Name)
or else Acts_As_Spec (Units.Table (Unum).Cunit))
+ and then (Nkind (Error_Node) /= N_With_Clause
+ or else not Limited_Present (Error_Node))
+
then
if Debug_Flag_L then
Write_Str (" circular dependency encountered");
@@ -565,7 +602,7 @@ package body Lib.Load is
-- Parse the new unit
Initialize_Scanner (Unum, Source_Index (Unum));
- Discard := Par (Configuration_Pragmas => False);
+ Discard_List (Par (Configuration_Pragmas => False));
Set_Loading (Unum, False);
-- If spec is irrelevant, then post errors and quit
@@ -705,10 +742,13 @@ package body Lib.Load is
Fnum : constant Unit_Number_Type := Get_Cunit_Unit_Number (From);
begin
- Units.Table (Unum).Version :=
- Units.Table (Unum).Version
- xor
- Source_Checksum (Source_Index (Fnum));
+
+ if Source_Index (Fnum) /= No_Source_File then
+ Units.Table (Unum).Version :=
+ Units.Table (Unum).Version
+ xor
+ Source_Checksum (Source_Index (Fnum));
+ end if;
end Version_Update;
----------------------------
diff --git a/gcc/ada/lib-load.ads b/gcc/ada/lib-load.ads
index 0d8c9d824b0..36e7e06622e 100644
--- a/gcc/ada/lib-load.ads
+++ b/gcc/ada/lib-load.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -88,6 +88,14 @@ package Lib.Load is
-----------------
procedure Initialize;
+ -- Initialize internal tables
+
+ procedure Initialize_Version (U : Unit_Number_Type);
+ -- This is called once the source file corresponding to unit U has been
+ -- fully scanned. At that point the checksum is computed, and can be used
+ -- to initialize the version number.
+
+ procedure Load_Main_Source;
-- Called at the start of compiling a new main source unit to initialize
-- the library processing for the new main source. Establishes and
-- initializes the units table entry for the new main unit (leaving
@@ -95,11 +103,6 @@ package Lib.Load is
-- more files. Otherwise the main source file has been opened and read
-- and then closed on return.
- procedure Initialize_Version (U : Unit_Number_Type);
- -- This is called once the source file corresponding to unit U has been
- -- fully scanned. At that point the checksum is computed, and can be used
- -- to initialize the version number.
-
function Load_Unit
(Load_Name : Unit_Name_Type;
Required : Boolean;
diff --git a/gcc/ada/lib-sort.adb b/gcc/ada/lib-sort.adb
index d8b6d71a3b4..89567506b32 100644
--- a/gcc/ada/lib-sort.adb
+++ b/gcc/ada/lib-sort.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -54,9 +54,21 @@ procedure Sort (Tbl : in out Unit_Ref_Table) is
function Lt_Uname (C1, C2 : Natural) return Boolean is
begin
- return
- Uname_Lt
- (Units.Table (T (C1)).Unit_Name, Units.Table (T (C2)).Unit_Name);
+ -- Preprocessing data and definition files are not sorted, they are
+ -- at the bottom of the list. They are recognized because they are
+ -- the only ones without a Unit_Name.
+
+ if Units.Table (T (C1)).Unit_Name = No_Name then
+ return False;
+
+ elsif Units.Table (T (C2)).Unit_Name = No_Name then
+ return True;
+
+ else
+ return
+ Uname_Lt
+ (Units.Table (T (C1)).Unit_Name, Units.Table (T (C2)).Unit_Name);
+ end if;
end Lt_Uname;
----------------
diff --git a/gcc/ada/lib-util.adb b/gcc/ada/lib-util.adb
index 0ff2c1d123b..767c8d88eb6 100644
--- a/gcc/ada/lib-util.adb
+++ b/gcc/ada/lib-util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -65,7 +65,7 @@ package body Lib.Util is
-- Write single hex digit
procedure Write_Info_Hex_Byte (J : Natural) is
- Hexd : String := "0123456789abcdef";
+ Hexd : constant String := "0123456789abcdef";
begin
Write_Info_Char (Hexd (J / 16 + 1));
diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb
index 254fa711128..35248a49d9b 100644
--- a/gcc/ada/lib-writ.adb
+++ b/gcc/ada/lib-writ.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -45,19 +45,46 @@ with Scn; use Scn;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Stringt; use Stringt;
+with Tbuild; use Tbuild;
with Uname; use Uname;
with System.WCh_Con; use System.WCh_Con;
package body Lib.Writ is
+ ----------------------------------
+ -- Add_Preprocessing_Dependency --
+ ----------------------------------
+
+ procedure Add_Preprocessing_Dependency (S : Source_File_Index) is
+ begin
+ Units.Increment_Last;
+ Units.Table (Units.Last) :=
+ (Unit_File_Name => File_Name (S),
+ Unit_Name => No_Name,
+ Expected_Unit => No_Name,
+ Source_Index => S,
+ Cunit => Empty,
+ Cunit_Entity => Empty,
+ Dependency_Num => 0,
+ Dependent_Unit => True,
+ Dynamic_Elab => False,
+ Fatal_Error => False,
+ Generate_Code => False,
+ Has_RACW => False,
+ Ident_String => Empty,
+ Loading => False,
+ Main_Priority => -1,
+ Serial_Number => 0,
+ Version => 0,
+ Error_Location => No_Location);
+ end Add_Preprocessing_Dependency;
+
------------------------------
-- Ensure_System_Dependency --
------------------------------
procedure Ensure_System_Dependency is
- Discard : List_Id;
-
System_Uname : Unit_Name_Type;
-- Unit name for system spec if needed for dummy entry
@@ -108,7 +135,7 @@ package body Lib.Writ is
-- Parse system.ads so that the checksum is set right
Initialize_Scanner (Units.Last, System_Source_File_Index);
- Discard := Par (Configuration_Pragmas => False);
+ Discard_List (Par (Configuration_Pragmas => False));
end Ensure_System_Dependency;
---------------
@@ -182,7 +209,11 @@ package body Lib.Writ is
Item := First (Context_Items (Cunit));
while Present (Item) loop
- if Nkind (Item) = N_With_Clause then
+ -- limited_with_clauses do not create dependencies.
+
+ if Nkind (Item) = N_With_Clause
+ and then not (Limited_Present (Item))
+ then
Unum := Get_Cunit_Unit_Number (Library_Unit (Item));
With_Flags (Unum) := True;
@@ -293,6 +324,14 @@ package body Lib.Writ is
Write_Info_Tab (49);
Write_Info_Str (Version_Get (Unit_Num));
+ if (Is_Subprogram (Uent)
+ or else Ekind (Uent) = E_Package
+ or else Is_Generic_Unit (Uent))
+ and then Body_Needed_For_SAL (Uent)
+ then
+ Write_Info_Str (" BN");
+ end if;
+
if Dynamic_Elab (Unit_Num) then
Write_Info_Str (" DE");
end if;
@@ -450,9 +489,13 @@ package body Lib.Writ is
if Nkind (Unit (Unode)) in N_Unit_Body then
for S in Units.First .. Last_Unit loop
- -- We are only interested in subunits
+ -- We are only interested in subunits.
+ -- For preproc. data and def. files, Cunit is Empty, so
+ -- we need to test that first.
- if Nkind (Unit (Cunit (S))) = N_Subunit then
+ if Cunit (S) /= Empty
+ and then Nkind (Unit (Cunit (S))) = N_Subunit
+ then
Pnode := Library_Unit (Cunit (S));
-- In gnatc mode, the errors in the subunits will not
@@ -509,7 +552,7 @@ package body Lib.Writ is
else
declare
- Hex : array (0 .. 15) of Character :=
+ Hex : constant array (0 .. 15) of Character :=
"0123456789ABCDEF";
begin
@@ -556,8 +599,11 @@ package body Lib.Writ is
-- parent spec of the main unit (case of main unit is a child
-- unit). The latter with is not needed for semantic purposes,
-- but is required by the binder for elaboration purposes.
+ -- For preproc. data and def. files, there is no Unit_Name,
+ -- check for that first.
- if (With_Flags (J) or else Unit_Name (J) = Pname)
+ if Unit_Name (J) /= No_Name
+ and then (With_Flags (J) or else Unit_Name (J) = Pname)
and then Units.Table (J).Dependent_Unit
then
Num_Withs := Num_Withs + 1;
@@ -638,8 +684,12 @@ package body Lib.Writ is
-- because it is referenced by Up_To_Date_ALI_File_Exists.
for Unum in Units.First .. Last_Unit loop
- Num_Sdep := Num_Sdep + 1;
- Sdep_Table (Num_Sdep) := Unum;
+ if Cunit_Entity (Unum) = Empty
+ or else not From_With_Type (Cunit_Entity (Unum))
+ then
+ Num_Sdep := Num_Sdep + 1;
+ Sdep_Table (Num_Sdep) := Unum;
+ end if;
end loop;
-- Sort the table so that the D lines are in order
@@ -673,13 +723,17 @@ package body Lib.Writ is
-- Output main program line if this is acceptable main program
- declare
+ Output_Main_Program_Line : declare
U : Node_Id := Unit (Units.Table (Main_Unit).Cunit);
S : Node_Id;
procedure M_Parameters;
-- Output parameters for main program line
+ ------------------
+ -- M_Parameters --
+ ------------------
+
procedure M_Parameters is
begin
if Main_Priority (Main_Unit) /= Default_Main_Priority then
@@ -699,6 +753,8 @@ package body Lib.Writ is
Write_Info_EOL;
end M_Parameters;
+ -- Start of processing for Output_Main_Program_Line
+
begin
if Nkind (U) = N_Subprogram_Body
or else (Nkind (U) = N_Package_Body
@@ -747,7 +803,7 @@ package body Lib.Writ is
end if;
end if;
end if;
- end;
+ end Output_Main_Program_Line;
-- Write command argmument ('A') lines
@@ -804,7 +860,7 @@ package body Lib.Writ is
Write_Info_Str (" NO");
end if;
- if No_Run_Time then
+ if No_Run_Time_Mode then
Write_Info_Str (" NR");
end if;
@@ -816,7 +872,7 @@ package body Lib.Writ is
Write_Info_Str (" UA");
end if;
- if Exception_Mechanism /= Setjmp_Longjmp then
+ if Exception_Mechanism /= Front_End_Setjmp_Longjmp_Exceptions then
if Unit_Exception_Table_Present then
Write_Info_Str (" UX");
end if;
@@ -826,6 +882,22 @@ package body Lib.Writ is
Write_Info_EOL;
+ -- Before outputting the restrictions line, update the setting of
+ -- the No_Elaboration_Code flag. Violations of this restriction
+ -- cannot be detected until after the backend has been called since
+ -- it is the backend that sets this flag. We have to check all units
+ -- for which we have generated code
+
+ for Unit in Units.First .. Last_Unit loop
+ if Units.Table (Unit).Generate_Code
+ or else Unit = Main_Unit
+ then
+ if not Has_No_Elaboration_Code (Cunit (Unit)) then
+ Violations (No_ELaboration_Code) := True;
+ end if;
+ end if;
+ end loop;
+
-- Output restrictions line
Write_Info_Initiate ('R');
@@ -843,6 +915,21 @@ package body Lib.Writ is
Write_Info_EOL;
+ -- Output interrupt state lines
+
+ for J in Interrupt_States.First .. Interrupt_States.Last loop
+ Write_Info_Initiate ('I');
+ Write_Info_Char (' ');
+ Write_Info_Nat (Interrupt_States.Table (J).Interrupt_Number);
+ Write_Info_Char (' ');
+ Write_Info_Char (Interrupt_States.Table (J).Interrupt_State);
+ Write_Info_Char (' ');
+ Write_Info_Nat
+ (Nat (Get_Logical_Line_Number
+ (Interrupt_States.Table (J).Pragma_Loc)));
+ Write_Info_EOL;
+ end loop;
+
-- Loop through file table to output information for all units for which
-- we have generated code, as marked by the Generate_Code flag.
diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads
index a2ec16a238a..ef640dc5d5a 100644
--- a/gcc/ada/lib-writ.ads
+++ b/gcc/ada/lib-writ.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -39,7 +39,7 @@ package Lib.Writ is
-- This section describes the format of the library information that is
-- associated with object files. The exact method of this association is
-- potentially implementation dependent and is described and implemented
- -- in package From the point of view of the description here, all we
+ -- in package ali. From the point of view of the description here, all we
-- need to know is that the information is represented as a string of
-- characters that is somehow associated with an object file, and can be
-- retrieved. If no library information exists for a given object file,
@@ -130,8 +130,6 @@ package Lib.Writ is
-- zero or more two letter codes that indicate configuration
-- pragmas and other parameters that apply:
--
- -- Present if the unit uses tasking directly or indirectly and
- -- has one or more valid xxx_Policy pragmas that apply to the unit.
-- The arguments are as follows:
--
-- CE Compilation errors. If this is present it means that the
@@ -163,7 +161,8 @@ package Lib.Writ is
-- can be produced (e.g. when a package spec is compiled
-- instead of the body, or a subunit on its own).
--
- -- NR No_Run_Time pragma in effect for all units in this file
+ -- NR No_Run_Time. Indicates that a pragma No_Run_Time applies
+ -- to all units in the file.
--
-- NS Normalize_Scalars pragma in effect for all units in
-- this file
@@ -172,6 +171,12 @@ package Lib.Writ is
-- in this file, where x is the first character (upper case)
-- of the policy name (e.g. 'P' for Priority_Queueing).
--
+ -- SL Indicates that the unit is an Interface to a Standalone
+ -- Library. Note that this indication is never given by the
+ -- compiler, but is added by the Project Manager in gnatmake
+ -- when an Interface ALI file is copied to the library
+ -- directory.
+ --
-- Tx A valid Task_Dispatching_Policy pragma applies to all
-- the units in this file, where x is the first character
-- (upper case) of the corresponding policy name (e.g. 'F'
@@ -223,6 +228,25 @@ package Lib.Writ is
-- has "v", which is not permitted, since these restrictions
-- are partition-wide.
+ -- ------------------------
+ -- -- I Interrupt States --
+ -- ------------------------
+
+ -- I interrupt-number interrupt-state line-number
+
+ -- This line records information from an Interrupt_State pragma.
+ -- There is one line for each separate pragma, and if no such
+ -- pragmas are used, then no I lines are present.
+
+ -- The interrupt-number is an unsigned positive integer giving
+ -- the value of the interrupt as defined in Ada.Interrupts.Names.
+
+ -- The interrupt-state is one of r/s/u for Runtime/System/User
+
+ -- The line number is an unsigned decimal integer giving the
+ -- line number of the corresponding Interrupt_State pragma.
+ -- This is used in consistency messages.
+
----------------------------
-- Compilation Unit Lines --
----------------------------
@@ -437,6 +461,11 @@ package Lib.Writ is
-- allows a reader of the ALI file to determine the exact mapping
-- of physical line numbers back to the original source.
+ -- Files with a zero checksum and a non-zero time stamp are in general
+ -- files on which the compilation depends but which are not Ada files
+ -- with further dependencies. This includes preprocessor data files
+ -- and preprocessor definition files.
+
-- Note: blank lines are ignored when the library information is
-- read, and separate sections of the file are separated by blank
-- lines to ease readability. Blanks between fields are also
@@ -456,6 +485,35 @@ package Lib.Writ is
-- The cross-reference data follows the dependency lines. See
-- the spec of Lib.Xref for details on the format of this data.
+ ----------------------
+ -- Global_Variables --
+ ----------------------
+
+ -- The table structure defined here stores one entry for each
+ -- Interrupt_State pragma encountered either in the main source or
+ -- in an ancillary with'ed source. Since interrupt state values
+ -- have to be consistent across all units in a partition, we may
+ -- as well detect inconsistencies at compile time when we can.
+
+ type Interrupt_State_Entry is record
+ Interrupt_Number : Pos;
+ -- Interrupt number value
+
+ Interrupt_State : Character;
+ -- Set to r/s/u for Runtime/System/User
+
+ Pragma_Loc : Source_Ptr;
+ -- Location of pragma setting this value in place
+ end record;
+
+ package Interrupt_States is new Table.Table (
+ Table_Component_Type => Interrupt_State_Entry,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 30,
+ Table_Increment => 200,
+ Table_Name => "Name_Interrupt_States");
+
-----------------
-- Subprograms --
-----------------
@@ -476,4 +534,8 @@ package Lib.Writ is
-- it reads this file and sets the Lib.Compilation_Arguments table from
-- the A lines in this file.
+ procedure Add_Preprocessing_Dependency (S : Source_File_Index);
+ -- Indicate that there is a dependency to be added on a preprocessing
+ -- data file or on a preprocessing definition file.
+
end Lib.Writ;
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index dd1e61cbd3f..014a9e97030 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-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- --
@@ -26,12 +26,17 @@
with Atree; use Atree;
with Csets; use Csets;
+with Elists; use Elists;
with Errout; use Errout;
with Lib.Util; use Lib.Util;
with Namet; use Namet;
+with Nlists; use Nlists;
with Opt; use Opt;
+with Sem_Prag; use Sem_Prag;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
+with Snames; use Snames;
+with Stringt; use Stringt;
with Stand; use Stand;
with Table; use Table;
with Widechar; use Widechar;
@@ -124,6 +129,7 @@ package body Lib.Xref is
Xrefs.Table (Indx).Loc := No_Location;
Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
Xrefs.Table (Indx).Lun := No_Unit;
+ Set_Has_Xref_Entry (E);
end if;
end Generate_Definition;
@@ -131,7 +137,10 @@ package body Lib.Xref is
-- Generate_Operator_Reference --
---------------------------------
- procedure Generate_Operator_Reference (N : Node_Id) is
+ procedure Generate_Operator_Reference
+ (N : Node_Id;
+ T : Entity_Id)
+ is
begin
if not In_Extended_Main_Source_Unit (N) then
return;
@@ -161,18 +170,14 @@ package body Lib.Xref is
-- marked as referenced is the first subtype, which is the user
-- defined entity that is relevant.
- else
- if Nkind (N) = N_Op_Eq
- or else Nkind (N) = N_Op_Ne
- or else Nkind (N) = N_Op_Le
- or else Nkind (N) = N_Op_Lt
- or else Nkind (N) = N_Op_Ge
- or else Nkind (N) = N_Op_Gt
- then
- Set_Referenced (First_Subtype (Etype (Right_Opnd (N))));
- else
- Set_Referenced (First_Subtype (Etype (N)));
- end if;
+ -- Note: we only do this for operators that come from source.
+ -- The generated code sometimes reaches for entities that do
+ -- not need to be explicitly visible (for example, when we
+ -- expand the code for comparing two record types, the fields
+ -- of the record may not be visible).
+
+ elsif Comes_From_Source (N) then
+ Set_Referenced (First_Subtype (T));
end if;
end Generate_Operator_Reference;
@@ -197,7 +202,7 @@ package body Lib.Xref is
pragma Assert (Nkind (E) in N_Entity);
-- Never collect references if not in main source unit. However,
- -- we omit this test if Typ is 'e', since these entries are
+ -- we omit this test if Typ is 'e' or 'k', since these entries are
-- really structural, and it is useful to have them in units
-- that reference packages as well as units that define packages.
-- We also omit the test for the case of 'p' since we want to
@@ -206,11 +211,12 @@ package body Lib.Xref is
if not In_Extended_Main_Source_Unit (N)
and then Typ /= 'e'
and then Typ /= 'p'
+ and then Typ /= 'k'
then
return;
end if;
- -- For reference type p, then entity must be in main source unit
+ -- For reference type p, the entity must be in main source unit
if Typ = 'p' and then not In_Extended_Main_Source_Unit (E) then
return;
@@ -233,9 +239,43 @@ package body Lib.Xref is
-- package contains no referenced entities).
if Set_Ref then
- Set_Referenced (E);
- -- Check for pragma unreferenced given
+ -- For a variable that appears on the left side of an
+ -- assignment statement, we set the Referenced_As_LHS
+ -- flag since this is indeed a left hand side.
+
+ if Ekind (E) = E_Variable
+ and then Nkind (Parent (N)) = N_Assignment_Statement
+ and then Name (Parent (N)) = N
+ and then No (Renamed_Object (E))
+ then
+ Set_Referenced_As_LHS (E);
+
+ -- Check for a reference in a pragma that should not count as a
+ -- making the variable referenced for warning purposes.
+
+ elsif Is_Non_Significant_Pragma_Reference (N) then
+ null;
+
+ -- A reference in an attribute definition clause does not
+ -- count as a reference except for the case of Address.
+ -- The reason that 'Address is an exception is that it
+ -- creates an alias through which the variable may be
+ -- referenced.
+
+ elsif Nkind (Parent (N)) = N_Attribute_Definition_Clause
+ and then Chars (Parent (N)) /= Name_Address
+ and then N = Name (Parent (N))
+ then
+ null;
+
+ -- Any other occurrence counts as referencing the entity
+
+ else
+ Set_Referenced (E);
+ end if;
+
+ -- Check for pragma Unreferenced given
if Has_Pragma_Unreferenced (E) then
@@ -248,6 +288,15 @@ package body Lib.Xref is
then
null;
+ -- Neither does a reference to a variable on the left side
+ -- of an assignment
+
+ elsif Ekind (E) = E_Variable
+ and then Nkind (Parent (N)) = N_Assignment_Statement
+ and then Name (Parent (N)) = N
+ then
+ null;
+
-- Here we issue the warning, since this is a real reference
else
@@ -299,6 +348,8 @@ package body Lib.Xref is
or else
Nkind (N) = N_Defining_Operator_Symbol
or else
+ Nkind (N) = N_Operator_Symbol
+ or else
(Nkind (N) = N_Character_Literal
and then Sloc (Entity (N)) /= Standard_Location)
or else
@@ -322,16 +373,33 @@ package body Lib.Xref is
Ent := E;
-- Entity does not come from source, but is a derived subprogram
- -- and the derived subprogram comes from source, in which case
- -- the reference is to this parent subprogram.
+ -- and the derived subprogram comes from source (after one or more
+ -- derivations) in which case the reference is to parent subprogram.
elsif Is_Overloadable (E)
and then Present (Alias (E))
- and then Comes_From_Source (Alias (E))
then
Ent := Alias (E);
- -- Ignore reference to any other source that is not from source
+ loop
+ if Comes_From_Source (Ent) then
+ exit;
+ elsif No (Alias (Ent)) then
+ return;
+ else
+ Ent := Alias (Ent);
+ end if;
+ end loop;
+
+ -- Record components of discriminated subtypes or derived types
+ -- must be treated as references to the original component.
+
+ elsif Ekind (E) = E_Component
+ and then Comes_From_Source (Original_Record_Component (E))
+ then
+ Ent := Original_Record_Component (E);
+
+ -- Ignore reference to any other entity that is not from source
else
return;
@@ -346,79 +414,295 @@ package body Lib.Xref is
Indx := Xrefs.Last;
Xrefs.Table (Indx).Loc := Ref;
- Xrefs.Table (Indx).Typ := Typ;
+
+ -- Overriding operations are marked with 'P'.
+
+ if Typ = 'p'
+ and then Is_Subprogram (N)
+ and then Is_Overriding_Operation (N)
+ then
+ Xrefs.Table (Indx).Typ := 'P';
+ else
+ Xrefs.Table (Indx).Typ := Typ;
+ end if;
+
Xrefs.Table (Indx).Eun := Get_Source_Unit (Def);
Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref);
Xrefs.Table (Indx).Ent := Ent;
+ Set_Has_Xref_Entry (Ent);
end if;
end Generate_Reference;
+ -----------------------------------
+ -- Generate_Reference_To_Formals --
+ -----------------------------------
+
+ procedure Generate_Reference_To_Formals (E : Entity_Id) is
+ Formal : Entity_Id;
+
+ begin
+ if Is_Generic_Subprogram (E) then
+ Formal := First_Entity (E);
+
+ while Present (Formal)
+ and then not Is_Formal (Formal)
+ loop
+ Next_Entity (Formal);
+ end loop;
+
+ else
+ Formal := First_Formal (E);
+ end if;
+
+ while Present (Formal) loop
+ if Ekind (Formal) = E_In_Parameter then
+
+ if Nkind (Parameter_Type (Parent (Formal)))
+ = N_Access_Definition
+ then
+ Generate_Reference (E, Formal, '^', False);
+ else
+ Generate_Reference (E, Formal, '>', False);
+ end if;
+
+ elsif Ekind (Formal) = E_In_Out_Parameter then
+ Generate_Reference (E, Formal, '=', False);
+
+ else
+ Generate_Reference (E, Formal, '<', False);
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end Generate_Reference_To_Formals;
+
+ -------------------------------------------
+ -- Generate_Reference_To_Generic_Formals --
+ -------------------------------------------
+
+ procedure Generate_Reference_To_Generic_Formals (E : Entity_Id) is
+ Formal : Entity_Id;
+
+ begin
+ Formal := First_Entity (E);
+
+ while Present (Formal) loop
+ if Comes_From_Source (Formal) then
+ Generate_Reference (E, Formal, 'z', False);
+ end if;
+
+ Next_Entity (Formal);
+ end loop;
+ end Generate_Reference_To_Generic_Formals;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Xrefs.Init;
+ end Initialize;
+
-----------------------
-- Output_References --
-----------------------
procedure Output_References is
- Nrefs : constant Nat := Xrefs.Last;
- Rnums : array (0 .. Nrefs) of Nat;
- -- This array contains numbers of references in the Xrefs table. This
- -- list is sorted in output order. The extra 0'th entry is convenient
- -- for the call to sort. When we sort the table, we move these entries
- -- around, but we do not move the original table entries.
+ procedure Get_Type_Reference
+ (Ent : Entity_Id;
+ Tref : out Entity_Id;
+ Left : out Character;
+ Right : out Character);
+ -- Given an entity id Ent, determines whether a type reference is
+ -- required. If so, Tref is set to the entity for the type reference
+ -- and Left and Right are set to the left/right brackets to be
+ -- output for the reference. If no type reference is required, then
+ -- Tref is set to Empty, and Left/Right are set to space.
+
+ procedure Output_Import_Export_Info (Ent : Entity_Id);
+ -- Ouput language and external name information for an interfaced
+ -- entity, using the format <language, external_name>,
+
+ ------------------------
+ -- Get_Type_Reference --
+ ------------------------
+
+ procedure Get_Type_Reference
+ (Ent : Entity_Id;
+ Tref : out Entity_Id;
+ Left : out Character;
+ Right : out Character)
+ is
+ Sav : Entity_Id;
+
+ begin
+ -- See if we have a type reference
- function Lt (Op1, Op2 : Natural) return Boolean;
- -- Comparison function for Sort call
+ Tref := Ent;
+ Left := '{';
+ Right := '}';
- procedure Move (From : Natural; To : Natural);
- -- Move procedure for Sort call
+ loop
+ Sav := Tref;
- function Lt (Op1, Op2 : Natural) return Boolean is
- T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
- T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
+ -- Processing for types
- begin
- -- First test. If entity is in different unit, sort by unit
+ if Is_Type (Tref) then
+
+ -- Case of base type
+
+ if Base_Type (Tref) = Tref then
+
+ -- If derived, then get first subtype
+
+ if Tref /= Etype (Tref) then
+ Tref := First_Subtype (Etype (Tref));
+
+ -- Set brackets for derived type, but don't
+ -- override pointer case since the fact that
+ -- something is a pointer is more important
+
+ if Left /= '(' then
+ Left := '<';
+ Right := '>';
+ end if;
+
+ -- If non-derived ptr, get directly designated type.
+ -- If the type has a full view, all references are
+ -- on the partial view, that is seen first.
+
+ elsif Is_Access_Type (Tref) then
+ Tref := Directly_Designated_Type (Tref);
+ Left := '(';
+ Right := ')';
+
+ elsif Is_Private_Type (Tref)
+ and then Present (Full_View (Tref))
+ and then Is_Access_Type (Full_View (Tref))
+ then
+ Tref := Directly_Designated_Type (Full_View (Tref));
+ Left := '(';
+ Right := ')';
+
+ -- If non-derived array, get component type.
+ -- Skip component type for case of String
+ -- or Wide_String, saves worthwhile space.
+
+ elsif Is_Array_Type (Tref)
+ and then Tref /= Standard_String
+ and then Tref /= Standard_Wide_String
+ then
+ Tref := Component_Type (Tref);
+ Left := '(';
+ Right := ')';
+
+ -- For other non-derived base types, nothing
+
+ else
+ exit;
+ end if;
+
+ -- For a subtype, go to ancestor subtype. If it is a
+ -- subtype created for a generic actual, not clear yet
+ -- what is the right type to use ???
+
+ else
+ Tref := Ancestor_Subtype (Tref);
+
+ -- If no ancestor subtype, go to base type
+
+ if No (Tref) then
+ Tref := Base_Type (Sav);
+ end if;
+ end if;
+
+ -- For objects, functions, enum literals,
+ -- just get type from Etype field.
+
+ elsif Is_Object (Tref)
+ or else Ekind (Tref) = E_Enumeration_Literal
+ or else Ekind (Tref) = E_Function
+ or else Ekind (Tref) = E_Operator
+ then
+ Tref := Etype (Tref);
- if T1.Eun /= T2.Eun then
- return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);
+ -- For anything else, exit
- -- Second test, within same unit, sort by entity Sloc
+ else
+ exit;
+ end if;
- elsif T1.Def /= T2.Def then
- return T1.Def < T2.Def;
+ -- Exit if no type reference, or we are stuck in
+ -- some loop trying to find the type reference, or
+ -- if the type is standard void type (the latter is
+ -- an implementation artifact that should not show
+ -- up in the generated cross-references).
- -- Third test, sort definitions ahead of references
+ exit when No (Tref)
+ or else Tref = Sav
+ or else Tref = Standard_Void_Type;
- elsif T1.Loc = No_Location then
- return True;
+ -- If we have a usable type reference, return, otherwise
+ -- keep looking for something useful (we are looking for
+ -- something that either comes from source or standard)
+
+ if Sloc (Tref) = Standard_Location
+ or else Comes_From_Source (Tref)
+ then
+ return;
+ end if;
+ end loop;
- elsif T2.Loc = No_Location then
- return False;
+ -- If we fall through the loop, no type reference
- -- Fourth test, for same entity, sort by reference location unit
+ Tref := Empty;
+ Left := ' ';
+ Right := ' ';
+ end Get_Type_Reference;
- elsif T1.Lun /= T2.Lun then
- return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
+ -------------------------------
+ -- Output_Import_Export_Info --
+ -------------------------------
- -- Fifth test order of location within referencing unit
+ procedure Output_Import_Export_Info (Ent : Entity_Id) is
+ Language_Name : Name_Id;
+ Conv : constant Convention_Id := Convention (Ent);
+ begin
+ if Conv = Convention_C then
+ Language_Name := Name_C;
- elsif T1.Loc /= T2.Loc then
- return T1.Loc < T2.Loc;
+ elsif Conv = Convention_CPP then
+ Language_Name := Name_CPP;
- -- Finally, for two locations at the same address, we prefer
- -- the one that does NOT have the type 'r' so that a modification
- -- or extension takes preference, when there are more than one
- -- reference at the same location.
+ elsif Conv = Convention_Ada then
+ Language_Name := Name_Ada;
else
- return T2.Typ = 'r';
+ -- These are the only languages that GPS knows about.
+
+ return;
end if;
- end Lt;
- procedure Move (From : Natural; To : Natural) is
- begin
- Rnums (Nat (To)) := Rnums (Nat (From));
- end Move;
+ Write_Info_Char ('<');
+ Get_Unqualified_Name_String (Language_Name);
+
+ for J in 1 .. Name_Len loop
+ Write_Info_Char (Name_Buffer (J));
+ end loop;
+
+ if Present (Interface_Name (Ent)) then
+ Write_Info_Char (',');
+ String_To_Name_Buffer (Strval (Interface_Name (Ent)));
+
+ for J in 1 .. Name_Len loop
+ Write_Info_Char (Name_Buffer (J));
+ end loop;
+ end if;
+
+ Write_Info_Char ('>');
+ end Output_Import_Export_Info;
-- Start of processing for Output_References
@@ -427,28 +711,141 @@ package body Lib.Xref is
return;
end if;
- -- Capture the definition Sloc values. We delay doing this till now,
- -- since at the time the reference or definition is made, private
- -- types may be swapped, and the Sloc value may be incorrect. We
- -- also set up the pointer vector for the sort.
+ -- Before we go ahead and output the references we have a problem
+ -- that needs dealing with. So far we have captured things that are
+ -- definitely referenced by the main unit, or defined in the main
+ -- unit. That's because we don't want to clutter up the ali file
+ -- for this unit with definition lines for entities in other units
+ -- that are not referenced.
+
+ -- But there is a glitch. We may reference an entity in another unit,
+ -- and it may have a type reference to an entity that is not directly
+ -- referenced in the main unit, which may mean that there is no xref
+ -- entry for this entity yet in the list of references.
+
+ -- If we don't do something about this, we will end with an orphan
+ -- type reference, i.e. it will point to an entity that does not
+ -- appear within the generated references in the ali file. That is
+ -- not good for tools using the xref information.
+
+ -- To fix this, we go through the references adding definition
+ -- entries for any unreferenced entities that can be referenced
+ -- in a type reference. There is a recursion problem here, and
+ -- that is dealt with by making sure that this traversal also
+ -- traverses any entries that get added by the traversal.
+
+ declare
+ J : Nat;
+ Tref : Entity_Id;
+ L, R : Character;
+ Indx : Nat;
+ Ent : Entity_Id;
+ Loc : Source_Ptr;
- for J in 1 .. Nrefs loop
- Rnums (J) := J;
- Xrefs.Table (J).Def :=
- Original_Location (Sloc (Xrefs.Table (J).Ent));
- end loop;
+ begin
+ -- Note that this is not a for loop for a very good reason. The
+ -- processing of items in the table can add new items to the
+ -- table, and they must be processed as well
+
+ J := 1;
+ while J <= Xrefs.Last loop
+ Ent := Xrefs.Table (J).Ent;
+ Get_Type_Reference (Ent, Tref, L, R);
+
+ if Present (Tref)
+ and then not Has_Xref_Entry (Tref)
+ and then Sloc (Tref) > No_Location
+ then
+ Xrefs.Increment_Last;
+ Indx := Xrefs.Last;
+ Loc := Original_Location (Sloc (Tref));
+ Xrefs.Table (Indx).Ent := Tref;
+ Xrefs.Table (Indx).Loc := No_Location;
+ Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
+ Xrefs.Table (Indx).Lun := No_Unit;
+ Set_Has_Xref_Entry (Tref);
+ end if;
+
+ -- Collect inherited primitive operations that may be
+ -- declared in another unit and have no visible reference
+ -- in the current one.
+
+ if Is_Type (Ent)
+ and then Is_Tagged_Type (Ent)
+ and then Is_Derived_Type (Ent)
+ and then Ent = Base_Type (Ent)
+ and then In_Extended_Main_Source_Unit (Ent)
+ then
- -- Sort the references
+ declare
+ Op_List : Elist_Id := Primitive_Operations (Ent);
+ Op : Elmt_Id;
+ Prim : Entity_Id;
- GNAT.Heap_Sort_A.Sort
- (Integer (Nrefs),
- Move'Unrestricted_Access,
- Lt'Unrestricted_Access);
+ function Parent_Op (E : Entity_Id) return Entity_Id;
+ -- Find original operation, which may be inherited
+ -- through several derivations.
- -- Now output the references
+ function Parent_Op (E : Entity_Id) return Entity_Id is
+ Orig_Op : Entity_Id := Alias (E);
+ begin
+ if No (Orig_Op) then
+ return Empty;
+
+ elsif not Comes_From_Source (E)
+ and then not Has_Xref_Entry (Orig_Op)
+ and then Comes_From_Source (Orig_Op)
+ then
+ return Orig_Op;
+ else
+ return Parent_Op (Orig_Op);
+ end if;
+ end Parent_Op;
+
+ begin
+ Op := First_Elmt (Op_List);
+
+ while Present (Op) loop
+
+ Prim := Parent_Op (Node (Op));
+
+ if Present (Prim) then
+ Xrefs.Increment_Last;
+ Indx := Xrefs.Last;
+ Loc := Original_Location (Sloc (Prim));
+ Xrefs.Table (Indx).Ent := Prim;
+ Xrefs.Table (Indx).Loc := No_Location;
+ Xrefs.Table (Indx).Eun :=
+ Get_Source_Unit (Sloc (Prim));
+ Xrefs.Table (Indx).Lun := No_Unit;
+ Set_Has_Xref_Entry (Prim);
+ end if;
+
+ Next_Elmt (Op);
+ end loop;
+ end;
+ end if;
+
+ J := J + 1;
+ end loop;
+ end;
+
+ -- Now we have all the references, including those for any embedded
+ -- type references, so we can sort them, and output them.
Output_Refs : declare
+ Nrefs : Nat := Xrefs.Last;
+ -- Number of references in table. This value may get reset
+ -- (reduced) when we eliminate duplicate reference entries.
+
+ Rnums : array (0 .. Nrefs) of Nat;
+ -- This array contains numbers of references in the Xrefs table.
+ -- This list is sorted in output order. The extra 0'th entry is
+ -- convenient for the call to sort. When we sort the table, we
+ -- move the entries in Rnums around, but we do not move the
+ -- original table entries.
+
Curxu : Unit_Number_Type;
-- Current xref unit
@@ -483,9 +880,71 @@ package body Lib.Xref is
Trunit : Unit_Number_Type;
-- Unit number for type reference
+ function Lt (Op1, Op2 : Natural) return Boolean;
+ -- Comparison function for Sort call
+
function Name_Change (X : Entity_Id) return Boolean;
-- Determines if entity X has a different simple name from Curent
+ procedure Move (From : Natural; To : Natural);
+ -- Move procedure for Sort call
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (Op1, Op2 : Natural) return Boolean is
+ T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
+ T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
+
+ begin
+ -- First test. If entity is in different unit, sort by unit
+
+ if T1.Eun /= T2.Eun then
+ return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);
+
+ -- Second test, within same unit, sort by entity Sloc
+
+ elsif T1.Def /= T2.Def then
+ return T1.Def < T2.Def;
+
+ -- Third test, sort definitions ahead of references
+
+ elsif T1.Loc = No_Location then
+ return True;
+
+ elsif T2.Loc = No_Location then
+ return False;
+
+ -- Fourth test, for same entity, sort by reference location unit
+
+ elsif T1.Lun /= T2.Lun then
+ return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
+
+ -- Fifth test order of location within referencing unit
+
+ elsif T1.Loc /= T2.Loc then
+ return T1.Loc < T2.Loc;
+
+ -- Finally, for two locations at the same address, we prefer
+ -- the one that does NOT have the type 'r' so that a modification
+ -- or extension takes preference, when there are more than one
+ -- reference at the same location.
+
+ else
+ return T2.Typ = 'r';
+ end if;
+ end Lt;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ Rnums (Nat (To)) := Rnums (Nat (From));
+ end Move;
+
-----------------
-- Name_Change --
-----------------
@@ -505,15 +964,64 @@ package body Lib.Xref is
-- Start of processing for Output_Refs
begin
+ -- Capture the definition Sloc values. We delay doing this till now,
+ -- since at the time the reference or definition is made, private
+ -- types may be swapped, and the Sloc value may be incorrect. We
+ -- also set up the pointer vector for the sort.
+
+ for J in 1 .. Nrefs loop
+ Rnums (J) := J;
+ Xrefs.Table (J).Def :=
+ Original_Location (Sloc (Xrefs.Table (J).Ent));
+ end loop;
+
+ -- Sort the references
+
+ GNAT.Heap_Sort_A.Sort
+ (Integer (Nrefs),
+ Move'Unrestricted_Access,
+ Lt'Unrestricted_Access);
+
+ -- Eliminate duplicate entries
+
+ declare
+ NR : constant Nat := Nrefs;
+
+ begin
+ -- We need this test for NR because if we force ALI file
+ -- generation in case of errors detected, it may be the case
+ -- that Nrefs is 0, so we should not reset it here
+
+ if NR >= 2 then
+ Nrefs := 1;
+
+ for J in 2 .. NR loop
+ if Xrefs.Table (Rnums (J)) /=
+ Xrefs.Table (Rnums (Nrefs))
+ then
+ Nrefs := Nrefs + 1;
+ Rnums (Nrefs) := Rnums (J);
+ end if;
+ end loop;
+ end if;
+ end;
+
+ -- Initialize loop through references
+
Curxu := No_Unit;
Curent := Empty;
Curdef := No_Location;
Curru := No_Unit;
Crloc := No_Location;
- for Refno in 1 .. Nrefs loop
+ -- Loop to output references
+ for Refno in 1 .. Nrefs loop
Output_One_Ref : declare
+ P2 : Source_Ptr;
+ WC : Char_Code;
+ Err : Boolean;
+ Ent : Entity_Id;
XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
-- The current entry to be accessed
@@ -521,15 +1029,9 @@ package body Lib.Xref is
P : Source_Ptr;
-- Used to index into source buffer to get entity name
- P2 : Source_Ptr;
- WC : Char_Code;
- Err : Boolean;
- Ent : Entity_Id;
- Sav : Entity_Id;
-
Left : Character;
Right : Character;
- -- Used for {} or <> for type reference
+ -- Used for {} or <> or () for type reference
procedure Output_Instantiation_Refs (Loc : Source_Ptr);
-- Recursive procedure to output instantiation references for
@@ -543,6 +1045,7 @@ package body Lib.Xref is
procedure Output_Instantiation_Refs (Loc : Source_Ptr) is
Iloc : constant Source_Ptr := Instantiation_Location (Loc);
Lun : Unit_Number_Type;
+ Cu : constant Unit_Number_Type := Curru;
begin
-- Nothing to do if this is not an instantiation
@@ -557,7 +1060,7 @@ package body Lib.Xref is
Lun := Get_Source_Unit (Iloc);
if Lun /= Curru then
- Curru := XE.Lun;
+ Curru := Lun;
Write_Info_Nat (Dependency_Num (Curru));
Write_Info_Char ('|');
end if;
@@ -571,6 +1074,7 @@ package body Lib.Xref is
-- Output final ] after call to get proper nesting
Write_Info_Char (']');
+ Curru := Cu;
return;
end Output_Instantiation_Refs;
@@ -628,7 +1132,7 @@ package body Lib.Xref is
Ent := Underlying_Type (Etype (XE.Ent));
if Present (Ent) then
- Ctyp := Xref_Entity_Letters (Ekind (Ent));
+ Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
end if;
end if;
@@ -646,20 +1150,41 @@ package body Lib.Xref is
end if;
end if;
+ -- Special handling for abstract types and operations.
+
+ if Is_Abstract (XE.Ent) then
+
+ if Ctyp = 'U' then
+ Ctyp := 'x'; -- abstract procedure
+
+ elsif Ctyp = 'V' then
+ Ctyp := 'y'; -- abstract function
+
+ elsif Ctyp = 'R' then
+ Ctyp := 'H'; -- abstract type
+ end if;
+ end if;
+
-- Only output reference if interesting type of entity,
- -- and suppress self references. Also suppress definitions
- -- of body formals (we only treat these as references, and
- -- the references were separately recorded).
-
- if Ctyp /= ' '
- and then XE.Loc /= XE.Def
- and then (not Is_Formal (XE.Ent)
- or else No (Spec_Entity (XE.Ent)))
+ -- and suppress self references, except for bodies that
+ -- act as specs. Also suppress definitions of body formals
+ -- (we only treat these as references, and the references
+ -- were separately recorded).
+
+ if Ctyp = ' '
+ or else (XE.Loc = XE.Def
+ and then
+ (XE.Typ /= 'b'
+ or else not Is_Subprogram (XE.Ent)))
+ or else (Is_Formal (XE.Ent)
+ and then Present (Spec_Entity (XE.Ent)))
then
+ null;
+
+ else
-- Start new Xref section if new xref unit
if XE.Eun /= Curxu then
-
if Write_Info_Col > 1 then
Write_Info_EOL;
end if;
@@ -705,11 +1230,92 @@ package body Lib.Xref is
-- Write level information
- if Is_Public (Curent) and then not Is_Hidden (Curent) then
- Write_Info_Char ('*');
- else
- Write_Info_Char (' ');
- end if;
+ Write_Level_Info : declare
+ function Is_Visible_Generic_Entity
+ (E : Entity_Id) return Boolean;
+ -- Check whether E is declared in the visible part
+ -- of a generic package. For source navigation
+ -- purposes, treat this as a visible entity.
+
+ function Is_Private_Record_Component
+ (E : Entity_Id) return Boolean;
+ -- Check whether E is a non-inherited component of a
+ -- private extension. Even if the enclosing record is
+ -- public, we want to treat the component as private
+ -- for navigation purposes.
+
+ ---------------------------------
+ -- Is_Private_Record_Component --
+ ---------------------------------
+
+ function Is_Private_Record_Component
+ (E : Entity_Id) return Boolean
+ is
+ S : constant Entity_Id := Scope (E);
+ begin
+ return
+ Ekind (E) = E_Component
+ and then Nkind (Declaration_Node (S)) =
+ N_Private_Extension_Declaration
+ and then Original_Record_Component (E) = E;
+ end Is_Private_Record_Component;
+
+ -------------------------------
+ -- Is_Visible_Generic_Entity --
+ -------------------------------
+
+ function Is_Visible_Generic_Entity
+ (E : Entity_Id) return Boolean
+ is
+ Par : Node_Id;
+
+ begin
+ if Ekind (Scope (E)) /= E_Generic_Package then
+ return False;
+ end if;
+
+ Par := Parent (E);
+ while Present (Par) loop
+ if
+ Nkind (Par) = N_Generic_Package_Declaration
+ then
+ -- Entity is a generic formal
+
+ return False;
+
+ elsif
+ Nkind (Parent (Par)) = N_Package_Specification
+ then
+ return
+ Is_List_Member (Par)
+ and then List_Containing (Par) =
+ Visible_Declarations (Parent (Par));
+ else
+ Par := Parent (Par);
+ end if;
+ end loop;
+
+ return False;
+ end Is_Visible_Generic_Entity;
+
+ -- Start of processing for Write_Level_Info
+
+ begin
+ if Is_Hidden (Curent)
+ or else Is_Private_Record_Component (Curent)
+ then
+ Write_Info_Char (' ');
+
+ elsif
+ Is_Public (Curent)
+ or else Is_Visible_Generic_Entity (Curent)
+ then
+ Write_Info_Char ('*');
+
+ else
+ Write_Info_Char (' ');
+ end if;
+ end Write_Level_Info;
-- Output entity name. We use the occurrence from the
-- actual source program at the definition point
@@ -799,89 +1405,16 @@ package body Lib.Xref is
(Int (Get_Column_Number (Sloc (Rref))));
end if;
- -- See if we have a type reference
-
- Tref := XE.Ent;
- Left := '{';
- Right := '}';
-
- loop
- Sav := Tref;
-
- -- Processing for types
-
- if Is_Type (Tref) then
-
- -- Case of base type
-
- if Base_Type (Tref) = Tref then
-
- -- If derived, then get first subtype
-
- if Tref /= Etype (Tref) then
- Tref := First_Subtype (Etype (Tref));
-
- -- Set brackets for derived type, but don't
- -- override pointer case since the fact that
- -- something is a pointer is more important
-
- if Left /= '(' then
- Left := '<';
- Right := '>';
- end if;
-
- -- If non-derived ptr, get designated type
-
- elsif Is_Access_Type (Tref) then
- Tref := Designated_Type (Tref);
- Left := '(';
- Right := ')';
+ -- Indicate that the entity is in the unit
+ -- of the current xref xection.
- -- For other non-derived base types, nothing
-
- else
- exit;
- end if;
-
- -- For a subtype, go to ancestor subtype
-
- else
- Tref := Ancestor_Subtype (Tref);
-
- -- If no ancestor subtype, go to base type
-
- if No (Tref) then
- Tref := Base_Type (Sav);
- end if;
- end if;
-
- -- For objects, functions, enum literals,
- -- just get type from Etype field.
-
- elsif Is_Object (Tref)
- or else Ekind (Tref) = E_Enumeration_Literal
- or else Ekind (Tref) = E_Function
- or else Ekind (Tref) = E_Operator
- then
- Tref := Etype (Tref);
-
- -- For anything else, exit
-
- else
- exit;
- end if;
+ Curru := Curxu;
- -- Exit if no type reference, or we are stuck in
- -- some loop trying to find the type reference, or
- -- if the type is standard void type (the latter is
- -- an implementation artifact that should not show
- -- up in the generated cross-references).
+ -- See if we have a type reference and if so output
- exit when No (Tref)
- or else Tref = Sav
- or else Tref = Standard_Void_Type;
+ Get_Type_Reference (XE.Ent, Tref, Left, Right);
- -- Here we have a type reference to output
+ if Present (Tref) then
-- Case of standard entity, output name
@@ -889,22 +1422,10 @@ package body Lib.Xref is
Write_Info_Char (Left);
Write_Info_Name (Chars (Tref));
Write_Info_Char (Right);
- exit;
-- Case of source entity, output location
- elsif Comes_From_Source (Tref) then
-
- -- Do not output type reference if referenced
- -- entity is not in the main unit and is itself
- -- not referenced, since otherwise the reference
- -- will dangle.
-
- exit when not Referenced (Tref)
- and then not In_Extended_Main_Source_Unit (Tref);
-
- -- Output the reference
-
+ else
Write_Info_Char (Left);
Trunit := Get_Source_Unit (Sloc (Tref));
@@ -937,19 +1458,17 @@ package body Lib.Xref is
Write_Info_Nat
(Int (Get_Column_Number (Sloc (Tref))));
- Write_Info_Char (Right);
- exit;
- -- If non-standard, non-source entity, keep looking
+ -- If the type comes from an instantiation,
+ -- add the corresponding info.
- else
- null;
+ Output_Instantiation_Refs (Sloc (Tref));
+ Write_Info_Char (Right);
end if;
- end loop;
+ end if;
-- End of processing for entity output
- Curru := Curxu;
Crloc := No_Location;
end if;
@@ -979,6 +1498,14 @@ package body Lib.Xref is
Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Loc)));
Write_Info_Char (XE.Typ);
+
+ if Is_Overloadable (XE.Ent)
+ and then Is_Imported (XE.Ent)
+ and then XE.Typ = 'b'
+ then
+ Output_Import_Export_Info (XE.Ent);
+ end if;
+
Write_Info_Nat (Int (Get_Column_Number (XE.Loc)));
Output_Instantiation_Refs (Sloc (XE.Ent));
diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads
index 6f9ded363ff..34434b9696f 100644
--- a/gcc/ada/lib-xref.ads
+++ b/gcc/ada/lib-xref.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-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- --
@@ -71,7 +71,8 @@ package Lib.Xref is
-- level is a single character that separates the col and
-- entity fields. It is an asterisk for a top level library
- -- entity that is publicly visible, and space otherwise.
+ -- entity that is publicly visible, as well for an entity declared
+ -- in the visible part of a generic package, and space otherwise.
-- entity is the name of the referenced entity, with casing in
-- the canical casing for the source file where it is defined.
@@ -97,6 +98,7 @@ package Lib.Xref is
-- derived types (points to the parent type) LR=<>
-- access types (points to designated type) LR=()
+ -- array types (points to component type) LR=()
-- subtypes (points to ancestor type) LR={}
-- functions (points to result type) LR={}
-- enumeration literals (points to enum type) LR={}
@@ -106,7 +108,7 @@ package Lib.Xref is
-- which has one of the two following forms:
-- L file | line type col R user entity
- -- L name-in-lower-case R standard entity
+ -- L name-in-lower-case R standard entity
-- For the form for a user entity, file is the dependency number
-- of the file containing the declaration of the related type.
@@ -133,14 +135,24 @@ package Lib.Xref is
-- type is one of
-- b = body entity
-- c = completion of private or incomplete type
+ -- d = discriminant of type
-- e = end of spec
+ -- H = abstract type
-- i = implicit reference
- -- l = label on end line
+ -- k = implicit reference to parent unit in child unit
+ -- l = label on END line
-- m = modification
-- p = primitive operation
+ -- P = overriding primitive operation
-- r = reference
-- t = end of body
+ -- w = WITH line
-- x = type extension
+ -- z = generic formal parameter
+ -- > = subprogram IN parameter
+ -- = = subprogram IN OUT parameter
+ -- < = subprogram OUT parameter
+ -- > = subprogram ACCESS parameter
-- b is used for spec entities that are repeated in a body,
-- including the unit (subprogram, package, task, protected
@@ -156,6 +168,13 @@ package Lib.Xref is
-- regarded as a separate definition, but rather a reference to
-- the initial declaration, marked with this special type.
+ -- d is used to identify a discriminant of a type. If this is
+ -- an incomplete or private type with discriminants, the entry
+ -- denotes the occurrence of the discriminant in the partial view
+ -- which is also the point of definition of the discriminant.
+ -- The occurrence of the same discriminant in the full view is
+ -- a regular reference to it.
+
-- e is used to identify the end of a construct in the following
-- cases:
@@ -182,6 +201,9 @@ package Lib.Xref is
-- source node that generates the implicit reference, and it is
-- useful to record this one.
+ -- k is used to denote a reference to the parent unit, in the
+ -- cross-reference line for a child unit.
+
-- l is used to identify the occurrence in the source of the
-- name on an end line. This is just a syntactic reference
-- which can be ignored for semantic purposes (such as call
@@ -199,6 +221,10 @@ package Lib.Xref is
-- source unit (main unit itself, its separate spec (if any).
-- and all subunits (considered recursively).
+ -- If the primitive operation overrides an inherited primitive
+ -- operation of the parent type, the letter 'P' is used in the
+ -- corresponding entry.
+
-- t is similar to e. It identifies the end of a corresponding
-- body (such a reference always links up with a b reference)
@@ -216,6 +242,16 @@ package Lib.Xref is
-- a tagged type is extended. This allows immediate access to
-- the parent of a tagged type.
+ -- z is used on the cross-reference line for a generic unit, to
+ -- mark the definition of a generic formal of the unit.
+ -- This entry type is similar to 'k' and 'p' in that it is an
+ -- implicit reference for an entity with a different name.
+
+ -- The characters >, <. =, and ^ are used on the cross-reference
+ -- line for a subprogram, to denote formal parameters and their
+ -- modes. As with the 'z' and 'p' entries, each such entry is
+ -- an implicit reference to an entity with a different name.
+
-- [..] is used for generic instantiation references. These
-- references are present only if the entity in question is
-- a generic entity, and in that case the [..] contains the
@@ -316,6 +352,10 @@ package Lib.Xref is
-- determine the character to use in the xref listing. The listing
-- will still include a '+' for a generic private type, for example.
+ -- For subprograms, the characters 'U' and 'V' appear in the table,
+ -- indicating procedures and functions. If the operation is abstract,
+ -- these letters are replaced in the xref by 'x' and 'y' respectively.
+
Xref_Entity_Letters : array (Entity_Kind) of Character := (
E_Void => ' ',
E_Variable => '*',
@@ -426,7 +466,7 @@ package Lib.Xref is
-- e non-Boolean enumeration object non_Boolean enumeration type
-- f floating-point object floating-point type
-- g (unused) (unused)
- -- h (unused) (unused)
+ -- h (unused) Abstract type
-- i signed integer object signed integer type
-- j (unused) (unused)
-- k generic package package
@@ -442,9 +482,26 @@ package Lib.Xref is
-- u generic procedure procedure
-- v generic function or operator function or operator
-- w protected object protected type
- -- x (unused) exception
- -- y (unused) entry or entry family
- -- z (unused) (unused)
+ -- x abstract procedure exception
+ -- y abstract function entry or entry family
+ -- z generic formal parameter (unused)
+
+ --------------------------------------
+ -- Handling of Imported Subprograms --
+ --------------------------------------
+
+ -- If a pragma Import or Interface applies to a subprogram, the
+ -- pragma is the completion of the subprogram. This is noted in
+ -- the ALI file by making the occurrence of the subprogram in the
+ -- pragma into a body reference ('b') and by including the external
+ -- name of the subprogram and its language, bracketed by '<' and '>'
+ -- in that reference. For example:
+ --
+ -- 3U13*elsewhere 4b<c,there>21
+ --
+ -- indicates that procedure elsewhere, declared at line 3, has a
+ -- pragma Import at line 4, that its body is in C, and that the link
+ -- name as given in the pragma is "there".
-----------------
-- Subprograms --
@@ -453,10 +510,16 @@ package Lib.Xref is
procedure Generate_Definition (E : Entity_Id);
-- Records the definition of an entity
- procedure Generate_Operator_Reference (N : Node_Id);
+ procedure Generate_Operator_Reference
+ (N : Node_Id;
+ T : Entity_Id);
-- Node N is an operator node, whose entity has been set. If this entity
-- is a user defined operator (i.e. an operator not defined in package
-- Standard), then a reference to the operator is recorded at node N.
+ -- T is the operand type of of the operator. A reference to the operator
+ -- is an implicit reference to the type, and that needs to be recorded
+ -- to avoid spurious warnings on unused entities, when the operator is
+ -- a renaming of a predefined operator.
procedure Generate_Reference
(E : Entity_Id;
@@ -520,7 +583,18 @@ package Lib.Xref is
-- generated even if Comes_From_Source is false. This is used for
-- certain implicit references, and also for end label references.
+ procedure Generate_Reference_To_Formals (E : Entity_Id);
+ -- Add a reference to the definition of each formal on the line for
+ -- a subprogram.
+
+ procedure Generate_Reference_To_Generic_Formals (E : Entity_Id);
+ -- Add a reference to the definition of each generic formal on the line
+ -- for a generic unit.
+
procedure Output_References;
-- Output references to the current ali file
+ procedure Initialize;
+ -- Initialize internal tables.
+
end Lib.Xref;
diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb
index b58fa7e78c9..db01b6b362f 100644
--- a/gcc/ada/lib.adb
+++ b/gcc/ada/lib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -392,7 +392,6 @@ package body Lib is
<<Continue>>
null;
end loop;
-
end Check_Same_Extended_Unit;
-------------------------------
@@ -460,23 +459,53 @@ package body Lib is
end if;
end Generic_Separately_Compiled;
+ function Generic_Separately_Compiled
+ (Sfile : File_Name_Type)
+ return Boolean
+ is
+ begin
+ -- Exactly the same as previous function, but works directly on a file
+ -- name.
+
+ if Is_Internal_File_Name
+ (Fname => Sfile,
+ Renamings_Included => True)
+ then
+ return False;
+
+ -- All other generic units do generate object files
+
+ else
+ return True;
+ end if;
+ end Generic_Separately_Compiled;
+
-------------------
-- Get_Code_Unit --
-------------------
function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is
- Source_File : Source_File_Index :=
- Get_Source_File_Index (Top_Level_Location (S));
-
begin
- for U in Units.First .. Units.Last loop
- if Source_Index (U) = Source_File then
- return U;
- end if;
- end loop;
+ -- Search table unless we have No_Location, which can happen if the
+ -- relevant location has not been set yet. Happens for example when
+ -- we obtain Sloc (Cunit (Main_Unit)) before it is set.
- -- If not in the table, must be the main source unit, and we just
- -- have not got it put into the table yet.
+ if S /= No_Location then
+ declare
+ Source_File : constant Source_File_Index :=
+ Get_Source_File_Index (Top_Level_Location (S));
+
+ begin
+ for U in Units.First .. Units.Last loop
+ if Source_Index (U) = Source_File then
+ return U;
+ end if;
+ end loop;
+ end;
+ end if;
+
+ -- If S was No_Location, or was not in the table, we must be in the
+ -- main source unit (and the value has not been placed in the table yet)
return Main_Unit;
end Get_Code_Unit;
@@ -544,23 +573,32 @@ package body Lib is
---------------------
function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is
- Source_File : Source_File_Index :=
- Get_Source_File_Index (Top_Level_Location (S));
-
begin
- Source_File := Get_Source_File_Index (S);
- while Template (Source_File) /= No_Source_File loop
- Source_File := Template (Source_File);
- end loop;
+ -- Search table unless we have No_Location, which can happen if the
+ -- relevant location has not been set yet. Happens for example when
+ -- we obtain Sloc (Cunit (Main_Unit)) before it is set.
- for U in Units.First .. Units.Last loop
- if Source_Index (U) = Source_File then
- return U;
- end if;
- end loop;
+ if S /= No_Location then
+ declare
+ Source_File : Source_File_Index :=
+ Get_Source_File_Index (Top_Level_Location (S));
- -- If not in the table, must be the main source unit, and we just
- -- have not got it put into the table yet.
+ begin
+ Source_File := Get_Source_File_Index (S);
+ while Template (Source_File) /= No_Source_File loop
+ Source_File := Template (Source_File);
+ end loop;
+
+ for U in Units.First .. Units.Last loop
+ if Source_Index (U) = Source_File then
+ return U;
+ end if;
+ end loop;
+ end;
+ end if;
+
+ -- If S was No_Location, or was not in the table, we must be in the
+ -- main source unit (and the value is not got put into the table yet)
return Main_Unit;
end Get_Source_Unit;
@@ -596,15 +634,43 @@ package body Lib is
then
return In_Extended_Main_Code_Unit (Associated_Node_For_Itype (N));
+ -- Otherwise see if we are in the main unit
+
elsif Get_Code_Unit (Sloc (N)) = Get_Code_Unit (Cunit (Main_Unit)) then
return True;
- else -- node may be in spec of main unit
+ -- Node may be in spec (or subunit etc) of main unit
+
+ else
return
In_Same_Extended_Unit (Sloc (N), Sloc (Cunit (Main_Unit)));
end if;
end In_Extended_Main_Code_Unit;
+ function In_Extended_Main_Code_Unit
+ (Loc : Source_Ptr)
+ return Boolean
+ is
+ begin
+ if Loc = Standard_Location then
+ return True;
+
+ elsif Loc = No_Location then
+ return False;
+
+ -- Otherwise see if we are in the main unit
+
+ elsif Get_Code_Unit (Loc) = Get_Code_Unit (Cunit (Main_Unit)) then
+ return True;
+
+ -- Location may be in spec (or subunit etc) of main unit
+
+ else
+ return
+ In_Same_Extended_Unit (Loc, Sloc (Cunit (Main_Unit)));
+ end if;
+ end In_Extended_Main_Code_Unit;
+
----------------------------------
-- In_Extended_Main_Source_Unit --
----------------------------------
@@ -613,11 +679,22 @@ package body Lib is
(N : Node_Or_Entity_Id)
return Boolean
is
+ Nloc : constant Source_Ptr := Sloc (N);
+ Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
+
begin
- if Sloc (N) = Standard_Location then
+ -- If Mloc is not set, it means we are still parsing the main unit,
+ -- so everything so far is in the extended main source unit.
+
+ if Mloc = No_Location then
return True;
- elsif Sloc (N) = No_Location then
+ -- Special value cases
+
+ elsif Nloc = Standard_Location then
+ return True;
+
+ elsif Nloc = No_Location then
return False;
-- Special case Itypes to test the Sloc of the associated node. The
@@ -631,11 +708,42 @@ package body Lib is
then
return In_Extended_Main_Source_Unit (Associated_Node_For_Itype (N));
+ -- Otherwise compare original locations to see if in same unit
+
else
return
In_Same_Extended_Unit
- (Original_Location (Sloc (N)),
- Original_Location (Sloc (Cunit (Main_Unit))));
+ (Original_Location (Nloc), Original_Location (Mloc));
+ end if;
+ end In_Extended_Main_Source_Unit;
+
+ function In_Extended_Main_Source_Unit
+ (Loc : Source_Ptr)
+ return Boolean
+ is
+ Mloc : constant Source_Ptr := Sloc (Cunit (Main_Unit));
+
+ begin
+ -- If Mloc is not set, it means we are still parsing the main unit,
+ -- so everything so far is in the extended main source unit.
+
+ if Mloc = No_Location then
+ return True;
+
+ -- Special value cases
+
+ elsif Loc = Standard_Location then
+ return True;
+
+ elsif Loc = No_Location then
+ return False;
+
+ -- Otherwise compare original locations to see if in same unit
+
+ else
+ return
+ In_Same_Extended_Unit
+ (Original_Location (Loc), Original_Location (Mloc));
end if;
end In_Extended_Main_Source_Unit;
@@ -807,6 +915,16 @@ package body Lib is
Compilation_Switches.Increment_Last;
Compilation_Switches.Table (Compilation_Switches.Last) :=
new String'(Switch);
+
+ -- Fix up --RTS flag which has been transformed by the gcc driver
+ -- into -fRTS
+
+ if Switch'Last >= Switch'First + 4
+ and then Switch (Switch'First .. Switch'First + 4) = "-fRTS"
+ then
+ Compilation_Switches.Table
+ (Compilation_Switches.Last) (Switch'First + 1) := '-';
+ end if;
end Store_Compilation_Switch;
--------------------------------
diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads
index 2811749fc03..e01ab65ff6b 100644
--- a/gcc/ada/lib.ads
+++ b/gcc/ada/lib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -361,7 +361,7 @@ package Lib is
-- This is a Boolean flag, which is set True to indicate that this
-- entry is for a semantically dependent unit. This flag is nearly
-- always set True, the only exception is for a unit that is loaded
- -- by an Rtsfind request in No_Run_Time mode, where the entity that
+ -- by an Rtsfind request in High_Integrity_Mode, where the entity that
-- is obtained by Rtsfind.RTE is for an inlined subprogram or other
-- entity for which a dependency need not be created.
@@ -472,6 +472,12 @@ package Lib is
-- If the main unit is itself a subunit, then the extended main unit
-- includes its parent unit, and the parent unit spec if it is separate.
+ function In_Extended_Main_Code_Unit
+ (Loc : Source_Ptr)
+ return Boolean;
+ -- Same function as above, but argument is a source pointer rather
+ -- than a node.
+
function In_Extended_Main_Source_Unit
(N : Node_Or_Entity_Id)
return Boolean;
@@ -484,6 +490,12 @@ package Lib is
-- a subunit, then the extended main unit includes its parent unit,
-- and the parent unit spec if it is separate.
+ function In_Extended_Main_Source_Unit
+ (Loc : Source_Ptr)
+ return Boolean;
+ -- Same function as above, but argument is a source pointer rather
+ -- than a node.
+
function Earlier_In_Extended_Unit (S1, S2 : Source_Ptr) return Boolean;
-- Given two Sloc values for which In_Same_Extended_Unit is true,
-- determine if S1 appears before S2. Returns True if S1 appears before
@@ -558,6 +570,8 @@ package Lib is
-- restricts the list to exclude any predefined files.
function Generic_Separately_Compiled (E : Entity_Id) return Boolean;
+ -- This is the old version of tbe documentation of this function:
+ --
-- Most generic units must be separately compiled. Since we always use
-- macro substitution for generics, the resulting object file is a dummy
-- one with no code, but the ali file has the normal form, and we need
@@ -575,6 +589,23 @@ package Lib is
-- compiler itself. The only such generics are predefined ones. This
-- function returns True if the given generic unit entity E is for a
-- generic unit that should be separately compiled, and false otherwise.
+ --
+ -- Now GNAT can compile any generic unit including predefifined ones, but
+ -- because of the backward compatibility (to keep the ability to use old
+ -- compiler versions to build GNAT) compiling library generics is an
+ -- option. That is, now GNAT compiles a library generic as an ordinary
+ -- unit, but it also can build an exeutable in case if its library
+ -- contains some (or all) predefined generics non compiled. See 9628-002
+ -- for the description of changes to be done to get rid of a special
+ -- processing of library generic.
+ --
+ -- So now this function returns TRUE if a generic MUST be separately
+ -- compiled with the current approach.
+
+ function Generic_Separately_Compiled
+ (Sfile : File_Name_Type)
+ return Boolean;
+ -- Same as the previous function, but works directly on a unit file name.
private
pragma Inline (Cunit);
diff --git a/gcc/ada/link.c b/gcc/ada/link.c
index 6cdbc9f1880..5a8fbeb8339 100644
--- a/gcc/ada/link.c
+++ b/gcc/ada/link.c
@@ -4,10 +4,9 @@
* *
* L I N K *
* *
- * *
* C Implementation File *
* *
- * Copyright (C) 1992-2001, 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- *
@@ -159,9 +158,9 @@ const char *object_library_extension = ".a";
const char *object_file_option = "";
const char *run_path_option = "-Wl,-rpath,";
char shared_libgnat_default = STATIC;
-int link_max = 2147483647;
-unsigned char objlist_file_supported = 0;
-unsigned char using_gnu_linker = 0;
+int link_max = 8192;
+unsigned char objlist_file_supported = 1;
+unsigned char using_gnu_linker = 1;
const char *object_library_extension = ".a";
#elif defined (__svr4__) && defined (i386)
diff --git a/gcc/ada/live.adb b/gcc/ada/live.adb
index 51a58f635ab..24c82130590 100644
--- a/gcc/ada/live.adb
+++ b/gcc/ada/live.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -91,9 +91,9 @@ package body Live is
-------------
function Body_Of (E : Entity_Id) return Node_Id is
- Decl : Node_Id := Unit_Declaration_Node (E);
- Result : Node_Id;
- Kind : Node_Kind := Nkind (Decl);
+ Decl : constant Node_Id := Unit_Declaration_Node (E);
+ Kind : constant Node_Kind := Nkind (Decl);
+ Result : Node_Id;
begin
if Kind = N_Subprogram_Body then
@@ -279,6 +279,8 @@ package body Live is
procedure Process (N : Node_Id) is
Result : Traverse_Result;
+ pragma Warnings (Off, Result);
+
begin
Result := Process (N);
end Process;
diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb
index 2408a879012..240f872d934 100644
--- a/gcc/ada/make.adb
+++ b/gcc/ada/make.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- --
@@ -33,6 +33,7 @@ with ALI; use ALI;
with ALI.Util; use ALI.Util;
with Csets;
with Debug;
+with Fmap;
with Fname; use Fname;
with Fname.SF; use Fname.SF;
with Fname.UF; use Fname.UF;
@@ -40,7 +41,7 @@ with Gnatvsn; use Gnatvsn;
with Hostparm; use Hostparm;
with Makeusg;
with MLib.Prj;
-with MLib.Tgt;
+with MLib.Tgt; use MLib.Tgt;
with MLib.Utl;
with Namet; use Namet;
with Opt; use Opt;
@@ -55,14 +56,13 @@ with Prj.Ext;
with Prj.Pars;
with Prj.Util;
with SFN_Scan;
-with Sinput.L;
+with Sinput.P;
with Snames; use Snames;
-with Stringt; use Stringt;
with Switch; use Switch;
with Switch.M; use Switch.M;
+with System.HTable;
with Targparm;
-
-with System.WCh_Con; use System.WCh_Con;
+with Tempdir;
package body Make is
@@ -73,6 +73,16 @@ package body Make is
-- Every program depends on this package, that must then be checked,
-- especially when -f and -a are used.
+ type Sigint_Handler is access procedure;
+
+ procedure Install_Int_Handler (Handler : Sigint_Handler);
+ pragma Import (C, Install_Int_Handler, "__gnat_install_int_handler");
+ -- Called by Gnatmake to install the SIGINT handler below
+
+ procedure Sigint_Intercepted;
+ -- Called when the program is interrupted by Ctrl-C to delete the
+ -- temporary mapping files and configuration pragmas files.
+
-------------------------
-- Note on terminology --
-------------------------
@@ -125,11 +135,16 @@ package body Make is
-- Extracts the first element from the Q.
procedure Insert_Project_Sources
- (The_Project : Project_Id;
- Into_Q : Boolean);
- -- If Into_Q is True, insert all sources of the project file that are not
- -- already marked into the Q. If Into_Q is False, call Osint.Add_File for
- -- all sources of the project file.
+ (The_Project : Project_Id;
+ All_Projects : Boolean;
+ Into_Q : Boolean);
+ -- If Into_Q is True, insert all sources of the project file(s) that are
+ -- not already marked into the Q. If Into_Q is False, call Osint.Add_File
+ -- for the first source, then insert all other sources that are not already
+ -- marked into the Q. If All_Projects is True, all sources of all projects
+ -- are concerned; otherwise, only sources of The_Project are concerned,
+ -- including, if The_Project is an extending project, sources inherited
+ -- from projects being extended.
First_Q_Initialization : Boolean := True;
-- Will be set to false after Init_Q has been called once.
@@ -138,6 +153,13 @@ package body Make is
-- Points to the first valid element in the Q.
Unique_Compile : Boolean := False;
+ -- Set to True if -u or -U or a project file with no main is used
+
+ Unique_Compile_All_Projects : Boolean := False;
+ -- Set to True if -U is used
+
+ RTS_Specified : String_Access := null;
+ -- Used to detect multiple --RTS= switches
type Q_Record is record
File : File_Name_Type;
@@ -183,14 +205,6 @@ package body Make is
Table_Increment => 100,
Table_Name => "Make.Saved_Linker_Switches");
- package Saved_Make_Switches is new Table.Table
- (Table_Component_Type => String_Access,
- Table_Index_Type => Integer,
- Table_Low_Bound => 1,
- Table_Initial => 20,
- Table_Increment => 100,
- Table_Name => "Make.Saved_Make_Switches");
-
package Switches_To_Check is new Table.Table (
Table_Component_Type => String_Access,
Table_Index_Type => Integer,
@@ -199,19 +213,96 @@ package body Make is
Table_Increment => 100,
Table_Name => "Make.Switches_To_Check");
+ package Library_Paths is new Table.Table (
+ Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Make.Library_Paths");
+
+ package Failed_Links is new Table.Table (
+ Table_Component_Type => File_Name_Type,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Make.Failed_Links");
+
+ package Successful_Links is new Table.Table (
+ Table_Component_Type => File_Name_Type,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Make.Successful_Links");
+
+ package Library_Projs is new Table.Table (
+ Table_Component_Type => Project_Id,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Make.Library_Projs");
+
+ type Linker_Options_Data is record
+ Project : Project_Id;
+ Options : String_List_Id;
+ end record;
+
+ package Linker_Opts is new Table.Table (
+ Table_Component_Type => Linker_Options_Data,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Make.Linker_Opts");
+
+ -- Two variables to keep the last binder and linker switch index
+ -- in tables Binder_Switches and Linker_Switches, before adding
+ -- switches from the project file (if any) and switches from the
+ -- command line (if any).
+
+ Last_Binder_Switch : Integer := 0;
+ Last_Linker_Switch : Integer := 0;
+
Normalized_Switches : Argument_List_Access := new Argument_List (1 .. 10);
Last_Norm_Switch : Natural := 0;
Saved_Maximum_Processes : Natural := 0;
- Saved_WC_Encoding_Method : WC_Encoding_Method := WC_Encoding_Method'First;
- Saved_WC_Encoding_Method_Set : Boolean := False;
type Arg_List_Ref is access Argument_List;
The_Saved_Gcc_Switches : Arg_List_Ref;
Project_File_Name : String_Access := null;
+ -- The path name of the main project file, if any
+
+ Project_File_Name_Present : Boolean := False;
+ -- True when -P is used with a space between -P and the project file name
+
Current_Verbosity : Prj.Verbosity := Prj.Default;
- Main_Project : Prj.Project_Id := No_Project;
+ -- Verbosity to parse the project files
+
+ Main_Project : Prj.Project_Id := No_Project;
+ -- The project id of the main project file, if any
+
+ -- Packages of project files where unknown attributes are errors.
+
+ Naming_String : aliased String := "naming";
+ Builder_String : aliased String := "builder";
+ Compiler_String : aliased String := "compiler";
+ Binder_String : aliased String := "binder";
+ Linker_String : aliased String := "linker";
+
+ Gnatmake_Packages : aliased String_List :=
+ (Naming_String 'Access,
+ Builder_String 'Access,
+ Compiler_String 'Access,
+ Binder_String 'Access,
+ Linker_String 'Access);
+
+ Packages_To_Check_By_Gnatmake : constant String_List_Access :=
+ Gnatmake_Packages'Access;
procedure Add_Source_Dir (N : String);
-- Call Add_Src_Search_Dir.
@@ -247,16 +338,6 @@ package body Make is
Table_Name => "Make.Bad_Compilation");
-- Full name of all the source files for which compilation fails.
- Original_Ada_Include_Path : constant String_Access :=
- Getenv ("ADA_INCLUDE_PATH");
- Original_Ada_Objects_Path : constant String_Access :=
- Getenv ("ADA_OBJECTS_PATH");
- Current_Ada_Include_Path : String_Access := null;
- Current_Ada_Objects_Path : String_Access := null;
-
- Max_Line_Length : constant := 127;
- -- Maximum number of characters per line, when displaying a path
-
Do_Compile_Step : Boolean := True;
Do_Bind_Step : Boolean := True;
Do_Link_Step : Boolean := True;
@@ -264,6 +345,111 @@ package body Make is
-- Can be set to False with the switches -c, -b and -l.
-- These flags are reset to True for each invokation of procedure Gnatmake.
+ Shared_String : aliased String := "-shared";
+
+ No_Shared_Switch : aliased Argument_List := (1 .. 0 => null);
+ Shared_Switch : aliased Argument_List := (1 => Shared_String'Access);
+ Bind_Shared : Argument_List_Access := No_Shared_Switch'Access;
+ -- Switch to added in front of gnatbind switches. By default no switch is
+ -- added. Switch "-shared" is added if there is a non-static Library
+ -- Project File.
+
+ Bind_Shared_Known : Boolean := False;
+ -- Set to True after the first time Bind_Shared is computed
+
+ procedure Make_Failed (S1 : String; S2 : String := ""; S3 : String := "");
+ -- Delete all temp files created by Gnatmake and call Osint.Fail,
+ -- with the parameter S1, S2 and S3 (see osint.ads).
+ -- This is called from the Prj hierarchy and the MLib hierarchy.
+
+ --------------------------
+ -- Obsolete Executables --
+ --------------------------
+
+ Executable_Obsolete : Boolean := False;
+ -- Executable_Obsolete is initially set to False for each executable,
+ -- and is set to True whenever one of the source of the executable is
+ -- compiled, or has already been compiled for another executable.
+
+ Max_Header : constant := 200; -- Arbitrary
+
+ type Header_Num is range 1 .. Max_Header;
+ -- Header_Num for the hash table Obsoleted below
+
+ function Hash (F : Name_Id) return Header_Num;
+ -- Hash function for the hash table Obsoleted below
+
+ package Obsoleted is new System.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => Name_Id,
+ Hash => Hash,
+ Equal => "=");
+ -- A hash table to keep all files that have been compiled, to detect
+ -- if an executable is up to date or not.
+
+ procedure Enter_Into_Obsoleted (F : Name_Id);
+ -- Enter a file name, without directory information, into the has table
+ -- Obsoleted.
+
+ function Is_In_Obsoleted (F : Name_Id) return Boolean;
+ -- Check if a file name, without directory information, has already been
+ -- entered into the hash table Obsoleted.
+
+ type Dependency is record
+ This : Name_Id;
+ Depends_On : Name_Id;
+ end record;
+ -- Components of table Dependencies below.
+
+ package Dependencies is new Table.Table (
+ Table_Component_Type => Dependency,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Make.Dependencies");
+ -- A table to keep dependencies, to be able to decide if an executable
+ -- is obsolete.
+
+ procedure Add_Dependency (S : Name_Id; On : Name_Id);
+ -- Add one entry in table Dependencies
+
+ ----------------------------
+ -- Arguments and Switches --
+ ----------------------------
+
+ Arguments : Argument_List_Access;
+ -- Used to gather the arguments for invocation of the compiler
+
+ Last_Argument : Natural := 0;
+ -- Last index of arguments in Arguments above
+
+ Arguments_Collected : Boolean := False;
+ -- Set to True when the arguments for the next invocation of the compiler
+ -- have been collected.
+
+ Arguments_Project : Project_Id;
+ -- Project id, if any, of the source to be compiled
+
+ Arguments_Path_Name : File_Name_Type;
+ -- Full path of the source to be compiled, when Arguments_Project is not
+ -- No_Project.
+
+ Dummy_Switch : constant String_Access := new String'("- ");
+ -- Used to initialized Prev_Switch in procedure Check
+
+ procedure Add_Arguments (Args : Argument_List);
+ -- Add arguments to global variable Arguments, increasing its size
+ -- if necessary and adjusting Last_Argument.
+
+ function Configuration_Pragmas_Switch
+ (For_Project : Project_Id) return Argument_List;
+ -- Return an argument list of one element, if there is a configuration
+ -- pragmas file to be specified for For_Project,
+ -- otherwise return an empty argument list.
+
----------------------
-- Marking Routines --
----------------------
@@ -311,15 +497,32 @@ package body Make is
-- Call Makeusg, if Usage_Needed is True.
-- Set Usage_Needed to False.
+ procedure Debug_Msg (S : String; N : Name_Id);
+ -- If Debug.Debug_Flag_W is set outputs string S followed by name N.
+
+ type Project_Array is array (Positive range <>) of Project_Id;
+ No_Projects : constant Project_Array := (1 .. 0 => No_Project);
+
+ procedure Recursive_Compute_Depth
+ (Project : Project_Id;
+ Visited : Project_Array;
+ Depth : Natural);
+ -- Compute depth of Project and of the projects it depends on
+
-----------------------
-- Gnatmake Routines --
-----------------------
+ Gnatmake_Called : Boolean := False;
+ -- Set to True when procedure Gnatmake is called.
+ -- Attempt to delete temporary files is made only when Gnatmake_Called
+ -- is True.
+
subtype Lib_Mark_Type is Byte;
- -- ??? this needs a comment
+ -- Used in Mark_Directory
Ada_Lib_Dir : constant Lib_Mark_Type := 1;
- -- ??? this needs a comment
+ -- Used to mark a directory as a GNAT lib dir
-- Note that the notion of GNAT lib dir is no longer used. The code
-- related to it has not been removed to give an idea on how to use
@@ -335,6 +538,10 @@ package body Make is
-- The directory lookup penalty is incurred every single time this
-- routine is called.
+ procedure Check_Steps;
+ -- Check what steps (Compile, Bind, Link) must be executed.
+ -- Set the step flags accordingly.
+
function Is_External_Assignment (Argv : String) return Boolean;
-- Verify that an external assignment switch is syntactically correct.
-- Correct forms are
@@ -355,28 +562,19 @@ package body Make is
-- Store Dir in name table and set lib mark as name info to identify
-- Ada libraries.
- function Object_File_Name (Source : String) return String;
- -- Returns the object file name suitable for switch -o.
+ Output_Is_Object : Boolean := True;
+ -- Set to False when using a switch -S for the compiler
- procedure Set_Ada_Paths
- (For_Project : Prj.Project_Id;
- Including_Libraries : Boolean);
- -- Set, if necessary, env. variables ADA_INCLUDE_PATH and
- -- ADA_OBJECTS_PATH.
- --
- -- Note: this will modify these environment variables only
- -- for the current gnatmake process and all of its children
- -- (invocations of the compiler, the binder and the linker).
- -- The caller process ADA_INCLUDE_PATH and ADA_OBJECTS_PATH are
- -- not affected.
+ procedure Check_For_S_Switch;
+ -- Set Output_Is_Object to False when the -S switch is used for the
+ -- compiler.
function Switches_Of
(Source_File : Name_Id;
Source_File_Name : String;
Naming : Naming_Data;
In_Package : Package_Id;
- Allow_ALI : Boolean)
- return Variable_Value;
+ Allow_ALI : Boolean) return Variable_Value;
-- Return the switches for the source file in the specified package
-- of a project file. If the Source_File ends with a standard GNAT
-- extension (".ads" or ".adb"), try first the full name, then the
@@ -385,22 +583,21 @@ package body Make is
-- default switches for Ada. If all failed, return No_Variable_Value.
procedure Test_If_Relative_Path
- (Switch : in out String_Access;
- Parent : String_Access);
+ (Switch : in out String_Access;
+ Parent : String_Access;
+ Including_L_Switch : Boolean := True);
-- Test if Switch is a relative search path switch.
-- If it is, fail if Parent is null, otherwise prepend the path with
-- Parent. This subprogram is only called when using project files.
+ -- For gnatbind switches, Including_L_Switch is False, because the
+ -- argument of the -L switch is not a path.
- procedure Set_Library_For
- (Project : Project_Id;
- There_Are_Libraries : in out Boolean);
- -- If Project is a library project, add the correct
- -- -L and -l switches to the linker invocation.
-
- procedure Set_Libraries is
- new For_Every_Project_Imported (Boolean, Set_Library_For);
- -- Add the -L and -l switches to the linker for all
- -- of the library projects.
+ function Is_In_Object_Directory
+ (Source_File : File_Name_Type;
+ Full_Lib_File : File_Name_Type) return Boolean;
+ -- Check if, when using a project file, the ALI file is in the project
+ -- directory of the ultimate extending project. If it is not, we ignore
+ -- the fact that this ALI file is read-only.
----------------------------------------------------
-- Compiler, Binder & Linker Data and Subprograms --
@@ -446,6 +643,13 @@ package body Make is
-- Set to True after having scanned the file_name for
-- switch "-o file_name"
+ Object_Directory_Seen : Boolean := False;
+ -- Set to True after having scanned the object directory for
+ -- switch "-D obj_dir".
+
+ Object_Directory_Path : String_Access := null;
+ -- The path name of the object directory, set with switch -D.
+
type Make_Program_Type is (None, Compiler, Binder, Linker);
Program_Args : Make_Program_Type := None;
@@ -453,6 +657,10 @@ package body Make is
-- options within the gnatmake command line.
-- Used in Scan_Make_Arg only, but must be a global variable.
+ Temporary_Config_File : Boolean := False;
+ -- Set to True when there is a temporary config file used for a project
+ -- file, to avoid displaying the -gnatec switch for a temporary file.
+
procedure Add_Switches
(The_Package : Package_Id;
File_Name : String;
@@ -476,10 +684,13 @@ package body Make is
-- added at the beginning of the command line.
procedure Check
- (Lib_File : File_Name_Type;
- ALI : out ALI_Id;
- O_File : out File_Name_Type;
- O_Stamp : out Time_Stamp_Type);
+ (Source_File : File_Name_Type;
+ The_Args : Argument_List;
+ Lib_File : File_Name_Type;
+ Read_Only : Boolean;
+ ALI : out ALI_Id;
+ O_File : out File_Name_Type;
+ O_Stamp : out Time_Stamp_Type);
-- Determines whether the library file Lib_File is up-to-date or not. The
-- full name (with path information) of the object file corresponding to
-- Lib_File is returned in O_File. Its time stamp is saved in O_Stamp.
@@ -499,23 +710,102 @@ package body Make is
-- linker file is returned in O_File and O_Stamp is empty.
-- Otherwise O_File is No_File.
+ procedure Collect_Arguments
+ (Source_File : File_Name_Type;
+ Args : Argument_List);
+ -- Collect all arguments for a source to be compiled, including those
+ -- that come from a project file.
+
procedure Display (Program : String; Args : Argument_List);
-- Displays Program followed by the arguments in Args if variable
-- Display_Executed_Programs is set. The lower bound of Args must be 1.
- type Temp_File_Names is array (Positive range <>) of Temp_File_Name;
+ -----------------
+ -- Mapping files
+ -----------------
+
+ type Temp_File_Names is
+ array (Project_Id range <>, Positive range <>) of Name_Id;
type Temp_Files_Ptr is access Temp_File_Names;
+ type Indices is array (Project_Id range <>) of Natural;
+
+ type Indices_Ptr is access Indices;
+
+ type Free_File_Indices is array
+ (Project_Id range <>, Positive range <>) of Positive;
+
+ type Free_Indices_Ptr is access Free_File_Indices;
+
The_Mapping_File_Names : Temp_Files_Ptr;
- Last_Mapping_File_Name : Natural := 0;
+ -- For each project, the name ids of the temporary mapping files used
+
+ Last_Mapping_File_Names : Indices_Ptr;
+ -- For each project, the index of the last mapping file created
+
+ The_Free_Mapping_File_Indices : Free_Indices_Ptr;
+ -- For each project, the indices in The_Mapping_File_Names of the mapping
+ -- file names that can be reused for subsequent compilations.
+
+ Last_Free_Indices : Indices_Ptr;
+ -- For each project, the number of mapping files that can be reused
+
+ Gnatmake_Mapping_File : String_Access := null;
+ -- The path name of a mapping file specified by switch -C=
procedure Delete_Mapping_Files;
-- Delete all temporary mapping files
- procedure Init_Mapping_File (File_Name : in out Temp_File_Name);
+ procedure Init_Mapping_File
+ (Project : Project_Id;
+ File_Index : in out Natural);
-- Create a new temporary mapping file, and fill it with the project file
- -- mappings, when using project file(s)
+ -- mappings, when using project file(s). The out parameter File_Index is
+ -- the index to the name of the file in the array The_Mapping_File_Names.
+
+ procedure Delete_Temp_Config_Files;
+ -- Delete all temporary config files
+
+ procedure Delete_All_Temp_Files;
+ -- Delete all temp files (config files, mapping files, path files)
+
+ -------------------
+ -- Add_Arguments --
+ -------------------
+
+ procedure Add_Arguments (Args : Argument_List) is
+ begin
+ if Arguments = null then
+ Arguments := new Argument_List (1 .. Args'Length + 10);
+
+ else
+ while Last_Argument + Args'Length > Arguments'Last loop
+ declare
+ New_Arguments : Argument_List_Access :=
+ new Argument_List (1 .. Arguments'Last * 2);
+
+ begin
+ New_Arguments (1 .. Last_Argument) :=
+ Arguments (1 .. Last_Argument);
+ Arguments := New_Arguments;
+ end;
+ end loop;
+ end if;
+
+ Arguments (Last_Argument + 1 .. Last_Argument + Args'Length) := Args;
+ Last_Argument := Last_Argument + Args'Length;
+ end Add_Arguments;
+
+ --------------------
+ -- Add_Dependency --
+ --------------------
+
+ procedure Add_Dependency (S : Name_Id; On : Name_Id) is
+ begin
+ Dependencies.Increment_Last;
+ Dependencies.Table (Dependencies.Last) := (S, On);
+ end Add_Dependency;
--------------------
-- Add_Object_Dir --
@@ -564,7 +854,7 @@ package body Make is
procedure Generic_Position (New_Position : out Integer);
-- Generic procedure that chooses a position for S in T at the
-- beginning or the end, depending on the boolean Append_Switch.
-
+ -- Calling this procedure may expand the table.
----------------------
-- Generic_Position --
@@ -691,17 +981,22 @@ package body Make is
while Switch_List /= Nil_String loop
Element := String_Elements.Table (Switch_List);
- String_To_Name_Buffer (Element.Value);
+ Get_Name_String (Element.Value);
if Name_Len > 0 then
- if Opt.Verbose_Mode then
- Write_Str (" Adding ");
- Write_Line (Name_Buffer (1 .. Name_Len));
- end if;
+ declare
+ Argv : constant String := Name_Buffer (1 .. Name_Len);
+ -- We need a copy, because Name_Buffer may be
+ -- modified.
- Scan_Make_Arg
- (Name_Buffer (1 .. Name_Len),
- And_Save => False);
+ begin
+ if Opt.Verbose_Mode then
+ Write_Str (" Adding ");
+ Write_Line (Argv);
+ end if;
+
+ Scan_Make_Arg (Argv, And_Save => False);
+ end;
end if;
Switch_List := Element.Next;
@@ -709,16 +1004,21 @@ package body Make is
when Single =>
Program_Args := Program;
- String_To_Name_Buffer (Switches.Value);
+ Get_Name_String (Switches.Value);
if Name_Len > 0 then
- if Opt.Verbose_Mode then
- Write_Str (" Adding ");
- Write_Line (Name_Buffer (1 .. Name_Len));
- end if;
+ declare
+ Argv : constant String := Name_Buffer (1 .. Name_Len);
+ -- We need a copy, because Name_Buffer may be modified
+
+ begin
+ if Opt.Verbose_Mode then
+ Write_Str (" Adding ");
+ Write_Line (Argv);
+ end if;
- Scan_Make_Arg
- (Name_Buffer (1 .. Name_Len), And_Save => False);
+ Scan_Make_Arg (Argv, And_Save => False);
+ end;
end if;
end case;
end if;
@@ -767,7 +1067,7 @@ package body Make is
Display (Gnatbind.all, Bind_Args (Args'First .. Bind_Last));
if Gnatbind_Path = null then
- Osint.Fail ("error, unable to locate " & Gnatbind.all);
+ Make_Failed ("error, unable to locate ", Gnatbind.all);
end if;
GNAT.OS_Lib.Spawn
@@ -783,10 +1083,13 @@ package body Make is
-----------
procedure Check
- (Lib_File : File_Name_Type;
- ALI : out ALI_Id;
- O_File : out File_Name_Type;
- O_Stamp : out Time_Stamp_Type)
+ (Source_File : File_Name_Type;
+ The_Args : Argument_List;
+ Lib_File : File_Name_Type;
+ Read_Only : Boolean;
+ ALI : out ALI_Id;
+ O_File : out File_Name_Type;
+ O_Stamp : out Time_Stamp_Type)
is
function First_New_Spec (A : ALI_Id) return File_Name_Type;
-- Looks in the with table entries of A and returns the spec file name
@@ -916,8 +1219,8 @@ package body Make is
Source_Name : Name_Id;
Text : Text_Buffer_Ptr;
- Prev_Switch : Character;
- -- First character of previous switch processed
+ Prev_Switch : String_Access;
+ -- Previous switch processed
Arg : Arg_Id := Arg_Id'First;
-- Current index in Args.Table for a given unit (init to stop warning)
@@ -925,15 +1228,29 @@ package body Make is
Switch_Found : Boolean;
-- True if a given switch has been found
- Num_Args : Integer;
- -- Number of compiler arguments processed
-
-- Start of processing for Check
begin
pragma Assert (Lib_File /= No_File);
- Text := Read_Library_Info (Lib_File);
+ -- If the ALI file is read-only, set temporarily
+ -- Check_Object_Consistency to False: we don't care if the object file
+ -- is not there; presumably, a library will be used for linking.
+
+ if Read_Only then
+ declare
+ Saved_Check_Object_Consistency : constant Boolean :=
+ Opt.Check_Object_Consistency;
+ begin
+ Opt.Check_Object_Consistency := False;
+ Text := Read_Library_Info (Lib_File);
+ Opt.Check_Object_Consistency := Saved_Check_Object_Consistency;
+ end;
+
+ else
+ Text := Read_Library_Info (Lib_File);
+ end if;
+
Full_Lib_File := Full_Library_Info_Name;
Full_Obj_File := Full_Object_File_Name;
Lib_Stamp := Current_Library_File_Stamp;
@@ -978,6 +1295,15 @@ package body Make is
return;
end if;
+ -- Don't take Ali file into account if it was generated with
+ -- errors.
+
+ if ALIs.Table (ALI).Compile_Errors then
+ Verbose_Msg (Full_Lib_File, "had errors, must be recompiled");
+ ALI := No_ALI_Id;
+ return;
+ end if;
+
-- Don't take Ali file into account if it was generated without
-- object.
@@ -992,23 +1318,28 @@ package body Make is
-- Check for matching compiler switches if needed
if Opt.Check_Switches then
- Prev_Switch := ASCII.Nul;
- Num_Args := 0;
+
+ -- First, collect all the switches
+
+ Collect_Arguments (Source_File, The_Args);
+
+ Prev_Switch := Dummy_Switch;
Get_Name_String (ALIs.Table (ALI).Sfile);
Switches_To_Check.Set_Last (0);
- for J in Gcc_Switches.First .. Gcc_Switches.Last loop
+ for J in 1 .. Last_Argument loop
- -- Skip non switches, -I and -o switches
+ -- Skip non switches -c, -I and -o switches
- if Gcc_Switches.Table (J) (1) = '-'
- and then Gcc_Switches.Table (J) (2) /= 'o'
- and then Gcc_Switches.Table (J) (2) /= 'I'
+ if Arguments (J) (1) = '-'
+ and then Arguments (J) (2) /= 'c'
+ and then Arguments (J) (2) /= 'o'
+ and then Arguments (J) (2) /= 'I'
then
Normalize_Compiler_Switches
- (Gcc_Switches.Table (J).all,
+ (Arguments (J).all,
Normalized_Switches,
Last_Norm_Switch);
@@ -1030,8 +1361,14 @@ package body Make is
-- orders between same switches, e.g -O -O2 is different
-- than -O2 -O, but -g -O is equivalent to -O -g.
- if Switches_To_Check.Table (J) (2) /= Prev_Switch then
- Prev_Switch := Switches_To_Check.Table (J) (2);
+ if Switches_To_Check.Table (J) (2) /= Prev_Switch (2) or else
+ (Prev_Switch'Length >= 6 and then
+ Prev_Switch (2 .. 5) = "gnat" and then
+ Switches_To_Check.Table (J)'Length >= 6 and then
+ Switches_To_Check.Table (J) (2 .. 5) = "gnat" and then
+ Prev_Switch (6) /= Switches_To_Check.Table (J) (6))
+ then
+ Prev_Switch := Switches_To_Check.Table (J);
Arg :=
Units.Table (ALIs.Table (ALI).First_Unit).First_Arg;
end if;
@@ -1041,8 +1378,6 @@ package body Make is
for K in Arg ..
Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg
loop
- Num_Args := Num_Args + 1;
-
if
Switches_To_Check.Table (J).all = Args.Table (K).all
then
@@ -1055,7 +1390,8 @@ package body Make is
if not Switch_Found then
if Opt.Verbose_Mode then
Verbose_Msg (ALIs.Table (ALI).Sfile,
- "switch mismatch");
+ "switch mismatch """ &
+ Switches_To_Check.Table (J).all & '"');
end if;
ALI := No_ALI_Id;
@@ -1063,13 +1399,29 @@ package body Make is
end if;
end loop;
- if Num_Args /=
+ if Switches_To_Check.Last /=
Integer (Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg -
Units.Table (ALIs.Table (ALI).First_Unit).First_Arg + 1)
then
if Opt.Verbose_Mode then
Verbose_Msg (ALIs.Table (ALI).Sfile,
- "different number of switches");
+ "different number of switches");
+
+ for K in Units.Table (ALIs.Table (ALI).First_Unit).First_Arg
+ .. Units.Table (ALIs.Table (ALI).First_Unit).Last_Arg
+ loop
+ Write_Str (Args.Table (K).all);
+ Write_Char (' ');
+ end loop;
+
+ Write_Eol;
+
+ for J in 1 .. Switches_To_Check.Last loop
+ Write_Str (Switches_To_Check.Table (J).all);
+ Write_Char (' ');
+ end loop;
+
+ Write_Eol;
end if;
ALI := No_ALI_Id;
@@ -1077,12 +1429,12 @@ package body Make is
end if;
end if;
- -- Get the source files and their time stamps. Note that some
+ -- Get the source files and their message digests. Note that some
-- sources may be missing if ALI is out-of-date.
Set_Source_Table (ALI);
- Modified_Source := Time_Stamp_Mismatch (ALI);
+ Modified_Source := Time_Stamp_Mismatch (ALI, Read_Only);
if Modified_Source /= No_File then
ALI := No_ALI_Id;
@@ -1117,6 +1469,26 @@ package body Make is
end if;
end Check;
+ ------------------------
+ -- Check_For_S_Switch --
+ ------------------------
+
+ procedure Check_For_S_Switch is
+ begin
+ -- By default, we generate an object file
+
+ Output_Is_Object := True;
+
+ for Arg in 1 .. Last_Argument loop
+ if Arguments (Arg).all = "-S" then
+ Output_Is_Object := False;
+
+ elsif Arguments (Arg).all = "-c" then
+ Output_Is_Object := True;
+ end if;
+ end loop;
+ end Check_For_S_Switch;
+
--------------------------
-- Check_Linker_Options --
--------------------------
@@ -1273,7 +1645,9 @@ package body Make is
if Opt = Linker_Switches.First
or else (Linker_Switches.Table (Opt - 1).all /= "-u"
and then
- Linker_Switches.Table (Opt - 1).all /= "-Xlinker")
+ Linker_Switches.Table (Opt - 1).all /= "-Xlinker"
+ and then
+ Linker_Switches.Table (Opt - 1).all /= "-L")
then
Name_Len := 0;
Add_Str_To_Name_Buffer (Linker_Switches.Table (Opt).all);
@@ -1283,6 +1657,201 @@ package body Make is
end Check_Linker_Options;
+ -----------------
+ -- Check_Steps --
+ -----------------
+
+ procedure Check_Steps is
+ begin
+ -- If either -c, -b or -l has been specified, we will not necessarily
+ -- execute all steps.
+
+ if Make_Steps then
+ Do_Compile_Step := Do_Compile_Step and Compile_Only;
+ Do_Bind_Step := Do_Bind_Step and Bind_Only;
+ Do_Link_Step := Do_Link_Step and Link_Only;
+
+ -- If -c has been specified, but not -b, ignore any potential -l
+
+ if Do_Compile_Step and then not Do_Bind_Step then
+ Do_Link_Step := False;
+ end if;
+ end if;
+ end Check_Steps;
+
+ -----------------------
+ -- Collect_Arguments --
+ -----------------------
+
+ procedure Collect_Arguments
+ (Source_File : File_Name_Type;
+ Args : Argument_List)
+ is
+ begin
+ Arguments_Collected := True;
+ Arguments_Project := No_Project;
+ Last_Argument := 0;
+ Add_Arguments (Args);
+
+ if Main_Project /= No_Project then
+ declare
+ Source_File_Name : constant String :=
+ Get_Name_String (Source_File);
+ Compiler_Package : Prj.Package_Id;
+ Switches : Prj.Variable_Value;
+ Data : Project_Data;
+
+ begin
+ Prj.Env.
+ Get_Reference
+ (Source_File_Name => Source_File_Name,
+ Project => Arguments_Project,
+ Path => Arguments_Path_Name);
+
+ -- If the source is not a source of a project file,
+ -- we simply add the saved gcc switches.
+
+ if Arguments_Project = No_Project then
+
+ Add_Arguments (The_Saved_Gcc_Switches.all);
+
+ else
+ -- We get the project directory for the relative path
+ -- switches and arguments.
+
+ Data := Projects.Table (Arguments_Project);
+
+ -- If the source is in an extended project, we go to
+ -- the ultimate extending project.
+
+ while Data.Extended_By /= No_Project loop
+ Arguments_Project := Data.Extended_By;
+ Data := Projects.Table (Arguments_Project);
+ end loop;
+
+ -- If building a dynamic or relocatable library, compile with
+ -- PIC option, if it exists.
+
+ if Data.Library and then Data.Library_Kind /= Static then
+ declare
+ PIC : constant String := MLib.Tgt.PIC_Option;
+
+ begin
+ if PIC /= "" then
+ Add_Arguments ((1 => new String'(PIC)));
+ end if;
+ end;
+ end if;
+
+ if Data.Dir_Path = null then
+ Data.Dir_Path :=
+ new String'(Get_Name_String (Data.Display_Directory));
+ Projects.Table (Arguments_Project) := Data;
+ end if;
+
+ -- We now look for package Compiler
+ -- and get the switches from this package.
+
+ Compiler_Package :=
+ Prj.Util.Value_Of
+ (Name => Name_Compiler,
+ In_Packages => Data.Decl.Packages);
+
+ if Compiler_Package /= No_Package then
+
+ -- If package Gnatmake.Compiler exists, we get
+ -- the specific switches for the current source,
+ -- or the global switches, if any.
+
+ Switches := Switches_Of
+ (Source_File => Source_File,
+ Source_File_Name => Source_File_Name,
+ Naming => Data.Naming,
+ In_Package => Compiler_Package,
+ Allow_ALI => False);
+
+ end if;
+
+ case Switches.Kind is
+
+ -- We have a list of switches. We add these switches,
+ -- plus the saved gcc switches.
+
+ when List =>
+
+ declare
+ Current : String_List_Id := Switches.Values;
+ Element : String_Element;
+ Number : Natural := 0;
+
+ begin
+ while Current /= Nil_String loop
+ Element := String_Elements.Table (Current);
+ Number := Number + 1;
+ Current := Element.Next;
+ end loop;
+
+ declare
+ New_Args : Argument_List (1 .. Number);
+
+ begin
+ Current := Switches.Values;
+
+ for Index in New_Args'Range loop
+ Element := String_Elements.Table (Current);
+ Get_Name_String (Element.Value);
+ New_Args (Index) :=
+ new String'(Name_Buffer (1 .. Name_Len));
+ Test_If_Relative_Path
+ (New_Args (Index), Parent => Data.Dir_Path);
+ Current := Element.Next;
+ end loop;
+
+ Add_Arguments
+ (Configuration_Pragmas_Switch
+ (Arguments_Project) &
+ New_Args & The_Saved_Gcc_Switches.all);
+ end;
+ end;
+
+ -- We have a single switch. We add this switch,
+ -- plus the saved gcc switches.
+
+ when Single =>
+ Get_Name_String (Switches.Value);
+
+ declare
+ New_Args : Argument_List :=
+ (1 => new String'
+ (Name_Buffer (1 .. Name_Len)));
+
+ begin
+ Test_If_Relative_Path
+ (New_Args (1), Parent => Data.Dir_Path);
+ Add_Arguments
+ (Configuration_Pragmas_Switch (Arguments_Project) &
+ New_Args & The_Saved_Gcc_Switches.all);
+ end;
+
+ -- We have no switches from Gnatmake.Compiler.
+ -- We add the saved gcc switches.
+
+ when Undefined =>
+ Add_Arguments
+ (Configuration_Pragmas_Switch (Arguments_Project) &
+ The_Saved_Gcc_Switches.all);
+ end case;
+ end if;
+ end;
+ end if;
+
+ -- Set Output_Is_Object, depending if there is a -S switch.
+ -- If the bind step is not performed, and there is a -S switch,
+ -- then we will not check for a valid object file.
+
+ Check_For_S_Switch;
+ end Collect_Arguments;
+
---------------------
-- Compile_Sources --
---------------------
@@ -1306,23 +1875,23 @@ package body Make is
function Compile
(S : Name_Id;
L : Name_Id;
- Args : Argument_List)
- return Process_Id;
+ Args : Argument_List) return Process_Id;
-- Compiles S using Args. If S is a GNAT predefined source
-- "-gnatpg" is added to Args. Non blocking call. L corresponds to the
-- expected library file name. Process_Id of the process spawned to
-- execute the compile.
- No_Mapping_File : constant Temp_File_Name := (others => ' ');
+ No_Mapping_File : constant Natural := 0;
type Compilation_Data is record
Pid : Process_Id;
Full_Source_File : File_Name_Type;
Lib_File : File_Name_Type;
Source_Unit : Unit_Name_Type;
- Mapping_File : Temp_File_Name := No_Mapping_File;
- Use_Mapping_File : Boolean := False;
- Syntax_Only : Boolean := False;
+ Mapping_File : Natural := No_Mapping_File;
+ Project : Project_Id := No_Project;
+ Syntax_Only : Boolean := False;
+ Output_Is_Object : Boolean := True;
end record;
Running_Compile : array (1 .. Max_Process) of Compilation_Data;
@@ -1358,36 +1927,33 @@ package body Make is
ALI : ALI_Id;
-- ALI Id of the current ALI file
+ Read_Only : Boolean := False;
+
Compilation_OK : Boolean;
Need_To_Compile : Boolean;
Pid : Process_Id;
Text : Text_Buffer_Ptr;
- Mfile : Temp_File_Name := No_Mapping_File;
-
- Data : Prj.Project_Data;
-
- Arg_Index : Natural;
- -- Index in Special_Args.Table of a given compilation file
+ Mfile : Natural := No_Mapping_File;
- Need_To_Check_Standard_Library : Boolean := Check_Readonly_Files;
+ Need_To_Check_Standard_Library : Boolean :=
+ Check_Readonly_Files and not Unique_Compile;
- Mapping_File_Arg : constant String_Access := new String'
- (1 => '-', 2 => 'g', 3 => 'n', 4 => 'a', 5 => 't', 6 => 'e', 7 => 'm',
- 8 .. 7 + Mfile'Length => ' ');
+ Mapping_File_Arg : String_Access;
procedure Add_Process
(Pid : Process_Id;
Sfile : File_Name_Type;
Afile : File_Name_Type;
Uname : Unit_Name_Type;
- Mfile : Temp_File_Name := No_Mapping_File;
- UMfile : Boolean := False);
+ Mfile : Natural := No_Mapping_File);
-- Adds process Pid to the current list of outstanding compilation
-- processes and record the full name of the source file Sfile that
-- we are compiling, the name of its library file Afile and the
- -- name of its unit Uname.
+ -- name of its unit Uname. If Mfile is not equal to No_Mapping_File,
+ -- it is the index of the mapping file used during compilation in the
+ -- array The_Mapping_File_Names.
procedure Await_Compile
(Sfile : out File_Name_Type;
@@ -1435,17 +2001,7 @@ package body Make is
function Bad_Compilation_Count return Natural;
-- Returns the number of compilation failures.
- procedure Debug_Msg (S : String; N : Name_Id);
- -- If Debug.Debug_Flag_W is set outputs string S followed by name N.
-
- function Configuration_Pragmas_Switch
- (For_Project : Project_Id)
- return Argument_List;
- -- Return an argument list of one element, if there is a configuration
- -- pragmas file to be specified for For_Project,
- -- otherwise return an empty argument list.
-
- procedure Get_Mapping_File;
+ procedure Get_Mapping_File (Project : Project_Id);
-- Get a mapping file name. If there is one to be reused, reuse it.
-- Otherwise, create a new mapping file.
@@ -1458,8 +2014,7 @@ package body Make is
Sfile : File_Name_Type;
Afile : File_Name_Type;
Uname : Unit_Name_Type;
- Mfile : Temp_File_Name := No_Mapping_File;
- UMfile : Boolean := False)
+ Mfile : Natural := No_Mapping_File)
is
OC1 : constant Positive := Outstanding_Compiles + 1;
@@ -1472,8 +2027,9 @@ package body Make is
Running_Compile (OC1).Lib_File := Afile;
Running_Compile (OC1).Source_Unit := Uname;
Running_Compile (OC1).Mapping_File := Mfile;
- Running_Compile (OC1).Use_Mapping_File := UMfile;
+ Running_Compile (OC1).Project := Arguments_Project;
Running_Compile (OC1).Syntax_Only := Syntax_Only;
+ Running_Compile (OC1).Output_Is_Object := Output_Is_Object;
Outstanding_Compiles := OC1;
end Add_Process;
@@ -1489,6 +2045,7 @@ package body Make is
OK : out Boolean)
is
Pid : Process_Id;
+ Project : Project_Id;
begin
pragma Assert (Outstanding_Compiles > 0);
@@ -1498,46 +2055,61 @@ package body Make is
Uname := No_Name;
OK := False;
- Wait_Process (Pid, OK);
+ -- The loop here is a work-around for a problem on VMS; in some
+ -- circumstances (shared library and several executables, for
+ -- example), there are child processes other than compilation
+ -- processes that are received. Until this problem is resolved,
+ -- we will ignore such processes.
- if Pid = Invalid_Pid then
- return;
- end if;
+ loop
+ Wait_Process (Pid, OK);
- for J in Running_Compile'First .. Outstanding_Compiles loop
- if Pid = Running_Compile (J).Pid then
- Sfile := Running_Compile (J).Full_Source_File;
- Afile := Running_Compile (J).Lib_File;
- Uname := Running_Compile (J).Source_Unit;
- Syntax_Only := Running_Compile (J).Syntax_Only;
+ if Pid = Invalid_Pid then
+ return;
+ end if;
- -- If a mapping file was used by this compilation,
- -- get its file name for reuse by a subsequent compilation
+ for J in Running_Compile'First .. Outstanding_Compiles loop
+ if Pid = Running_Compile (J).Pid then
+ Sfile := Running_Compile (J).Full_Source_File;
+ Afile := Running_Compile (J).Lib_File;
+ Uname := Running_Compile (J).Source_Unit;
+ Syntax_Only := Running_Compile (J).Syntax_Only;
+ Output_Is_Object := Running_Compile (J).Output_Is_Object;
+ Project := Running_Compile (J).Project;
+
+ -- If a mapping file was used by this compilation,
+ -- get its file name for reuse by a subsequent compilation
+
+ if Running_Compile (J).Mapping_File /= No_Mapping_File then
+ Last_Free_Indices (Project) :=
+ Last_Free_Indices (Project) + 1;
+ The_Free_Mapping_File_Indices
+ (Project, Last_Free_Indices (Project)) :=
+ Running_Compile (J).Mapping_File;
+ end if;
- if Running_Compile (J).Use_Mapping_File then
- Last_Mapping_File_Name := Last_Mapping_File_Name + 1;
- The_Mapping_File_Names (Last_Mapping_File_Name) :=
- Running_Compile (J).Mapping_File;
- end if;
+ -- To actually remove this Pid and related info from
+ -- Running_Compile replace its entry with the last valid
+ -- entry in Running_Compile.
- -- To actually remove this Pid and related info from
- -- Running_Compile replace its entry with the last valid
- -- entry in Running_Compile.
+ if J = Outstanding_Compiles then
+ null;
- if J = Outstanding_Compiles then
- null;
+ else
+ Running_Compile (J) :=
+ Running_Compile (Outstanding_Compiles);
+ end if;
- else
- Running_Compile (J) :=
- Running_Compile (Outstanding_Compiles);
+ Outstanding_Compiles := Outstanding_Compiles - 1;
+ return;
end if;
+ end loop;
- Outstanding_Compiles := Outstanding_Compiles - 1;
- return;
- end if;
- end loop;
+ -- This child process was not one of our compilation processes;
+ -- just ignore it for now.
- raise Program_Error;
+ -- raise Program_Error;
+ end loop;
end Await_Compile;
---------------------------
@@ -1556,251 +2128,77 @@ package body Make is
procedure Collect_Arguments_And_Compile (Source_File : File_Name_Type) is
begin
- -- If we use mapping file (-P or -C switches), then get one
+ -- If arguments have not yet been collected (in Check), collect them
+ -- now.
- if Create_Mapping_File then
- Get_Mapping_File;
+ if not Arguments_Collected then
+ Collect_Arguments (Source_File, Args);
end if;
- -- If no project file is used, then just call Compile with
- -- the specified Args.
-
- if Main_Project = No_Project then
- Pid := Compile (Full_Source_File, Lib_File, Args);
-
- -- A project file was used
-
- else
- -- First check if the current source is an immediate
- -- source of a project file.
-
- if Opt.Verbose_Mode then
- Write_Eol;
- Write_Line ("Establishing Project context.");
- end if;
-
- declare
- Source_File_Name : constant String :=
- Get_Name_String (Source_File);
- Current_Project : Prj.Project_Id;
- Path_Name : File_Name_Type := Source_File;
- Compiler_Package : Prj.Package_Id;
- Switches : Prj.Variable_Value;
- Object_File : String_Access;
-
- begin
- if Opt.Verbose_Mode then
- Write_Str ("Checking if the Project File exists for """);
- Write_Str (Source_File_Name);
- Write_Line (""".");
- end if;
-
- Prj.Env.
- Get_Reference
- (Source_File_Name => Source_File_Name,
- Project => Current_Project,
- Path => Path_Name);
-
- if Current_Project = No_Project then
-
- -- The current source is not an immediate source of any
- -- project file. Call Compile with the specified Args plus
- -- the saved gcc switches.
-
- if Opt.Verbose_Mode then
- Write_Str ("No Project File.");
- Write_Eol;
- end if;
-
- Pid := Compile
- (Full_Source_File,
- Lib_File,
- Args & The_Saved_Gcc_Switches.all);
-
- -- We now know the project of the current source
-
- else
- -- Set ADA_INCLUDE_PATH and ADA_OBJECTS_PATH if the project
- -- has changed.
+ -- If we use mapping file (-P or -C switches), then get one
- -- Note: this will modify these environment variables only
- -- for the current gnatmake process and all of its children
- -- (invocations of the compiler, the binder and the linker).
+ if Create_Mapping_File then
+ Get_Mapping_File (Arguments_Project);
+ end if;
- -- The caller's ADA_INCLUDE_PATH and ADA_OBJECTS_PATH are
- -- not affected.
+ -- If the source is part of a project file, we set the ADA_*_PATHs,
+ -- check for an eventual library project, and use the full path.
- Set_Ada_Paths (Current_Project, True);
+ if Arguments_Project /= No_Project then
+ Prj.Env.Set_Ada_Paths (Arguments_Project, True);
- Data := Projects.Table (Current_Project);
+ if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then
+ declare
+ The_Data : Project_Data :=
+ Projects.Table (Arguments_Project);
+ Prj : Project_Id := Arguments_Project;
- -- Check if it is a library project that needs to be
- -- processed, only if it is not the main project.
+ begin
+ while The_Data.Extended_By /= No_Project loop
+ Prj := The_Data.Extended_By;
+ The_Data := Projects.Table (Prj);
+ end loop;
- if MLib.Tgt.Libraries_Are_Supported
- and then Current_Project /= Main_Project
- and then Data.Library
- and then not Data.Flag1
- then
- -- Add to the Q all sources of the project that have
- -- not been marked
+ if The_Data.Library and then not The_Data.Flag1 then
+ -- Add to the Q all sources of the project that
+ -- have not been marked
Insert_Project_Sources
- (The_Project => Current_Project, Into_Q => True);
+ (The_Project => Prj,
+ All_Projects => False,
+ Into_Q => True);
-- Now mark the project as processed
- Data.Flag1 := True;
- Projects.Table (Current_Project).Flag1 := True;
- end if;
-
- Get_Name_String (Data.Object_Directory);
-
- if Name_Buffer (Name_Len) = '/'
- or else Name_Buffer (Name_Len) = Directory_Separator
- then
- Object_File :=
- new String'
- (Name_Buffer (1 .. Name_Len) &
- Object_File_Name (Source_File_Name));
-
- else
- Object_File :=
- new String'
- (Name_Buffer (1 .. Name_Len) &
- Directory_Separator &
- Object_File_Name (Source_File_Name));
+ Projects.Table (Prj).Flag1 := True;
end if;
+ end;
+ end if;
- if Opt.Verbose_Mode then
- Write_Str ("Project file is """);
- Write_Str (Get_Name_String (Data.Name));
- Write_Str (""".");
- Write_Eol;
- end if;
-
- -- We know look for package Compiler
- -- and get the switches from this package.
-
- if Opt.Verbose_Mode then
- Write_Str ("Checking package Compiler.");
- Write_Eol;
- end if;
-
- Compiler_Package :=
- Prj.Util.Value_Of
- (Name => Name_Compiler,
- In_Packages => Data.Decl.Packages);
-
- if Compiler_Package /= No_Package then
-
- if Opt.Verbose_Mode then
- Write_Str ("Getting the switches.");
- Write_Eol;
- end if;
-
- -- If package Gnatmake.Compiler exists, we get
- -- the specific switches for the current source,
- -- or the global switches, if any.
-
- Switches := Switches_Of
- (Source_File => Source_File,
- Source_File_Name => Source_File_Name,
- Naming =>
- Projects.Table (Current_Project).Naming,
- In_Package => Compiler_Package,
- Allow_ALI => False);
-
- end if;
-
- case Switches.Kind is
-
- -- We have a list of switches. We add to Args
- -- these switches, plus the saved gcc switches.
-
- when List =>
-
- declare
- Current : String_List_Id := Switches.Values;
- Element : String_Element;
- Number : Natural := 0;
-
- begin
- while Current /= Nil_String loop
- Element := String_Elements.Table (Current);
- Number := Number + 1;
- Current := Element.Next;
- end loop;
-
- declare
- New_Args : Argument_List (1 .. Number);
-
- begin
- Current := Switches.Values;
-
- for Index in New_Args'Range loop
- Element := String_Elements.Table (Current);
- String_To_Name_Buffer (Element.Value);
- New_Args (Index) :=
- new String' (Name_Buffer (1 .. Name_Len));
- Test_If_Relative_Path
- (New_Args (Index), Parent => null);
- Current := Element.Next;
- end loop;
-
- Pid := Compile
- (Path_Name,
- Lib_File,
- Args & Output_Flag & Object_File &
- Configuration_Pragmas_Switch
- (Current_Project) &
- New_Args & The_Saved_Gcc_Switches.all);
- end;
- end;
-
- -- We have a single switch. We add to Args
- -- this switch, plus the saved gcc switches.
-
- when Single =>
- String_To_Name_Buffer (Switches.Value);
+ -- Change to the object directory of the project file, if it is
+ -- not the main project file.
- declare
- New_Args : Argument_List :=
- (1 => new String'
- (Name_Buffer (1 .. Name_Len)));
+ if Arguments_Project /= Main_Project then
+ Change_Dir
+ (Get_Name_String
+ (Projects.Table (Arguments_Project).Object_Directory));
+ end if;
- begin
- Test_If_Relative_Path
- (New_Args (1), Parent => null);
- Pid := Compile
- (Path_Name,
- Lib_File,
- Args &
- Output_Flag &
- Object_File &
- New_Args &
- Configuration_Pragmas_Switch (Current_Project) &
- The_Saved_Gcc_Switches.all);
- end;
+ Pid := Compile (Arguments_Path_Name, Lib_File,
+ Arguments (1 .. Last_Argument));
- -- We have no switches from Gnatmake.Compiler.
- -- We add to Args the saved gcc switches.
+ -- Change back to the object directory of the main project file,
+ -- if necessary.
- when Undefined =>
- if Opt.Verbose_Mode then
- Write_Str ("There are no switches.");
- Write_Eol;
- end if;
+ if Arguments_Project /= Main_Project then
+ Change_Dir
+ (Get_Name_String
+ (Projects.Table (Main_Project).Object_Directory));
+ end if;
- Pid := Compile
- (Path_Name,
- Lib_File,
- Args & Output_Flag & Object_File &
- Configuration_Pragmas_Switch (Current_Project) &
- The_Saved_Gcc_Switches.all);
- end case;
- end if;
- end;
+ else
+ Pid := Compile (Full_Source_File, Lib_File,
+ Arguments (1 .. Last_Argument));
end if;
end Collect_Arguments_And_Compile;
@@ -1808,8 +2206,8 @@ package body Make is
-- Compile --
-------------
- function Compile (S : Name_Id; L : Name_Id; Args : Argument_List)
- return Process_Id
+ function Compile
+ (S : Name_Id; L : Name_Id; Args : Argument_List) return Process_Id
is
Comp_Args : Argument_List (Args'First .. Args'Last + 8);
Comp_Next : Integer := Args'First;
@@ -1837,6 +2235,8 @@ package body Make is
-- Start of processing for Compile
begin
+ Enter_Into_Obsoleted (S);
+
-- By default, Syntax_Only is False
Syntax_Only := False;
@@ -1856,7 +2256,7 @@ package body Make is
elsif Args (J).all = "-gnatc" then
-- If we compile with -gnatc, the bind step and the link step
- -- are inhibited. We set Syntax_Only to True for the case when
+ -- are inhibited. We set Syntax_Only to False for the case when
-- -gnats was previously specified.
Do_Bind_Step := False;
@@ -1899,10 +2299,11 @@ package body Make is
Comp_Args (Comp_Last) := GNAT_Flag;
else
- Fail
+ Make_Failed
("not allowed to compile """ &
Get_Name_String (Fname) &
- """; use -a switch.");
+ """; use -a switch, or compile file with " &
+ """-gnatg"" switch");
end if;
end if;
end;
@@ -1911,14 +2312,14 @@ package body Make is
-- the gcc driver. If this is not the case then add the ada flag
-- "-x ada".
- if not Ada_File_Name (S) then
+ if not Ada_File_Name (S) and then not Targparm.AAMP_On_Target then
Comp_Last := Comp_Last + 1;
Comp_Args (Comp_Last) := Ada_Flag_1;
Comp_Last := Comp_Last + 1;
Comp_Args (Comp_Last) := Ada_Flag_2;
end if;
- if L /= Strip_Directory (L) then
+ if L /= Strip_Directory (L) or else Object_Directory_Path /= null then
-- Build -o argument.
@@ -1935,7 +2336,19 @@ package body Make is
Comp_Last := Comp_Last + 1;
Comp_Args (Comp_Last) := Output_Flag;
Comp_Last := Comp_Last + 1;
- Comp_Args (Comp_Last) := new String'(Name_Buffer (1 .. Name_Len));
+
+ -- If an object directory was specified, prepend the object file
+ -- name with this object directory.
+
+ if Object_Directory_Path /= null then
+ Comp_Args (Comp_Last) :=
+ new String'(Object_Directory_Path.all &
+ Name_Buffer (1 .. Name_Len));
+
+ else
+ Comp_Args (Comp_Last) :=
+ new String'(Name_Buffer (1 .. Name_Len));
+ end if;
end if;
if Create_Mapping_File then
@@ -1953,7 +2366,7 @@ package body Make is
Display (Gcc.all, Comp_Args (Args'First .. Comp_Last));
if Gcc_Path = null then
- Osint.Fail ("error, unable to locate " & Gcc.all);
+ Make_Failed ("error, unable to locate ", Gcc.all);
end if;
return
@@ -1961,65 +2374,33 @@ package body Make is
(Gcc_Path.all, Comp_Args (Args'First .. Comp_Last));
end Compile;
- ----------------------------------
- -- Configuration_Pragmas_Switch --
- ----------------------------------
-
- function Configuration_Pragmas_Switch
- (For_Project : Project_Id)
- return Argument_List
- is
- begin
- Prj.Env.Create_Config_Pragmas_File (For_Project, Main_Project);
-
- if Projects.Table (For_Project).Config_File_Name /= No_Name then
- return
- (1 => new String'("-gnatec" &
- Get_Name_String
- (Projects.Table (For_Project).Config_File_Name)));
-
- else
- return (1 .. 0 => null);
- end if;
- end Configuration_Pragmas_Switch;
-
- ---------------
- -- Debug_Msg --
- ---------------
-
- procedure Debug_Msg (S : String; N : Name_Id) is
- begin
- if Debug.Debug_Flag_W then
- Write_Str (" ... ");
- Write_Str (S);
- Write_Str (" ");
- Write_Name (N);
- Write_Eol;
- end if;
- end Debug_Msg;
-
----------------------
-- Get_Mapping_File --
----------------------
- procedure Get_Mapping_File is
+ procedure Get_Mapping_File (Project : Project_Id) is
begin
-- If there is a mapping file ready to be reused, reuse it
- if Last_Mapping_File_Name > 0 then
- Mfile := The_Mapping_File_Names (Last_Mapping_File_Name);
- Last_Mapping_File_Name := Last_Mapping_File_Name - 1;
+ if Last_Free_Indices (Project) > 0 then
+ Mfile := The_Free_Mapping_File_Indices
+ (Project, Last_Free_Indices (Project));
+ Last_Free_Indices (Project) := Last_Free_Indices (Project) - 1;
-- Otherwise, create and initialize a new one
else
- Init_Mapping_File (File_Name => Mfile);
+ Init_Mapping_File (Project => Project, File_Index => Mfile);
end if;
-- Put the name in the mapping file argument for the invocation
-- of the compiler.
- Mapping_File_Arg (8 .. Mapping_File_Arg'Last) := Mfile;
+ Free (Mapping_File_Arg);
+ Mapping_File_Arg :=
+ new String'("-gnatem=" &
+ Get_Name_String
+ (The_Mapping_File_Names (Project, Mfile)));
end Get_Mapping_File;
@@ -2079,7 +2460,10 @@ package body Make is
Good_ALI.Init;
Output.Set_Standard_Error;
- Init_Q;
+
+ if First_Q_Initialization then
+ Init_Q;
+ end if;
if Initialize_ALI_Data then
Initialize_ALI;
@@ -2096,18 +2480,13 @@ package body Make is
Opt.Check_Source_Files := True;
Opt.All_Sources := False;
- -- If the main source is marked, there is nothing to compile.
- -- This can happen when we have several main subprograms.
- -- For the first main, we always insert in the Q.
-
- if not Is_Marked (Main_Source) then
- Insert_Q (Main_Source);
- Mark (Main_Source);
- end if;
+ Insert_Q (Main_Source);
+ Mark (Main_Source);
- First_Compiled_File := No_File;
- Most_Recent_Obj_File := No_File;
- Main_Unit := False;
+ First_Compiled_File := No_File;
+ Most_Recent_Obj_File := No_File;
+ Most_Recent_Obj_Stamp := Empty_Time_Stamp;
+ Main_Unit := False;
-- Keep looping until there is no more work to do (the Q is empty)
-- and all the outstanding compilations have terminated
@@ -2140,6 +2519,13 @@ package body Make is
Lib_File := Osint.Lib_File_Name (Source_File);
Full_Lib_File := Osint.Full_Lib_File_Name (Lib_File);
+ -- If this source has already been compiled, the executable is
+ -- obsolete.
+
+ if Is_In_Obsoleted (Source_File) then
+ Executable_Obsolete := True;
+ end if;
+
-- If the library file is an Ada library skip it
if Full_Lib_File /= No_File
@@ -2147,11 +2533,15 @@ package body Make is
then
Verbose_Msg (Lib_File, "is in an Ada library", Prefix => " ");
- -- If the library file is a read-only library skip it
+ -- If the library file is a read-only library skip it, but only
+ -- if, when using project files, this library file is in the
+ -- right object directory (a read-only ALI file in the object
+ -- directory of a project being extended should not be skipped).
elsif Full_Lib_File /= No_File
and then not Check_Readonly_Files
and then Is_Readonly_Library (Full_Lib_File)
+ and then Is_In_Object_Directory (Source_File, Full_Lib_File)
then
Verbose_Msg
(Lib_File, "is a read-only library", Prefix => " ");
@@ -2173,7 +2563,8 @@ package body Make is
Fail
("not allowed to compile """ &
Get_Name_String (Source_File) &
- """; use -a switch.");
+ """; use -a switch, or compile file with " &
+ """-gnatg"" switch");
end if;
Verbose_Msg
@@ -2182,13 +2573,20 @@ package body Make is
-- The source file that we are checking can be located
else
+ Arguments_Collected := False;
+
-- Don't waste any time if we have to recompile anyway
Obj_Stamp := Empty_Time_Stamp;
Need_To_Compile := Force_Compilations;
if not Force_Compilations then
- Check (Lib_File, ALI, Obj_File, Obj_Stamp);
+ Read_Only :=
+ Full_Lib_File /= No_File
+ and then not Check_Readonly_Files
+ and then Is_Readonly_Library (Full_Lib_File);
+ Check (Source_File, Args, Lib_File, Read_Only,
+ ALI, Obj_File, Obj_Stamp);
Need_To_Compile := (ALI = No_ALI_Id);
end if;
@@ -2248,10 +2646,6 @@ package body Make is
end if;
- -- Check for special compilation flags
-
- Arg_Index := 0;
-
-- Start the compilation and record it. We can do this
-- because there is at least one free process.
@@ -2267,8 +2661,7 @@ package body Make is
Full_Source_File,
Lib_File,
Source_Unit,
- Mfile,
- Create_Mapping_File);
+ Mfile);
end if;
end if;
end if;
@@ -2300,11 +2693,14 @@ package body Make is
Opt.Check_Object_Consistency;
begin
- -- If compilation was not OK, don't check object
- -- consistency.
+ -- If compilation was not OK, or if output is not an
+ -- object file and we don't do the bind step, don't check
+ -- for object consistency.
Opt.Check_Object_Consistency :=
- Opt.Check_Object_Consistency and Compilation_OK;
+ Opt.Check_Object_Consistency
+ and Compilation_OK
+ and (Output_Is_Object or Do_Bind_Step);
Text := Read_Library_Info (Lib_File);
-- Restore Check_Object_Consistency to its initial value
@@ -2312,8 +2708,8 @@ package body Make is
Opt.Check_Object_Consistency := Saved_Object_Consistency;
end;
- -- If no ALI file was generated by this compilation nothing
- -- more to do, otherwise scan the ali file and record it.
+ -- If an ALI file was generated by this compilation, scan
+ -- the ALI file and record it.
-- If the scan fails, a previous ali file is inconsistent with
-- the unit just compiled.
@@ -2355,12 +2751,10 @@ package body Make is
end if;
end if;
- exit Make_Loop when Unique_Compile;
-
-- PHASE 3: Check if we recorded good ALI files. If yes process
-- them now in the order in which they have been recorded. There
-- are two occasions in which we record good ali files. The first is
- -- in phase 1 when, after scanning an existing ALI file we realise
+ -- in phase 1 when, after scanning an existing ALI file we realize
-- it is up-to-date, the second instance is after a successful
-- compilation.
@@ -2377,8 +2771,9 @@ package body Make is
-- The following adds the standard library (s-stalib) to the
-- list of files to be handled by gnatmake: this file and any
-- files it depends on are always included in every bind,
- -- except in No_Run_Time mode, even if they are not
- -- in the explicit dependency list.
+ -- even if they are not in the explicit dependency list.
+ -- Of course, it is not added if Suppress_Standard_Library
+ -- is True.
-- However, to avoid annoying output about s-stalib.ali being
-- read only, when "-v" is used, we add the standard library
@@ -2387,7 +2782,7 @@ package body Make is
if Need_To_Check_Standard_Library then
Need_To_Check_Standard_Library := False;
- if not ALIs.Table (ALI).No_Run_Time then
+ if not Targparm.Suppress_Standard_Library_On_Target then
declare
Sfile : Name_Id;
Add_It : Boolean := True;
@@ -2405,43 +2800,57 @@ package body Make is
Add_It := Find_File (Sfile, Osint.Source) /= No_File;
end if;
- if Add_It and then not Is_Marked (Sfile) then
- Insert_Q (Sfile);
- Mark (Sfile);
+ if Add_It then
+ if Is_Marked (Sfile) then
+ if Is_In_Obsoleted (Sfile) then
+ Executable_Obsolete := True;
+ end if;
+
+ else
+ Insert_Q (Sfile);
+ Mark (Sfile);
+ end if;
end if;
end;
end if;
end if;
-- Now insert in the Q the unmarked source files (i.e. those
- -- which have neever been inserted in the Q and hence never
- -- considered).
+ -- which have never been inserted in the Q and hence never
+ -- considered). Only do that if Unique_Compile is False.
- for J in
- ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit
- loop
- for K in
- Units.Table (J).First_With .. Units.Table (J).Last_With
+ if not Unique_Compile then
+ for J in
+ ALIs.Table (ALI).First_Unit .. ALIs.Table (ALI).Last_Unit
loop
- Sfile := Withs.Table (K).Sfile;
+ for K in
+ Units.Table (J).First_With .. Units.Table (J).Last_With
+ loop
+ Sfile := Withs.Table (K).Sfile;
+ Add_Dependency (ALIs.Table (ALI).Sfile, Sfile);
- if Sfile = No_File then
- Debug_Msg ("Skipping generic:", Withs.Table (K).Uname);
+ if Is_In_Obsoleted (Sfile) then
+ Executable_Obsolete := True;
+ end if;
- elsif Is_Marked (Sfile) then
- Debug_Msg ("Skipping marked file:", Sfile);
+ if Sfile = No_File then
+ Debug_Msg ("Skipping generic:", Withs.Table (K).Uname);
- elsif not Check_Readonly_Files
- and then Is_Internal_File_Name (Sfile)
- then
- Debug_Msg ("Skipping internal file:", Sfile);
+ elsif Is_Marked (Sfile) then
+ Debug_Msg ("Skipping marked file:", Sfile);
- else
- Insert_Q (Sfile, Withs.Table (K).Uname);
- Mark (Sfile);
- end if;
+ elsif not Check_Readonly_Files
+ and then Is_Internal_File_Name (Sfile)
+ then
+ Debug_Msg ("Skipping internal file:", Sfile);
+
+ else
+ Insert_Q (Sfile, Withs.Table (K).Uname);
+ Mark (Sfile);
+ end if;
+ end loop;
end loop;
- end loop;
+ end if;
end loop;
if Opt.Display_Compilation_Progress then
@@ -2462,38 +2871,185 @@ package body Make is
-- Delete any temporary configuration pragma file
- if Main_Project /= No_Project then
+ Delete_Temp_Config_Files;
+
+ end Compile_Sources;
+
+ ----------------------------------
+ -- Configuration_Pragmas_Switch --
+ ----------------------------------
+
+ function Configuration_Pragmas_Switch
+ (For_Project : Project_Id) return Argument_List
+ is
+ The_Packages : Package_Id;
+ Gnatmake : Package_Id;
+ Compiler : Package_Id;
+
+ Global_Attribute : Variable_Value := Nil_Variable_Value;
+ Local_Attribute : Variable_Value := Nil_Variable_Value;
+
+ Global_Attribute_Present : Boolean := False;
+ Local_Attribute_Present : Boolean := False;
+
+ Result : Argument_List (1 .. 3);
+ Last : Natural := 0;
+
+ function Absolute_Path
+ (Path : Name_Id;
+ Project : Project_Id) return String;
+ -- Returns an absolute path for a configuration pragmas file.
+
+ -------------------
+ -- Absolute_Path --
+ -------------------
+
+ function Absolute_Path
+ (Path : Name_Id;
+ Project : Project_Id) return String
+ is
+ begin
+ Get_Name_String (Path);
+
declare
- Success : Boolean;
+ Path_Name : constant String := Name_Buffer (1 .. Name_Len);
begin
- for Project in 1 .. Projects.Last loop
- if Projects.Table (Project).Config_File_Temp then
- if Opt.Verbose_Mode then
- Write_Str ("Deleting temp configuration file """);
- Write_Str (Get_Name_String
- (Projects.Table (Project).Config_File_Name));
- Write_Line ("""");
+ if Is_Absolute_Path (Path_Name) then
+ return Path_Name;
+
+ else
+ declare
+ Parent_Directory : constant String :=
+ Get_Name_String (Projects.Table (Project).Directory);
+
+ begin
+ if Parent_Directory (Parent_Directory'Last) =
+ Directory_Separator
+ then
+ return Parent_Directory & Path_Name;
+
+ else
+ return Parent_Directory & Directory_Separator & Path_Name;
end if;
+ end;
+ end if;
+ end;
+ end Absolute_Path;
- Delete_File
- (Name => Get_Name_String
- (Projects.Table (Project).Config_File_Name),
- Success => Success);
+ -- Start of processing for Configuration_Pragmas_Switch
+
+ begin
+ Prj.Env.Create_Config_Pragmas_File (For_Project, Main_Project);
+
+ if Projects.Table (For_Project).Config_File_Name /= No_Name then
+ Temporary_Config_File :=
+ Projects.Table (For_Project).Config_File_Temp;
+ Last := 1;
+ Result (1) :=
+ new String'
+ ("-gnatec=" &
+ Get_Name_String
+ (Projects.Table (For_Project).Config_File_Name));
+
+ else
+ Temporary_Config_File := False;
+ end if;
+
+ -- Check for attribute Builder'Global_Configuration_Pragmas
+
+ The_Packages := Projects.Table (Main_Project).Decl.Packages;
+ Gnatmake :=
+ Prj.Util.Value_Of
+ (Name => Name_Builder,
+ In_Packages => The_Packages);
+
+ if Gnatmake /= No_Package then
+ Global_Attribute := Prj.Util.Value_Of
+ (Variable_Name => Name_Global_Configuration_Pragmas,
+ In_Variables => Packages.Table (Gnatmake).Decl.Attributes);
+ Global_Attribute_Present :=
+ Global_Attribute /= Nil_Variable_Value
+ and then Get_Name_String (Global_Attribute.Value) /= "";
+
+ if Global_Attribute_Present then
+ declare
+ Path : constant String :=
+ Absolute_Path (Global_Attribute.Value, Main_Project);
+ begin
+ if not Is_Regular_File (Path) then
+ Make_Failed
+ ("cannot find configuration pragmas file ", Path);
+ end if;
- -- Make sure that we don't have a config file for this
- -- project, in case when there are several mains.
- -- In this case, we will recreate another config file:
- -- we cannot reuse the one that we just deleted!
+ Last := Last + 1;
+ Result (Last) := new String'("-gnatec=" & Path);
+ end;
+ end if;
+ end if;
+
+ -- Check for attribute Compiler'Local_Configuration_Pragmas
- Projects.Table (Project).Config_Checked := False;
- Projects.Table (Project).Config_File_Name := No_Name;
- Projects.Table (Project).Config_File_Temp := False;
+ The_Packages := Projects.Table (For_Project).Decl.Packages;
+ Compiler :=
+ Prj.Util.Value_Of
+ (Name => Name_Compiler,
+ In_Packages => The_Packages);
+
+ if Compiler /= No_Package then
+ Local_Attribute := Prj.Util.Value_Of
+ (Variable_Name => Name_Local_Configuration_Pragmas,
+ In_Variables => Packages.Table (Compiler).Decl.Attributes);
+ Local_Attribute_Present :=
+ Local_Attribute /= Nil_Variable_Value
+ and then Get_Name_String (Local_Attribute.Value) /= "";
+
+ if Local_Attribute_Present then
+ declare
+ Path : constant String :=
+ Absolute_Path (Local_Attribute.Value, For_Project);
+ begin
+ if not Is_Regular_File (Path) then
+ Make_Failed
+ ("cannot find configuration pragmas file ", Path);
end if;
- end loop;
- end;
+
+ Last := Last + 1;
+ Result (Last) := new String'("-gnatec=" & Path);
+ end;
+ end if;
end if;
- end Compile_Sources;
+
+ return Result (1 .. Last);
+ end Configuration_Pragmas_Switch;
+
+ ---------------
+ -- Debug_Msg --
+ ---------------
+
+ procedure Debug_Msg (S : String; N : Name_Id) is
+ begin
+ if Debug.Debug_Flag_W then
+ Write_Str (" ... ");
+ Write_Str (S);
+ Write_Str (" ");
+ Write_Name (N);
+ Write_Eol;
+ end if;
+ end Debug_Msg;
+
+ ---------------------------
+ -- Delete_All_Temp_Files --
+ ---------------------------
+
+ procedure Delete_All_Temp_Files is
+ begin
+ if Gnatmake_Called and not Debug.Debug_Flag_N then
+ Delete_Mapping_Files;
+ Delete_Temp_Config_Files;
+ Prj.Env.Delete_All_Path_Files;
+ end if;
+ end Delete_All_Temp_Files;
--------------------------
-- Delete_Mapping_Files --
@@ -2501,14 +3057,56 @@ package body Make is
procedure Delete_Mapping_Files is
Success : Boolean;
-
begin
- for Index in 1 .. Last_Mapping_File_Name loop
- Delete_File
- (Name => The_Mapping_File_Names (Index), Success => Success);
- end loop;
+ if not Debug.Debug_Flag_N then
+ if The_Mapping_File_Names /= null then
+ for Project in The_Mapping_File_Names'Range (1) loop
+ for Index in 1 .. Last_Mapping_File_Names (Project) loop
+ Delete_File
+ (Name => Get_Name_String
+ (The_Mapping_File_Names (Project, Index)),
+ Success => Success);
+ end loop;
+ end loop;
+ end if;
+ end if;
end Delete_Mapping_Files;
+ ------------------------------
+ -- Delete_Temp_Config_Files --
+ ------------------------------
+
+ procedure Delete_Temp_Config_Files is
+ Success : Boolean;
+ begin
+ if (not Debug.Debug_Flag_N) and Main_Project /= No_Project then
+ for Project in 1 .. Projects.Last loop
+ if Projects.Table (Project).Config_File_Temp then
+ if Opt.Verbose_Mode then
+ Write_Str ("Deleting temp configuration file """);
+ Write_Str (Get_Name_String
+ (Projects.Table (Project).Config_File_Name));
+ Write_Line ("""");
+ end if;
+
+ Delete_File
+ (Name => Get_Name_String
+ (Projects.Table (Project).Config_File_Name),
+ Success => Success);
+
+ -- Make sure that we don't have a config file for this
+ -- project, in case when there are several mains.
+ -- In this case, we will recreate another config file:
+ -- we cannot reuse the one that we just deleted!
+
+ Projects.Table (Project).Config_Checked := False;
+ Projects.Table (Project).Config_File_Name := No_Name;
+ Projects.Table (Project).Config_File_Temp := False;
+ end if;
+ end loop;
+ end if;
+ end Delete_Temp_Config_Files;
+
-------------
-- Display --
-------------
@@ -2526,12 +3124,36 @@ package body Make is
-- created when using a project file.
if Main_Project = No_Project
- or else Args (J)'Length /= 7 + Temp_File_Name'Length
- or else Args (J)'First /= 1
- or else Args (J)(1 .. 7) /= "-gnatem"
+ or else Debug.Debug_Flag_N
+ or else Args (J)'Length < 8
+ or else
+ Args (J)(Args (J)'First .. Args (J)'First + 6) /= "-gnatem"
then
- Write_Str (" ");
- Write_Str (Args (J).all);
+ -- When -dn is not specified, do not display the config
+ -- pragmas switch (-gnatec) for the temporary file created
+ -- by the project manager (always the first -gnatec switch).
+ -- Reset Temporary_Config_File to False so that the eventual
+ -- other -gnatec switches will be displayed.
+
+ if (not Debug.Debug_Flag_N)
+ and then Temporary_Config_File
+ and then Args (J)'Length > 7
+ and then Args (J)(Args (J)'First .. Args (J)'First + 6)
+ = "-gnatec"
+ then
+ Temporary_Config_File := False;
+
+ -- Do not display the -F=mapping_file switch for gnatbind,
+ -- if -dn is not specified.
+
+ elsif Debug.Debug_Flag_N
+ or else Args (J)'Length < 4
+ or else Args (J)(Args (J)'First .. Args (J)'First + 2) /=
+ "-F="
+ then
+ Write_Str (" ");
+ Write_Str (Args (J).all);
+ end if;
end if;
end loop;
@@ -2571,6 +3193,33 @@ package body Make is
return Q_Front >= Q.Last;
end Empty_Q;
+ --------------------------
+ -- Enter_Into_Obsoleted --
+ --------------------------
+
+ procedure Enter_Into_Obsoleted (F : Name_Id) is
+ Name : String := Get_Name_String (F);
+ First : Natural := Name'Last;
+ F2 : Name_Id := F;
+
+ begin
+ while First > Name'First
+ and then Name (First - 1) /= Directory_Separator
+ and then Name (First - 1) /= '/'
+ loop
+ First := First - 1;
+ end loop;
+
+ if First /= Name'First then
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer (Name (First .. Name'Last));
+ F2 := Name_Find;
+ end if;
+
+ Debug_Msg ("New entry in Obsoleted table:", F2);
+ Obsoleted.Set (F2, True);
+ end Enter_Into_Obsoleted;
+
---------------------
-- Extract_Failure --
---------------------
@@ -2611,6 +3260,16 @@ package body Make is
Source_Unit := Unit;
end Extract_From_Q;
+ -----------------
+ -- Make_Failed --
+ -----------------
+
+ procedure Make_Failed (S1 : String; S2 : String := ""; S3 : String := "") is
+ begin
+ Delete_All_Temp_Files;
+ Osint.Fail (S1, S2, S3);
+ end Make_Failed;
+
--------------
-- Gnatmake --
--------------
@@ -2637,28 +3296,34 @@ package body Make is
-- Non_Std_Executable is set to True when there is a possibility
-- that the linker will not choose the correct executable file name.
- Executable_Obsolete : Boolean := False;
- -- Executable_Obsolete is set to True for the first obsolete main
- -- and is never reset to False. Any subsequent main will always
- -- be rebuild (if we rebuild mains), even in the case when it is not
- -- really necessary, because it is too hard to decide.
-
Current_Work_Dir : constant String_Access :=
new String'(Get_Current_Dir);
-- The current working directory, used to modify some relative path
-- switches on the command line when a project file is used.
begin
+ Gnatmake_Called := True;
+
+ Install_Int_Handler (Sigint_Intercepted'Access);
+
Do_Compile_Step := True;
Do_Bind_Step := True;
Do_Link_Step := True;
+ Obsoleted.Reset;
+
Make.Initialize;
+ Bind_Shared := No_Shared_Switch'Access;
+ Bind_Shared_Known := False;
+
+ Failed_Links.Set_Last (0);
+ Successful_Links.Set_Last (0);
+
if Hostparm.Java_VM then
Gcc := new String'("jgnat");
Gnatbind := new String'("jgnatbind");
- Gnatlink := new String '("jgnatlink");
+ Gnatlink := new String'("jgnatlink");
-- Do not check for an object file (".o") when compiling to
-- Java bytecode since ".class" files are generated instead.
@@ -2666,85 +3331,111 @@ package body Make is
Opt.Check_Object_Consistency := False;
end if;
- if Opt.Verbose_Mode then
- Targparm.Get_Target_Parameters;
+ if Main_Project /= No_Project then
- Write_Eol;
- Write_Str ("GNATMAKE ");
+ -- If the main project file is a library project file, main(s)
+ -- cannot be specified on the command line.
- if Targparm.High_Integrity_Mode_On_Target then
- Write_Str ("Pro High Integrity ");
- end if;
+ if Osint.Number_Of_Files /= 0 then
+ if Projects.Table (Main_Project).Library then
+ Make_Failed ("cannot specify a main program " &
+ "on the command line for a library project file");
+ end if;
- Write_Str (Gnatvsn.Gnat_Version_String);
- Write_Str (" Copyright 1995-2002 Free Software Foundation, Inc.");
- Write_Eol;
- end if;
+ -- If no mains have been specified on the command line,
+ -- and we are using a project file, we either find the main(s)
+ -- in the attribute Main of the main project, or we put all
+ -- the sources of the project file as mains.
- -- If no mains have been specified on the command line,
- -- and we are using a project file, we either find the main(s)
- -- in the attribute Main of the main project, or we put all
- -- the sources of the project file as mains.
+ else
+ declare
+ Value : String_List_Id := Projects.Table (Main_Project).Mains;
- if Main_Project /= No_Project and then Osint.Number_Of_Files = 0 then
- Name_Len := 4;
- Name_Buffer (1 .. 4) := "main";
+ begin
+ -- The attribute Main is an empty list or not specified,
+ -- or else gnatmake was invoked with the switch "-u".
- declare
- Main_Id : constant Name_Id := Name_Find;
+ if Value = Prj.Nil_String or else Unique_Compile then
- Mains : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Variable_Name => Main_Id,
- In_Variables =>
- Projects.Table (Main_Project).Decl.Attributes);
+ if (not Make_Steps) or else Compile_Only
+ or else not Projects.Table (Main_Project).Library
+ then
+ -- First make sure that the binder and the linker
+ -- will not be invoked.
- Value : String_List_Id := Mains.Values;
+ Do_Bind_Step := False;
+ Do_Link_Step := False;
- begin
- -- The attribute Main is an empty list or not specified,
- -- or else gnatmake was invoked with the switch "-u".
+ -- Put all the sources in the queue
- if Value = Prj.Nil_String or else Unique_Compile then
+ Insert_Project_Sources
+ (The_Project => Main_Project,
+ All_Projects => Unique_Compile_All_Projects,
+ Into_Q => False);
- -- First make sure that the binder and the linker
- -- will not be invoked.
+ -- If there are no sources to compile, we fail
- Do_Bind_Step := False;
- Do_Link_Step := False;
+ if Osint.Number_Of_Files = 0 then
+ Make_Failed ("no sources to compile");
+ end if;
+ end if;
- -- Set Unique_Compile if it was not already set
+ else
+ -- The attribute Main is not an empty list.
+ -- Put all the main subprograms in the list as if there
+ -- were specified on the command line.
+
+ while Value /= Prj.Nil_String loop
+ Get_Name_String (String_Elements.Table (Value).Value);
+ Osint.Add_File (Name_Buffer (1 .. Name_Len));
+ Value := String_Elements.Table (Value).Next;
+ end loop;
- Unique_Compile := True;
+ end if;
+ end;
+ end if;
+ end if;
- -- Put all the sources in the queue
+ if Opt.Verbose_Mode then
+ Write_Eol;
+ Write_Str ("GNATMAKE ");
+ Write_Str (Gnatvsn.Gnat_Version_String);
+ Write_Str (" Copyright 1995-2003 Free Software Foundation, Inc.");
+ Write_Eol;
+ end if;
- Insert_Project_Sources
- (The_Project => Main_Project, Into_Q => False);
+ if Osint.Number_Of_Files = 0 then
+ if Main_Project /= No_Project
+ and then Projects.Table (Main_Project).Library
+ then
+ if Do_Bind_Step
+ and then not Projects.Table (Main_Project).Standalone_Library
+ then
+ Make_Failed ("only stand-alone libraries may be bound");
+ end if;
- else
- -- The attribute Main is not an empty list.
- -- Put all the main subprograms in the list as if there were
- -- specified on the command line.
-
- while Value /= Prj.Nil_String loop
- String_To_Name_Buffer (String_Elements.Table (Value).Value);
- Osint.Add_File (Name_Buffer (1 .. Name_Len));
- Value := String_Elements.Table (Value).Next;
- end loop;
+ -- Add the default search directories to be able to find libgnat
- end if;
- end;
+ Osint.Add_Default_Search_Dirs;
- end if;
+ -- And bind and or link the library
- -- Output usage information if no files. Note that this can happen
- -- in the case of a project file that contains only subunits.
+ MLib.Prj.Build_Library
+ (For_Project => Main_Project,
+ Gnatbind => Gnatbind.all,
+ Gnatbind_Path => Gnatbind_Path,
+ Gcc => Gcc.all,
+ Gcc_Path => Gcc_Path,
+ Bind => Bind_Only,
+ Link => Link_Only);
+ Exit_Program (E_Success);
- if Osint.Number_Of_Files = 0 then
- Makeusg;
- Exit_Program (E_Fatal);
+ else
+ -- Output usage information if no files to compile
+ Makeusg;
+ Exit_Program (E_Fatal);
+ end if;
end if;
-- If -M was specified, behave as if -n was specified
@@ -2758,10 +3449,10 @@ package body Make is
Main_Source_File := Next_Main_Source;
- if Project_File_Name = null then
- Add_Switch ("-I-", Compiler, And_Save => True);
- Add_Switch ("-I-", Binder, And_Save => True);
+ Add_Switch ("-I-", Binder, And_Save => True);
+ Add_Switch ("-I-", Compiler, And_Save => True);
+ if Main_Project = No_Project then
if Opt.Look_In_Primary_Dir then
Add_Switch
@@ -2788,10 +3479,32 @@ package body Make is
if Main_Project /= No_Project then
- Change_Dir
- (Get_Name_String (Projects.Table (Main_Project).Object_Directory));
+ if Projects.Table (Main_Project).Object_Directory = No_Name then
+ Make_Failed ("no sources to compile");
+ end if;
+
+ -- Change the current directory to the object directory of the main
+ -- project.
+
+ begin
+ Change_Dir
+ (Get_Name_String
+ (Projects.Table (Main_Project).Object_Directory));
+
+ exception
+ when Directory_Error =>
+ Make_Failed ("unable to change working directory to """,
+ Get_Name_String
+ (Projects.Table (Main_Project).Object_Directory),
+ """");
+ end;
+
+ -- Source file lookups should be cached for efficiency.
+ -- Source files are not supposed to change.
- -- Find the file name of the main unit
+ Osint.Source_File_Data (Cache => True);
+
+ -- Find the file name of the (first) main unit
declare
Main_Source_File_Name : constant String :=
@@ -2799,12 +3512,14 @@ package body Make is
Main_Unit_File_Name : constant String :=
Prj.Env.File_Name_Of_Library_Unit_Body
(Name => Main_Source_File_Name,
- Project => Main_Project);
+ Project => Main_Project,
+ Main_Project_Only =>
+ not Unique_Compile);
The_Packages : constant Package_Id :=
Projects.Table (Main_Project).Decl.Packages;
- Gnatmake : constant Prj.Package_Id :=
+ Builder_Package : constant Prj.Package_Id :=
Prj.Util.Value_Of
(Name => Name_Builder,
In_Packages => The_Packages);
@@ -2817,16 +3532,15 @@ package body Make is
Linker_Package : constant Prj.Package_Id :=
Prj.Util.Value_Of
(Name => Name_Linker,
- In_Packages => The_Packages);
+ In_Packages => The_Packages);
begin
-- We fail if we cannot find the main source file
- -- as an immediate source of the main project file.
if Main_Unit_File_Name = "" then
- Fail ('"' & Main_Source_File_Name &
- """ is not a unit of project " &
- Project_File_Name.all & ".");
+ Make_Failed ('"' & Main_Source_File_Name,
+ """ is not a unit of project ",
+ Project_File_Name.all & ".");
else
-- Remove any directory information from the main
-- source file name.
@@ -2860,11 +3574,10 @@ package body Make is
end;
end if;
- -- If there is a package gnatmake in the main project file, add
- -- the switches from it. We also add the switches from packages
- -- gnatbind and gnatlink, if any.
+ -- If there is a package Builder in the main project file, add
+ -- the switches from it.
- if Gnatmake /= No_Package then
+ if Builder_Package /= No_Package then
-- If there is only one main, we attempt to get the gnatmake
-- switches for this main (if any). If there are no specific
@@ -2880,130 +3593,231 @@ package body Make is
Add_Switches
(File_Name => Main_Unit_File_Name,
- The_Package => Gnatmake,
+ The_Package => Builder_Package,
Program => None);
else
-- If there are several mains, we always get the general
-- gnatmake switches (if any).
- -- Note: As there is never a source with name " ",
- -- we are guaranteed to always get the gneneral switches.
+ -- Warn the user, if necessary, so that he is not surprized
+ -- that specific switches are not taken into account.
- Add_Switches
- (File_Name => " ",
- The_Package => Gnatmake,
- Program => None);
- end if;
+ declare
+ Defaults : constant Variable_Value :=
+ Prj.Util.Value_Of
+ (Name => Name_Ada,
+ Attribute_Or_Array_Name => Name_Default_Switches,
+ In_Package => Builder_Package);
+
+ Switches : constant Array_Element_Id :=
+ Prj.Util.Value_Of
+ (Name => Name_Switches,
+ In_Arrays =>
+ Packages.Table (Builder_Package).Decl.Arrays);
+
+ begin
+ if Defaults /= Nil_Variable_Value then
+ if (not Opt.Quiet_Output)
+ and then Switches /= No_Array_Element
+ then
+ Write_Line
+ ("Warning: using Builder'Default_Switches" &
+ "(""Ada""), as there are several mains");
+ end if;
+ -- As there is never a source with name " ", we are
+ -- guaranteed to always get the general switches.
+
+ Add_Switches
+ (File_Name => " ",
+ The_Package => Builder_Package,
+ Program => None);
+
+ elsif (not Opt.Quiet_Output)
+ and then Switches /= No_Array_Element
+ then
+ Write_Line
+ ("Warning: using no switches from package Builder," &
+ " as there are several mains");
+ end if;
+ end;
+ end if;
end if;
- if Binder_Package /= No_Package then
+ Osint.Add_Default_Search_Dirs;
- -- If there is only one main, we attempt to get the gnatbind
- -- switches for this main (if any). If there are no specific
- -- switch for this particular main, get the general gnatbind
- -- switches (if any).
+ -- Record the current last switch index for table Binder_Switches
+ -- and Linker_Switches, so that these tables may be reset before
+ -- for each main, before adding swiches from the project file
+ -- and from the command line.
- if Osint.Number_Of_Files = 1 then
- if Opt.Verbose_Mode then
- Write_Str ("Adding binder switches for """);
- Write_Str (Main_Unit_File_Name);
- Write_Line (""".");
- end if;
+ Last_Binder_Switch := Binder_Switches.Last;
+ Last_Linker_Switch := Linker_Switches.Last;
- Add_Switches
- (File_Name => Main_Unit_File_Name,
- The_Package => Binder_Package,
- Program => Binder);
+ Check_Steps;
- else
- -- If there are several mains, we always get the general
- -- gnatbind switches (if any).
+ -- Add binder switches from the project file for the first main
- -- Note: As there is never a source with name " ",
- -- we are guaranteed to always get the gneneral switches.
+ if Do_Bind_Step and Binder_Package /= No_Package then
+ if Opt.Verbose_Mode then
+ Write_Str ("Adding binder switches for """);
+ Write_Str (Main_Unit_File_Name);
+ Write_Line (""".");
+ end if;
- Add_Switches
- (File_Name => " ",
- The_Package => Binder_Package,
- Program => Binder);
+ Add_Switches
+ (File_Name => Main_Unit_File_Name,
+ The_Package => Binder_Package,
+ Program => Binder);
+ end if;
+
+ -- Add linker switches from the project file for the first main
+
+ if Do_Link_Step and Linker_Package /= No_Package then
+ if Opt.Verbose_Mode then
+ Write_Str ("Adding linker switches for""");
+ Write_Str (Main_Unit_File_Name);
+ Write_Line (""".");
end if;
+ Add_Switches
+ (File_Name => Main_Unit_File_Name,
+ The_Package => Linker_Package,
+ Program => Linker);
end if;
+ end;
+ end if;
- if Linker_Package /= No_Package then
+ -- Get the target parameters, which are only needed for a couple of
+ -- cases in gnatmake. Protect against an exception, such as the case
+ -- of system.ads missing from the library, and fail gracefully.
- -- If there is only one main, we attempt to get the
- -- gnatlink switches for this main (if any). If there are
- -- no specific switch for this particular main, we get the
- -- general gnatlink switches (if any).
+ begin
+ Targparm.Get_Target_Parameters;
- if Osint.Number_Of_Files = 1 then
- if Opt.Verbose_Mode then
- Write_Str ("Adding linker switches for""");
- Write_Str (Main_Unit_File_Name);
- Write_Line (""".");
- end if;
+ exception
+ when Unrecoverable_Error =>
+ Make_Failed ("*** make failed.");
+ end;
- Add_Switches
- (File_Name => Main_Unit_File_Name,
- The_Package => Linker_Package,
- Program => Linker);
+ Display_Commands (not Opt.Quiet_Output);
- else
- -- If there are several mains, we always get the general
- -- gnatlink switches (if any).
+ Check_Steps;
- -- Note: As there is never a source with name " ",
- -- we are guaranteed to always get the general switches.
+ if Main_Project /= No_Project then
- Add_Switches
- (File_Name => " ",
- The_Package => Linker_Package,
- Program => Linker);
+ -- For all library project, if the library file does not exist
+ -- put all the project sources in the queue, and flag the project
+ -- so that the library is generated.
+
+ if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then
+ for Proj in Projects.First .. Projects.Last loop
+ if Projects.Table (Proj).Library then
+ Projects.Table (Proj).Flag1 :=
+ not MLib.Tgt.Library_Exists_For (Proj);
+
+ if Projects.Table (Proj).Flag1 then
+ if Opt.Verbose_Mode then
+ Write_Str
+ ("Library file does not exist for project """);
+ Write_Str
+ (Get_Name_String (Projects.Table (Proj).Name));
+ Write_Line ("""");
+ end if;
+
+ Insert_Project_Sources
+ (The_Project => Proj,
+ All_Projects => False,
+ Into_Q => True);
+ end if;
end if;
- end if;
- end;
- end if;
+ end loop;
+ end if;
- Display_Commands (not Opt.Quiet_Output);
+ -- If a relative path output file has been specified, we add
+ -- the exec directory.
- -- If we are using a project file, relative paths are forbidden in the
- -- project file, but we add the current working directory for any
- -- relative path on the command line.
+ for J in reverse 1 .. Saved_Linker_Switches.Last - 1 loop
+ if Saved_Linker_Switches.Table (J).all = Output_Flag.all then
+ declare
+ Exec_File_Name : constant String :=
+ Saved_Linker_Switches.Table (J + 1).all;
- if Main_Project /= No_Project then
+ begin
+ if not Is_Absolute_Path (Exec_File_Name) then
+ for Index in Exec_File_Name'Range loop
+ if Exec_File_Name (Index) = Directory_Separator then
+ Make_Failed ("relative executable (""",
+ Exec_File_Name,
+ """) with directory part not " &
+ "allowed when using project files");
+ end if;
+ end loop;
- for J in 1 .. Binder_Switches.Last loop
- Test_If_Relative_Path
- (Binder_Switches.Table (J), Parent => null);
- end loop;
+ Get_Name_String (Projects.Table
+ (Main_Project).Exec_Directory);
- for J in 1 .. Saved_Binder_Switches.Last loop
- Test_If_Relative_Path
- (Saved_Binder_Switches.Table (J), Parent => Current_Work_Dir);
- end loop;
+ if Name_Buffer (Name_Len) /= Directory_Separator then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Directory_Separator;
+ end if;
- for J in 1 .. Linker_Switches.Last loop
- Test_If_Relative_Path
- (Linker_Switches.Table (J), Parent => null);
- end loop;
+ Name_Buffer (Name_Len + 1 ..
+ Name_Len + Exec_File_Name'Length) :=
+ Exec_File_Name;
+ Name_Len := Name_Len + Exec_File_Name'Length;
+ Saved_Linker_Switches.Table (J + 1) :=
+ new String'(Name_Buffer (1 .. Name_Len));
+ end if;
+ end;
- for J in 1 .. Saved_Linker_Switches.Last loop
- Test_If_Relative_Path
- (Saved_Linker_Switches.Table (J), Parent => Current_Work_Dir);
+ exit;
+ end if;
end loop;
- for J in 1 .. Gcc_Switches.Last loop
- Test_If_Relative_Path
- (Gcc_Switches.Table (J), Parent => null);
- end loop;
+ -- If we are using a project file, for relative paths we add the
+ -- current working directory for any relative path on the command
+ -- line and the project directory, for any relative path in the
+ -- project file.
- for J in 1 .. Saved_Gcc_Switches.Last loop
- Test_If_Relative_Path
- (Saved_Gcc_Switches.Table (J), Parent => Current_Work_Dir);
- end loop;
+ declare
+ Dir_Path : constant String_Access :=
+ new String'(Get_Name_String
+ (Projects.Table (Main_Project).Directory));
+ begin
+ for J in 1 .. Binder_Switches.Last loop
+ Test_If_Relative_Path
+ (Binder_Switches.Table (J),
+ Parent => Dir_Path, Including_L_Switch => False);
+ end loop;
+
+ for J in 1 .. Saved_Binder_Switches.Last loop
+ Test_If_Relative_Path
+ (Saved_Binder_Switches.Table (J),
+ Parent => Current_Work_Dir, Including_L_Switch => False);
+ end loop;
+
+ for J in 1 .. Linker_Switches.Last loop
+ Test_If_Relative_Path
+ (Linker_Switches.Table (J), Parent => Dir_Path);
+ end loop;
+
+ for J in 1 .. Saved_Linker_Switches.Last loop
+ Test_If_Relative_Path
+ (Saved_Linker_Switches.Table (J), Parent => Current_Work_Dir);
+ end loop;
+
+ for J in 1 .. Gcc_Switches.Last loop
+ Test_If_Relative_Path
+ (Gcc_Switches.Table (J), Parent => Dir_Path);
+ end loop;
+
+ for J in 1 .. Saved_Gcc_Switches.Last loop
+ Test_If_Relative_Path
+ (Saved_Gcc_Switches.Table (J), Parent => Current_Work_Dir);
+ end loop;
+ end;
end if;
-- We now put in the Binder_Switches and Linker_Switches tables,
@@ -3084,25 +3898,19 @@ package body Make is
end if;
-- Allocate as many temporary mapping file names as the maximum
- -- number of compilation processed.
+ -- number of compilation processed, for each possible project.
The_Mapping_File_Names :=
- new Temp_File_Names (1 .. Saved_Maximum_Processes);
-
- -- If either -c, -b or -l has been specified, we will not necessarily
- -- execute all steps.
-
- if Compile_Only or else Bind_Only or else Link_Only then
- Do_Compile_Step := Do_Compile_Step and Compile_Only;
- Do_Bind_Step := Do_Bind_Step and Bind_Only;
- Do_Link_Step := Do_Link_Step and Link_Only;
-
- -- If -c has been specified, but not -b, ignore any potential -l
+ new Temp_File_Names
+ (No_Project .. Projects.Last, 1 .. Saved_Maximum_Processes);
+ Last_Mapping_File_Names :=
+ new Indices'(No_Project .. Projects.Last => 0);
- if Do_Compile_Step and then not Do_Bind_Step then
- Do_Link_Step := False;
- end if;
- end if;
+ The_Free_Mapping_File_Indices :=
+ new Free_File_Indices
+ (No_Project .. Projects.Last, 1 .. Saved_Maximum_Processes);
+ Last_Free_Indices :=
+ new Indices'(No_Project .. Projects.Last => 0);
Bad_Compilation.Init;
@@ -3112,168 +3920,147 @@ package body Make is
Multiple_Main_Loop : for N_File in 1 .. Osint.Number_Of_Files loop
- if Do_Compile_Step then
- Recursive_Compilation_Step : declare
- Args : Argument_List (1 .. Gcc_Switches.Last);
+ -- First, find the executable name and path
- First_Compiled_File : Name_Id;
+ Executable := No_File;
+ Executable_Obsolete := False;
+ Non_Std_Executable := False;
- Youngest_Obj_File : Name_Id;
- Youngest_Obj_Stamp : Time_Stamp_Type;
+ -- Look inside the linker switches to see if the name
+ -- of the final executable program was specified.
- Executable_Stamp : Time_Stamp_Type;
- -- Executable is the final executable program.
-
- begin
- Executable := No_File;
- Non_Std_Executable := False;
+ for
+ J in reverse Linker_Switches.First .. Linker_Switches.Last
+ loop
+ if Linker_Switches.Table (J).all = Output_Flag.all then
+ pragma Assert (J < Linker_Switches.Last);
- for J in 1 .. Gcc_Switches.Last loop
- Args (J) := Gcc_Switches.Table (J);
- end loop;
+ -- We cannot specify a single executable for several
+ -- main subprograms!
- -- Look inside the linker switches to see if the name
- -- of the final executable program was specified.
+ if Osint.Number_Of_Files > 1 then
+ Fail
+ ("cannot specify a single executable " &
+ "for several mains");
+ end if;
- for
- J in reverse Linker_Switches.First .. Linker_Switches.Last
- loop
- if Linker_Switches.Table (J).all = Output_Flag.all then
- pragma Assert (J < Linker_Switches.Last);
+ Name_Len := Linker_Switches.Table (J + 1)'Length;
+ Name_Buffer (1 .. Name_Len) :=
+ Linker_Switches.Table (J + 1).all;
- -- We cannot specify a single executable for several
- -- main subprograms!
+ -- Put in canonical case to detect suffixs such as ".EXE" on
+ -- Windows or VMS.
- if Osint.Number_Of_Files > 1 then
- Fail
- ("cannot specify a single executable " &
- "for several mains");
- end if;
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Name_Len := Linker_Switches.Table (J + 1)'Length;
- Name_Buffer (1 .. Name_Len) :=
- Linker_Switches.Table (J + 1).all;
+ -- If target has an executable suffix and it has not been
+ -- specified then it is added here.
- -- If target has an executable suffix and it has not been
- -- specified then it is added here.
+ if Executable_Suffix'Length /= 0
+ and then Name_Buffer
+ (Name_Len - Executable_Suffix'Length + 1 .. Name_Len)
+ /= Executable_Suffix
+ then
+ -- Get back the original name to keep the case on Windows
- if Executable_Suffix'Length /= 0
- and then Linker_Switches.Table (J + 1)
- (Name_Len - Executable_Suffix'Length + 1
- .. Name_Len) /= Executable_Suffix
- then
- Name_Buffer (Name_Len + 1 ..
- Name_Len + Executable_Suffix'Length) :=
- Executable_Suffix;
- Name_Len := Name_Len + Executable_Suffix'Length;
- end if;
+ Name_Buffer (1 .. Name_Len) :=
+ Linker_Switches.Table (J + 1).all;
- Executable := Name_Enter;
+ -- Add the executable suffix
- Verbose_Msg (Executable, "final executable");
- end if;
- end loop;
+ Name_Buffer (Name_Len + 1 ..
+ Name_Len + Executable_Suffix'Length) :=
+ Executable_Suffix;
+ Name_Len := Name_Len + Executable_Suffix'Length;
- -- If the name of the final executable program was not
- -- specified then construct it from the main input file.
+ else
+ -- Get back the original name to keep the case on Windows
- if Executable = No_File then
- if Main_Project = No_Project then
- Executable :=
- Executable_Name (Strip_Suffix (Main_Source_File));
+ Name_Buffer (1 .. Name_Len) :=
+ Linker_Switches.Table (J + 1).all;
+ end if;
- else
- -- If we are using a project file, we attempt to
- -- remove the body (or spec) termination of the main
- -- subprogram. We find it the the naming scheme of the
- -- project file. This will avoid to generate an
- -- executable "main.2" for a main subprogram
- -- "main.2.ada", when the body termination is ".2.ada".
+ Executable := Name_Enter;
- declare
- Body_Append : constant String :=
- Get_Name_String
- (Projects.Table
- (Main_Project).
- Naming.Current_Impl_Suffix);
-
- Spec_Append : constant String :=
- Get_Name_String
- (Projects.Table
- (Main_Project).
- Naming.Current_Spec_Suffix);
+ Verbose_Msg (Executable, "final executable");
+ end if;
+ end loop;
- begin
- Get_Name_String (Main_Source_File);
+ -- If the name of the final executable program was not
+ -- specified then construct it from the main input file.
- if Name_Len > Body_Append'Length
- and then Name_Buffer
- (Name_Len - Body_Append'Length + 1 .. Name_Len) =
- Body_Append
- then
- -- We have found the body termination. We remove it
- -- add the executable termination, if any.
+ if Executable = No_File then
+ if Main_Project = No_Project then
+ Executable :=
+ Executable_Name (Strip_Suffix (Main_Source_File));
- Name_Len := Name_Len - Body_Append'Length;
- Executable := Executable_Name (Name_Find);
+ else
+ -- If we are using a project file, we attempt to
+ -- remove the body (or spec) termination of the main
+ -- subprogram. We find it the the naming scheme of the
+ -- project file. This will avoid to generate an
+ -- executable "main.2" for a main subprogram
+ -- "main.2.ada", when the body termination is ".2.ada".
+
+ Executable := Prj.Util.Executable_Of
+ (Main_Project, Main_Source_File);
+ end if;
+ end if;
- elsif Name_Len > Spec_Append'Length
- and then
- Name_Buffer
- (Name_Len - Spec_Append'Length + 1 .. Name_Len) =
- Spec_Append
- then
- -- We have found the spec termination. We remove
- -- it, add the executable termination, if any.
+ if Main_Project /= No_Project then
+ declare
+ Exec_File_Name : constant String :=
+ Get_Name_String (Executable);
- Name_Len := Name_Len - Spec_Append'Length;
- Executable := Executable_Name (Name_Find);
+ begin
+ if not Is_Absolute_Path (Exec_File_Name) then
+ for Index in Exec_File_Name'Range loop
+ if Exec_File_Name (Index) = Directory_Separator then
+ Make_Failed ("relative executable (""",
+ Exec_File_Name,
+ """) with directory part not " &
+ "allowed when using project files");
+ end if;
+ end loop;
- else
- Executable :=
- Executable_Name (Strip_Suffix (Main_Source_File));
- end if;
+ Get_Name_String (Projects.Table
+ (Main_Project).Exec_Directory);
- end;
+ if
+ Name_Buffer (Name_Len) /= Directory_Separator
+ then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Directory_Separator;
end if;
+
+ Name_Buffer (Name_Len + 1 ..
+ Name_Len + Exec_File_Name'Length) :=
+ Exec_File_Name;
+ Name_Len := Name_Len + Exec_File_Name'Length;
+ Executable := Name_Find;
+ Non_Std_Executable := True;
end if;
+ end;
- if Main_Project /= No_Project then
- declare
- Exec_File_Name : constant String :=
- Get_Name_String (Executable);
+ end if;
- begin
- if not Is_Absolute_Path (Exec_File_Name) then
- for Index in Exec_File_Name'Range loop
- if Exec_File_Name (Index) = Directory_Separator then
- Fail ("relative executable (""" &
- Exec_File_Name &
- """) with directory part not allowed " &
- "when using project files");
- end if;
- end loop;
+ if Do_Compile_Step then
+ Recursive_Compilation_Step : declare
+ Args : Argument_List (1 .. Gcc_Switches.Last);
- Get_Name_String (Projects.Table
- (Main_Project).Exec_Directory);
+ First_Compiled_File : Name_Id;
+ Youngest_Obj_File : Name_Id;
+ Youngest_Obj_Stamp : Time_Stamp_Type;
- if
- Name_Buffer (Name_Len) /= Directory_Separator
- then
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Directory_Separator;
- end if;
+ Executable_Stamp : Time_Stamp_Type;
+ -- Executable is the final executable program.
- Name_Buffer (Name_Len + 1 ..
- Name_Len + Exec_File_Name'Length) :=
- Exec_File_Name;
- Name_Len := Name_Len + Exec_File_Name'Length;
- Executable := Name_Find;
- Non_Std_Executable := True;
- end if;
- end;
+ Library_Rebuilt : Boolean := False;
- end if;
+ begin
+ for J in 1 .. Gcc_Switches.Last loop
+ Args (J) := Gcc_Switches.Table (J);
+ end loop;
-- Now we invoke Compile_Sources for the current main
@@ -3298,6 +4085,10 @@ package body Make is
Write_Eol;
end if;
+ -- Make sure the queue will be reinitialized for the next round
+
+ First_Q_Initialization := True;
+
Total_Compilation_Failures :=
Total_Compilation_Failures + Compilation_Failures;
@@ -3311,23 +4102,67 @@ package body Make is
end if;
end if;
- -- Regenerate libraries, if any and if object files
- -- have been regenerated
+ -- Regenerate libraries, if any, and if object files
+ -- have been regenerated.
if Main_Project /= No_Project
- and then MLib.Tgt.Libraries_Are_Supported
+ and then MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None
+ and then (Do_Bind_Step or Unique_Compile_All_Projects
+ or not Compile_Only)
+ and then (Do_Link_Step or N_File = Osint.Number_Of_Files)
then
+ Library_Projs.Init;
- for Proj in Projects.First .. Projects.Last loop
+ declare
+ Proj2 : Project_Id;
+ Depth : Natural;
+ Current : Natural;
- if Proj /= Main_Project
- and then Projects.Table (Proj).Flag1
- then
- MLib.Prj.Build_Library (For_Project => Proj);
- end if;
+ begin
+ -- Put in Library_Projs table all library project
+ -- file ids when the library need to be rebuilt.
- end loop;
+ for Proj1 in Projects.First .. Projects.Last loop
+ if Projects.Table (Proj1).Library
+ and then not Projects.Table (Proj1).Flag1
+ then
+ MLib.Prj.Check_Library (Proj1);
+ end if;
+
+ if Projects.Table (Proj1).Flag1 then
+ Library_Projs.Increment_Last;
+ Current := Library_Projs.Last;
+ Depth := Projects.Table (Proj1).Depth;
+
+ -- Put the projects in decreasing depth order,
+ -- so that if libA depends on libB, libB is first
+ -- in order.
+
+ while Current > 1 loop
+ Proj2 := Library_Projs.Table (Current - 1);
+ exit when Projects.Table (Proj2).Depth >= Depth;
+ Library_Projs.Table (Current) := Proj2;
+ Current := Current - 1;
+ end loop;
+
+ Library_Projs.Table (Current) := Proj1;
+ Projects.Table (Proj1).Flag1 := False;
+ end if;
+ end loop;
+ end;
+
+ -- Build the libraries, if any need to be built
+
+ for J in 1 .. Library_Projs.Last loop
+ Library_Rebuilt := True;
+ MLib.Prj.Build_Library
+ (For_Project => Library_Projs.Table (J),
+ Gnatbind => Gnatbind.all,
+ Gnatbind_Path => Gnatbind_Path,
+ Gcc => Gcc.all,
+ Gcc_Path => Gcc_Path);
+ end loop;
end if;
if Opt.List_Dependencies then
@@ -3342,13 +4177,10 @@ package body Make is
elsif First_Compiled_File = No_File
and then not Do_Bind_Step
and then not Opt.Quiet_Output
+ and then not Library_Rebuilt
and then Osint.Number_Of_Files = 1
then
- if Unique_Compile then
- Inform (Msg => "object up to date.");
- else
- Inform (Msg => "objects up to date.");
- end if;
+ Inform (Msg => "objects up to date.");
elsif Opt.Do_Not_Execute
and then First_Compiled_File /= No_File
@@ -3392,13 +4224,24 @@ package body Make is
then
Executable_Stamp := File_Stamp (Executable);
- -- Once Executable_Obsolete is set to True, it is never
- -- reset to False, because it is too hard to accurately
- -- decide if a subsequent main need to be rebuilt or not.
+ if not Executable_Obsolete then
+ Executable_Obsolete :=
+ Youngest_Obj_Stamp > Executable_Stamp;
+ end if;
+
+ if not Executable_Obsolete then
+ for Index in reverse 1 .. Dependencies.Last loop
+ if Is_In_Obsoleted
+ (Dependencies.Table (Index).Depends_On)
+ then
+ Enter_Into_Obsoleted
+ (Dependencies.Table (Index).This);
+ end if;
+ end loop;
- Executable_Obsolete :=
- Executable_Obsolete
- or else Youngest_Obj_Stamp > Executable_Stamp;
+ Executable_Obsolete := Is_In_Obsoleted (Main_Source_File);
+ Dependencies.Init;
+ end if;
if not Executable_Obsolete then
@@ -3459,10 +4302,7 @@ package body Make is
-- main. So we set Executable_Obsolete to True to make sure that
-- the subsequent mains will be rebuilt.
- Executable_Obsolete := True;
-
- Main_ALI_In_Place_Mode_Step :
- declare
+ Main_ALI_In_Place_Mode_Step : declare
ALI_File : File_Name_Type;
Src_File : File_Name_Type;
@@ -3484,20 +4324,65 @@ package body Make is
end if;
if Main_ALI_File = No_File then
- Fail ("could not find the main ALI file");
+ Make_Failed ("could not find the main ALI file");
end if;
-
end Main_ALI_In_Place_Mode_Step;
if Do_Bind_Step then
Bind_Step : declare
Args : Argument_List
- (Binder_Switches.First .. Binder_Switches.Last);
+ (Binder_Switches.First .. Binder_Switches.Last + 1);
+ -- The arguments for the invocation of gnatbind
+
+ Last_Arg : Natural := Binder_Switches.Last;
+ -- Index of the last argument in Args
+
+ Mapping_FD : File_Descriptor := Invalid_FD;
+ -- A File Descriptor for an eventual mapping file
+
+ Mapping_Path : Name_Id := No_Name;
+ -- The path name of the mapping file
+
+ ALI_Unit : Name_Id := No_Name;
+ -- The unit name of an ALI file
+
+ ALI_Name : Name_Id := No_Name;
+ -- The file name of the ALI file
+
+ ALI_Project : Project_Id := No_Project;
+ -- The project of the ALI file
+
+ Bytes : Integer;
+ OK : Boolean := True;
+
+ Status : Boolean;
+ -- For call to Close
begin
+ -- If it is the first time the bind step is performed,
+ -- check if there are shared libraries, so that gnatbind is
+ -- called with -shared.
+
+ if not Bind_Shared_Known then
+ if Main_Project /= No_Project
+ and then MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None
+ then
+ for Proj in Projects.First .. Projects.Last loop
+ if Projects.Table (Proj).Library and then
+ Projects.Table (Proj).Library_Kind /= Static
+ then
+ Bind_Shared := Shared_Switch'Access;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ Bind_Shared_Known := True;
+ end if;
+
-- Get all the binder switches
- for J in Binder_Switches.First .. Binder_Switches.Last loop
+ for J in Binder_Switches.First .. Last_Arg loop
Args (J) := Binder_Switches.Table (J);
end loop;
@@ -3506,57 +4391,454 @@ package body Make is
-- Put all the source directories in ADA_INCLUDE_PATH,
-- and all the object directories in ADA_OBJECTS_PATH
- Set_Ada_Paths (Main_Project, False);
+ Prj.Env.Set_Ada_Paths (Main_Project, False);
+
+ -- If switch -C was specified, create a binder mapping file
+
+ if Create_Mapping_File then
+ Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path);
+
+ if Mapping_FD /= Invalid_FD then
+
+ -- Traverse all units
+
+ for J in Prj.Com.Units.First .. Prj.Com.Units.Last loop
+ declare
+ Unit : constant Prj.Com.Unit_Data :=
+ Prj.Com.Units.Table (J);
+ use Prj.Com;
+
+ begin
+ if Unit.Name /= No_Name then
+
+ -- If there is a body, put it in the mapping
+
+ if Unit.File_Names (Body_Part).Name /= No_Name
+ and then Unit.File_Names (Body_Part).Project
+ /= No_Project
+ then
+ Get_Name_String (Unit.Name);
+ Name_Buffer
+ (Name_Len + 1 .. Name_Len + 2) := "%b";
+ Name_Len := Name_Len + 2;
+ ALI_Unit := Name_Find;
+ ALI_Name :=
+ Lib_File_Name
+ (Unit.File_Names (Body_Part).Name);
+ ALI_Project :=
+ Unit.File_Names (Body_Part).Project;
+
+ -- Otherwise, if there is a spec, put it
+ -- in the mapping.
+
+ elsif Unit.File_Names (Specification).Name
+ /= No_Name
+ and then Unit.File_Names
+ (Specification).Project
+ /= No_Project
+ then
+ Get_Name_String (Unit.Name);
+ Name_Buffer
+ (Name_Len + 1 .. Name_Len + 2) := "%s";
+ Name_Len := Name_Len + 2;
+ ALI_Unit := Name_Find;
+ ALI_Name := Lib_File_Name
+ (Unit.File_Names (Specification).Name);
+ ALI_Project :=
+ Unit.File_Names (Specification).Project;
+
+ else
+ ALI_Name := No_Name;
+ end if;
+
+ -- If we have something to put in the mapping
+ -- then we do it now. However, if the project
+ -- is extended, we don't put anything in the
+ -- mapping file, because we do not know where
+ -- the ALI file is: it might be in the ext-
+ -- ended project obj dir as well as in the
+ -- extending project obj dir.
+
+ if ALI_Name /= No_Name
+ and then Projects.Table
+ (ALI_Project).Extended_By
+ = No_Project
+ and then Projects.Table
+ (ALI_Project).Extends
+ = No_Project
+ then
+ -- First line is the unit name
+
+ Get_Name_String (ALI_Unit);
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := ASCII.LF;
+ Bytes :=
+ Write
+ (Mapping_FD,
+ Name_Buffer (1)'Address,
+ Name_Len);
+ OK := Bytes = Name_Len;
+
+ if OK then
+
+ -- Second line it the ALI file name
+
+ Get_Name_String (ALI_Name);
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := ASCII.LF;
+ Bytes :=
+ Write
+ (Mapping_FD,
+ Name_Buffer (1)'Address,
+ Name_Len);
+ OK := Bytes = Name_Len;
+ end if;
+
+ if OK then
+
+ -- Third line it the ALI path name,
+ -- concatenation of the project
+ -- directory with the ALI file name.
+
+ declare
+ ALI : constant String :=
+ Get_Name_String (ALI_Name);
+ begin
+ Get_Name_String
+ (Projects.Table (ALI_Project).
+ Object_Directory);
+
+ if Name_Buffer (Name_Len) /=
+ Directory_Separator
+ then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) :=
+ Directory_Separator;
+ end if;
+
+ Name_Buffer
+ (Name_Len + 1 ..
+ Name_Len + ALI'Length) := ALI;
+ Name_Len :=
+ Name_Len + ALI'Length + 1;
+ Name_Buffer (Name_Len) := ASCII.LF;
+ Bytes :=
+ Write
+ (Mapping_FD,
+ Name_Buffer (1)'Address,
+ Name_Len);
+ OK := Bytes = Name_Len;
+ end;
+ end if;
+
+ -- If OK is False, it means we were unable
+ -- to write a line. No point in continuing
+ -- with the other units.
+
+ exit when not OK;
+ end if;
+ end if;
+ end;
+ end loop;
+
+ Close (Mapping_FD, Status);
+
+ OK := OK and Status;
+
+ -- If the creation of the mapping file was successful,
+ -- we add the switch to the arguments of gnatbind.
+
+ if OK then
+ Last_Arg := Last_Arg + 1;
+ Args (Last_Arg) := new String'
+ ("-F=" & Get_Name_String (Mapping_Path));
+ end if;
+ end if;
+ end if;
+
end if;
- Bind (Main_ALI_File, Args);
+ begin
+ Bind (Main_ALI_File,
+ Bind_Shared.all & Args (Args'First .. Last_Arg));
+
+ exception
+ when others =>
+
+ -- If -dn was not specified, delete the temporary mapping
+ -- file, if one was created.
+
+ if not Debug.Debug_Flag_N
+ and then Mapping_Path /= No_Name
+ then
+ Delete_File (Get_Name_String (Mapping_Path), OK);
+ end if;
+
+ -- And reraise the exception
+
+ raise;
+ end;
+
+ -- If -dn was not specified, delete the temporary mapping file,
+ -- if one was created.
+
+ if not Debug.Debug_Flag_N and then Mapping_Path /= No_Name then
+ Delete_File (Get_Name_String (Mapping_Path), OK);
+ end if;
end Bind_Step;
end if;
if Do_Link_Step then
-
Link_Step : declare
There_Are_Libraries : Boolean := False;
Linker_Switches_Last : constant Integer := Linker_Switches.Last;
+ Path_Option : constant String_Access :=
+ MLib.Tgt.Linker_Library_Path_Option;
+ Current : Natural;
+ Proj2 : Project_Id;
+ Depth : Natural;
begin
+ if not Run_Path_Option then
+ Linker_Switches.Increment_Last;
+ Linker_Switches.Table (Linker_Switches.Last) :=
+ new String'("-R");
+ end if;
+
if Main_Project /= No_Project then
+ Library_Paths.Set_Last (0);
+ Library_Projs.Init;
+
+ if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then
+ -- Check for library projects
+
+ for Proj1 in 1 .. Projects.Last loop
+ if Proj1 /= Main_Project
+ and then Projects.Table (Proj1).Library
+ then
+ -- Add this project to table Library_Projs
+
+ There_Are_Libraries := True;
+ Depth := Projects.Table (Proj1).Depth;
+ Library_Projs.Increment_Last;
+ Current := Library_Projs.Last;
+
+ -- Any project with a greater depth should be
+ -- after this project in the list.
+
+ while Current > 1 loop
+ Proj2 := Library_Projs.Table (Current - 1);
+ exit when Projects.Table (Proj2).Depth <= Depth;
+ Library_Projs.Table (Current) := Proj2;
+ Current := Current - 1;
+ end loop;
- if MLib.Tgt.Libraries_Are_Supported then
- Set_Libraries (Main_Project, There_Are_Libraries);
+ Library_Projs.Table (Current) := Proj1;
+
+ -- If it is not a static library and path option
+ -- is set, add it to the Library_Paths table.
+
+ if Projects.Table (Proj1).Library_Kind /= Static
+ and then Path_Option /= null
+ then
+ Library_Paths.Increment_Last;
+ Library_Paths.Table (Library_Paths.Last) :=
+ new String'
+ (Get_Name_String
+ (Projects.Table (Proj1).Library_Dir));
+ end if;
+ end if;
+ end loop;
+
+ for Index in 1 .. Library_Projs.Last loop
+ -- Add the -L switch
+
+ Linker_Switches.Increment_Last;
+ Linker_Switches.Table (Linker_Switches.Last) :=
+ new String'("-L" &
+ Get_Name_String
+ (Projects.Table
+ (Library_Projs.Table (Index)).
+ Library_Dir));
+
+ -- Add the -l switch
+
+ Linker_Switches.Increment_Last;
+ Linker_Switches.Table (Linker_Switches.Last) :=
+ new String'("-l" &
+ Get_Name_String
+ (Projects.Table
+ (Library_Projs.Table (Index)).
+ Library_Name));
+ end loop;
end if;
if There_Are_Libraries then
- -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
+ -- If Path_Option is not null, create the switch
+ -- ("-Wl,-rpath," or equivalent) with all the non static
+ -- library dirs plus the standard GNAT library dir.
+ -- We do that only if Run_Path_Option is True
+ -- (not disabled by -R switch).
- Linker_Switches.Increment_Last;
- Linker_Switches.Table (Linker_Switches.Last) :=
- new String'("-L" & MLib.Utl.Lib_Directory);
- Linker_Switches.Increment_Last;
- Linker_Switches.Table (Linker_Switches.Last) :=
- new String'("-lgnarl");
- Linker_Switches.Increment_Last;
- Linker_Switches.Table (Linker_Switches.Last) :=
- new String'("-lgnat");
+ if Run_Path_Option and Path_Option /= null then
+ declare
+ Option : String_Access;
+ Length : Natural := Path_Option'Length;
+ Current : Natural;
- declare
- Option : constant String_Access :=
- MLib.Tgt.Linker_Library_Path_Option
- (MLib.Utl.Lib_Directory);
+ begin
+ for Index in
+ Library_Paths.First .. Library_Paths.Last
+ loop
+ -- Add the length of the library dir plus one
+ -- for the directory separator.
+
+ Length :=
+ Length +
+ Library_Paths.Table (Index)'Length + 1;
+ end loop;
+
+ -- Finally, add the length of the standard GNAT
+ -- library dir.
+
+ Length := Length + MLib.Utl.Lib_Directory'Length;
+ Option := new String (1 .. Length);
+ Option (1 .. Path_Option'Length) := Path_Option.all;
+ Current := Path_Option'Length;
+
+ -- Put each library dir followed by a dir separator
+
+ for Index in
+ Library_Paths.First .. Library_Paths.Last
+ loop
+ Option
+ (Current + 1 ..
+ Current +
+ Library_Paths.Table (Index)'Length) :=
+ Library_Paths.Table (Index).all;
+ Current :=
+ Current +
+ Library_Paths.Table (Index)'Length + 1;
+ Option (Current) := Path_Separator;
+ end loop;
+
+ -- Finally put the standard GNAT library dir
+
+ Option
+ (Current + 1 ..
+ Current + MLib.Utl.Lib_Directory'Length) :=
+ MLib.Utl.Lib_Directory;
+
+ -- And add the switch to the linker switches
- begin
- if Option /= null then
Linker_Switches.Increment_Last;
Linker_Switches.Table (Linker_Switches.Last) :=
Option;
- end if;
- end;
+ end;
+ end if;
+
end if;
-- Put the object directories in ADA_OBJECTS_PATH
- Set_Ada_Paths (Main_Project, False);
+ Prj.Env.Set_Ada_Paths (Main_Project, False);
+
+ -- Check for attributes Linker'Linker_Options in projects
+ -- other than the main project
+
+ declare
+ Linker_Package : Package_Id;
+ Options : Variable_Value;
+
+ begin
+ Linker_Opts.Init;
+
+ for Index in 1 .. Projects.Last loop
+ if Index /= Main_Project then
+ Linker_Package :=
+ Prj.Util.Value_Of
+ (Name => Name_Linker,
+ In_Packages =>
+ Projects.Table (Index).Decl.Packages);
+ Options :=
+ Prj.Util.Value_Of
+ (Name => Name_Ada,
+ Attribute_Or_Array_Name => Name_Linker_Options,
+ In_Package => Linker_Package);
+
+ -- If attribute is present, add the project with
+ -- the attribute to table Linker_Opts.
+
+ if Options /= Nil_Variable_Value then
+ Linker_Opts.Increment_Last;
+ Linker_Opts.Table (Linker_Opts.Last) :=
+ (Project => Index, Options => Options.Values);
+ end if;
+ end if;
+ end loop;
+ end;
+
+ declare
+ Opt1 : Linker_Options_Data;
+ Opt2 : Linker_Options_Data;
+ Depth : Natural;
+ Options : String_List_Id;
+ Option : Name_Id;
+ begin
+ -- Sort the project by increasing depths
+
+ for Index in 1 .. Linker_Opts.Last loop
+ Opt1 := Linker_Opts.Table (Index);
+ Depth := Projects.Table (Opt1.Project).Depth;
+
+ for J in Index + 1 .. Linker_Opts.Last loop
+ Opt2 := Linker_Opts.Table (J);
+
+ if
+ Projects.Table (Opt2.Project).Depth < Depth
+ then
+ Linker_Opts.Table (Index) := Opt2;
+ Linker_Opts.Table (J) := Opt1;
+ Opt1 := Opt2;
+ Depth :=
+ Projects.Table (Opt1.Project).Depth;
+ end if;
+ end loop;
+
+ -- If Dir_Path has not been computed for this project,
+ -- do it now.
+
+ if Projects.Table (Opt1.Project).Dir_Path = null then
+ Projects.Table (Opt1.Project).Dir_Path :=
+ new String'
+ (Get_Name_String
+ (Projects.Table (Opt1.Project). Directory));
+ end if;
+
+ Options := Opt1.Options;
+
+ -- Add each of the options to the linker switches
+
+ while Options /= Nil_String loop
+ Option := String_Elements.Table (Options).Value;
+ Options := String_Elements.Table (Options).Next;
+ Linker_Switches.Increment_Last;
+ Linker_Switches.Table (Linker_Switches.Last) :=
+ new String'(Get_Name_String (Option));
+
+ -- Object files and -L switches specified with
+ -- relative paths and must be converted to
+ -- absolute paths.
+
+ Test_If_Relative_Path
+ (Switch =>
+ Linker_Switches.Table (Linker_Switches.Last),
+ Parent => Projects.Table (Opt1.Project).Dir_Path,
+ Including_L_Switch => True);
+ end loop;
+ end loop;
+ end;
end if;
declare
@@ -3582,10 +4864,9 @@ package body Make is
Last_Arg := Last_Arg + 1;
Args (Last_Arg) := Linker_Switches.Table (J);
end if;
-
end loop;
- -- And invoke the linker
+ -- If need be, add the -o switch
if Non_Std_Executable then
Last_Arg := Last_Arg + 1;
@@ -3593,14 +4874,28 @@ package body Make is
Last_Arg := Last_Arg + 1;
Args (Last_Arg) :=
new String'(Get_Name_String (Executable));
+ end if;
+
+ -- And invoke the linker
+
+ begin
Link (Main_ALI_File, Args (Args'First .. Last_Arg));
+ Successful_Links.Increment_Last;
+ Successful_Links.Table (Successful_Links.Last) :=
+ Main_ALI_File;
- else
- Link
- (Main_ALI_File,
- Args (Args'First .. Last_Arg));
- end if;
+ exception
+ when Link_Failed =>
+ if Osint.Number_Of_Files = 1 or not Opt.Keep_Going then
+ raise;
+ else
+ Write_Line ("*** link failed");
+ Failed_Links.Increment_Last;
+ Failed_Links.Table (Failed_Links.Last) :=
+ Main_ALI_File;
+ end if;
+ end;
end;
Linker_Switches.Set_Last (Linker_Switches_Last);
@@ -3628,16 +4923,31 @@ package body Make is
Prj.Env.
File_Name_Of_Library_Unit_Body
(Name => Main_Source_File_Name,
- Project => Main_Project);
+ Project => Main_Project,
+ Main_Project_Only =>
+ not Unique_Compile);
+
+ The_Packages : constant Package_Id :=
+ Projects.Table (Main_Project).Decl.Packages;
+
+ Binder_Package : constant Prj.Package_Id :=
+ Prj.Util.Value_Of
+ (Name => Name_Binder,
+ In_Packages => The_Packages);
+
+ Linker_Package : constant Prj.Package_Id :=
+ Prj.Util.Value_Of
+ (Name => Name_Linker,
+ In_Packages => The_Packages);
begin
-- We fail if we cannot find the main source file
-- as an immediate source of the main project file.
if Main_Unit_File_Name = "" then
- Fail ('"' & Main_Source_File_Name &
- """ is not a unit of project " &
- Project_File_Name.all & ".");
+ Make_Failed ('"' & Main_Source_File_Name,
+ """ is not a unit of project ",
+ Project_File_Name.all & ".");
else
-- Remove any directory information from the main
@@ -3663,11 +4973,116 @@ package body Make is
Main_Source_File := Name_Find;
end;
end if;
+
+ -- We now deal with the binder and linker switches.
+ -- If no project file is used, there is nothing to do
+ -- because the binder and linker switches are the same
+ -- for all mains.
+
+ -- Reset the tables Binder_Switches and Linker_Switches
+
+ Binder_Switches.Set_Last (Last_Binder_Switch);
+ Linker_Switches.Set_Last (Last_Linker_Switch);
+
+ -- Add binder switches from the project file for this main,
+ -- if any.
+
+ if Do_Bind_Step and Binder_Package /= No_Package then
+ if Opt.Verbose_Mode then
+ Write_Str ("Adding binder switches for """);
+ Write_Str (Main_Unit_File_Name);
+ Write_Line (""".");
+ end if;
+
+ Add_Switches
+ (File_Name => Main_Unit_File_Name,
+ The_Package => Binder_Package,
+ Program => Binder);
+ end if;
+
+ -- Add linker switches from the project file for this main,
+ -- if any.
+
+ if Do_Link_Step and Linker_Package /= No_Package then
+ if Opt.Verbose_Mode then
+ Write_Str ("Adding linker switches for""");
+ Write_Str (Main_Unit_File_Name);
+ Write_Line (""".");
+ end if;
+
+ Add_Switches
+ (File_Name => Main_Unit_File_Name,
+ The_Package => Linker_Package,
+ Program => Linker);
+ end if;
+
+ -- As we are using a project file, for relative paths we add
+ -- the current working directory for any relative path on
+ -- the command line and the project directory, for any
+ -- relative path in the project file.
+
+ declare
+ Dir_Path : constant String_Access :=
+ new String'(Get_Name_String
+ (Projects.Table (Main_Project).Directory));
+ begin
+ for
+ J in Last_Binder_Switch + 1 .. Binder_Switches.Last
+ loop
+ Test_If_Relative_Path
+ (Binder_Switches.Table (J),
+ Parent => Dir_Path, Including_L_Switch => False);
+ end loop;
+
+ for
+ J in Last_Linker_Switch + 1 .. Linker_Switches.Last
+ loop
+ Test_If_Relative_Path
+ (Linker_Switches.Table (J), Parent => Dir_Path);
+ end loop;
+ end;
+
+ -- We now put in the Binder_Switches and Linker_Switches
+ -- tables, the binder and linker switches of the command
+ -- line that have been put in the Saved_ tables.
+ -- These switches will follow the project file switches.
+
+ for J in 1 .. Saved_Binder_Switches.Last loop
+ Add_Switch
+ (Saved_Binder_Switches.Table (J),
+ Binder,
+ And_Save => False);
+ end loop;
+
+ for J in 1 .. Saved_Linker_Switches.Last loop
+ Add_Switch
+ (Saved_Linker_Switches.Table (J),
+ Linker,
+ And_Save => False);
+ end loop;
end;
end if;
end if;
end loop Multiple_Main_Loop;
+ if Failed_Links.Last > 0 then
+ for Index in 1 .. Successful_Links.Last loop
+ Write_Str ("Linking of """);
+ Write_Str (Get_Name_String (Successful_Links.Table (Index)));
+ Write_Line (""" succeeded.");
+ end loop;
+
+ for Index in 1 .. Failed_Links.Last loop
+ Write_Str ("Linking of """);
+ Write_Str (Get_Name_String (Failed_Links.Table (Index)));
+ Write_Line (""" failed.");
+ end loop;
+
+ if Total_Compilation_Failures = 0 then
+ raise Compilation_Failed;
+ end if;
+ end if;
+
if Total_Compilation_Failures /= 0 then
List_Bad_Compilations;
raise Compilation_Failed;
@@ -3676,30 +5091,43 @@ package body Make is
-- Delete the temporary mapping file that was created if we are
-- using project files.
- Delete_Mapping_Files;
+ if not Debug.Debug_Flag_N then
+ Delete_Mapping_Files;
+ Prj.Env.Delete_All_Path_Files;
+ end if;
Exit_Program (E_Success);
exception
when Bind_Failed =>
- Delete_Mapping_Files;
- Osint.Fail ("*** bind failed.");
+ Make_Failed ("*** bind failed.");
when Compilation_Failed =>
- Delete_Mapping_Files;
+ if not Debug.Debug_Flag_N then
+ Delete_Mapping_Files;
+ Prj.Env.Delete_All_Path_Files;
+ end if;
+
Exit_Program (E_Fatal);
when Link_Failed =>
- Delete_Mapping_Files;
- Osint.Fail ("*** link failed.");
+ Make_Failed ("*** link failed.");
when X : others =>
- Delete_Mapping_Files;
Write_Line (Exception_Information (X));
- Osint.Fail ("INTERNAL ERROR. Please report.");
+ Make_Failed ("INTERNAL ERROR. Please report.");
end Gnatmake;
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : Name_Id) return Header_Num is
+ begin
+ return Header_Num (1 + F mod Max_Header);
+ end Hash;
+
--------------------
-- In_Ada_Lib_Dir --
--------------------
@@ -3736,21 +5164,51 @@ package body Make is
-- Init_Mapping_File --
-----------------------
- procedure Init_Mapping_File (File_Name : in out Temp_File_Name) is
+ procedure Init_Mapping_File
+ (Project : Project_Id;
+ File_Index : in out Natural)
+ is
FD : File_Descriptor;
+
+ Status : Boolean;
+ -- For call to Close
+
begin
- if Main_Project /= No_Project then
- Prj.Env.Create_Mapping_File (File_Name);
+ -- Increase the index of the last mapping file for this project
- else
- Create_Temp_File (FD, File_Name);
+ Last_Mapping_File_Names (Project) :=
+ Last_Mapping_File_Names (Project) + 1;
+
+ -- If there is a project file, call Create_Mapping_File with
+ -- the project id.
+
+ if Project /= No_Project then
+ Prj.Env.Create_Mapping_File
+ (Project,
+ The_Mapping_File_Names
+ (Project, Last_Mapping_File_Names (Project)));
+
+ -- Otherwise, just create an empty file
+ else
+ Tempdir.Create_Temp_File
+ (FD,
+ The_Mapping_File_Names
+ (No_Project, Last_Mapping_File_Names (No_Project)));
if FD = Invalid_FD then
- Fail ("disk full");
+ Make_Failed ("disk full");
end if;
- Close (FD);
+ Close (FD, Status);
+
+ if not Status then
+ Make_Failed ("disk full");
+ end if;
end if;
+
+ -- And return the index of the newly created file
+
+ File_Index := Last_Mapping_File_Names (Project);
end Init_Mapping_File;
------------
@@ -3794,6 +5252,10 @@ package body Make is
Prj.Initialize;
+ Dependencies.Init;
+
+ RTS_Specified := null;
+
Next_Arg := 1;
Scan_Args : while Next_Arg <= Argument_Count loop
Scan_Make_Arg (Argument (Next_Arg), And_Save => True);
@@ -3804,12 +5266,48 @@ package body Make is
Makeusg;
end if;
+ -- Test for trailing -P switch
+
+ if Project_File_Name_Present and then Project_File_Name = null then
+ Make_Failed ("project file name missing after -P");
+
-- Test for trailing -o switch
- if Opt.Output_File_Name_Present
+ elsif Opt.Output_File_Name_Present
and then not Output_File_Name_Seen
then
- Fail ("output file name missing after -o");
+ Make_Failed ("output file name missing after -o");
+
+ -- Test for trailing -D switch
+
+ elsif Opt.Object_Directory_Present
+ and then not Object_Directory_Seen then
+ Make_Failed ("object directory missing after -D");
+ end if;
+
+ -- Test for simultaneity of -i and -D
+
+ if Object_Directory_Path /= null and then In_Place_Mode then
+ Make_Failed ("-i and -D cannot be used simutaneously");
+ end if;
+
+ -- Deal with -C= switch
+
+ if Gnatmake_Mapping_File /= null then
+ -- First, check compatibility with other switches
+
+ if Project_File_Name /= null then
+ Make_Failed ("-C= switch is not compatible with -P switch");
+
+ elsif Saved_Maximum_Processes > 1 then
+ Make_Failed ("-C= switch is not compatible with -jnnn switch");
+ end if;
+
+ Fmap.Initialize (Gnatmake_Mapping_File.all);
+ Add_Switch
+ ("-gnatem=" & Gnatmake_Mapping_File.all,
+ Compiler,
+ And_Save => True);
end if;
if Project_File_Name /= null then
@@ -3838,11 +5336,11 @@ package body Make is
Prj.Pars.Parse
(Project => Main_Project,
- Project_File_Name => Project_File_Name.all);
+ Project_File_Name => Project_File_Name.all,
+ Packages_To_Check => Packages_To_Check_By_Gnatmake);
if Main_Project = No_Project then
- Fail ("""" & Project_File_Name.all &
- """ processing failed");
+ Make_Failed ("""", Project_File_Name.all, """ processing failed");
end if;
if Opt.Verbose_Mode then
@@ -3859,28 +5357,34 @@ package body Make is
Add_Source_Directories (Main_Project);
Add_Object_Directories (Main_Project);
- end if;
+ -- Compute depth of each project
- Osint.Add_Default_Search_Dirs;
+ Recursive_Compute_Depth
+ (Main_Project, Visited => No_Projects, Depth => 0);
- -- Mark the GNAT libraries if needed.
+ else
- -- Source file lookups should be cached for efficiency.
- -- Source files are not supposed to change.
+ Osint.Add_Default_Search_Dirs;
- Osint.Source_File_Data (Cache => True);
+ -- Source file lookups should be cached for efficiency.
+ -- Source files are not supposed to change. However, we do that now
+ -- only if no project file is used; if a project file is used, we
+ -- do it just after changing the directory to the object directory.
- -- Read gnat.adc file to initialize Fname.UF
+ Osint.Source_File_Data (Cache => True);
- Fname.UF.Initialize;
+ -- Read gnat.adc file to initialize Fname.UF
- begin
- Fname.SF.Read_Source_File_Name_Pragmas;
+ Fname.UF.Initialize;
- exception
- when Err : SFN_Scan.Syntax_Error_In_GNAT_ADC =>
- Osint.Fail (Exception_Message (Err));
- end;
+ begin
+ Fname.SF.Read_Source_File_Name_Pragmas;
+
+ exception
+ when Err : SFN_Scan.Syntax_Error_In_GNAT_ADC =>
+ Make_Failed (Exception_Message (Err));
+ end;
+ end if;
end Initialize;
-----------------------------------
@@ -3888,11 +5392,48 @@ package body Make is
-----------------------------------
procedure Insert_Project_Sources
- (The_Project : Project_Id;
- Into_Q : Boolean)
+ (The_Project : Project_Id;
+ All_Projects : Boolean;
+ Into_Q : Boolean)
is
+ Put_In_Q : Boolean := Into_Q;
Unit : Com.Unit_Data;
Sfile : Name_Id;
+ Extending : constant Boolean :=
+ Projects.Table (The_Project).Extends /= No_Project;
+
+ function Check_Project (P : Project_Id) return Boolean;
+ -- Returns True if P is The_Project or a project extended by
+ -- The_Project.
+
+ -------------------
+ -- Check_Project --
+ -------------------
+
+ function Check_Project (P : Project_Id) return Boolean is
+ begin
+ if All_Projects or P = The_Project then
+ return True;
+ elsif Extending then
+ declare
+ Data : Project_Data := Projects.Table (The_Project);
+
+ begin
+ loop
+ if P = Data.Extends then
+ return True;
+ end if;
+
+ Data := Projects.Table (Data.Extends);
+ exit when Data.Extends = No_Project;
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Check_Project;
+
+ -- Start of processing of Insert_Project_Sources
begin
-- For all the sources in the project files,
@@ -3901,13 +5442,16 @@ package body Make is
Unit := Com.Units.Table (Id);
Sfile := No_Name;
- -- If there is a source for the body,
+ -- If there is a source for the body, and the body has not been
+ -- locally removed,
- if Unit.File_Names (Com.Body_Part).Name /= No_Name then
+ if Unit.File_Names (Com.Body_Part).Name /= No_Name
+ and then Unit.File_Names (Com.Body_Part).Path /= Slash
+ then
- -- And it is a source of the specified project
+ -- And it is a source for the specified project
- if Unit.File_Names (Com.Body_Part).Project = The_Project then
+ if Check_Project (Unit.File_Names (Com.Body_Part).Project) then
-- If we don't have a spec, we cannot consider the source
-- if it is a subunit
@@ -3916,13 +5460,24 @@ package body Make is
declare
Src_Ind : Source_File_Index;
+ -- Here we are cheating a little bit: we don't want to
+ -- use Sinput.L, because it depends on the GNAT tree
+ -- (Atree, Sinfo, ...). So, we pretend that it is
+ -- a project file, and we use Sinput.P.
+ -- Source_File_Is_Subunit is just scanning through
+ -- the file until it finds one of the reserved words
+ -- separate, procedure, function, generic or package.
+ -- Fortunately, these Ada reserved words are also
+ -- reserved for project files.
+
begin
- Src_Ind := Sinput.L.Load_Source_File
- (Unit.File_Names (Com.Body_Part).Name);
+ Src_Ind := Sinput.P.Load_Project_File
+ (Get_Name_String
+ (Unit.File_Names (Com.Body_Part).Path));
-- If it is a subunit, discard it
- if Sinput.L.Source_File_Is_Subunit (Src_Ind) then
+ if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
Sfile := No_Name;
else
@@ -3936,17 +5491,19 @@ package body Make is
end if;
elsif Unit.File_Names (Com.Specification).Name /= No_Name
- and then Unit.File_Names (Com.Specification).Project = The_Project
+ and then Unit.File_Names (Com.Specification).Path /= Slash
+ and then Check_Project (Unit.File_Names (Com.Specification).Project)
then
-- If there is no source for the body, but there is a source
- -- for the spec, then we take this one.
+ -- for the spec which has not been locally removed, then we take
+ -- this one.
Sfile := Unit.File_Names (Com.Specification).Name;
end if;
- -- If Into_Q is True, we insert into the Q
+ -- If Put_In_Q is True, we insert into the Q
- if Into_Q then
+ if Put_In_Q then
-- For the first source inserted into the Q, we need
-- to initialize the Q, but not for the subsequent sources.
@@ -3959,16 +5516,32 @@ package body Make is
-- is not marked.
if Sfile /= No_Name and then not Is_Marked (Sfile) then
+ if Opt.Verbose_Mode then
+ Write_Str ("Adding """);
+ Write_Str (Get_Name_String (Sfile));
+ Write_Line (""" to the queue");
+ end if;
+
Insert_Q (Sfile);
Mark (Sfile);
end if;
elsif Sfile /= No_Name then
- -- If Into_Q is False, we add the source as it it were
- -- specified on the command line.
+ -- If Put_In_Q is False, we add the source as it it were
+ -- specified on the command line, and we set Put_In_Q to True,
+ -- so that the following sources will be put directly in the
+ -- queue. This will allow parallel compilation processes if -jx
+ -- switch is used.
+
+ if Opt.Verbose_Mode then
+ Write_Str ("Adding """);
+ Write_Str (Get_Name_String (Sfile));
+ Write_Line (""" as if on the command line");
+ end if;
Osint.Add_File (Get_Name_String (Sfile));
+ Put_In_Q := True;
end if;
end loop;
end Insert_Project_Sources;
@@ -4035,6 +5608,126 @@ package body Make is
end if;
end Is_External_Assignment;
+ ---------------------
+ -- Is_In_Obsoleted --
+ ---------------------
+
+ function Is_In_Obsoleted (F : Name_Id) return Boolean is
+ begin
+ if F = No_File then
+ return False;
+
+ else
+ declare
+ Name : String := Get_Name_String (F);
+ First : Natural := Name'Last;
+ F2 : Name_Id := F;
+
+ begin
+ while First > Name'First
+ and then Name (First - 1) /= Directory_Separator
+ and then Name (First - 1) /= '/'
+ loop
+ First := First - 1;
+ end loop;
+
+ if First /= Name'First then
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer (Name (First .. Name'Last));
+ F2 := Name_Find;
+ end if;
+
+ return Obsoleted.Get (F2);
+ end;
+ end if;
+ end Is_In_Obsoleted;
+
+ ----------------------------
+ -- Is_In_Object_Directory --
+ ----------------------------
+
+ function Is_In_Object_Directory
+ (Source_File : File_Name_Type;
+ Full_Lib_File : File_Name_Type) return Boolean
+ is
+ begin
+ -- There is something to check only when using project files.
+ -- Otherwise, this function returns True (last line of the function).
+
+ if Main_Project /= No_Project then
+ declare
+ Source_File_Name : constant String :=
+ Get_Name_String (Source_File);
+ Saved_Verbosity : constant Verbosity := Prj.Com.Current_Verbosity;
+ Project : Project_Id := No_Project;
+ Path_Name : Name_Id := No_Name;
+ Data : Project_Data;
+
+ begin
+ -- Call Get_Reference to know the ultimate extending project of
+ -- the source. Call it with verbosity default to avoid verbose
+ -- messages.
+
+ Prj.Com.Current_Verbosity := Default;
+ Prj.Env.
+ Get_Reference
+ (Source_File_Name => Source_File_Name,
+ Project => Project,
+ Path => Path_Name);
+ Prj.Com.Current_Verbosity := Saved_Verbosity;
+
+ -- If this source is in a project, check that the ALI file is
+ -- in its object directory. If it is not, return False, so that
+ -- the ALI file will not be skipped.
+
+ -- If the source is not in an extending project, we fall back to
+ -- the general case and return True at the end of the function.
+
+ if Project /= No_Project
+ and then Projects.Table (Project).Extends /= No_Project
+ then
+ Data := Projects.Table (Project);
+
+ declare
+ Object_Directory : constant String :=
+ Normalize_Pathname
+ (Get_Name_String
+ (Data.Object_Directory));
+
+ Olast : Natural := Object_Directory'Last;
+
+ Lib_File_Directory : constant String :=
+ Normalize_Pathname (Dir_Name
+ (Get_Name_String (Full_Lib_File)));
+
+ Llast : Natural := Lib_File_Directory'Last;
+
+ begin
+ -- For directories, Normalize_Pathname may or may not put
+ -- a directory separator at the end, depending on its input.
+ -- Remove any last directory separator before comparaison.
+ -- Returns True only if the two directories are the same.
+
+ if Object_Directory (Olast) = Directory_Separator then
+ Olast := Olast - 1;
+ end if;
+
+ if Lib_File_Directory (Llast) = Directory_Separator then
+ Llast := Llast - 1;
+ end if;
+
+ return Object_Directory (Object_Directory'First .. Olast) =
+ Lib_File_Directory (Lib_File_Directory'First .. Llast);
+ end;
+ end if;
+ end;
+ end if;
+
+ -- When the source is not in a project file, always return True
+
+ return True;
+ end Is_In_Object_Directory;
+
---------------
-- Is_Marked --
---------------
@@ -4049,21 +5742,21 @@ package body Make is
----------
procedure Link (ALI_File : File_Name_Type; Args : Argument_List) is
- Link_Args : Argument_List (Args'First .. Args'Last + 1);
+ Link_Args : Argument_List (1 .. Args'Length + 1);
Success : Boolean;
begin
- Link_Args (Args'Range) := Args;
-
Get_Name_String (ALI_File);
- Link_Args (Args'Last + 1) := new String'(Name_Buffer (1 .. Name_Len));
+ Link_Args (1) := new String'(Name_Buffer (1 .. Name_Len));
+
+ Link_Args (2 .. Args'Length + 1) := Args;
GNAT.OS_Lib.Normalize_Arguments (Link_Args);
Display (Gnatlink.all, Link_Args);
if Gnatlink_Path = null then
- Osint.Fail ("error, unable to locate " & Gnatlink.all);
+ Make_Failed ("error, unable to locate ", Gnatlink.all);
end if;
GNAT.OS_Lib.Spawn (Gnatlink_Path.all, Link_Args, Success);
@@ -4195,26 +5888,80 @@ package body Make is
Set_Name_Table_Byte (N, B or Mark);
end Mark_Directory;
- ----------------------
- -- Object_File_Name --
- ----------------------
+ -----------------------------
+ -- Recursive_Compute_Depth --
+ -----------------------------
+
+ procedure Recursive_Compute_Depth
+ (Project : Project_Id;
+ Visited : Project_Array;
+ Depth : Natural)
+ is
+ List : Project_List;
+ Proj : Project_Id;
+ OK : Boolean;
+ New_Visited : constant Project_Array := Visited & Project;
- function Object_File_Name (Source : String) return String is
begin
- -- If the source name has an extension, then replace it with
- -- the object suffix.
+ -- Nothing to do if there is no project
+
+ if Project = No_Project then
+ return;
+ end if;
+
+ -- If current depth of project is lower than Depth, adjust it
+
+ if Projects.Table (Project).Depth < Depth then
+ Projects.Table (Project).Depth := Depth;
+ end if;
+
+ List := Projects.Table (Project).Imported_Projects;
+
+ -- Visit each imported project
+
+ while List /= Empty_Project_List loop
+ Proj := Project_Lists.Table (List).Project;
+ List := Project_Lists.Table (List).Next;
+
+ OK := True;
+
+ -- To avoid endless loops due to cycles with limited widts,
+ -- do not revisit a project that is already in the chain of imports
+ -- that brought us here.
+
+ for J in Visited'Range loop
+ if Visited (J) = Proj then
+ OK := False;
+ exit;
+ end if;
+ end loop;
- for Index in reverse Source'First + 1 .. Source'Last loop
- if Source (Index) = '.' then
- return Source (Source'First .. Index - 1) & Object_Suffix;
+ if OK then
+ Recursive_Compute_Depth
+ (Project => Proj,
+ Visited => New_Visited,
+ Depth => Depth + 1);
end if;
end loop;
- -- If there is no dot, or if it is the first character, just add the
- -- object suffix.
+ -- Visit a project being extended, if any
- return Source & Object_Suffix;
- end Object_File_Name;
+ Recursive_Compute_Depth
+ (Project => Projects.Table (Project).Extends,
+ Visited => New_Visited,
+ Depth => Depth + 1);
+ end Recursive_Compute_Depth;
+
+ -----------------------
+ -- Sigint_Intercpted --
+ -----------------------
+
+ procedure Sigint_Intercepted is
+ begin
+ Write_Line ("*** Interrupted ***");
+ Delete_All_Temp_Files;
+ OS_Exit (1);
+ end Sigint_Intercepted;
-------------------
-- Scan_Make_Arg --
@@ -4228,15 +5975,30 @@ package body Make is
return;
end if;
+ -- If the previous switch has set the Project_File_Name_Present
+ -- flag (that is we have seen a -P alone), then the next argument is
+ -- the name of the project file.
+
+ if Project_File_Name_Present and then Project_File_Name = null then
+ if Argv (1) = '-' then
+ Make_Failed ("project file name missing after -P");
+
+ else
+ Project_File_Name_Present := False;
+ Project_File_Name := new String'(Argv);
+ end if;
+
-- If the previous switch has set the Output_File_Name_Present
-- flag (that is we have seen a -o), then the next argument is
-- the name of the output executable.
- if Opt.Output_File_Name_Present and then not Output_File_Name_Seen then
+ elsif Opt.Output_File_Name_Present
+ and then not Output_File_Name_Seen
+ then
Output_File_Name_Seen := True;
if Argv (1) = '-' then
- Fail ("output file name missing after -o");
+ Make_Failed ("output file name missing after -o");
else
Add_Switch ("-o", Linker, And_Save => And_Save);
@@ -4245,8 +6007,9 @@ package body Make is
-- specified explicitly.
if Executable_Suffix'Length /= 0
- and then Argv (Argv'Last - Executable_Suffix'Length + 1
- .. Argv'Last) /= Executable_Suffix
+ and then (Argv'Length <= Executable_Suffix'Length
+ or else Argv (Argv'Last - Executable_Suffix'Length + 1
+ .. Argv'Last) /= Executable_Suffix)
then
Add_Switch
(Argv & Executable_Suffix,
@@ -4257,7 +6020,41 @@ package body Make is
end if;
end if;
- -- Then check if we are dealing with -cargs/-bargs/-largs
+ -- If the previous switch has set the Object_Directory_Present flag
+ -- (that is we have seen a -D), then the next argument is
+ -- the path name of the object directory..
+
+ elsif Opt.Object_Directory_Present
+ and then not Object_Directory_Seen
+ then
+ Object_Directory_Seen := True;
+
+ if Argv (1) = '-' then
+ Make_Failed ("object directory path name missing after -D");
+
+ elsif not Is_Directory (Argv) then
+ Make_Failed ("cannot find object directory """, Argv, """");
+
+ else
+ Add_Lib_Search_Dir (Argv);
+
+ -- Specify the object directory to the binder
+
+ Add_Switch ("-aO" & Argv, Binder, And_Save => And_Save);
+
+ -- Record the object directory. Make sure it ends with a directory
+ -- separator.
+
+ if Argv (Argv'Last) = Directory_Separator then
+ Object_Directory_Path := new String'(Argv);
+
+ else
+ Object_Directory_Path :=
+ new String'(Argv & Directory_Separator);
+ end if;
+ end if;
+
+ -- Then check if we are dealing with -cargs/-bargs/-largs/-margs
elsif Argv = "-bargs"
or else
@@ -4284,7 +6081,8 @@ package body Make is
elsif Program_Args = Linker
and then Argv = "-o"
then
- Fail ("switch -o not allowed within a -largs. Use -o directly.");
+ Make_Failed ("switch -o not allowed within a -largs. " &
+ "Use -o directly.");
-- Check to see if we are reading switches after a -cargs,
-- -bargs or -largs switch. If yes save it.
@@ -4301,12 +6099,10 @@ package body Make is
elsif Program_Args = Compiler then
if Argv (3 .. Argv'Last) /= "-" then
Add_Src_Search_Dir (Argv (3 .. Argv'Last));
-
end if;
elsif Program_Args = Binder then
Add_Lib_Search_Dir (Argv (3 .. Argv'Last));
-
end if;
end if;
@@ -4319,7 +6115,7 @@ package body Make is
and then Argv (1 .. 6) = "--GCC="
then
declare
- Program_Args : Argument_List_Access :=
+ Program_Args : constant Argument_List_Access :=
Argument_String_To_List
(Argv (7 .. Argv'Last));
@@ -4342,7 +6138,7 @@ package body Make is
and then Argv (1 .. 11) = "--GNATBIND="
then
declare
- Program_Args : Argument_List_Access :=
+ Program_Args : constant Argument_List_Access :=
Argument_String_To_List
(Argv (12 .. Argv'Last));
@@ -4363,7 +6159,7 @@ package body Make is
and then Argv (1 .. 11) = "--GNATLINK="
then
declare
- Program_Args : Argument_List_Access :=
+ Program_Args : constant Argument_List_Access :=
Argument_String_To_List
(Argv (12 .. Argv'Last));
begin
@@ -4383,11 +6179,22 @@ package body Make is
then
Add_Switch (Argv, Compiler, And_Save => And_Save);
Add_Switch (Argv, Binder, And_Save => And_Save);
+ Add_Switch (Argv, Linker, And_Save => And_Save);
if Argv'Length <= 6 or else Argv (6) /= '=' then
- Osint.Fail ("missing path for --RTS");
+ Make_Failed ("missing path for --RTS");
else
+ -- Check that this is the first time we see this switch or
+ -- if it is not the first time, the same path is specified.
+
+ if RTS_Specified = null then
+ RTS_Specified := new String'(Argv (7 .. Argv'Last));
+
+ elsif RTS_Specified.all /= Argv (7 .. Argv'Last) then
+ Make_Failed ("--RTS cannot be specified multiple times");
+ end if;
+
-- Valid --RTS switch
Opt.No_Stdinc := True;
@@ -4395,10 +6202,11 @@ package body Make is
Opt.RTS_Switch := True;
declare
- Src_Path_Name : String_Ptr :=
+ Src_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
(Argv (7 .. Argv'Last), Include);
- Lib_Path_Name : String_Ptr :=
+
+ Lib_Path_Name : constant String_Ptr :=
Get_RTS_Search_Dir
(Argv (7 .. Argv'Last), Objects);
@@ -4406,27 +6214,31 @@ package body Make is
if Src_Path_Name /= null and then
Lib_Path_Name /= null
then
- Add_Search_Dirs (Src_Path_Name, Include);
- Add_Search_Dirs (Lib_Path_Name, Objects);
+ -- Set the RTS_*_Path_Name variables, so that the correct
+ -- directories will be set when
+ -- Osint.Add_Default_Search_Dirs will be called later.
+
+ RTS_Src_Path_Name := Src_Path_Name;
+ RTS_Lib_Path_Name := Lib_Path_Name;
elsif Src_Path_Name = null
and Lib_Path_Name = null then
- Osint.Fail ("RTS path not valid: missing " &
- "adainclude and adalib directories");
+ Make_Failed ("RTS path not valid: missing " &
+ "adainclude and adalib directories");
elsif Src_Path_Name = null then
- Osint.Fail ("RTS path not valid: missing " &
- "adainclude directory");
+ Make_Failed ("RTS path not valid: missing adainclude " &
+ "directory");
elsif Lib_Path_Name = null then
- Osint.Fail ("RTS path not valid: missing " &
- "adalib directory");
+ Make_Failed ("RTS path not valid: missing adalib " &
+ "directory");
end if;
end;
end if;
else
- Fail ("unknown switch: ", Argv);
+ Make_Failed ("unknown switch: ", Argv);
end if;
-- If we have seen a regular switch process it
@@ -4434,7 +6246,7 @@ package body Make is
elsif Argv (1) = '-' then
if Argv'Length = 1 then
- Fail ("switch character cannot be followed by a blank");
+ Make_Failed ("switch character cannot be followed by a blank");
-- -I-
@@ -4446,7 +6258,7 @@ package body Make is
elsif (Argv'Length = 3 and then Argv (3) = '-')
or else (Argv'Length = 4 and then Argv (4) = '-')
then
- Fail ("trailing ""-"" at the end of ", Argv, " forbidden.");
+ Make_Failed ("trailing ""-"" at the end of ", Argv, " forbidden.");
-- -Idir
@@ -4454,13 +6266,7 @@ package body Make is
Add_Src_Search_Dir (Argv (3 .. Argv'Last));
Add_Lib_Search_Dir (Argv (3 .. Argv'Last));
Add_Switch (Argv, Compiler, And_Save => And_Save);
- Add_Switch ("-aO" & Argv (3 .. Argv'Last),
- Binder,
- And_Save => And_Save);
-
- -- No need to pass any source dir to the binder
- -- since gnatmake call it with the -x flag
- -- (ie do not check source time stamp)
+ Add_Switch (Argv, Binder, And_Save => And_Save);
-- -aIdir (to gcc this is like a -I switch)
@@ -4469,6 +6275,7 @@ package body Make is
Add_Switch ("-I" & Argv (4 .. Argv'Last),
Compiler,
And_Save => And_Save);
+ Add_Switch (Argv, Binder, And_Save => And_Save);
-- -aOdir
@@ -4503,17 +6310,40 @@ package body Make is
elsif Argv (2) = 'L' then
Add_Switch (Argv, Linker, And_Save => And_Save);
- -- For -gxxxxx,-pg : give the switch to both the compiler and the
- -- linker (except for -gnatxxx which is only for the compiler)
+ -- For -gxxxxx,-pg,-mxxx: give the switch to both the compiler and
+ -- the linker (except for -gnatxxx which is only for the compiler)
elsif
(Argv (2) = 'g' and then (Argv'Last < 5
or else Argv (2 .. 5) /= "gnat"))
or else Argv (2 .. Argv'Last) = "pg"
+ or else (Argv (2) = 'm' and then Argv'Last > 2)
then
Add_Switch (Argv, Compiler, And_Save => And_Save);
Add_Switch (Argv, Linker, And_Save => And_Save);
+ -- -C=<mapping file>
+
+ elsif Argv'Last > 2 and then Argv (2) = 'C' then
+ if And_Save then
+ if Argv (3) /= '=' or else Argv'Last <= 3 then
+ Make_Failed ("illegal switch ", Argv);
+ end if;
+
+ Gnatmake_Mapping_File := new String'(Argv (4 .. Argv'Last));
+ end if;
+
+ -- -D
+
+ elsif Argv'Last = 2 and then Argv (2) = 'D' then
+ if Project_File_Name /= null then
+ Make_Failed ("-D cannot be used in conjunction with a " &
+ "project file");
+
+ else
+ Scan_Make_Switches (Argv);
+ end if;
+
-- -d
elsif Argv (2) = 'd'
@@ -4521,6 +6351,17 @@ package body Make is
then
Opt.Display_Compilation_Progress := True;
+ -- -i
+
+ elsif Argv'Last = 2 and then Argv (2) = 'i' then
+ if Project_File_Name /= null then
+ Make_Failed ("-i cannot be used in conjunction with a " &
+ "project file");
+
+ else
+ Scan_Make_Switches (Argv);
+ end if;
+
-- -j (need to save the result)
elsif Argv (2) = 'j' then
@@ -4547,13 +6388,30 @@ package body Make is
Do_Bind_Step := False;
Do_Link_Step := False;
- -- -Pprj (only once, and only on the command line)
+ -- -U
- elsif Argv'Last > 2
- and then Argv (2) = 'P'
+ elsif Argv (2) = 'U'
+ and then Argv'Last = 2
then
+ Unique_Compile_All_Projects := True;
+ Unique_Compile := True;
+ Opt.Compile_Only := True;
+ Do_Bind_Step := False;
+ Do_Link_Step := False;
+
+ -- -Pprj or -P prj (only once, and only on the command line)
+
+ elsif Argv (2) = 'P' then
if Project_File_Name /= null then
- Fail ("cannot have several project files specified");
+ Make_Failed ("cannot have several project files specified");
+
+ elsif Object_Directory_Path /= null then
+ Make_Failed ("-D cannot be used in conjunction with a " &
+ "project file");
+
+ elsif In_Place_Mode then
+ Make_Failed ("-i cannot be used in conjunction with a " &
+ "project file");
elsif not And_Save then
@@ -4564,20 +6422,15 @@ package body Make is
("either the tool is not ""project-aware"" or " &
"a project file is specified inside a project file");
- else
- Project_File_Name := new String' (Argv (3 .. Argv'Last));
- end if;
+ elsif Argv'Last = 2 then
- -- -S (Assemble)
+ -- -P is used alone: the project file name is the next option
- -- Since no object file is created, don't check object
- -- consistency.
+ Project_File_Name_Present := True;
- elsif Argv (2) = 'S'
- and then Argv'Last = 2
- then
- Opt.Check_Object_Consistency := False;
- Add_Switch (Argv, Compiler, And_Save => And_Save);
+ else
+ Project_File_Name := new String'(Argv (3 .. Argv'Last));
+ end if;
-- -vPx (verbosity of the parsing of the project files)
@@ -4598,16 +6451,6 @@ package body Make is
end case;
end if;
- -- -Wx (need to save the result)
-
- elsif Argv (2) = 'W' then
- Scan_Make_Switches (Argv);
-
- if And_Save then
- Saved_WC_Encoding_Method := Wide_Character_Encoding_Method;
- Saved_WC_Encoding_Method_Set := True;
- end if;
-
-- -Xext=val (External assignment)
elsif Argv (2) = 'X'
@@ -4657,12 +6500,13 @@ package body Make is
-- By default all switches with more than one character
-- or one character switches which are not in 'a' .. 'z'
- -- (except 'C' and 'M') are passed to the compiler, unless we are
- -- dealing with a debug switch (starts with 'd')
+ -- (except 'C', 'F', and 'M') are passed to the compiler,
+ -- unless we are dealing with a debug switch (starts with 'd')
elsif Argv (2) /= 'd'
- and then Argv (2 .. Argv'Last) /= "M"
and then Argv (2 .. Argv'Last) /= "C"
+ and then Argv (2 .. Argv'Last) /= "F"
+ and then Argv (2 .. Argv'Last) /= "M"
and then (Argv'Length > 2 or else Argv (2) not in 'a' .. 'z')
then
Add_Switch (Argv, Compiler, And_Save => And_Save);
@@ -4680,155 +6524,6 @@ package body Make is
end if;
end Scan_Make_Arg;
- -------------------
- -- Set_Ada_Paths --
- -------------------
-
- procedure Set_Ada_Paths
- (For_Project : Prj.Project_Id;
- Including_Libraries : Boolean)
- is
- New_Ada_Include_Path : constant String_Access :=
- Prj.Env.Ada_Include_Path (For_Project);
-
- New_Ada_Objects_Path : constant String_Access :=
- Prj.Env.Ada_Objects_Path
- (For_Project, Including_Libraries);
-
- begin
- -- If ADA_INCLUDE_PATH needs to be changed (we are not using the same
- -- project file), set the new ADA_INCLUDE_PATH
-
- if New_Ada_Include_Path /= Current_Ada_Include_Path then
- Current_Ada_Include_Path := New_Ada_Include_Path;
-
- if Original_Ada_Include_Path'Length = 0 then
- Setenv ("ADA_INCLUDE_PATH",
- New_Ada_Include_Path.all);
-
- else
- -- If there existed an ADA_INCLUDE_PATH at the invocation of
- -- gnatmake, concatenate new ADA_INCLUDE_PATH with the original.
-
- Setenv ("ADA_INCLUDE_PATH",
- Original_Ada_Include_Path.all &
- Path_Separator &
- New_Ada_Include_Path.all);
- end if;
-
- if Opt.Verbose_Mode then
- declare
- Include_Path : constant String_Access :=
- Getenv ("ADA_INCLUDE_PATH");
-
- begin
- -- Display the new ADA_INCLUDE_PATH
-
- Write_Str ("ADA_INCLUDE_PATH = """);
- Prj.Util.Write_Str
- (S => Include_Path.all,
- Max_Length => Max_Line_Length,
- Separator => Path_Separator);
- Write_Str ("""");
- Write_Eol;
- end;
- end if;
- end if;
-
- -- If ADA_OBJECTS_PATH needs to be changed (we are not using the same
- -- project file), set the new ADA_OBJECTS_PATH
-
- if New_Ada_Objects_Path /= Current_Ada_Objects_Path then
- Current_Ada_Objects_Path := New_Ada_Objects_Path;
-
- if Original_Ada_Objects_Path'Length = 0 then
- Setenv ("ADA_OBJECTS_PATH",
- New_Ada_Objects_Path.all);
-
- else
- -- If there existed an ADA_OBJECTS_PATH at the invocation of
- -- gnatmake, concatenate new ADA_OBJECTS_PATH with the original.
-
- Setenv ("ADA_OBJECTS_PATH",
- Original_Ada_Objects_Path.all &
- Path_Separator &
- New_Ada_Objects_Path.all);
- end if;
-
- if Opt.Verbose_Mode then
- declare
- Objects_Path : constant String_Access :=
- Getenv ("ADA_OBJECTS_PATH");
-
- begin
- -- Display the new ADA_OBJECTS_PATH
-
- Write_Str ("ADA_OBJECTS_PATH = """);
- Prj.Util.Write_Str
- (S => Objects_Path.all,
- Max_Length => Max_Line_Length,
- Separator => Path_Separator);
- Write_Str ("""");
- Write_Eol;
- end;
- end if;
- end if;
-
- end Set_Ada_Paths;
-
- ---------------------
- -- Set_Library_For --
- ---------------------
-
- procedure Set_Library_For
- (Project : Project_Id;
- There_Are_Libraries : in out Boolean)
- is
- begin
- -- Case of library project
-
- if Projects.Table (Project).Library then
- There_Are_Libraries := True;
-
- -- Add the -L switch
-
- Linker_Switches.Increment_Last;
- Linker_Switches.Table (Linker_Switches.Last) :=
- new String'("-L" &
- Get_Name_String
- (Projects.Table (Project).Library_Dir));
-
- -- Add the -l switch
-
- Linker_Switches.Increment_Last;
- Linker_Switches.Table (Linker_Switches.Last) :=
- new String'("-l" &
- Get_Name_String
- (Projects.Table (Project).Library_Name));
-
- -- Add the Wl,-rpath switch if library non static
-
- if Projects.Table (Project).Library_Kind /= Static then
- declare
- Option : constant String_Access :=
- MLib.Tgt.Linker_Library_Path_Option
- (Get_Name_String
- (Projects.Table (Project).Library_Dir));
-
- begin
- if Option /= null then
- Linker_Switches.Increment_Last;
- Linker_Switches.Table (Linker_Switches.Last) :=
- Option;
- end if;
-
- end;
-
- end if;
-
- end if;
- end Set_Library_For;
-
-----------------
-- Switches_Of --
-----------------
@@ -4838,8 +6533,7 @@ package body Make is
Source_File_Name : String;
Naming : Naming_Data;
In_Package : Package_Id;
- Allow_ALI : Boolean)
- return Variable_Value
+ Allow_ALI : Boolean) return Variable_Value
is
Switches : Variable_Value;
@@ -4867,19 +6561,19 @@ package body Make is
Last : Positive := Source_File_Name'Length;
Spec_Suffix : constant String :=
Get_Name_String (Naming.Current_Spec_Suffix);
- Impl_Suffix : constant String :=
- Get_Name_String (Naming.Current_Impl_Suffix);
+ Body_Suffix : constant String :=
+ Get_Name_String (Naming.Current_Body_Suffix);
Truncated : Boolean := False;
begin
Name (1 .. Last) := Source_File_Name;
- if Last > Impl_Suffix'Length
- and then Name (Last - Impl_Suffix'Length + 1 .. Last) =
- Impl_Suffix
+ if Last > Body_Suffix'Length
+ and then Name (Last - Body_Suffix'Length + 1 .. Last) =
+ Body_Suffix
then
Truncated := True;
- Last := Last - Impl_Suffix'Length;
+ Last := Last - Body_Suffix'Length;
end if;
if not Truncated
@@ -4933,8 +6627,9 @@ package body Make is
---------------------------
procedure Test_If_Relative_Path
- (Switch : in out String_Access;
- Parent : String_Access)
+ (Switch : in out String_Access;
+ Parent : String_Access;
+ Including_L_Switch : Boolean := True)
is
begin
if Switch /= null then
@@ -4950,7 +6645,7 @@ package body Make is
if Sw'Length >= 3
and then (Sw (2) = 'A'
or else Sw (2) = 'I'
- or else Sw (2) = 'L')
+ or else (Including_L_Switch and then Sw (2) = 'L'))
then
Start := 3;
@@ -4965,18 +6660,20 @@ package body Make is
then
Start := 4;
- elsif Sw'Length >= 7
- and then Sw (2 .. 6) = "-RTS="
- then
- Start := 7;
else
return;
end if;
+ -- Because relative path arguments to --RTS= may be relative
+ -- to the search directory prefix, those relative path
+ -- arguments are not converted.
+
if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
- if Parent = null then
- Fail ("relative search path switches (""" & Sw &
- """) are not allowed inside project files");
+ if Parent = null or else Parent'Length = 0 then
+ Make_Failed
+ ("relative search path switches (""",
+ Sw,
+ """) are not allowed");
else
Switch :=
@@ -4987,6 +6684,18 @@ package body Make is
Sw (Start .. Sw'Last));
end if;
end if;
+
+ else
+ if not Is_Absolute_Path (Sw) then
+ if Parent = null or else Parent'Length = 0 then
+ Make_Failed
+ ("relative paths (""", Sw, """) are not allowed");
+
+ else
+ Switch :=
+ new String'(Parent.all & Directory_Separator & Sw);
+ end if;
+ end if;
end if;
end;
end if;
@@ -5036,4 +6745,8 @@ package body Make is
Write_Eol;
end Verbose_Msg;
+begin
+ Prj.Com.Fail := Make_Failed'Access;
+ MLib.Fail := Make_Failed'Access;
+ -- Make sure that in case of failure, the temp files will be deleted
end Make;
diff --git a/gcc/ada/make.ads b/gcc/ada/make.ads
index ea586e2dcd2..f07846336c7 100644
--- a/gcc/ada/make.ads
+++ b/gcc/ada/make.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -29,9 +29,10 @@
-- gives the individual routines for performing such tasks as well as
-- the routine gnatmake below that puts it all together.
-with GNAT.OS_Lib; use GNAT.OS_Lib; -- defines Argument_List
with Table;
-with Types; use Types;
+with Types; use Types;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
package Make is
diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb
index edacc2d508e..13ba0e50fbc 100644
--- a/gcc/ada/makeusg.adb
+++ b/gcc/ada/makeusg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -69,7 +69,18 @@ begin
-- Line for -C
Write_Str (" -C Cache source mappings: " &
- "invoke the compiler with a mapping file");
+ "invoke compiler with temp mapping file");
+ Write_Eol;
+
+ -- Line for -C=<mapping file>
+
+ Write_Str (" -C=mapp Cache source mappings: " &
+ "invoke compiler with mapping file mapp");
+ Write_Eol;
+
+ -- Line for -D
+
+ Write_Str (" -D dir Specify dir as the object directory");
Write_Eol;
-- Line for -f
@@ -77,6 +88,11 @@ begin
Write_Str (" -f Force recompilations of non predefined units");
Write_Eol;
+ -- Line for -F
+
+ Write_Str (" -F Full project path name in brief error messages");
+ Write_Eol;
+
-- Line for -i
Write_Str (" -i In place. Replace existing ali file, ");
@@ -129,6 +145,11 @@ begin
Write_Str (" -q Be quiet/terse");
Write_Eol;
+ -- Line for -R
+
+ Write_Str (" -R Do not use a run_path_option when linking");
+ Write_Eol;
+
-- Line for -s
Write_Str (" -s Recompile if compiler switches have changed");
@@ -136,7 +157,12 @@ begin
-- Line for -u
- Write_Str (" -u Unique compilation. Only compile the given file.");
+ Write_Str (" -u Unique compilation. Only compile the given files.");
+ Write_Eol;
+
+ -- Line for -U
+
+ Write_Str (" -U Unique compilation for all sources of all projects");
Write_Eol;
-- Line for -v
diff --git a/gcc/ada/mdll-fil.adb b/gcc/ada/mdll-fil.adb
index 1c9c9ff23c8..c3050ad7138 100644
--- a/gcc/ada/mdll-fil.adb
+++ b/gcc/ada/mdll-fil.adb
@@ -20,7 +20,7 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/mdll-fil.ads b/gcc/ada/mdll-fil.ads
index 06e6188b4c5..dbe1313a7e9 100644
--- a/gcc/ada/mdll-fil.ads
+++ b/gcc/ada/mdll-fil.ads
@@ -20,7 +20,7 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/mdll-utl.adb b/gcc/ada/mdll-utl.adb
index c7fb1554866..82c33b0d6c1 100644
--- a/gcc/ada/mdll-utl.adb
+++ b/gcc/ada/mdll-utl.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- --
@@ -20,7 +20,7 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -29,6 +29,7 @@
with Ada.Text_IO;
with Ada.Exceptions;
+with GNAT.Directory_Operations;
with Sdefault;
package body MDLL.Utl is
@@ -137,8 +138,8 @@ package body MDLL.Utl is
OS_Lib.Spawn (Dlltool_Exec.all, Arguments (1 .. A), Success);
if not Success then
- Exceptions.Raise_Exception (Tools_Error'Identity,
- Dlltool_Name & " execution error.");
+ Exceptions.Raise_Exception
+ (Tools_Error'Identity, Dlltool_Name & " execution error.");
end if;
end Dlltool;
@@ -217,8 +218,8 @@ package body MDLL.Utl is
OS_Lib.Spawn (Gcc_Exec.all, Arguments (1 .. A), Success);
if not Success then
- Exceptions.Raise_Exception (Tools_Error'Identity,
- Gcc_Name & " execution error.");
+ Exceptions.Raise_Exception
+ (Tools_Error'Identity, Gcc_Name & " execution error.");
end if;
end Gcc;
@@ -244,9 +245,19 @@ package body MDLL.Utl is
OS_Lib.Spawn (Gnatbind_Exec.all, Arguments, Success);
+ -- Delete binder files on failure
+
if not Success then
- Exceptions.Raise_Exception (Tools_Error'Identity,
- Gnatbind_Name & " execution error.");
+ declare
+ Base_Name : constant String :=
+ Directory_Operations.Base_Name (Alis (1).all, ".ali");
+ begin
+ OS_Lib.Delete_File ("b~" & Base_Name & ".ads", Success);
+ OS_Lib.Delete_File ("b~" & Base_Name & ".adb", Success);
+ end;
+
+ Exceptions.Raise_Exception
+ (Tools_Error'Identity, Gnatbind_Name & " execution error.");
end if;
end Gnatbind;
@@ -272,8 +283,19 @@ package body MDLL.Utl is
OS_Lib.Spawn (Gnatlink_Exec.all, Arguments, Success);
if not Success then
- Exceptions.Raise_Exception (Tools_Error'Identity,
- Gnatlink_Name & " execution error.");
+ -- Delete binder files
+ declare
+ Base_Name : constant String :=
+ Directory_Operations.Base_Name (Ali, ".ali");
+ begin
+ OS_Lib.Delete_File ("b~" & Base_Name & ".ads", Success);
+ OS_Lib.Delete_File ("b~" & Base_Name & ".adb", Success);
+ OS_Lib.Delete_File ("b~" & Base_Name & ".ali", Success);
+ OS_Lib.Delete_File ("b~" & Base_Name & ".o", Success);
+ end;
+
+ Exceptions.Raise_Exception
+ (Tools_Error'Identity, Gnatlink_Name & " execution error.");
end if;
end Gnatlink;
@@ -289,8 +311,9 @@ package body MDLL.Utl is
Dlltool_Exec := OS_Lib.Locate_Exec_On_Path (Dlltool_Name);
if Dlltool_Exec = null then
- Exceptions.Raise_Exception (Tools_Error'Identity,
- Dlltool_Name & " not found in path");
+ Exceptions.Raise_Exception
+ (Tools_Error'Identity, Dlltool_Name & " not found in path");
+
elsif Verbose then
Text_IO.Put_Line ("using " & Dlltool_Exec.all);
end if;
@@ -300,8 +323,9 @@ package body MDLL.Utl is
Gcc_Exec := OS_Lib.Locate_Exec_On_Path (Gcc_Name);
if Gcc_Exec = null then
- Exceptions.Raise_Exception (Tools_Error'Identity,
- Gcc_Name & " not found in path");
+ Exceptions.Raise_Exception
+ (Tools_Error'Identity, Gcc_Name & " not found in path");
+
elsif Verbose then
Text_IO.Put_Line ("using " & Gcc_Exec.all);
end if;
@@ -311,8 +335,9 @@ package body MDLL.Utl is
Gnatbind_Exec := OS_Lib.Locate_Exec_On_Path (Gnatbind_Name);
if Gnatbind_Exec = null then
- Exceptions.Raise_Exception (Tools_Error'Identity,
- Gnatbind_Name & " not found in path");
+ Exceptions.Raise_Exception
+ (Tools_Error'Identity, Gnatbind_Name & " not found in path");
+
elsif Verbose then
Text_IO.Put_Line ("using " & Gnatbind_Exec.all);
end if;
@@ -322,8 +347,9 @@ package body MDLL.Utl is
Gnatlink_Exec := OS_Lib.Locate_Exec_On_Path (Gnatlink_Name);
if Gnatlink_Exec = null then
- Exceptions.Raise_Exception (Tools_Error'Identity,
- Gnatlink_Name & " not found in path");
+ Exceptions.Raise_Exception
+ (Tools_Error'Identity, Gnatlink_Name & " not found in path");
+
elsif Verbose then
Text_IO.Put_Line ("using " & Gnatlink_Exec.all);
Text_IO.New_Line;
diff --git a/gcc/ada/mdll-utl.ads b/gcc/ada/mdll-utl.ads
index 55a70def422..9ba99f1aff0 100644
--- a/gcc/ada/mdll-utl.ads
+++ b/gcc/ada/mdll-utl.ads
@@ -20,7 +20,7 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/mdll.adb b/gcc/ada/mdll.adb
index b542eeef2a9..37dc55fff1e 100644
--- a/gcc/ada/mdll.adb
+++ b/gcc/ada/mdll.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -29,6 +29,7 @@
with Ada.Text_IO;
+with GNAT.Directory_Operations;
with MDLL.Utl;
with MDLL.Fil;
@@ -70,6 +71,10 @@ package body MDLL is
Out_Opt : aliased String := "-o";
Adr_Opt : aliased String := "-Wl,--image-base=" & Lib_Address;
+ L_Afiles : Argument_List := Afiles;
+ -- Local afiles list. This list can be reordered to ensure that the
+ -- binder ali file is not the first entry in this list.
+
All_Options : constant Argument_List := Options & Largs_Options;
procedure Build_Reloc_DLL;
@@ -179,7 +184,7 @@ package body MDLL is
-- 1) Build base file with objects files.
- Utl.Gnatbind (Afiles, Options & Bargs_Options);
+ Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
declare
Params : OS_Lib.Argument_List :=
@@ -187,7 +192,7 @@ package body MDLL is
Lib_Opt'Unchecked_Access &
Bas_Opt'Unchecked_Access & Ofiles & All_Options;
begin
- Utl.Gnatlink (Afiles (Afiles'Last).all, Params);
+ Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
end;
-- 2) Build exp from base file.
@@ -199,7 +204,7 @@ package body MDLL is
-- 3) Build base file with exp file and objects files.
- Utl.Gnatbind (Afiles, Options & Bargs_Options);
+ Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
declare
Params : OS_Lib.Argument_List :=
@@ -210,7 +215,7 @@ package body MDLL is
Ofiles &
All_Options;
begin
- Utl.Gnatlink (Afiles (Afiles'Last).all, Params);
+ Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
end;
-- 4) Build new exp from base file and the lib file (.a)
@@ -222,7 +227,7 @@ package body MDLL is
-- 5) Build the dynamic library
- Utl.Gnatbind (Afiles, Options & Bargs_Options);
+ Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
declare
Params : OS_Lib.Argument_List :=
@@ -233,7 +238,7 @@ package body MDLL is
Ofiles &
All_Options;
begin
- Utl.Gnatlink (Afiles (Afiles'Last).all, Params);
+ Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
end;
OS_Lib.Delete_File (Exp_File, Success);
@@ -317,7 +322,7 @@ package body MDLL is
-- Build the DLL
- Utl.Gnatbind (Afiles, Options & Bargs_Options);
+ Utl.Gnatbind (L_Afiles, Options & Bargs_Options);
declare
Params : OS_Lib.Argument_List :=
@@ -328,7 +333,7 @@ package body MDLL is
Ofiles &
All_Options;
begin
- Utl.Gnatlink (Afiles (Afiles'Last).all, Params);
+ Utl.Gnatlink (L_Afiles (L_Afiles'Last).all, Params);
end;
OS_Lib.Delete_File (Exp_File, Success);
@@ -340,17 +345,35 @@ package body MDLL is
end Ada_Build_Non_Reloc_DLL;
begin
+ -- On Windows the binder file must not be in the first position
+ -- in the list. This is due to the way DLL's are built on Windows.
+ -- We swap the first ali with the last one if it is the case.
+
+ if L_Afiles'Length > 1 then
+ declare
+ Filename : constant String :=
+ Directory_Operations.Base_Name (L_Afiles (1).all);
+ First : constant Positive := Filename'First;
+
+ begin
+ if Filename (First .. First + 1) = "b~" then
+ L_Afiles (L_Afiles'Last) := Afiles (1);
+ L_Afiles (1) := Afiles (Afiles'Last);
+ end if;
+ end;
+ end if;
+
case Relocatable is
when True =>
- if Afiles'Length = 0 then
+ if L_Afiles'Length = 0 then
Build_Reloc_DLL;
else
Ada_Build_Reloc_DLL;
end if;
when False =>
- if Afiles'Length = 0 then
+ if L_Afiles'Length = 0 then
Build_Non_Reloc_DLL;
else
Ada_Build_Non_Reloc_DLL;
diff --git a/gcc/ada/memroot.adb b/gcc/ada/memroot.adb
index 2779476a160..edfce668acd 100644
--- a/gcc/ada/memroot.adb
+++ b/gcc/ada/memroot.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2002 Ada Core Technologies, Inc. --
+-- Copyright (C) 1997-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -20,16 +20,20 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with GNAT.Table;
with GNAT.HTable; use GNAT.HTable;
with Ada.Text_IO; use Ada.Text_IO;
+with System.Storage_Elements; use System.Storage_Elements;
package body Memroot is
+ Main_Name_Id : Name_Id;
+ -- The constant "main" where we should stop the backtraces
+
-------------
-- Name_Id --
-------------
@@ -79,13 +83,14 @@ package body Memroot is
function Image
(F : Frame_Id;
Max_Fil : Integer;
- Max_Lin : Integer)
- return String;
+ Max_Lin : Integer;
+ Short : Boolean := False) return String;
-- Returns an image for F containing the file name, the Line number,
- -- and the subprogram name. When possible, spaces are inserted between
- -- the line number and the subprogram name in order to align images of the
- -- same frame. Alignement is cimputed with Max_Fil & Max_Lin representing
- -- the max number of character in a filename or length in a given frame.
+ -- and if 'Short' is not true, the subprogram name. When possible, spaces
+ -- are inserted between the line number and the subprogram name in order
+ -- to align images of the same frame. Alignement is cimputed with Max_Fil
+ -- & Max_Lin representing the max number of character in a filename or
+ -- length in a given frame.
package Frames is new GNAT.Table (
Table_Component_Type => Frame,
@@ -94,14 +99,14 @@ package body Memroot is
Table_Initial => 400,
Table_Increment => 100);
- type Frame_Range is range 1 .. 513;
- function H (N : Frame) return Frame_Range;
+ type Frame_Range is range 1 .. 10000;
+ function H (N : Integer_Address) return Frame_Range;
package Frame_HTable is new GNAT.HTable.Simple_HTable (
Header_Num => Frame_Range,
Element => Frame_Id,
No_Element => No_Frame_Id,
- Key => Frame,
+ Key => Integer_Address,
Hash => H,
Equal => "=");
@@ -155,22 +160,19 @@ package body Memroot is
-- Enter_Frame --
-----------------
- function Enter_Frame (Name, File, Line : Name_Id) return Frame_Id is
- Res : Frame_Id;
-
+ function Enter_Frame
+ (Addr : System.Address;
+ Name : Name_Id;
+ File : Name_Id;
+ Line : Name_Id)
+ return Frame_Id
+ is
begin
Frames.Increment_Last;
Frames.Table (Frames.Last) := Frame'(Name, File, Line);
- Res := Frame_HTable.Get (Frames.Table (Frames.Last));
-
- if Res /= No_Frame_Id then
- Frames.Decrement_Last;
- return Res;
- else
- Frame_HTable.Set (Frames.Table (Frames.Last), Frames.Last);
- return Frames.Last;
- end if;
+ Frame_HTable.Set (To_Integer (Addr), Frames.Last);
+ return Frames.Last;
end Enter_Frame;
----------------
@@ -285,10 +287,9 @@ package body Memroot is
return H (String (Chars.Table (N.First .. N.Last)));
end H;
- function H (N : Frame) return Frame_Range is
+ function H (N : Integer_Address) return Frame_Range is
begin
- return Frame_Range (1 + (7 * N.Name + 13 * N.File + 17 * N.Line)
- mod Frame_Range'Range_Length);
+ return Frame_Range (1 + N mod Frame_Range'Range_Length);
end H;
---------------------
@@ -314,9 +315,9 @@ package body Memroot is
function Image
(F : Frame_Id;
Max_Fil : Integer;
- Max_Lin : Integer)
- return String is
-
+ Max_Lin : Integer;
+ Short : Boolean := False) return String
+ is
Fram : Frame renames Frames.Table (F);
Fil : Name renames Names.Table (Fram.File);
Lin : Name renames Names.Table (Fram.Line);
@@ -329,12 +330,18 @@ package body Memroot is
Spaces : constant String (1 .. 80) := (1 .. 80 => ' ');
- begin
- return String (Chars.Table (Fil.First .. Fil.Last))
+ Result : constant String :=
+ String (Chars.Table (Fil.First .. Fil.Last))
& ':'
- & String (Chars.Table (Lin.First .. Lin.Last))
- & Spaces (1 .. 1 + Max_Fil - Fil_Len + Max_Lin - Lin_Len)
- & String (Chars.Table (Nam.First .. Nam.Last));
+ & String (Chars.Table (Lin.First .. Lin.Last));
+ begin
+ if Short then
+ return Result;
+ else
+ return Result
+ & Spaces (1 .. 1 + Max_Fil - Fil_Len + Max_Lin - Lin_Len)
+ & String (Chars.Table (Nam.First .. Nam.Last));
+ end if;
end Image;
-------------
@@ -361,7 +368,7 @@ package body Memroot is
-- Print_BT --
--------------
- procedure Print_BT (B : Root_Id) is
+ procedure Print_BT (B : Root_Id; Short : Boolean := False) is
Max_Col_Width : constant := 35;
-- Largest filename length for which backtraces will be
-- properly aligned. Frames containing longer names won't be
@@ -392,7 +399,7 @@ package body Memroot is
for J in F'Range loop
Put (" ");
- Put_Line (Image (F (J), Max_Fil, Max_Lin));
+ Put_Line (Image (F (J), Max_Fil, Max_Lin, Short));
end loop;
end Print_BT;
@@ -400,7 +407,7 @@ package body Memroot is
-- Read_BT --
-------------
- function Read_BT (BT_Depth : Integer; FT : File_Type) return Root_Id is
+ function Read_BT (BT_Depth : Integer) return Root_Id is
Max_Line : constant Integer := 500;
Curs1 : Integer;
Curs2 : Integer;
@@ -411,9 +418,11 @@ package body Memroot is
Nam : Name_Id;
Fil : Name_Id;
Lin : Name_Id;
-
- No_File : Boolean := False;
+ Add : System.Address;
+ Int_Add : Integer_Address;
+ Fr : Frame_Id;
Main_Found : Boolean := False;
+ pragma Warnings (Off, Line);
procedure Find_File;
-- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
@@ -430,79 +439,32 @@ package body Memroot is
-- Position Curs1 and Curs2 so that Line (Curs1 .. Curs2) contains
-- the subprogram name.
- procedure Gmem_Read_BT_Frame (Buf : out String; Last : out Natural);
- -- GMEM functionality binding
+ function Skip_To_Space (Pos : Integer) return Integer;
+ -- Scans Line starting with position Pos, returning the position
+ -- immediately before the first space, or the value of Last if no
+ -- spaces were found
+
+
+ pragma Inline (Find_File, Find_Line, Find_Name, Skip_To_Space);
---------------
-- Find_File --
---------------
procedure Find_File is
- Match_Parent : Integer;
-
begin
- -- Skip parameters
-
- Curs1 := Curs2 + 3;
- Match_Parent := 1;
- while Curs1 <= Last loop
- if Line (Curs1) = '(' then
- Match_Parent := Match_Parent + 1;
- elsif Line (Curs1) = ')' then
- Match_Parent := Match_Parent - 1;
- exit when Match_Parent = 0;
- end if;
-
- Curs1 := Curs1 + 1;
- end loop;
-
-- Skip " at "
- Curs1 := Curs1 + 5;
-
- if Curs1 >= Last then
-
- -- Maybe the file reference is on one of the next lines
-
- Read : loop
- Get_Line (FT, Line, Last);
-
- -- If we have another Frame or if the backtrace is finished
- -- the file reference was just missing
-
- if Last <= 1 or else Line (1) = '#' then
- No_File := True;
- Curs2 := Curs1 - 1;
- return;
-
- else
- Curs1 := 1;
- while Curs1 <= Last - 2 loop
- if Line (Curs1) = '(' then
- Match_Parent := Match_Parent + 1;
- elsif Line (Curs1) = ')' then
- Match_Parent := Match_Parent - 1;
- end if;
-
- if Match_Parent = 0
- and then Line (Curs1 .. Curs1 + 1) = "at"
- then
- Curs1 := Curs1 + 3;
- exit Read;
- end if;
-
- Curs1 := Curs1 + 1;
- end loop;
- end if;
- end loop Read;
- end if;
+ Curs1 := Curs2 + 5;
+ Curs2 := Last;
- -- Let's assume that the filename length is greater than 1
- -- it simplifies dealing with the potential drive ':' on
- -- windows systems
+ -- Scan backwards from end of line until ':' is encountered
- Curs2 := Curs1 + 1;
- while Line (Curs2 + 1) /= ':' loop Curs2 := Curs2 + 1; end loop;
+ for J in reverse Curs1 .. Last loop
+ if Line (J) = ':' then
+ Curs2 := J - 1;
+ end if;
+ end loop;
end Find_File;
---------------
@@ -513,8 +475,12 @@ package body Memroot is
begin
Curs1 := Curs2 + 2;
Curs2 := Last;
- if Curs2 - Curs1 > 5 then
- raise Constraint_Error;
+
+ -- Check for Curs1 too large. Should never happen with non-corrupt
+ -- output. If it does happen, just reset it to the highest value.
+
+ if Curs1 > Last then
+ Curs1 := Last;
end if;
end Find_Line;
@@ -524,93 +490,78 @@ package body Memroot is
procedure Find_Name is
begin
- Curs1 := 3;
-
- -- Skip Frame #
+ -- Skip the address value and " in "
- while Line (Curs1) /= ' ' loop Curs1 := Curs1 + 1; end loop;
-
- -- Skip spaces
-
- while Line (Curs1) = ' ' loop Curs1 := Curs1 + 1; end loop;
-
- Curs2 := Curs1;
- while Line (Curs2 + 1) /= ' ' loop Curs2 := Curs2 + 1; end loop;
+ Curs1 := Skip_To_Space (1) + 5;
+ Curs2 := Skip_To_Space (Curs1);
end Find_Name;
- ------------------------
- -- Gmem_Read_BT_Frame --
- ------------------------
-
- procedure Gmem_Read_BT_Frame (Buf : out String; Last : out Natural) is
- procedure Read_BT_Frame (buf : System.Address);
- pragma Import (C, Read_BT_Frame, "__gnat_gmem_read_bt_frame");
+ -------------------
+ -- Skip_To_Space --
+ -------------------
- function Strlen (chars : System.Address) return Natural;
- pragma Import (C, Strlen, "strlen");
-
- S : String (1 .. 1000);
+ function Skip_To_Space (Pos : Integer) return Integer is
begin
- Read_BT_Frame (S'Address);
- Last := Strlen (S'Address);
- Buf (1 .. Last) := S (1 .. Last);
- end Gmem_Read_BT_Frame;
+ for Cur in Pos .. Last loop
+ if Line (Cur) = ' ' then
+ return Cur - 1;
+ end if;
+ end loop;
+
+ return Last;
+ end Skip_To_Space;
+
+ procedure Gmem_Read_Next_Frame (Addr : out System.Address);
+ pragma Import (C, Gmem_Read_Next_Frame, "__gnat_gmem_read_next_frame");
+ -- Read the next frame in the current traceback. Addr is set to 0 if
+ -- there are no more addresses in this traceback. The pointer is moved
+ -- to the next frame.
+
+ procedure Gmem_Symbolic
+ (Addr : System.Address; Buf : String; Last : out Natural);
+ pragma Import (C, Gmem_Symbolic, "__gnat_gmem_symbolic");
+ -- Get the symbolic traceback for Addr. Note: we cannot use
+ -- GNAT.Tracebacks.Symbolic, since the latter will only work with the
+ -- current executable.
+ --
+ -- "__gnat_gmem_symbolic" will work with the executable whose name is
+ -- given in gnat_argv[0], as initialized by Gnatmem.Gmem_A21_Initialize.
-- Start of processing for Read_BT
begin
+ while F <= BT_Depth and then not Main_Found loop
+ Gmem_Read_Next_Frame (Add);
+ Int_Add := To_Integer (Add);
+ exit when Int_Add = 0;
- if Gmem_Mode then
- Gmem_Read_BT_Frame (Line, Last);
- else
- Line (1) := ' ';
- while Line (1) /= '#' loop
- Get_Line (FT, Line, Last);
- end loop;
- end if;
+ Fr := Frame_HTable.Get (Int_Add);
- while Last >= 1 and then Line (1) = '#' and then not Main_Found loop
- if F <= BT_Depth then
+ if Fr = No_Frame_Id then
+ Gmem_Symbolic (Add, Line, Last);
+ Last := Last - 1; -- get rid of the trailing line-feed
Find_Name;
+
-- Skip the __gnat_malloc frame itself
+
if Line (Curs1 .. Curs2) /= "<__gnat_malloc>" then
Nam := Enter_Name (Line (Curs1 .. Curs2));
- Main_Found := Line (Curs1 .. Curs2) = "main";
+ Main_Found := (Nam = Main_Name_Id);
Find_File;
+ Fil := Enter_Name (Line (Curs1 .. Curs2));
+ Find_Line;
+ Lin := Enter_Name (Line (Curs1 .. Curs2));
- if No_File then
- Fil := No_Name_Id;
- Lin := No_Name_Id;
- else
- Fil := Enter_Name (Line (Curs1 .. Curs2));
-
- Find_Line;
- Lin := Enter_Name (Line (Curs1 .. Curs2));
- end if;
-
- Frames (F) := Enter_Frame (Nam, Fil, Lin);
+ Frames (F) := Enter_Frame (Add, Nam, Fil, Lin);
F := F + 1;
end if;
- end if;
-
- if No_File then
-
- -- If no file reference was found, the next line has already
- -- been read because, it may sometimes be found on the next
- -- line
-
- No_File := False;
else
- if Gmem_Mode then
- Gmem_Read_BT_Frame (Line, Last);
- else
- Get_Line (FT, Line, Last);
- exit when End_Of_File (FT);
- end if;
+ Frames (F) := Fr;
+ Main_Found := (Memroot.Frames.Table (Fr).Name = Main_Name_Id);
+ F := F + 1;
end if;
-
end loop;
return Enter_Root (Frames (1 .. F - 1));
@@ -661,4 +612,5 @@ begin
Names.Increment_Last;
Names.Table (Names.Last) := Name'(1, 0);
+ Main_Name_Id := Enter_Name ("main");
end Memroot;
diff --git a/gcc/ada/memroot.ads b/gcc/ada/memroot.ads
index 03399109657..9daf4d54181 100644
--- a/gcc/ada/memroot.ads
+++ b/gcc/ada/memroot.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2001 Ada Core Technologies, Inc. --
+-- Copyright (C) 1997-2003 Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -20,7 +20,7 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -36,13 +36,9 @@
-- through a Name_Id in order to avoid duplication.
with System.Storage_Elements; use System.Storage_Elements;
-with Ada.Text_IO; use Ada.Text_IO;
package Memroot is
- -- Work with instrumented allocation routines
- Gmem_Mode : Boolean := False;
-
-- Simple abstract type for names. A name is a sequence of letters.
type Name_Id is new Natural;
@@ -57,7 +53,12 @@ package Memroot is
type Frame_Id is new Natural;
No_Frame_Id : constant Frame_Id := 0;
- function Enter_Frame (Name, File, Line : Name_Id) return Frame_Id;
+ function Enter_Frame
+ (Addr : System.Address;
+ Name : Name_Id;
+ File : Name_Id;
+ Line : Name_Id)
+ return Frame_Id;
type Frame_Array is array (Natural range <>) of Frame_Id;
@@ -69,8 +70,8 @@ package Memroot is
type Root_Id is new Natural;
No_Root_Id : constant Root_Id := 0;
- function Read_BT (BT_Depth : Integer; FT : File_Type) return Root_Id;
- -- Read a backtrace from file FT whose maximum frame number is given by
+ function Read_BT (BT_Depth : Integer) return Root_Id;
+ -- Reads a backtrace whose maximum frame number is given by
-- BT_Depth and returns the corresponding Allocation root.
function Enter_Root (Fr : Frame_Array) return Root_Id;
@@ -79,8 +80,10 @@ package Memroot is
function Frames_Of (B : Root_Id) return Frame_Array;
-- Retreives the Frames of the root's backtrace
- procedure Print_BT (B : Root_Id);
+ procedure Print_BT (B : Root_Id; Short : Boolean := False);
-- Prints on standard out the backtrace associated with the root B
+ -- When Short is set to True, only the filename & line info is printed.
+ -- When it is set to false, the subprogram name is also printed.
function Get_First return Root_Id;
function Get_Next return Root_Id;
diff --git a/gcc/ada/memtrack.adb b/gcc/ada/memtrack.adb
index f23f76c3eee..30eb2e61ebf 100644
--- a/gcc/ada/memtrack.adb
+++ b/gcc/ada/memtrack.adb
@@ -4,13 +4,9 @@
-- --
-- S Y S T E M . M E M O R Y --
-- --
--- S p e c --
+-- B o d y --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
+-- Copyright (C) 2001-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- --
@@ -36,30 +32,33 @@
------------------------------------------------------------------------------
-- This version contains allocation tracking capability.
+
-- The object file corresponding to this instrumented version is to be found
-- in libgmem.
+
-- When enabled, the subsystem logs all the calls to __gnat_malloc and
-- __gnat_free. This log can then be processed by gnatmem to detect
-- dynamic memory leaks.
---
+
-- To use this functionality, you must compile your application with -g
-- and then link with this object file:
---
+
-- gnatmake -g program -largs -lgmem
---
+
-- After compilation, you may use your program as usual except that upon
-- completion, it will generate in the current directory the file gmem.out.
---
+
-- You can then investigate for possible memory leaks and mismatch by calling
-- gnatmem with this file as an input:
---
+
-- gnatmem -i gmem.out program
---
+
-- See gnatmem section in the GNAT User's Guide for more details.
---
+
-- NOTE: This capability is currently supported on the following targets:
---
+
-- Windows
+-- AIX
-- GNU/Linux
-- HP-UX
-- Irix
@@ -71,12 +70,14 @@ pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb");
with Ada.Exceptions;
with System.Soft_Links;
with System.Traceback;
+with System.Traceback_Entries;
package body System.Memory is
use Ada.Exceptions;
use System.Soft_Links;
use System.Traceback;
+ use System.Traceback_Entries;
function c_malloc (Size : size_t) return System.Address;
pragma Import (C, c_malloc, "malloc");
@@ -122,13 +123,8 @@ package body System.Memory is
Max_Call_Stack : constant := 200;
-- Maximum number of frames supported
- Skip_Frame : constant := 1;
- -- Number of frames to remove from the call stack to hide functions from
- -- this unit.
-
- Tracebk : aliased array (0 .. Max_Call_Stack) of System.Address;
+ Tracebk : aliased array (0 .. Max_Call_Stack) of Traceback_Entry;
Num_Calls : aliased Integer := 0;
- -- Store the current call stack from Alloc and Free
Gmemfname : constant String := "gmem.out" & ASCII.NUL;
-- Allocation log of a program is saved in a file gmem.out
@@ -143,6 +139,11 @@ package body System.Memory is
-- header string is used as a magic-tag to know if the .out file is to be
-- handled by GDB or by the GMEM (instrumented malloc/free) implementation.
+ First_Call : Boolean := True;
+ -- Depending on implementation, some of the traceback routines may
+ -- themselves do dynamic allocation. We use First_Call flag to avoid
+ -- infinite recursion
+
-----------
-- Alloc --
-----------
@@ -169,21 +170,35 @@ package body System.Memory is
Result := c_malloc (Actual_Size);
- -- Logs allocation call
- -- format is:
- -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
-
- Gmem_Initialize;
- Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls);
- Num_Calls := Num_Calls - Skip_Frame;
- fputc (Character'Pos ('A'), Gmemfile);
- fwrite (Result'Address, Address_Size, 1, Gmemfile);
- fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
- Gmemfile);
- fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
- Gmemfile);
- fwrite (Tracebk (Skip_Frame)'Address, Address_Size, size_t (Num_Calls),
- Gmemfile);
+ if First_Call then
+
+ -- Logs allocation call
+ -- format is:
+ -- 'A' <mem addr> <size chunk> <len backtrace> <addr1> ... <addrn>
+
+ First_Call := False;
+
+ Gmem_Initialize;
+ Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
+ Skip_Frames => 2);
+ fputc (Character'Pos ('A'), Gmemfile);
+ fwrite (Result'Address, Address_Size, 1, Gmemfile);
+ fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1,
+ Gmemfile);
+ fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
+ Gmemfile);
+
+ for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
+ declare
+ Ptr : System.Address := PC_For (Tracebk (J));
+ begin
+ fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
+ end;
+ end loop;
+
+ First_Call := True;
+
+ end if;
Unlock_Task.all;
@@ -217,21 +232,35 @@ package body System.Memory is
begin
Lock_Task.all;
- -- Logs deallocation call
- -- format is:
- -- 'D' <mem addr> <len backtrace> <addr1> ... <addrn>
-
- Gmem_Initialize;
- Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls);
- Num_Calls := Num_Calls - Skip_Frame;
- fputc (Character'Pos ('D'), Gmemfile);
- fwrite (Addr'Address, Address_Size, 1, Gmemfile);
- fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
- Gmemfile);
- fwrite (Tracebk (Skip_Frame)'Address, Address_Size, size_t (Num_Calls),
- Gmemfile);
-
- c_free (Ptr);
+ if First_Call then
+
+ -- Logs deallocation call
+ -- format is:
+ -- 'D' <mem addr> <len backtrace> <addr1> ... <addrn>
+
+ First_Call := False;
+
+ Gmem_Initialize;
+ Call_Chain (Tracebk'Address, Max_Call_Stack, Num_Calls,
+ Skip_Frames => 2);
+ fputc (Character'Pos ('D'), Gmemfile);
+ fwrite (Addr'Address, Address_Size, 1, Gmemfile);
+ fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1,
+ Gmemfile);
+
+ for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop
+ declare
+ Ptr : System.Address := PC_For (Tracebk (J));
+ begin
+ fwrite (Ptr'Address, Address_Size, 1, Gmemfile);
+ end;
+ end loop;
+
+ c_free (Ptr);
+
+ First_Call := True;
+
+ end if;
Unlock_Task.all;
end Free;
diff --git a/gcc/ada/misc.c b/gcc/ada/misc.c
index 45f069d32fb..83907b94903 100644
--- a/gcc/ada/misc.c
+++ b/gcc/ada/misc.c
@@ -6,7 +6,6 @@
* *
* C Implementation File *
* *
- * *
* Copyright (C) 1992-2003 Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
@@ -80,19 +79,25 @@
extern FILE *asm_out_file;
-static size_t gnat_tree_size PARAMS ((enum tree_code));
-static bool gnat_init PARAMS ((void));
+/* The largest alignment, in bits, that is needed for using the widest
+ move instruction. */
+unsigned int largest_move_alignment;
+
+static size_t gnat_tree_size (enum tree_code);
+static bool gnat_init (void);
+static void gnat_finish_incomplete_decl (tree);
static unsigned int gnat_init_options (unsigned int, const char **);
-static int gnat_handle_option (size_t scode, const char *arg, int value);
-static HOST_WIDE_INT gnat_get_alias_set PARAMS ((tree));
-static void gnat_print_decl PARAMS ((FILE *, tree, int));
-static void gnat_print_type PARAMS ((FILE *, tree, int));
-static const char *gnat_printable_name PARAMS ((tree, int));
-static tree gnat_eh_runtime_type PARAMS ((tree));
-static int gnat_eh_type_covers PARAMS ((tree, tree));
-static void gnat_parse_file PARAMS ((int));
-static rtx gnat_expand_expr PARAMS ((tree, rtx, enum machine_mode,
- int));
+static int gnat_handle_option (size_t, const char *, int);
+static HOST_WIDE_INT gnat_get_alias_set (tree);
+static void gnat_print_decl (FILE *, tree, int);
+static void gnat_print_type (FILE *, tree, int);
+static const char *gnat_printable_name (tree, int);
+static tree gnat_eh_runtime_type (tree);
+static int gnat_eh_type_covers (tree, tree);
+static void gnat_parse_file (int);
+static rtx gnat_expand_expr (tree, rtx, enum machine_mode, int);
+static void internal_error_function (const char *, va_list *);
+static void gnat_adjust_rli (record_layout_info);
/* Structure giving our language-specific hooks. */
@@ -180,7 +185,10 @@ const char *const tree_code_name[] = {
};
#undef DEFTREECODE
-/* Command-line argc and argv. */
+/* Command-line argc and argv.
+ These variables are global, since they are imported and used in
+ back_end.adb */
+
unsigned int save_argc;
const char **save_argv;
@@ -189,19 +197,16 @@ const char **save_argv;
extern int gnat_argc;
extern char **gnat_argv;
-static void internal_error_function PARAMS ((const char *, va_list *));
-static void gnat_adjust_rli PARAMS ((record_layout_info));
/* Declare functions we use as part of startup. */
-extern void __gnat_initialize PARAMS((void));
-extern void adainit PARAMS((void));
-extern void _ada_gnat1drv PARAMS((void));
+extern void __gnat_initialize (void);
+extern void adainit (void);
+extern void _ada_gnat1drv (void);
/* The parser for the language. For us, we process the GNAT tree. */
static void
-gnat_parse_file (set_yydebug)
- int set_yydebug ATTRIBUTE_UNUSED;
+gnat_parse_file (int set_yydebug ATTRIBUTE_UNUSED)
{
/* call the target specific initializations */
__gnat_initialize();
@@ -223,14 +228,21 @@ gnat_parse_file (set_yydebug)
static int
gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
{
+ const struct cl_option *option = &cl_options[scode];
enum opt_code code = (enum opt_code) scode;
char *q;
unsigned int i;
+ if (arg == NULL && (option->flags & (CL_JOINED | CL_SEPARATE)))
+ {
+ error ("missing argument to \"-%s\"", option->opt_text);
+ return 1;
+ }
+
switch (code)
{
default:
- abort();
+ abort ();
case OPT_I:
q = xmalloc (sizeof("-I") + strlen (arg));
@@ -240,8 +252,17 @@ gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
gnat_argc++;
break;
- case OPT_Wall:
/* All front ends are expected to accept this. */
+ case OPT_Wall:
+ /* These are used in the GCC Makefile. */
+ case OPT_Wmissing_prototypes:
+ case OPT_Wstrict_prototypes:
+ case OPT_Wwrite_strings:
+ case OPT_Wno_long_long:
+ break;
+
+ /* This is handled by the front-end. */
+ case OPT_nostdinc:
break;
case OPT_fRTS:
@@ -251,10 +272,11 @@ gnat_handle_option (size_t scode, const char *arg, int value ATTRIBUTE_UNUSED)
case OPT_gant:
warning ("`-gnat' misspelled as `-gant'");
- break;
+
+ /* ... fall through ... */
case OPT_gnat:
- /* Recopy the switches without the 'gnat' prefix */
+ /* Recopy the switches without the 'gnat' prefix. */
gnat_argv[gnat_argc] = xmalloc (strlen (arg) + 2);
gnat_argv[gnat_argc][0] = '-';
strcpy (gnat_argv[gnat_argc] + 1, arg);
@@ -295,9 +317,7 @@ gnat_init_options (unsigned int argc, const char **argv)
/* Here is the function to handle the compiler error processing in GCC. */
static void
-internal_error_function (msgid, ap)
- const char *msgid;
- va_list *ap;
+internal_error_function (const char *msgid, va_list *ap)
{
char buffer[1000]; /* Assume this is big enough. */
char *p;
@@ -321,13 +341,15 @@ internal_error_function (msgid, ap)
Compiler_Abort (fp, -1);
}
-/* Langhook for tree_size: determine size of our 'x' and 'c' nodes. */
+/* Langhook for tree_size: Determine size of our 'x' and 'c' nodes. */
+
static size_t
gnat_tree_size (enum tree_code code)
{
switch (code)
{
- case GNAT_LOOP_ID: return sizeof (struct tree_loop_id);
+ case GNAT_LOOP_ID:
+ return sizeof (struct tree_loop_id);
default:
abort ();
}
@@ -340,11 +362,7 @@ static bool
gnat_init ()
{
/* Performs whatever initialization steps needed by the language-dependent
- lexical analyzer.
-
- Define the additional tree codes here. This isn't the best place to put
- it, but it's where g++ does it. */
-
+ lexical analyzer. */
gnat_init_decl_processing ();
/* Add the input filename as the last argument. */
@@ -362,7 +380,35 @@ gnat_init ()
return true;
}
-/* If we are using the GCC mechanism for to process exception handling, we
+/* This function is called indirectly from toplev.c to handle incomplete
+ declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise,
+ compile_file in toplev.c makes an indirect call through the function pointer
+ incomplete_decl_finalize_hook which is initialized to this routine in
+ init_decl_processing. */
+
+static void
+gnat_finish_incomplete_decl (tree dont_care ATTRIBUTE_UNUSED)
+{
+ gigi_abort (202);
+}
+
+/* Compute the alignment of the largest mode that can be used for copying
+ objects. */
+
+void
+gnat_compute_largest_alignment ()
+{
+ enum machine_mode mode;
+
+ for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT); mode != VOIDmode;
+ mode = GET_MODE_WIDER_MODE (mode))
+ if (mov_optab->handlers[(int) mode].insn_code != CODE_FOR_nothing)
+ largest_move_alignment = MIN (BIGGEST_ALIGNMENT,
+ MAX (largest_move_alignment,
+ GET_MODE_ALIGNMENT (mode)));
+}
+
+/* If we are using the GCC mechanism to process exception handling, we
have to register the personality routine for Ada and to initialize
various language dependent hooks. */
@@ -376,10 +422,28 @@ gnat_init_gcc_eh ()
if (No_Exception_Handlers_Set ())
return;
+ /* Tell GCC we are handling cleanup actions through exception propagation.
+ This opens possibilities that we don't take advantage of yet, but is
+ nonetheless necessary to ensure that fixup code gets assigned to the
+ right exception regions. */
+ using_eh_for_cleanups ();
+
eh_personality_libfunc = init_one_libfunc ("__gnat_eh_personality");
lang_eh_type_covers = gnat_eh_type_covers;
lang_eh_runtime_type = gnat_eh_runtime_type;
+
+ /* Turn on -fexceptions and -fnon-call-exceptions. The first one triggers
+ the generation of the necessary exception runtime tables. The second one
+ is useful for two reasons: 1/ we map some asynchronous signals like SEGV
+ to exceptions, so we need to ensure that the insns which can lead to such
+ signals are correctly attached to the exception region they pertain to,
+ 2/ Some calls to pure subprograms are handled as libcall blocks and then
+ marked as "cannot trap" if the flag is not set (see emit_libcall_block).
+ We should not let this be since it is possible for such calls to actually
+ raise in Ada. */
+
flag_exceptions = 1;
+ flag_non_call_exceptions = 1;
init_eh ();
#ifdef DWARF2_UNWIND_INFO
@@ -388,13 +452,10 @@ gnat_init_gcc_eh ()
#endif
}
-/* Hooks for print-tree.c: */
+/* Language hooks, first one to print language-specific items in a DECL. */
static void
-gnat_print_decl (file, node, indent)
- FILE *file;
- tree node;
- int indent;
+gnat_print_decl (FILE *file, tree node, int indent)
{
switch (TREE_CODE (node))
{
@@ -414,10 +475,7 @@ gnat_print_decl (file, node, indent)
}
static void
-gnat_print_type (file, node, indent)
- FILE *file;
- tree node;
- int indent;
+gnat_print_type (FILE *file, tree node, int indent)
{
switch (TREE_CODE (node))
{
@@ -466,9 +524,7 @@ gnat_print_type (file, node, indent)
}
static const char *
-gnat_printable_name (decl, verbosity)
- tree decl;
- int verbosity ATTRIBUTE_UNUSED;
+gnat_printable_name (tree decl, int verbosity ATTRIBUTE_UNUSED)
{
const char *coded_name = IDENTIFIER_POINTER (DECL_NAME (decl));
char *ada_name = (char *) ggc_alloc (strlen (coded_name) * 2 + 60);
@@ -482,18 +538,13 @@ gnat_printable_name (decl, verbosity)
here are TRANSFORM_EXPR, ALLOCATE_EXPR, USE_EXPR and NULL_EXPR. */
static rtx
-gnat_expand_expr (exp, target, tmode, modifier)
- tree exp;
- rtx target;
- enum machine_mode tmode;
- int modifier; /* Actually an enum expand_modifier. */
+gnat_expand_expr (tree exp, rtx target, enum machine_mode tmode, int modifier)
{
tree type = TREE_TYPE (exp);
tree new;
rtx result;
/* Update EXP to be the new expression to expand. */
-
switch (TREE_CODE (exp))
{
case TRANSFORM_EXPR:
@@ -561,18 +612,34 @@ gnat_expand_expr (exp, target, tmode, modifier)
that will pad the record at the end. */
static void
-gnat_adjust_rli (rli)
- record_layout_info rli ATTRIBUTE_UNUSED;
+gnat_adjust_rli (record_layout_info rli ATTRIBUTE_UNUSED)
{
- /* This function has no actual effect; record_align should already
+#if 0
+ /* ??? This code seems to have no actual effect; record_align should already
reflect the largest alignment desired by a field. jason 2003-04-01 */
+ unsigned int record_align = rli->unpadded_align;
+ tree field;
+
+ /* If an alignment has been specified, don't use anything larger unless we
+ have to. */
+ if (TYPE_ALIGN (rli->t) != 0 && TYPE_ALIGN (rli->t) < record_align)
+ record_align = MAX (rli->record_align, TYPE_ALIGN (rli->t));
+
+ /* If any fields have variable size, we need to force the record to be at
+ least as aligned as the alignment of that type. */
+ for (field = TYPE_FIELDS (rli->t); field; field = TREE_CHAIN (field))
+ if (TREE_CODE (DECL_SIZE_UNIT (field)) != INTEGER_CST)
+ record_align = MAX (record_align, DECL_ALIGN (field));
+
+ if (TYPE_PACKED (rli->t))
+ rli->record_align = record_align;
+#endif
}
/* Make a TRANSFORM_EXPR to later expand GNAT_NODE into code. */
tree
-make_transform_expr (gnat_node)
- Node_Id gnat_node;
+make_transform_expr (Node_Id gnat_node)
{
tree gnu_result = build (TRANSFORM_EXPR, void_type_node);
@@ -585,8 +652,7 @@ make_transform_expr (gnat_node)
here that a __builtin_setjmp was done to BUF. */
void
-update_setjmp_buf (buf)
- tree buf;
+update_setjmp_buf (tree buf)
{
enum machine_mode sa_mode = Pmode;
rtx stack_save;
@@ -621,8 +687,7 @@ update_setjmp_buf (buf)
/* Map compile-time to run-time tree for GCC exception handling scheme. */
static tree
-gnat_eh_runtime_type (type)
- tree type;
+gnat_eh_runtime_type (tree type)
{
return type;
}
@@ -631,8 +696,7 @@ gnat_eh_runtime_type (type)
the exception handling part of the back-end. */
static int
-gnat_eh_type_covers (a, b)
- tree a, b;
+gnat_eh_type_covers (tree a, tree b)
{
/* a catches b if they represent the same exception id or if a
is an "others".
@@ -647,8 +711,7 @@ gnat_eh_type_covers (a, b)
This improves the debugger's ability to display the value. */
void
-adjust_decl_rtl (decl)
- tree decl;
+adjust_decl_rtl (tree decl)
{
tree new_type;
@@ -706,8 +769,7 @@ adjust_decl_rtl (decl)
/* Record the current code position in GNAT_NODE. */
void
-record_code_position (gnat_node)
- Node_Id gnat_node;
+record_code_position (Node_Id gnat_node)
{
if (global_bindings_p ())
{
@@ -728,8 +790,7 @@ record_code_position (gnat_node)
/* Insert the code for GNAT_NODE at the position saved for that node. */
void
-insert_code_for (gnat_node)
- Node_Id gnat_node;
+insert_code_for (Node_Id gnat_node)
{
if (global_bindings_p ())
{
@@ -757,8 +818,7 @@ insert_code_for (gnat_node)
/* Get the alias set corresponding to a type or expression. */
static HOST_WIDE_INT
-gnat_get_alias_set (type)
- tree type;
+gnat_get_alias_set (tree type)
{
/* If this is a padding type, use the type of the first field. */
if (TREE_CODE (type) == RECORD_TYPE
@@ -779,8 +839,7 @@ gnat_get_alias_set (type)
default. */
int
-default_pass_by_ref (gnu_type)
- tree gnu_type;
+default_pass_by_ref (tree gnu_type)
{
CUMULATIVE_ARGS cum;
@@ -808,8 +867,7 @@ default_pass_by_ref (gnu_type)
it should be passed by reference. */
int
-must_pass_by_ref (gnu_type)
- tree gnu_type;
+must_pass_by_ref (tree gnu_type)
{
/* We pass only unconstrained objects, those required by the language
to be passed by reference, and objects of variable size. The latter
@@ -821,11 +879,3 @@ must_pass_by_ref (gnu_type)
|| (TYPE_SIZE (gnu_type) != 0
&& TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST));
}
-
-/* This function returns the version of GCC being used. Here it's GCC 3. */
-
-int
-gcc_version ()
-{
- return 3;
-}
diff --git a/gcc/ada/mkdir.c b/gcc/ada/mkdir.c
index 5c9b445d0d2..2501461f9f0 100644
--- a/gcc/ada/mkdir.c
+++ b/gcc/ada/mkdir.c
@@ -4,10 +4,9 @@
* *
* M K D I R *
* *
- * *
* C Implementation File *
* *
- * Copyright (C) 2002, Free Software Foundation, Inc. *
+ * Copyright (C) 2002-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- *
@@ -31,14 +30,22 @@
* *
****************************************************************************/
-/* This file provides a portable binding to the mkdir() function */
-
#ifdef __vxworks
#include "vxWorks.h"
#endif /* __vxworks */
-#include <sys/types.h>
+#ifdef IN_RTS
+#include "tconfig.h"
+#include "tsystem.h"
#include <sys/stat.h>
+#else
+#include "config.h"
+#include "system.h"
+#endif
+
+#include "adaint.h"
+
+/* This function provides a portable binding to the mkdir function. */
int
__gnat_mkdir (dir_name)
diff --git a/gcc/ada/mlib-fil.adb b/gcc/ada/mlib-fil.adb
index 83c59f25e90..534a7d1619f 100644
--- a/gcc/ada/mlib-fil.adb
+++ b/gcc/ada/mlib-fil.adb
@@ -20,7 +20,7 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/mlib-fil.ads b/gcc/ada/mlib-fil.ads
index 04e529907e3..fa44f22d874 100644
--- a/gcc/ada/mlib-fil.ads
+++ b/gcc/ada/mlib-fil.ads
@@ -20,7 +20,7 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb
index 92d93adb6e4..f71ae7b2e81 100644
--- a/gcc/ada/mlib-prj.adb
+++ b/gcc/ada/mlib-prj.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001, Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -20,74 +20,191 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+with ALI; use ALI;
+with Hostparm;
+with MLib.Fil; use MLib.Fil;
+with MLib.Tgt; use MLib.Tgt;
+with MLib.Utl; use MLib.Utl;
+with Namet; use Namet;
+with Opt;
+with Output; use Output;
+with Prj.Com; use Prj.Com;
+with Prj.Env; use Prj.Env;
+with Prj.Util; use Prj.Util;
+with Sinput.P;
+with Snames; use Snames;
+with Table;
+with Types; use Types;
+
with Ada.Characters.Handling;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with MLib.Fil;
-with MLib.Tgt;
-with Opt;
-with Output; use Output;
-with Osint; use Osint;
-with Namet; use Namet;
-with Table;
-with Types; use Types;
+with GNAT.HTable;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System; use System;
+with System.Case_Util; use System.Case_Util;
package body MLib.Prj is
- package Files renames MLib.Fil;
- package Target renames MLib.Tgt;
+ Prj_Add_Obj_Files : Types.Int;
+ pragma Import (C, Prj_Add_Obj_Files, "__gnat_prj_add_obj_files");
+ Add_Object_Files : constant Boolean := Prj_Add_Obj_Files /= 0;
+ -- Indicates if object files in pragmas Linker_Options (found in the
+ -- binder generated file) should be taken when linking aq stand-alone
+ -- library.
+ -- False for Windows, True for other platforms.
+
+ ALI_Suffix : constant String := ".ali";
+ B_Start : String := "b~";
+
+ S_Osinte_Ads : Name_Id := No_Name;
+ -- Name_Id for "s-osinte.ads"
+
+ S_Dec_Ads : Name_Id := No_Name;
+ -- Name_Id for "dec.ads"
+
+ No_Argument_List : aliased String_List := (1 .. 0 => null);
+ No_Argument : constant String_List_Access := No_Argument_List'Access;
+
+ Arguments : String_List_Access := No_Argument;
+ -- Used to accumulate arguments for the invocation of gnatbind and of
+ -- the compiler. Also used to collect the interface ALI when copying
+ -- the ALI files to the library directory.
+
+ Argument_Number : Natural := 0;
+ -- Index of the last argument in Arguments
+
+ Initial_Argument_Max : constant := 10;
+
+ No_Main_String : aliased String := "-n";
+ No_Main : constant String_Access := No_Main_String'Access;
+
+ Output_Switch_String : aliased String := "-o";
+ Output_Switch : constant String_Access := Output_Switch_String'Access;
+
+ Compile_Switch_String : aliased String := "-c";
+ Compile_Switch : constant String_Access := Compile_Switch_String'Access;
-- List of objects to put inside the library
Object_Files : Argument_List_Access;
+
package Objects is new Table.Table
(Table_Name => "Mlib.Prj.Objects",
Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 50,
- Table_Increment => 50);
+ Table_Increment => 100);
+
+ package Objects_Htable is new GNAT.HTable.Simple_HTable
+ (Header_Num => Com.Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => Name_Id,
+ Hash => Com.Hash,
+ Equal => "=");
-- List of non-Ada object files
Foreign_Objects : Argument_List_Access;
+
package Foreigns is new Table.Table
(Table_Name => "Mlib.Prj.Foreigns",
Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 20,
- Table_Increment => 20);
+ Table_Increment => 100);
-- List of ALI files
Ali_Files : Argument_List_Access;
- package Alis is new Table.Table
+
+ package ALIs is new Table.Table
(Table_Name => "Mlib.Prj.Alis",
Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 50,
- Table_Increment => 50);
+ Table_Increment => 100);
-- List of options set in the command line.
Options : Argument_List_Access;
+
package Opts is new Table.Table
(Table_Name => "Mlib.Prj.Opts",
Table_Component_Type => String_Access,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 5,
- Table_Increment => 5);
-
- type Build_Mode_State is
- (None, Static, Dynamic, Relocatable);
+ Table_Increment => 100);
+
+ -- All the ALI file in the library
+
+ package Library_ALIs is new GNAT.HTable.Simple_HTable
+ (Header_Num => Com.Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => Name_Id,
+ Hash => Com.Hash,
+ Equal => "=");
+
+ -- The ALI files in the interface sets
+
+ package Interface_ALIs is new GNAT.HTable.Simple_HTable
+ (Header_Num => Com.Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => Name_Id,
+ Hash => Com.Hash,
+ Equal => "=");
+
+ -- The ALI files that have been processed to check if the corresponding
+ -- library unit is in the interface set.
+
+ package Processed_ALIs is new GNAT.HTable.Simple_HTable
+ (Header_Num => Com.Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => Name_Id,
+ Hash => Com.Hash,
+ Equal => "=");
+
+ -- The projects imported directly or indirectly.
+
+ package Processed_Projects is new GNAT.HTable.Simple_HTable
+ (Header_Num => Com.Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => Name_Id,
+ Hash => Com.Hash,
+ Equal => "=");
+
+ -- The library projects imported directly or indirectly.
+
+ package Library_Projs is new Table.Table (
+ Table_Component_Type => Project_Id,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 10,
+ Table_Name => "Make.Library_Projs");
+
+ type Build_Mode_State is (None, Static, Dynamic, Relocatable);
+
+ procedure Add_Argument (S : String);
+ -- Add one argument to the array Arguments.
+ -- If Arguments is full, double its size.
+
+ function ALI_File_Name (Source : String) return String;
+ -- Return the ALI file name corresponding to a source.
procedure Check (Filename : String);
-- Check if filename is a regular file. Fail if it is not.
@@ -96,205 +213,1161 @@ package body MLib.Prj is
-- Check each object files in table Object_Files
-- Fail if any of them is not a regular file
+ procedure Clean (Directory : Name_Id);
+ -- Attempt to delete all files in Directory, but not subdirectories
+
+ procedure Copy_Interface_Sources
+ (For_Project : Project_Id;
+ Interfaces : Argument_List;
+ To_Dir : Name_Id);
+ -- Copy the interface sources of a SAL to directory To_Dir
+
+ procedure Display (Executable : String);
+ -- Display invocation of gnatbind and of the compiler with the arguments
+ -- in Arguments, except when Quiet_Output is True.
+
+ procedure Process_Binder_File (Name : String);
+ -- For Stand-Alone libraries, get the Linker Options in the binder
+ -- generated file.
+
procedure Reset_Tables;
-- Make sure that all the above tables are empty
- -- (Objects, Foreign_Objects, Ali_Files, Options)
+ -- (Objects, Foreign_Objects, Ali_Files, Options).
+
+ ------------------
+ -- Add_Argument --
+ ------------------
+
+ procedure Add_Argument (S : String) is
+ begin
+ if Argument_Number = Arguments'Last then
+ declare
+ New_Args : constant String_List_Access :=
+ new String_List (1 .. 2 * Arguments'Last);
+
+ begin
+ -- Copy the String_Accesses and set them to null in Arguments
+ -- so that they will not be deallocated by the call to
+ -- Free (Arguments).
+
+ New_Args (Arguments'Range) := Arguments.all;
+ Arguments.all := (others => null);
+ Free (Arguments);
+ Arguments := New_Args;
+ end;
+ end if;
+
+ Argument_Number := Argument_Number + 1;
+ Arguments (Argument_Number) := new String'(S);
+ end Add_Argument;
+
+ -------------------
+ -- ALI_File_Name --
+ -------------------
+
+ function ALI_File_Name (Source : String) return String is
+ begin
+ -- If the source name has an extension, then replace it with
+ -- the ALI suffix.
+
+ for Index in reverse Source'First + 1 .. Source'Last loop
+ if Source (Index) = '.' then
+ return Source (Source'First .. Index - 1) & ALI_Suffix;
+ end if;
+ end loop;
+
+ -- If there is no dot, or if it is the first character, just add the
+ -- ALI suffix.
+
+ return Source & ALI_Suffix;
+ end ALI_File_Name;
-------------------
-- Build_Library --
-------------------
- procedure Build_Library (For_Project : Project_Id) is
- Data : constant Project_Data := Projects.Table (For_Project);
+ procedure Build_Library
+ (For_Project : Project_Id;
+ Gnatbind : String;
+ Gnatbind_Path : String_Access;
+ Gcc : String;
+ Gcc_Path : String_Access;
+ Bind : Boolean := True;
+ Link : Boolean := True)
+ is
+ Warning_For_Library : Boolean := False;
+ -- Set to True for the first warning about a unit missing from the
+ -- interface set.
+
+ Libgnarl_Needed : Boolean := False;
+ -- Set to True if library needs to be linked with libgnarl
+
+ Libdecgnat_Needed : Boolean := False;
+ -- On OpenVMS, set to True if library needs to be linked with libdecgnat
- Project_Name : constant String :=
- Get_Name_String (Data.Name);
+ Data : Project_Data := Projects.Table (For_Project);
+
+ Object_Directory_Path : constant String :=
+ Get_Name_String (Data.Object_Directory);
+
+ Standalone : constant Boolean := Data.Standalone_Library;
+
+ Project_Name : constant String := Get_Name_String (Data.Name);
+
+ DLL_Address : constant String_Access :=
+ new String'(Default_DLL_Address);
+
+ Current_Dir : constant String := Get_Current_Dir;
Lib_Filename : String_Access;
- Lib_Dirpath : String_Access := new String'(".");
- DLL_Address : String_Access := new String'(Target.Default_DLL_Address);
+ Lib_Dirpath : String_Access;
Lib_Version : String_Access := new String'("");
The_Build_Mode : Build_Mode_State := None;
+ Success : Boolean := False;
+
+ Library_Options : Variable_Value := Nil_Variable_Value;
+
+ Library_GCC : Variable_Value := Nil_Variable_Value;
+
+ Driver_Name : Name_Id := No_Name;
+
+ In_Main_Object_Directory : Boolean := True;
+
+ Rpath : String_Access := null;
+ -- Allocated only if Path Option is supported
+
+ Rpath_Last : Natural := 0;
+ -- Index of last valid character of Rpath
+
+ Initial_Rpath_Length : constant := 200;
+ -- Initial size of Rpath, when first allocated
+
+ Path_Option : String_Access := Linker_Library_Path_Option;
+ -- If null, Path Option is not supported.
+ -- Not a constant so that it can be deallocated.
+
+ Copy_Dir : Name_Id;
+ -- Directory where to copy ALI files and possibly interface sources
+
+ procedure Add_ALI_For (Source : Name_Id);
+ -- Add the name of the ALI file corresponding to Source to the
+ -- Arguments.
+
+ procedure Add_Rpath (Path : String);
+ -- Add a path name to Rpath
+
+ function Check_Project (P : Project_Id) return Boolean;
+ -- Returns True if P is For_Project or a project extended by For_Project
+
+ procedure Check_Libs (ALI_File : String);
+ -- Set Libgnarl_Needed if the ALI_File indicates that there is a need
+ -- to link with -lgnarl (this is the case when there is a dependency
+ -- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file
+ -- indicates that there is a need to link with -ldecgnat (this is the
+ -- case when there is a dependency on dec.ads).
+
+ procedure Process (The_ALI : File_Name_Type);
+ -- Check if the closure of a library unit which is or should be in the
+ -- interface set is also in the interface set. Issue a warning for each
+ -- missing library unit.
+
+ procedure Process_Imported_Libraries;
+ -- Add the -L and -l switches for the imported Library Project Files,
+ -- and, if Path Option is supported, the library directory path names
+ -- to Rpath.
+
+ -----------------
+ -- Add_ALI_For --
+ -----------------
+
+ procedure Add_ALI_For (Source : Name_Id) is
+ ALI : constant String := ALI_File_Name (Get_Name_String (Source));
+ begin
+ Add_Argument (ALI);
+
+ -- Add the ALI file name to the library ALIs
+
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer (S => ALI);
+ Library_ALIs.Set (Name_Find, True);
+ end Add_ALI_For;
+
+ ---------------
+ -- Add_Rpath --
+ ---------------
+
+ procedure Add_Rpath (Path : String) is
+
+ procedure Double;
+ -- Double Rpath size
+
+ ------------
+ -- Double --
+ ------------
+
+ procedure Double is
+ New_Rpath : constant String_Access :=
+ new String (1 .. 2 * Rpath'Length);
+ begin
+ New_Rpath (1 .. Rpath_Last) := Rpath (1 .. Rpath_Last);
+ Free (Rpath);
+ Rpath := New_Rpath;
+ end Double;
+
+ -- Start of processing for Add_Rpath
+
+ begin
+ -- If firt path, allocate initial Rpath
+
+ if Rpath = null then
+ Rpath := new String (1 .. Initial_Rpath_Length);
+ Rpath_Last := 0;
+
+ else
+ -- Otherwise, add a path separator between two path names
+
+ if Rpath_Last = Rpath'Last then
+ Double;
+ end if;
+
+ Rpath_Last := Rpath_Last + 1;
+ Rpath (Rpath_Last) := Path_Separator;
+ end if;
+
+ -- Increase Rpath size until it is large enough
+
+ while Rpath_Last + Path'Length > Rpath'Last loop
+ Double;
+ end loop;
+
+ -- Add the path name
+
+ Rpath (Rpath_Last + 1 .. Rpath_Last + Path'Length) := Path;
+ Rpath_Last := Rpath_Last + Path'Length;
+ end Add_Rpath;
+
+ -------------------
+ -- Check_Project --
+ -------------------
+
+ function Check_Project (P : Project_Id) return Boolean is
+ begin
+ if P = For_Project then
+ return True;
+
+ elsif P /= No_Project then
+ declare
+ Data : Project_Data := Projects.Table (For_Project);
+
+ begin
+ while Data.Extends /= No_Project loop
+ if P = Data.Extends then
+ return True;
+ end if;
+
+ Data := Projects.Table (Data.Extends);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Check_Project;
+
+ ----------------
+ -- Check_Libs --
+ ----------------
+
+ procedure Check_Libs (ALI_File : String) is
+ Lib_File : Name_Id;
+ Text : Text_Buffer_Ptr;
+ Id : ALI.ALI_Id;
+
+ pragma Warnings (Off, Id);
+ -- Comment needed ???
+
+ begin
+ if not Libgnarl_Needed or
+ (Hostparm.OpenVMS and then (not Libdecgnat_Needed))
+ then
+ -- Scan the ALI file
+
+ Name_Len := ALI_File'Length;
+ Name_Buffer (1 .. Name_Len) := ALI_File;
+ Lib_File := Name_Find;
+ Text := Read_Library_Info (Lib_File, True);
+
+ Id := ALI.Scan_ALI
+ (F => Lib_File,
+ T => Text,
+ Ignore_ED => False,
+ Err => True,
+ Read_Lines => "D");
+ Free (Text);
+
+ -- Look for s-osinte.ads in the dependencies
+
+ for Index in ALI.ALIs.Table (Id).First_Sdep ..
+ ALI.ALIs.Table (Id).Last_Sdep
+ loop
+ if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then
+ Libgnarl_Needed := True;
+
+ elsif Hostparm.OpenVMS and then
+ ALI.Sdep.Table (Index).Sfile = S_Dec_Ads
+ then
+ Libdecgnat_Needed := True;
+ end if;
+ end loop;
+ end if;
+ end Check_Libs;
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process (The_ALI : File_Name_Type) is
+ Text : Text_Buffer_Ptr;
+ Idread : ALI_Id;
+ First_Unit : ALI.Unit_Id;
+ Last_Unit : ALI.Unit_Id;
+ Unit_Data : Unit_Record;
+ Afile : File_Name_Type;
+
+ begin
+ -- Nothing to do if the ALI file has already been processed.
+ -- This happens if an interface imports another interface.
+
+ if not Processed_ALIs.Get (The_ALI) then
+ Processed_ALIs.Set (The_ALI, True);
+ Text := Read_Library_Info (The_ALI);
+
+ if Text /= null then
+ Idread :=
+ Scan_ALI
+ (F => The_ALI,
+ T => Text,
+ Ignore_ED => False,
+ Err => True);
+ Free (Text);
+
+ if Idread /= No_ALI_Id then
+ First_Unit := ALI.ALIs.Table (Idread).First_Unit;
+ Last_Unit := ALI.ALIs.Table (Idread).Last_Unit;
+
+ -- Process both unit (spec and body) if the body is needed
+ -- by the spec (inline or generic). Otherwise, just process
+ -- the spec.
+
+ if First_Unit /= Last_Unit and then
+ not ALI.Units.Table (Last_Unit).Body_Needed_For_SAL
+ then
+ First_Unit := Last_Unit;
+ end if;
+
+ for Unit in First_Unit .. Last_Unit loop
+ Unit_Data := ALI.Units.Table (Unit);
+
+ -- Check if each withed unit which is in the library is
+ -- also in the interface set, if it has not yet been
+ -- processed.
+
+ for W in Unit_Data.First_With .. Unit_Data.Last_With loop
+ Afile := Withs.Table (W).Afile;
+
+ if Library_ALIs.Get (Afile)
+ and then not Processed_ALIs.Get (Afile)
+ then
+ if not Interface_ALIs.Get (Afile) then
+ if not Warning_For_Library then
+ Write_Str ("Warning: In library project """);
+ Get_Name_String (Data.Name);
+ To_Mixed (Name_Buffer (1 .. Name_Len));
+ Write_Str (Name_Buffer (1 .. Name_Len));
+ Write_Line ("""");
+ Warning_For_Library := True;
+ end if;
+
+ Write_Str (" Unit """);
+ Get_Name_String (Withs.Table (W).Uname);
+ To_Mixed (Name_Buffer (1 .. Name_Len - 2));
+ Write_Str (Name_Buffer (1 .. Name_Len - 2));
+ Write_Line (""" is not in the interface set");
+ Write_Str (" but it is needed by ");
+
+ case Unit_Data.Utype is
+ when Is_Spec =>
+ Write_Str ("the spec of ");
+
+ when Is_Body =>
+ Write_Str ("the body of ");
+
+ when others =>
+ null;
+ end case;
+
+ Write_Str ("""");
+ Get_Name_String (Unit_Data.Uname);
+ To_Mixed (Name_Buffer (1 .. Name_Len - 2));
+ Write_Str (Name_Buffer (1 .. Name_Len - 2));
+ Write_Line ("""");
+ end if;
+
+ -- Now, process this unit
+
+ Process (Afile);
+ end if;
+ end loop;
+ end loop;
+ end if;
+ end if;
+ end if;
+ end Process;
+
+ --------------------------------
+ -- Process_Imported_Libraries --
+ --------------------------------
+
+ procedure Process_Imported_Libraries is
+ Current : Project_Id;
+
+ procedure Process_Project (Project : Project_Id);
+ -- Process Project and its imported projects recursively.
+ -- Add any library projects to table Library_Projs.
+
+ ---------------------
+ -- Process_Project --
+ ---------------------
+
+ procedure Process_Project (Project : Project_Id) is
+ Data : constant Project_Data := Projects.Table (Project);
+ Imported : Project_List := Data.Imported_Projects;
+ Element : Project_Element;
+
+ begin
+ -- Nothing to do if process has already been processed.
+
+ if not Processed_Projects.Get (Data.Name) then
+ Processed_Projects.Set (Data.Name, True);
+
+ -- If it is a library project, add it to Library_Projs
+
+ if Project /= For_Project and then Data.Library then
+ Library_Projs.Increment_Last;
+ Library_Projs.Table (Library_Projs.Last) := Project;
+ end if;
+
+ -- Call Process_Project recursively for any imported project
+
+ while Imported /= Empty_Project_List loop
+ Element := Project_Lists.Table (Imported);
+
+ if Element.Project /= No_Project then
+ Process_Project (Element.Project);
+ end if;
+
+ Imported := Element.Next;
+ end loop;
+ end if;
+ end Process_Project;
+
+ -- Start of processing for Process_Imported_Libraries
+
+ begin
+ -- Build list of library projects imported directly or indirectly
+
+ Process_Project (For_Project);
+
+ -- If there are more that one library project file, make sure
+ -- that if libA depends on libB, libB is first in order.
+
+ if Library_Projs.Last > 1 then
+ declare
+ Index : Integer := 1;
+ Proj1 : Project_Id;
+ Proj2 : Project_Id;
+ List : Project_List := Empty_Project_List;
+
+ begin
+ Library_Loop : while Index < Library_Projs.Last loop
+ Proj1 := Library_Projs.Table (Index);
+ List := Projects.Table (Proj1).Imported_Projects;
+
+ List_Loop : while List /= Empty_Project_List loop
+ Proj2 := Project_Lists.Table (List).Project;
+
+ for J in Index + 1 .. Library_Projs.Last loop
+ if Proj2 = Library_Projs.Table (J) then
+ Library_Projs.Table (J) := Proj1;
+ Library_Projs.Table (Index) := Proj2;
+ exit List_Loop;
+ end if;
+ end loop;
+
+ List := Project_Lists.Table (List).Next;
+ end loop List_Loop;
+
+ if List = Empty_Project_List then
+ Index := Index + 1;
+ end if;
+ end loop Library_Loop;
+ end;
+ end if;
+
+ -- Now that we have a correct order, add the -L and -l switches and,
+ -- if the Rpath option is supported, add the directory to the Rpath.
+
+ for Index in 1 .. Library_Projs.Last loop
+ Current := Library_Projs.Table (Index);
+
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) :=
+ new String'
+ ("-L" &
+ Get_Name_String
+ (Projects.Table (Current).Library_Dir));
+
+ if Path_Option /= null then
+ Add_Rpath
+ (Get_Name_String
+ (Projects.Table (Current).Library_Dir));
+ end if;
+
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) :=
+ new String'
+ ("-l" &
+ Get_Name_String
+ (Projects.Table (Current).Library_Name));
+ end loop;
+ end Process_Imported_Libraries;
+
+ -- Start of processing for Build_Library
+
begin
Reset_Tables;
-- Fail if project is not a library project
if not Data.Library then
- Fail ("project """, Project_Name, """ has no library");
+ Com.Fail ("project """, Project_Name, """ has no library");
end if;
- Lib_Dirpath := new String'(Get_Name_String (Data.Library_Dir));
- Lib_Filename := new String'(Get_Name_String (Data.Library_Name));
+ -- If this is the first time Build_Library is called, get the Name_Id
+ -- of "s-osinte.ads".
+
+ if S_Osinte_Ads = No_Name then
+ Name_Len := 12;
+ Name_Buffer (1 .. Name_Len) := "s-osinte.ads";
+ S_Osinte_Ads := Name_Find;
+ end if;
+
+ if S_Dec_Ads = No_Name then
+ Name_Len := 7;
+ Name_Buffer (1 .. Name_Len) := "dec.ads";
+ S_Dec_Ads := Name_Find;
+ end if;
- case Data.Library_Kind is
- when Static =>
- The_Build_Mode := Static;
+ -- We work in the object directory
- when Dynamic =>
- The_Build_Mode := Dynamic;
+ Change_Dir (Object_Directory_Path);
- when Relocatable =>
- The_Build_Mode := Relocatable;
+ if Standalone then
+ -- Call gnatbind only if Bind is True
- if Target.PIC_Option /= "" then
- Opts.Increment_Last;
- Opts.Table (Opts.Last) := new String'(Target.PIC_Option);
+ if Bind then
+ if Gnatbind_Path = null then
+ Com.Fail ("unable to locate ", Gnatbind);
end if;
- end case;
- -- Get the library version, if any
+ if Gcc_Path = null then
+ Com.Fail ("unable to locate ", Gcc);
+ end if;
+
+ -- Allocate Arguments, if it is the first time we see a standalone
+ -- library.
+
+ if Arguments = No_Argument then
+ Arguments := new String_List (1 .. Initial_Argument_Max);
+ end if;
+
+ -- Add "-n -o b~<lib>.adb (b$<lib>.adb on VMS) -L<lib>"
+
+ Argument_Number := 2;
+ Arguments (1) := No_Main;
+ Arguments (2) := Output_Switch;
+
+ if Hostparm.OpenVMS then
+ B_Start (B_Start'Last) := '$';
+ end if;
+
+ Add_Argument
+ (B_Start & Get_Name_String (Data.Library_Name) & ".adb");
+ Add_Argument ("-L" & Get_Name_String (Data.Library_Name));
+
+ -- Get all the ALI files of the project file
+
+ declare
+ Unit : Unit_Data;
+
+ begin
+ Library_ALIs.Reset;
+ Interface_ALIs.Reset;
+ Processed_ALIs.Reset;
+ for Source in 1 .. Com.Units.Last loop
+ Unit := Com.Units.Table (Source);
+
+ if Unit.File_Names (Body_Part).Name /= No_Name
+ and then Unit.File_Names (Body_Part).Path /= Slash
+ then
+ if
+ Check_Project (Unit.File_Names (Body_Part).Project)
+ then
+ if Unit.File_Names (Specification).Name = No_Name then
+ declare
+ Src_Ind : Source_File_Index;
+
+ begin
+ Src_Ind := Sinput.P.Load_Project_File
+ (Get_Name_String
+ (Unit.File_Names
+ (Body_Part).Path));
+
+ -- Add the ALI file only if it is not a subunit
+
+ if
+ not Sinput.P.Source_File_Is_Subunit (Src_Ind)
+ then
+ Add_ALI_For
+ (Unit.File_Names (Body_Part).Name);
+ end if;
+ end;
+
+ else
+ Add_ALI_For (Unit.File_Names (Body_Part).Name);
+ end if;
+ end if;
+
+ elsif Unit.File_Names (Specification).Name /= No_Name
+ and then Unit.File_Names (Specification).Path /= Slash
+ and then Check_Project
+ (Unit.File_Names (Specification).Project)
+ then
+ Add_ALI_For (Unit.File_Names (Specification).Name);
+ end if;
+ end loop;
+ end;
+
+ -- Set the paths
+
+ Set_Ada_Paths
+ (Project => For_Project, Including_Libraries => True);
+
+ -- Display the gnatbind command, if not in quiet output
+
+ Display (Gnatbind);
+
+ -- Invoke gnatbind
+
+ GNAT.OS_Lib.Spawn
+ (Gnatbind_Path.all, Arguments (1 .. Argument_Number), Success);
+
+ if not Success then
+ Com.Fail ("could not bind standalone library ",
+ Get_Name_String (Data.Library_Name));
+ end if;
+
+ end if;
+
+ -- Compile the binder generated file only if Link is true
+
+ if Link then
+ -- Set the paths
+
+ Set_Ada_Paths
+ (Project => For_Project, Including_Libraries => True);
+
+ -- Invoke <gcc> -c b$$<lib>.adb
+
+ -- Allocate Arguments, if it is the first time we see a standalone
+ -- library.
+
+ if Arguments = No_Argument then
+ Arguments := new String_List (1 .. Initial_Argument_Max);
+ end if;
- if Data.Lib_Internal_Name /= No_Name then
- Lib_Version := new String'(Get_Name_String (Data.Lib_Internal_Name));
+ Argument_Number := 1;
+ Arguments (1) := Compile_Switch;
+
+ if Hostparm.OpenVMS then
+ B_Start (B_Start'Last) := '$';
+ end if;
+
+ Add_Argument
+ (B_Start & Get_Name_String (Data.Library_Name) & ".adb");
+
+ -- If necessary, add the PIC option
+
+ if PIC_Option /= "" then
+ Add_Argument (PIC_Option);
+ end if;
+
+ Display (Gcc);
+ GNAT.OS_Lib.Spawn
+ (Gcc_Path.all, Arguments (1 .. Argument_Number), Success);
+
+ if not Success then
+ Com.Fail
+ ("could not compile binder generated file for library ",
+ Get_Name_String (Data.Library_Name));
+ end if;
+
+ -- Process binder generated file for pragmas Linker_Options
+
+ Process_Binder_File (Arguments (2).all & ASCII.NUL);
+ end if;
end if;
- -- Add the objects found in the object directory
+ -- Build the library only if Link is True
- declare
- Object_Dir : Dir_Type;
- Filename : String (1 .. 255);
- Last : Natural;
- Object_Dir_Path : constant String :=
- Get_Name_String (Data.Object_Directory);
- begin
- Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path);
+ if Link then
+ -- If attribute Library_GCC was specified, get the driver name
- -- For all entries in the object directory
+ Library_GCC := Value_Of (Name_Library_GCC, Data.Decl.Attributes);
- loop
- Read (Object_Dir, Filename, Last);
+ if not Library_GCC.Default then
+ Driver_Name := Library_GCC.Value;
+ end if;
- exit when Last = 0;
+ -- If attribute Library_Options was specified, add these additional
+ -- options.
- -- Check if it is an object file
+ Library_Options :=
+ Value_Of (Name_Library_Options, Data.Decl.Attributes);
- if Files.Is_Obj (Filename (1 .. Last)) then
- -- record this object file
+ if not Library_Options.Default then
+ declare
+ Current : String_List_Id := Library_Options.Values;
+ Element : String_Element;
- Objects.Increment_Last;
- Objects.Table (Objects.Last) :=
- new String' (Object_Dir_Path & Directory_Separator &
- Filename (1 .. Last));
+ begin
+ while Current /= Nil_String loop
+ Element := String_Elements.Table (Current);
+ Get_Name_String (Element.Value);
- if Is_Regular_File
- (Object_Dir_Path &
- Files.Ext_To (Object_Dir_Path &
- Filename (1 .. Last), "ali"))
- then
- -- Record the corresponding ali file
+ if Name_Len /= 0 then
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) :=
+ new String'(Name_Buffer (1 .. Name_Len));
+ end if;
- Alis.Increment_Last;
- Alis.Table (Alis.Last) :=
- new String' (Object_Dir_Path &
- Files.Ext_To
- (Filename (1 .. Last), "ali"));
+ Current := Element.Next;
+ end loop;
+ end;
+ end if;
- else
- -- The object file is a foreign object file
+ Lib_Dirpath := new String'(Get_Name_String (Data.Library_Dir));
+ Lib_Filename := new String'(Get_Name_String (Data.Library_Name));
+
+ case Data.Library_Kind is
+ when Static =>
+ The_Build_Mode := Static;
- Foreigns.Increment_Last;
- Foreigns.Table (Foreigns.Last) :=
- new String'(Object_Dir_Path &
- Filename (1 .. Last));
+ when Dynamic =>
+ The_Build_Mode := Dynamic;
+ when Relocatable =>
+ The_Build_Mode := Relocatable;
+
+ if PIC_Option /= "" then
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) := new String'(PIC_Option);
end if;
- end if;
+ end case;
+
+ -- Get the library version, if any
+
+ if Data.Lib_Internal_Name /= No_Name then
+ Lib_Version :=
+ new String'(Get_Name_String (Data.Lib_Internal_Name));
+ end if;
+
+ -- Add the objects found in the object directory and the object
+ -- directories of the extended files, if any, except for generated
+ -- object files (b~.. or B$..) from extended projects.
+ -- When there are one or more extended files, only add an object file
+ -- if no object file with the same name have already been added.
+
+ In_Main_Object_Directory := True;
+
+ loop
+ declare
+ Object_Dir_Path : constant String :=
+ Get_Name_String (Data.Object_Directory);
+ Object_Dir : Dir_Type;
+ Filename : String (1 .. 255);
+ Last : Natural;
+ Id : Name_Id;
+
+ begin
+ Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path);
+
+ -- For all entries in the object directory
+
+ loop
+ Read (Object_Dir, Filename, Last);
+
+ exit when Last = 0;
+
+ -- Check if it is an object file
+
+ if Is_Obj (Filename (1 .. Last)) then
+ declare
+ Object_Path : String :=
+ Normalize_Pathname
+ (Object_Dir_Path & Directory_Separator &
+ Filename (1 .. Last));
+
+ begin
+ Canonical_Case_File_Name (Object_Path);
+ Canonical_Case_File_Name (Filename (1 .. Last));
+
+ -- If in the object directory of an extended project,
+ -- do not consider generated object files.
+
+ if In_Main_Object_Directory or else
+ Last < 5 or else
+ Filename (1 .. B_Start'Length) /= B_Start
+ then
+ Name_Len := Last;
+ Name_Buffer (1 .. Name_Len) := Filename (1 .. Last);
+ Id := Name_Find;
+
+ if not Objects_Htable.Get (Id) then
+
+ -- Record this object file
+
+ Objects_Htable.Set (Id, True);
+ Objects.Increment_Last;
+ Objects.Table (Objects.Last) :=
+ new String'(Object_Path);
+
+ declare
+ ALI_File : constant String :=
+ Ext_To (Object_Path, "ali");
+
+ begin
+ if Is_Regular_File (ALI_File) then
+
+ -- Record the ALI file
+
+ ALIs.Increment_Last;
+ ALIs.Table (ALIs.Last) :=
+ new String'(ALI_File);
+
+ -- Find out if for this ALI file,
+ -- libgnarl or libdecgnat (on OpenVMS)
+ -- is necessary.
+
+ Check_Libs (ALI_File);
+
+ else
+ -- The object file is a foreign object
+ -- file.
+
+ Foreigns.Increment_Last;
+ Foreigns.Table (Foreigns.Last) :=
+ new String'(Object_Path);
+ end if;
+ end;
+ end if;
+ end if;
+ end;
+ end if;
+ end loop;
+
+ Close (Dir => Object_Dir);
+
+ exception
+ when Directory_Error =>
+ Com.Fail ("cannot find object directory """,
+ Get_Name_String (Data.Object_Directory),
+ """");
+ end;
+
+ exit when Data.Extends = No_Project;
+
+ In_Main_Object_Directory := False;
+ Data := Projects.Table (Data.Extends);
end loop;
- Close (Dir => Object_Dir);
+ -- Add the -L and -l switches for the imported Library Project Files,
+ -- and, if Path Option is supported, the library directory path names
+ -- to Rpath.
- exception
- when Directory_Error =>
- Fail ("cannot find object directory """,
- Get_Name_String (Data.Object_Directory),
- """");
- end;
+ Process_Imported_Libraries;
- -- We want to link some Ada files, so we need to link with
- -- the GNAT runtime (libgnat & libgnarl)
+ -- Link with libgnat and possibly libgnarl
- if The_Build_Mode = Dynamic or else The_Build_Mode = Relocatable then
Opts.Increment_Last;
- Opts.Table (Opts.Last) := new String' ("-lgnarl");
+ Opts.Table (Opts.Last) := new String'("-L" & Lib_Directory);
+
+ -- If Path Option is supported, add libgnat directory path name to
+ -- Rpath.
+
+ if Path_Option /= null then
+ Add_Rpath (Lib_Directory);
+ end if;
+
+ if Libgnarl_Needed then
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) := new String'("-lgnarl");
+ end if;
+
+ if Libdecgnat_Needed then
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) :=
+ new String'("-L" & Lib_Directory & "/../declib");
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) := new String'("-ldecgnat");
+ end if;
+
Opts.Increment_Last;
- Opts.Table (Opts.Last) := new String' ("-lgnat");
- end if;
+ Opts.Table (Opts.Last) := new String'("-lgnat");
- Object_Files :=
- new Argument_List'(Argument_List (Objects.Table (1 .. Objects.Last)));
+ -- If Path Option is supported, add the necessary switch with the
+ -- content of Rpath. As Rpath contains at least libgnat directory
+ -- path name, it is guaranteed that it is not null.
- Foreign_Objects :=
- new Argument_List'(Argument_List
- (Foreigns.Table (1 .. Foreigns.Last)));
+ if Path_Option /= null then
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) :=
+ new String'(Path_Option.all & Rpath (1 .. Rpath_Last));
+ Free (Path_Option);
+ Free (Rpath);
+ end if;
- Ali_Files :=
- new Argument_List'(Argument_List (Alis.Table (1 .. Alis.Last)));
+ Object_Files :=
+ new Argument_List'
+ (Argument_List (Objects.Table (1 .. Objects.Last)));
- Options :=
- new Argument_List'(Argument_List (Opts.Table (1 .. Opts.Last)));
+ Foreign_Objects :=
+ new Argument_List'(Argument_List
+ (Foreigns.Table (1 .. Foreigns.Last)));
- -- We fail if there are no object to put in the library
- -- (Ada or foreign objects)
+ Ali_Files :=
+ new Argument_List'(Argument_List (ALIs.Table (1 .. ALIs.Last)));
- if Object_Files'Length = 0 then
- Fail ("no object files");
+ Options :=
+ new Argument_List'(Argument_List (Opts.Table (1 .. Opts.Last)));
- end if;
+ -- We fail if there are no object to put in the library
+ -- (Ada or foreign objects).
- if not Opt.Quiet_Output then
- Write_Eol;
- Write_Str ("building ");
- Write_Str (Ada.Characters.Handling.To_Lower
- (Build_Mode_State'Image (The_Build_Mode)));
- Write_Str (" library for project ");
- Write_Line (Project_Name);
- Write_Eol;
+ if Object_Files'Length = 0 then
+ Com.Fail ("no object files for library """ &
+ Lib_Filename.all & '"');
+
+ end if;
+
+ if not Opt.Quiet_Output then
+ Write_Eol;
+ Write_Str ("building ");
+ Write_Str (Ada.Characters.Handling.To_Lower
+ (Build_Mode_State'Image (The_Build_Mode)));
+ Write_Str (" library for project ");
+ Write_Line (Project_Name);
+
+ Write_Eol;
+
+ Write_Line ("object files:");
+
+ for Index in Object_Files'Range loop
+ Write_Str (" ");
+ Write_Line (Object_Files (Index).all);
+ end loop;
+
+ Write_Eol;
+
+ if Ali_Files'Length = 0 then
+ Write_Line ("NO ALI files");
+
+ else
+ Write_Line ("ALI files:");
+
+ for Index in Ali_Files'Range loop
+ Write_Str (" ");
+ Write_Line (Ali_Files (Index).all);
+ end loop;
+ end if;
+
+ Write_Eol;
+ end if;
+
+ -- We check that all object files are regular files
+
+ Check_Context;
+
+ -- Delete the existing library file, if it exists.
+ -- Fail if the library file is not writable, or if it is not possible
+ -- to delete the file.
+
+ declare
+ DLL_Name : aliased String :=
+ Lib_Dirpath.all & "/lib" &
+ Lib_Filename.all & "." & DLL_Ext;
+
+ Archive_Name : aliased String :=
+ Lib_Dirpath.all & "/lib" &
+ Lib_Filename.all & "." & Archive_Ext;
+
+ type Str_Ptr is access all String;
+ -- This type is necessary to meet the accessibility rules of Ada.
+ -- It is not possible to use String_Access here.
+
+ Full_Lib_Name : Str_Ptr;
+ -- Designates the full library path name. Either DLL_Name or
+ -- Archive_Name, depending on the library kind.
+
+ Success : Boolean := False;
+ -- Used to call Delete_File
+
+ begin
+ if The_Build_Mode = Static then
+ Full_Lib_Name := Archive_Name'Access;
+ else
+ Full_Lib_Name := DLL_Name'Access;
+ end if;
+
+ if Is_Regular_File (Full_Lib_Name.all) then
+ if Is_Writable_File (Full_Lib_Name.all) then
+ Delete_File (Full_Lib_Name.all, Success);
+ end if;
+
+ if Is_Regular_File (Full_Lib_Name.all) then
+ Com.Fail ("could not delete """ & Full_Lib_Name.all & """");
+ end if;
+ end if;
+ end;
+
+ Argument_Number := 0;
+
+ -- If we have a standalone library, gather all the interface ALI.
+ -- They are passed to Build_Dynamic_Library, where they are used by
+ -- some platforms (VMS, for example) to decide what symbols should be
+ -- exported. They are also flagged as Interface when we copy them to
+ -- the library directory (by Copy_ALI_Files, below).
+
+ if Standalone then
+ Data := Projects.Table (For_Project);
+
+ declare
+ Interface : String_List_Id := Data.Lib_Interface_ALIs;
+ ALI : File_Name_Type;
+
+ begin
+ while Interface /= Nil_String loop
+ ALI := String_Elements.Table (Interface).Value;
+ Interface_ALIs.Set (ALI, True);
+ Get_Name_String (String_Elements.Table (Interface).Value);
+ Add_Argument (Name_Buffer (1 .. Name_Len));
+ Interface := String_Elements.Table (Interface).Next;
+ end loop;
+
+ Interface := Data.Lib_Interface_ALIs;
+
+ if not Opt.Quiet_Output then
+
+ -- Check that the interface set is complete: any unit in the
+ -- library that is needed by an interface should also be an
+ -- interface. If it is not the case, output a warning.
+
+ while Interface /= Nil_String loop
+ ALI := String_Elements.Table (Interface).Value;
+ Process (ALI);
+ Interface := String_Elements.Table (Interface).Next;
+ end loop;
+ end if;
+ end;
+ end if;
+
+ -- Clean the library directory, if it is also the directory where
+ -- the ALI files are copied, either because there is no interface
+ -- copy directory or because the interface copy directory is the
+ -- same as the library directory.
+
+ Copy_Dir := Projects.Table (For_Project).Library_Dir;
+ Clean (Copy_Dir);
+
+ -- Call the procedure to build the library, depending on the build
+ -- mode.
+
+ case The_Build_Mode is
+ when Dynamic | Relocatable =>
+ Build_Dynamic_Library
+ (Ofiles => Object_Files.all,
+ Foreign => Foreign_Objects.all,
+ Afiles => Ali_Files.all,
+ Options => Options.all,
+ Interfaces => Arguments (1 .. Argument_Number),
+ Lib_Filename => Lib_Filename.all,
+ Lib_Dir => Lib_Dirpath.all,
+ Driver_Name => Driver_Name,
+ Lib_Address => DLL_Address.all,
+ Lib_Version => Lib_Version.all,
+ Relocatable => The_Build_Mode = Relocatable,
+ Auto_Init => Data.Lib_Auto_Init);
+
+ when Static =>
+ MLib.Build_Library
+ (Object_Files.all,
+ Ali_Files.all,
+ Lib_Filename.all,
+ Lib_Dirpath.all);
+
+ when None =>
+ null;
+ end case;
+
+ -- We need to copy the ALI files from the object directory
+ -- to the library directory, so that the linker find them there,
+ -- and does not need to look in the object directory where it would
+ -- also find the object files; and we don't want that: we want the
+ -- linker to use the library.
+
+ -- Copy the ALI files and make the copies read-only. For interfaces,
+ -- mark the copies as interfaces.
+
+ Copy_ALI_Files
+ (Files => Ali_Files.all,
+ To => Copy_Dir,
+ Interfaces => Arguments (1 .. Argument_Number));
+
+ -- Copy interface sources if Library_Src_Dir specified
+
+ if Standalone
+ and then Projects.Table (For_Project).Library_Src_Dir /= No_Name
+ then
+ -- Clean the interface copy directory, if it is not also the
+ -- library directory. If it is also the library directory, it has
+ -- already been cleaned before the generation of the library.
+
+ if Projects.Table (For_Project).Library_Src_Dir /= Copy_Dir then
+ Copy_Dir := Projects.Table (For_Project).Library_Src_Dir;
+ Clean (Copy_Dir);
+ end if;
+
+ Copy_Interface_Sources
+ (For_Project => For_Project,
+ Interfaces => Arguments (1 .. Argument_Number),
+ To_Dir => Copy_Dir);
+ end if;
end if;
- -- We check that all object files are regular files
-
- Check_Context;
-
- -- And we call the procedure to build the library,
- -- depending on the build mode
-
- case The_Build_Mode is
- when Dynamic | Relocatable =>
- Target.Build_Dynamic_Library
- (Ofiles => Object_Files.all,
- Foreign => Foreign_Objects.all,
- Afiles => Ali_Files.all,
- Options => Options.all,
- Lib_Filename => Lib_Filename.all,
- Lib_Dir => Lib_Dirpath.all,
- Lib_Address => DLL_Address.all,
- Lib_Version => Lib_Version.all,
- Relocatable => The_Build_Mode = Relocatable);
-
- when Static =>
- MLib.Build_Library
- (Object_Files.all,
- Ali_Files.all,
- Lib_Filename.all,
- Lib_Dirpath.all);
-
- when None =>
- null;
- end case;
-
- -- We need to copy the ALI files from the object directory
- -- to the library directory, so that the linker find them
- -- there, and does not need to look in the object directory
- -- where it would also find the object files; and we don't want
- -- that: we want the linker to use the library.
-
- Target.Copy_ALI_Files
- (From => Projects.Table (For_Project).Object_Directory,
- To => Projects.Table (For_Project).Library_Dir);
+ -- Reset the current working directory to its previous value
+ Change_Dir (Current_Dir);
end Build_Library;
-----------
@@ -304,8 +1377,7 @@ package body MLib.Prj is
procedure Check (Filename : String) is
begin
if not Is_Regular_File (Filename) then
- Fail (Filename, " not found.");
-
+ Com.Fail (Filename, " not found.");
end if;
end Check;
@@ -315,13 +1387,415 @@ package body MLib.Prj is
procedure Check_Context is
begin
- -- check that each object file exist
+ -- check that each object file exists
for F in Object_Files'Range loop
Check (Object_Files (F).all);
end loop;
end Check_Context;
+ -------------------
+ -- Check_Library --
+ -------------------
+
+ procedure Check_Library (For_Project : Project_Id) is
+ Data : constant Project_Data := Projects.Table (For_Project);
+
+ begin
+ if Data.Library and not Data.Flag1 then
+ declare
+ Current : constant Dir_Name_Str := Get_Current_Dir;
+ Lib_Name : constant Name_Id := Library_File_Name_For (For_Project);
+ Lib_TS : Time_Stamp_Type;
+ Obj_TS : Time_Stamp_Type;
+
+ Object_Dir : Dir_Type;
+
+ begin
+ if Hostparm.OpenVMS then
+ B_Start (B_Start'Last) := '$';
+ end if;
+
+ Change_Dir (Get_Name_String (Data.Library_Dir));
+
+ Lib_TS := File_Stamp (Lib_Name);
+
+ -- If the library file does not exist, then the time stamp will
+ -- be Empty_Time_Stamp, earlier than any other time stamp.
+
+ Change_Dir (Get_Name_String (Data.Object_Directory));
+ Open (Dir => Object_Dir, Dir_Name => ".");
+
+ -- For all entries in the object directory
+
+ loop
+ Read (Object_Dir, Name_Buffer, Name_Len);
+ exit when Name_Len = 0;
+
+ -- Check if it is an object file, but ignore any binder
+ -- generated file.
+
+ if Is_Obj (Name_Buffer (1 .. Name_Len))
+ and then Name_Buffer (1 .. B_Start'Length) /= B_Start
+ then
+
+ -- Get the object file time stamp
+
+ Obj_TS := File_Stamp (Name_Find);
+
+ -- If library file time stamp is earlier, set Flag1 and
+ -- return. String comparaison is used, otherwise time stamps
+ -- may be too close and the comparaison would return True,
+ -- which would trigger an unnecessary rebuild of the
+ -- library.
+
+ if String (Lib_TS) < String (Obj_TS) then
+
+ -- Library must be rebuilt
+
+ Projects.Table (For_Project).Flag1 := True;
+ exit;
+ end if;
+ end if;
+ end loop;
+
+ Change_Dir (Current);
+ end;
+ end if;
+ end Check_Library;
+
+ -----------
+ -- Clean --
+ -----------
+
+ procedure Clean (Directory : Name_Id) is
+ Current : constant Dir_Name_Str := Get_Current_Dir;
+
+ Dir : Dir_Type;
+
+ Name : String (1 .. 200);
+ Last : Natural;
+
+ Disregard : Boolean;
+
+ procedure Set_Writable (Name : System.Address);
+ pragma Import (C, Set_Writable, "__gnat_set_writable");
+
+ begin
+ Get_Name_String (Directory);
+
+ -- Change the working directory to the directory to clean
+
+ begin
+ Change_Dir (Name_Buffer (1 .. Name_Len));
+
+ exception
+ when others =>
+ Com.Fail
+ ("unable to access directory """,
+ Name_Buffer (1 .. Name_Len),
+ """");
+ end;
+
+ Open (Dir, ".");
+
+ -- For each regular file in the directory, make it writable and
+ -- delete the file.
+
+ loop
+ Read (Dir, Name, Last);
+ exit when Last = 0;
+
+ if Is_Regular_File (Name (1 .. Last)) then
+ Name (Last + 1) := ASCII.NUL;
+ Set_Writable (Name (1)'Address);
+ Delete_File (Name (1 .. Last), Disregard);
+ end if;
+ end loop;
+
+ Close (Dir);
+
+ -- Restore the initial working directory
+
+ Change_Dir (Current);
+ end Clean;
+
+ ----------------------------
+ -- Copy_Interface_Sources --
+ ----------------------------
+
+ procedure Copy_Interface_Sources
+ (For_Project : Project_Id;
+ Interfaces : Argument_List;
+ To_Dir : Name_Id)
+ is
+ Current : constant Dir_Name_Str := Get_Current_Dir;
+ Target : constant Dir_Name_Str := Get_Name_String (To_Dir);
+
+ Text : Text_Buffer_Ptr;
+ The_ALI : ALI.ALI_Id;
+ Lib_File : Name_Id;
+
+ First_Unit : ALI.Unit_Id;
+ Second_Unit : ALI.Unit_Id;
+
+ Data : Unit_Data;
+
+ Copy_Subunits : Boolean := False;
+
+ procedure Copy (File_Name : Name_Id);
+ -- Copy one source of the project to the target directory
+
+ ----------
+ -- Copy --
+ ----------
+
+ procedure Copy (File_Name : Name_Id) is
+ Success : Boolean := False;
+
+ begin
+ Unit_Loop :
+ for Index in 1 .. Com.Units.Last loop
+ Data := Com.Units.Table (Index);
+
+ for J in Data.File_Names'Range loop
+ if Data.File_Names (J).Project = For_Project
+ and then Data.File_Names (J).Name = File_Name
+ then
+ Copy_File
+ (Get_Name_String (Data.File_Names (J).Path),
+ Target,
+ Success,
+ Mode => Overwrite,
+ Preserve => Preserve);
+ exit Unit_Loop;
+ end if;
+ end loop;
+ end loop Unit_Loop;
+ end Copy;
+
+ use ALI;
+
+ -- Start of processing for Copy_Interface_Sources
+
+ begin
+ -- Change the working directory to the object directory
+
+ Change_Dir
+ (Get_Name_String (Projects.Table (For_Project).Object_Directory));
+
+ for Index in Interfaces'Range loop
+
+ -- First, load the ALI file
+
+ Name_Len := 0;
+ Add_Str_To_Name_Buffer (Interfaces (Index).all);
+ Lib_File := Name_Find;
+ Text := Read_Library_Info (Lib_File);
+ The_ALI := Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
+ Free (Text);
+
+ Second_Unit := No_Unit_Id;
+ First_Unit := ALI.ALIs.Table (The_ALI).First_Unit;
+ Copy_Subunits := True;
+
+ -- If there is both a spec and a body, check if they are both needed
+
+ if ALI.Units.Table (First_Unit).Utype = Is_Body then
+ Second_Unit := ALI.ALIs.Table (The_ALI).Last_Unit;
+
+ -- If the body is not needed, then reset First_Unit
+
+ if not ALI.Units.Table (Second_Unit).Body_Needed_For_SAL then
+ First_Unit := No_Unit_Id;
+ Copy_Subunits := False;
+ end if;
+
+ elsif ALI.Units.Table (First_Unit).Utype = Is_Spec_Only then
+ Copy_Subunits := False;
+ end if;
+
+ -- Copy the file(s) that need to be copied
+
+ if First_Unit /= No_Unit_Id then
+ Copy (File_Name => ALI.Units.Table (First_Unit).Sfile);
+ end if;
+
+ if Second_Unit /= No_Unit_Id then
+ Copy (File_Name => ALI.Units.Table (Second_Unit).Sfile);
+ end if;
+
+ -- Copy all the separates, if any
+
+ if Copy_Subunits then
+ for Dep in ALI.ALIs.Table (The_ALI).First_Sdep ..
+ ALI.ALIs.Table (The_ALI).Last_Sdep
+ loop
+ if Sdep.Table (Dep).Subunit_Name /= No_Name then
+ Copy (File_Name => Sdep.Table (Dep).Sfile);
+ end if;
+ end loop;
+ end if;
+ end loop;
+
+ -- Restore the initial working directory
+
+ Change_Dir (Current);
+ end Copy_Interface_Sources;
+
+ -------------
+ -- Display --
+ -------------
+
+ procedure Display (Executable : String) is
+ begin
+ if not Opt.Quiet_Output then
+ Write_Str (Executable);
+
+ for Index in 1 .. Argument_Number loop
+ Write_Char (' ');
+ Write_Str (Arguments (Index).all);
+ end loop;
+
+ Write_Eol;
+ end if;
+ end Display;
+
+ -------------------------
+ -- Process_Binder_File --
+ -------------------------
+
+ procedure Process_Binder_File (Name : String) is
+ Fd : FILEs;
+ -- Binder file's descriptor
+
+ Read_Mode : constant String := "r" & ASCII.Nul;
+ -- For fopen
+
+ Status : Interfaces.C_Streams.int;
+ -- For fclose
+
+ Begin_Info : String := "-- BEGIN Object file/option list";
+ End_Info : String := "-- END Object file/option list ";
+
+ Next_Line : String (1 .. 1000);
+ -- Current line value
+ -- Where does this odd constant 1000 come from, looks suspicious ???
+
+ Nlast : Integer;
+ -- End of line slice (the slice does not contain the line terminator)
+
+ procedure Get_Next_Line;
+ -- Read the next line from the binder file without the line terminator
+
+ -------------------
+ -- Get_Next_Line --
+ -------------------
+
+ procedure Get_Next_Line is
+ Fchars : chars;
+
+ begin
+ Fchars := fgets (Next_Line'Address, Next_Line'Length, Fd);
+
+ if Fchars = System.Null_Address then
+ Fail ("Error reading binder output");
+ end if;
+
+ Nlast := 1;
+ while Nlast <= Next_Line'Last
+ and then Next_Line (Nlast) /= ASCII.LF
+ and then Next_Line (Nlast) /= ASCII.CR
+ loop
+ Nlast := Nlast + 1;
+ end loop;
+
+ Nlast := Nlast - 1;
+ end Get_Next_Line;
+
+ -- Start of processing for Process_Binder_File
+
+ begin
+ Fd := fopen (Name'Address, Read_Mode'Address);
+
+ if Fd = NULL_Stream then
+ Fail ("Failed to open binder output");
+ end if;
+
+ -- Skip up to the Begin Info line
+
+ loop
+ Get_Next_Line;
+ exit when Next_Line (1 .. Nlast) = Begin_Info;
+ end loop;
+
+ -- Find the first switch
+
+ loop
+ Get_Next_Line;
+
+ exit when Next_Line (1 .. Nlast) = End_Info;
+
+ -- As the binder generated file is in Ada, remove the first eight
+ -- characters " -- ".
+
+ Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast);
+ Nlast := Nlast - 8;
+
+ -- Stop when the first switch is found
+
+ exit when Next_Line (1) = '-';
+ end loop;
+
+ if Next_Line (1 .. Nlast) /= End_Info then
+ loop
+ -- Disregard -static and -shared, as -shared will be used
+ -- in any case.
+
+ -- Disregard -lgnat, -lgnarl and -ldecgnat as they will be added
+ -- later, because they are also needed for non Stand-Alone shared
+ -- libraries.
+
+ if Next_Line (1 .. Nlast) /= "-static" and then
+ Next_Line (1 .. Nlast) /= "-shared" and then
+ Next_Line (1 .. Nlast) /= "-ldecgnat" and then
+ Next_Line (1 .. Nlast) /= "-lgnarl" and then
+ Next_Line (1 .. Nlast) /= "-lgnat"
+ then
+ if Next_Line (1) /= '-' then
+
+ -- This is not an option, should we add it?
+
+ if Add_Object_Files then
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) :=
+ new String'(Next_Line (1 .. Nlast));
+ end if;
+
+ else
+ -- Add all other options
+
+ Opts.Increment_Last;
+ Opts.Table (Opts.Last) :=
+ new String'(Next_Line (1 .. Nlast));
+ end if;
+ end if;
+
+ -- Next option, if any
+
+ Get_Next_Line;
+ exit when Next_Line (1 .. Nlast) = End_Info;
+
+ -- Remove first eight characters " -- "
+
+ Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast);
+ Nlast := Nlast - 8;
+ end loop;
+ end if;
+
+ Status := fclose (Fd);
+ end Process_Binder_File;
+
------------------
-- Reset_Tables --
------------------
@@ -329,9 +1803,12 @@ package body MLib.Prj is
procedure Reset_Tables is
begin
Objects.Init;
+ Objects_Htable.Reset;
Foreigns.Init;
- Alis.Init;
+ ALIs.Init;
Opts.Init;
+ Processed_Projects.Reset;
+ Library_Projs.Init;
end Reset_Tables;
end MLib.Prj;
diff --git a/gcc/ada/mlib-prj.ads b/gcc/ada/mlib-prj.ads
index c6d8d8fddd3..7f8ac59ec24 100644
--- a/gcc/ada/mlib-prj.ads
+++ b/gcc/ada/mlib-prj.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001, Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -20,7 +20,7 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -30,8 +30,24 @@ with Prj; use Prj;
package MLib.Prj is
- procedure Build_Library (For_Project : Project_Id);
- -- Build the library of library project For_Project
- -- Fails if For_Project is not a library project file
+ procedure Build_Library
+ (For_Project : Project_Id;
+ Gnatbind : String;
+ Gnatbind_Path : String_Access;
+ Gcc : String;
+ Gcc_Path : String_Access;
+ Bind : Boolean := True;
+ Link : Boolean := True);
+ -- Build the library of library project For_Project.
+ -- Fails if For_Project is not a library project file.
+ -- Gnatbind, Gnatbind_Path, Gcc, Gcc_Path are used for standalone
+ -- libraries, to call the binder and to compile the binder generated
+ -- files. If Bind is False the binding of a stand-alone library is skipped.
+ -- If Link is False, the library is not linked/built.
+
+ procedure Check_Library (For_Project : Project_Id);
+ -- Check if the library of a library project needs to be rebuilt,
+ -- because its time-stamp is earlier than the time stamp of one of its
+ -- object files.
end MLib.Prj;
diff --git a/gcc/ada/mlib-tgt.adb b/gcc/ada/mlib-tgt.adb
index c5ec4fa59e8..0fc5919db40 100644
--- a/gcc/ada/mlib-tgt.adb
+++ b/gcc/ada/mlib-tgt.adb
@@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001, Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -21,35 +21,51 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the default version which does not support libraries.
-- All subprograms are dummies, because they are never called,
--- except Libraries_Are_Supported which returns False.
+-- except Support_For_Libraries which returns None.
package body MLib.Tgt is
- pragma Warnings (Off); -- stop warnings on unreferenced formals
+ ---------------------
+ -- Archive_Builder --
+ ---------------------
+
+ function Archive_Builder return String is
+ begin
+ return "ar";
+ end Archive_Builder;
+
+ -----------------------------
+ -- Archive_Builder_Options --
+ -----------------------------
+
+ function Archive_Builder_Options return String_List_Access is
+ begin
+ return new String_List'(1 => new String'("cr"));
+ end Archive_Builder_Options;
-----------------
-- Archive_Ext --
-----------------
- function Archive_Ext return String is
+ function Archive_Ext return String is
begin
- return "";
+ return "";
end Archive_Ext;
- -----------------
- -- Base_Option --
- -----------------
+ ---------------------
+ -- Archive_Indexer --
+ ---------------------
- function Base_Option return String is
+ function Archive_Indexer return String is
begin
- return "";
- end Base_Option;
+ return "ranlib";
+ end Archive_Indexer;
---------------------------
-- Build_Dynamic_Library --
@@ -60,27 +76,31 @@ package body MLib.Tgt is
Foreign : Argument_List;
Afiles : Argument_List;
Options : Argument_List;
+ Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
- Relocatable : Boolean := False)
+ Relocatable : Boolean := False;
+ Auto_Init : Boolean := False)
is
- begin
- null;
- end Build_Dynamic_Library;
-
- --------------------
- -- Copy_ALI_Files --
- --------------------
+ pragma Unreferenced (Ofiles);
+ pragma Unreferenced (Foreign);
+ pragma Unreferenced (Afiles);
+ pragma Unreferenced (Options);
+ pragma Unreferenced (Interfaces);
+ pragma Unreferenced (Lib_Filename);
+ pragma Unreferenced (Lib_Dir);
+ pragma Unreferenced (Driver_Name);
+ pragma Unreferenced (Lib_Address);
+ pragma Unreferenced (Lib_Version);
+ pragma Unreferenced (Relocatable);
+ pragma Unreferenced (Auto_Init);
- procedure Copy_ALI_Files
- (From : Name_Id;
- To : Name_Id)
- is
begin
null;
- end Copy_ALI_Files;
+ end Build_Dynamic_Library;
-------------------------
-- Default_DLL_Address --
@@ -97,7 +117,7 @@ package body MLib.Tgt is
function DLL_Ext return String is
begin
- return "";
+ return "";
end DLL_Ext;
--------------------
@@ -106,7 +126,7 @@ package body MLib.Tgt is
function Dynamic_Option return String is
begin
- return "";
+ return "";
end Dynamic_Option;
-------------------
@@ -114,6 +134,8 @@ package body MLib.Tgt is
-------------------
function Is_Object_Ext (Ext : String) return Boolean is
+ pragma Unreferenced (Ext);
+
begin
return False;
end Is_Object_Ext;
@@ -123,6 +145,8 @@ package body MLib.Tgt is
--------------
function Is_C_Ext (Ext : String) return Boolean is
+ pragma Unreferenced (Ext);
+
begin
return False;
end Is_C_Ext;
@@ -132,6 +156,8 @@ package body MLib.Tgt is
--------------------
function Is_Archive_Ext (Ext : String) return Boolean is
+ pragma Unreferenced (Ext);
+
begin
return False;
end Is_Archive_Ext;
@@ -145,23 +171,33 @@ package body MLib.Tgt is
return "libgnat.a";
end Libgnat;
- -----------------------------
- -- Libraries_Are_Supported --
- -----------------------------
+ ------------------------
+ -- Library_Exists_For --
+ ------------------------
+
+ function Library_Exists_For (Project : Project_Id) return Boolean is
+ pragma Unreferenced (Project);
- function Libraries_Are_Supported return Boolean is
begin
return False;
- end Libraries_Are_Supported;
+ end Library_Exists_For;
+
+ ---------------------------
+ -- Library_File_Name_For --
+ ---------------------------
+
+ function Library_File_Name_For (Project : Project_Id) return Name_Id is
+ pragma Unreferenced (Project);
+
+ begin
+ return No_Name;
+ end Library_File_Name_For;
--------------------------------
-- Linker_Library_Path_Option --
--------------------------------
- function Linker_Library_Path_Option
- (Directory : String)
- return String_Access
- is
+ function Linker_Library_Path_Option return String_Access is
begin
return null;
end Linker_Library_Path_Option;
@@ -172,7 +208,7 @@ package body MLib.Tgt is
function Object_Ext return String is
begin
- return "";
+ return "";
end Object_Ext;
----------------
@@ -181,7 +217,25 @@ package body MLib.Tgt is
function PIC_Option return String is
begin
- return "";
+ return "";
end PIC_Option;
+ -----------------------------------------------
+ -- Standalone_Library_Auto_Init_Is_Supported --
+ -----------------------------------------------
+
+ function Standalone_Library_Auto_Init_Is_Supported return Boolean is
+ begin
+ return False;
+ end Standalone_Library_Auto_Init_Is_Supported;
+
+ ---------------------------
+ -- Support_For_Libraries --
+ ---------------------------
+
+ function Support_For_Libraries return Library_Support is
+ begin
+ return None;
+ end Support_For_Libraries;
+
end MLib.Tgt;
diff --git a/gcc/ada/mlib-tgt.ads b/gcc/ada/mlib-tgt.ads
index a84a989946e..d7cad10b091 100644
--- a/gcc/ada/mlib-tgt.ads
+++ b/gcc/ada/mlib-tgt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001, Ada Core Technologies, Inc. --
+-- Copyright (C) 2001-2003, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -20,7 +20,7 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -30,36 +30,63 @@
-- There are several versions for the body of this package.
-- In the default version, libraries are not supported, so function
--- Libraries_Are_Supported returns False.
+-- Support_For_Libraries return None.
with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Types; use Types;
+with Prj; use Prj;
package MLib.Tgt is
- function Libraries_Are_Supported return Boolean;
- -- Indicates if building libraries by gnatmake and gnatmlib
- -- are supported by the GNAT implementation for the OS.
+ type Library_Support is (None, Static_Only, Full);
+ -- Support for Library Project File.
+ -- - None: Library Project Files are not supported at all
+ -- - Static_Only: Library Project Files are only supported for static
+ -- libraries.
+ -- - Full: Library Project Files are supported for static and dynamic
+ -- (shared) libraries.
+
+ function Support_For_Libraries return Library_Support;
+ -- Indicates how building libraries by gnatmake is supported by the GNAT
+ -- implementation for the platform.
+
+ function Standalone_Library_Auto_Init_Is_Supported return Boolean;
+ -- Indicates if when building a dynamic Standalone Library,
+ -- automatic initialization is supported. If it is, then it is the default,
+ -- unless attribute Library_Auto_Init has the value "false".
+
+ function Archive_Builder return String;
+ -- Returns the name of the archive builder program, usually "ar"
+
+ function Archive_Builder_Options return String_List_Access;
+ -- A list of options to invoke the Archive_Builder, usually "cr" for "ar"
+
+ function Archive_Indexer return String;
+ -- Returns the name of the program, if any, that generates an index
+ -- to the contents of an archive, usually "ranlib".
function Default_DLL_Address return String;
- -- default address for non relocatable DLL
+ -- Default address for non relocatable DLL.
+ -- For OSes where a dynamic library is always relocatable,
+ -- this function returns an empty string.
function Dynamic_Option return String;
- -- gcc option to create a dynamic library
-
- function Base_Option return String;
+ -- gcc option to create a dynamic library.
+ -- For Unix, returns "-shared", for Windows returns "-mdll".
function Libgnat return String;
-- System dependent static GNAT library
function Archive_Ext return String;
- -- System dependent static library extension
+ -- System dependent static library extension, without leading dot.
+ -- For Unix and Windows, return "a".
function Object_Ext return String;
- -- System dependent object extension
+ -- System dependent object extension, without leadien dot.
+ -- On Unix, returns "o".
function DLL_Ext return String;
- -- System dependent dynamic library extension
+ -- System dependent dynamic library extension, without leading dot.
+ -- On Unix, returns "so", on Windows, returns "dll".
function PIC_Option return String;
-- Position independent code option
@@ -73,26 +100,58 @@ package MLib.Tgt is
function Is_Archive_Ext (Ext : String) return Boolean;
-- Returns True iff Ext is an extension for a library
- procedure Copy_ALI_Files
- (From : Name_Id;
- To : Name_Id);
- -- Copy all ALI files from directory From to directory To
-
- function Linker_Library_Path_Option
- (Directory : String)
- return String_Access;
- -- Linker option to specify the library directory path
+ function Linker_Library_Path_Option return String_Access;
+ -- Linker option to specify to the linker the library directory path.
+ -- If non null, the library directory path is to be appended.
+ -- Should be deallocated by the caller, when no longer needed.
procedure Build_Dynamic_Library
(Ofiles : Argument_List;
Foreign : Argument_List;
Afiles : Argument_List;
Options : Argument_List;
+ Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
+ Driver_Name : Name_Id := No_Name;
Lib_Address : String := "";
Lib_Version : String := "";
- Relocatable : Boolean := False);
- -- Build a dynamic/relocatable library
+ Relocatable : Boolean := False;
+ Auto_Init : Boolean := False);
+ -- Build a dynamic/relocatable library.
+ --
+ -- Ofiles is the list of all object files in the library.
+ -- Foreign is the list of non Ada object files (also included in Ofiles).
+ -- Afiles is the list of ALI files for the Ada object files.
+ -- Options is a list of options to be passed to the tool (gcc or other)
+ -- that effectively builds the dynamic library.
+ -- Interfaces is the list of ALI files for the interfaces of a SAL.
+ -- It is empty if the library is not a SAL.
+ -- Lib_Filename is the name of the library, without any prefix or
+ -- extension. For example, on Unix, if Lib_Filename is "toto", the name of
+ -- the library file will be "libtoto.so".
+ -- Lib_Dir is the directory path where the library will be located.
+ -- Lib_Address is the base address of the library for a non relocatable
+ -- library, given as an hexadecimal string.
+ -- For OSes that support symbolic links, Lib_Version, if non null, is
+ -- the actual file name of the library. For example on Unix,
+ -- if Lib_Filename is "toto" and Lib_Version is "libtoto.so.2.1",
+ -- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which will
+ -- be the actual library file.
+ -- Relocatable indicates if the library should be relocatable or not,
+ -- for those OSes that actually support non relocatable dynamic libraries.
+ -- Relocatable indicates that automatic elaboration/finalization must be
+ -- indicated to the linker, if possible.
+ -- Note: Depending on the OS, some of the parameters may not be taken
+ -- into account. For example, on Linux, Foreign, Afiles Lib_Address and
+ -- Relocatable are ignored.
+
+ function Library_Exists_For (Project : Project_Id) return Boolean;
+ -- Return True if the library file for a library project already exists.
+ -- This function can only be called for library projects.
+
+ function Library_File_Name_For (Project : Project_Id) return Name_Id;
+ -- Returns the file name of the library file of a library project.
+ -- This function can only be called for library projects.
end MLib.Tgt;
diff --git a/gcc/ada/mlib-utl.adb b/gcc/ada/mlib-utl.adb
index 06ef897d069..7c3a4ee707f 100644
--- a/gcc/ada/mlib-utl.adb
+++ b/gcc/ada/mlib-utl.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002, Ada Core Technologies, Inc. --
+-- Copyright (C) 2002-2003, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -20,34 +20,33 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with MLib.Fil;
-with MLib.Tgt;
-with Namet; use Namet;
-with Opt;
-with Osint; use Osint;
-with Output; use Output;
+with MLib.Fil; use MLib.Fil;
+with MLib.Tgt; use MLib.Tgt;
-package body MLib.Utl is
+with Namet; use Namet;
+with Opt;
+with Osint;
+with Output; use Output;
- use GNAT;
+with GNAT; use GNAT;
- package Files renames MLib.Fil;
- package Target renames MLib.Tgt;
+package body MLib.Utl is
Initialized : Boolean := False;
Gcc_Name : constant String := "gcc";
Gcc_Exec : OS_Lib.String_Access;
- Ar_Name : constant String := "ar";
+ Ar_Name : OS_Lib.String_Access;
Ar_Exec : OS_Lib.String_Access;
+ Ar_Options : OS_Lib.String_List_Access;
- Ranlib_Name : constant String := "ranlib";
- Ranlib_Exec : OS_Lib.String_Access;
+ Ranlib_Name : OS_Lib.String_Access;
+ Ranlib_Exec : OS_Lib.String_Access := null;
procedure Initialize;
-- Look for the tools in the path and record the full path for each one
@@ -57,53 +56,69 @@ package body MLib.Utl is
--------
procedure Ar (Output_File : String; Objects : Argument_List) is
- Create_Add_Opt : OS_Lib.String_Access := new String' ("cr");
-
Full_Output_File : constant String :=
- Files.Ext_To (Output_File, Target.Archive_Ext);
+ Ext_To (Output_File, Archive_Ext);
+
+ Arguments : OS_Lib.Argument_List_Access;
- Arguments : OS_Lib.Argument_List (1 .. 2 + Objects'Length);
Success : Boolean;
+ Line_Length : Natural := 0;
+ Max_Line_Length : constant := 200; -- arbitrary
+
begin
Initialize;
- Arguments (1) := Create_Add_Opt; -- "ar cr ..."
- Arguments (2) := new String'(Full_Output_File);
- Arguments (3 .. Arguments'Last) := Objects;
+ Arguments :=
+ new String_List (1 .. 1 + Ar_Options'Length + Objects'Length);
+ Arguments (1 .. Ar_Options'Length) := Ar_Options.all; -- "ar cr ..."
+ Arguments (Ar_Options'Length + 1) := new String'(Full_Output_File);
+ Arguments (Ar_Options'Length + 2 .. Arguments'Last) := Objects;
Delete_File (Full_Output_File);
if not Opt.Quiet_Output then
- Write_Str (Ar_Name);
+ Write_Str (Ar_Name.all);
+ Line_Length := Ar_Name'Length;
for J in Arguments'Range loop
+ -- Make sure the Output buffer does not overflow
+
+ if Line_Length + 1 + Arguments (J)'Length > Max_Line_Length then
+ Write_Eol;
+ Line_Length := 0;
+ end if;
+
Write_Char (' ');
Write_Str (Arguments (J).all);
+ Line_Length := Line_Length + 1 + Arguments (J)'Length;
end loop;
Write_Eol;
end if;
- OS_Lib.Spawn (Ar_Exec.all, Arguments, Success);
+ OS_Lib.Spawn (Ar_Exec.all, Arguments.all, Success);
if not Success then
- Fail (Ar_Name, " execution error.");
+ Fail (Ar_Name.all, " execution error.");
end if;
-- If we have found ranlib, run it over the library
if Ranlib_Exec /= null then
if not Opt.Quiet_Output then
- Write_Str (Ranlib_Name);
+ Write_Str (Ranlib_Name.all);
Write_Char (' ');
- Write_Line (Arguments (2).all);
+ Write_Line (Arguments (Ar_Options'Length + 1).all);
end if;
- OS_Lib.Spawn (Ranlib_Exec.all, (1 => Arguments (2)), Success);
+ OS_Lib.Spawn
+ (Ranlib_Exec.all,
+ (1 => Arguments (Ar_Options'Length + 1)),
+ Success);
if not Success then
- Fail (Ranlib_Name, " execution error.");
+ Fail (Ranlib_Name.all, " execution error.");
end if;
end if;
end Ar;
@@ -138,21 +153,41 @@ package body MLib.Utl is
procedure Gcc
(Output_File : String;
Objects : Argument_List;
- Options : Argument_List)
+ Options : Argument_List;
+ Driver_Name : Name_Id := No_Name;
+ Options_2 : Argument_List := No_Argument_List)
is
- Arguments : OS_Lib.Argument_List
- (1 .. 7 + Objects'Length + Options'Length);
+ Arguments :
+ OS_Lib.Argument_List
+ (1 .. 7 + Objects'Length + Options'Length + Options_2'Length);
- A : Natural := 0;
- Success : Boolean;
- Out_Opt : OS_Lib.String_Access := new String' ("-o");
- Out_V : OS_Lib.String_Access := new String' (Output_File);
- Lib_Dir : OS_Lib.String_Access := new String' ("-L" & Lib_Directory);
- Lib_Opt : OS_Lib.String_Access := new String' (Target.Dynamic_Option);
+ A : Natural := 0;
+ Success : Boolean;
+ Out_Opt : constant OS_Lib.String_Access :=
+ new String'("-o");
+ Out_V : constant OS_Lib.String_Access :=
+ new String'(Output_File);
+ Lib_Dir : constant OS_Lib.String_Access :=
+ new String'("-L" & Lib_Directory);
+ Lib_Opt : constant OS_Lib.String_Access :=
+ new String'(Dynamic_Option);
+
+ Driver : String_Access;
begin
Initialize;
+ if Driver_Name = No_Name then
+ Driver := Gcc_Exec;
+
+ else
+ Driver := OS_Lib.Locate_Exec_On_Path (Get_Name_String (Driver_Name));
+
+ if Driver = null then
+ Fail (Get_Name_String (Driver_Name), " not found in path");
+ end if;
+ end if;
+
if Lib_Opt'Length /= 0 then
A := A + 1;
Arguments (A) := Lib_Opt;
@@ -173,8 +208,11 @@ package body MLib.Utl is
A := A + Objects'Length;
Arguments (A - Objects'Length + 1 .. A) := Objects;
+ A := A + Options_2'Length;
+ Arguments (A - Options_2'Length + 1 .. A) := Options_2;
+
if not Opt.Quiet_Output then
- Write_Str (Gcc_Exec.all);
+ Write_Str (Driver.all);
for J in 1 .. A loop
Write_Char (' ');
@@ -184,10 +222,15 @@ package body MLib.Utl is
Write_Eol;
end if;
- OS_Lib.Spawn (Gcc_Exec.all, Arguments (1 .. A), Success);
+ OS_Lib.Spawn (Driver.all, Arguments (1 .. A), Success);
if not Success then
- Fail (Gcc_Name, " execution error");
+ if Driver_Name = No_Name then
+ Fail (Gcc_Name, " execution error");
+
+ else
+ Fail (Get_Name_String (Driver_Name), " execution error");
+ end if;
end if;
end Gcc;
@@ -196,8 +239,6 @@ package body MLib.Utl is
----------------
procedure Initialize is
- use type OS_Lib.String_Access;
-
begin
if not Initialized then
Initialized := True;
@@ -207,7 +248,6 @@ package body MLib.Utl is
Gcc_Exec := OS_Lib.Locate_Exec_On_Path (Gcc_Name);
if Gcc_Exec = null then
-
Fail (Gcc_Name, " not found in path");
elsif Opt.Verbose_Mode then
@@ -217,28 +257,32 @@ package body MLib.Utl is
-- ar
- Ar_Exec := OS_Lib.Locate_Exec_On_Path (Ar_Name);
+ Ar_Name := new String'(Archive_Builder);
+ Ar_Exec := OS_Lib.Locate_Exec_On_Path (Ar_Name.all);
if Ar_Exec = null then
-
- Fail (Ar_Name, " not found in path");
+ Fail (Ar_Name.all, " not found in path");
elsif Opt.Verbose_Mode then
Write_Str ("found ");
Write_Line (Ar_Exec.all);
end if;
+ Ar_Options := Archive_Builder_Options;
+
-- ranlib
- Ranlib_Exec := OS_Lib.Locate_Exec_On_Path (Ranlib_Name);
+ Ranlib_Name := new String'(Archive_Indexer);
- if Ranlib_Exec /= null and then Opt.Verbose_Mode then
- Write_Str ("found ");
- Write_Line (Ranlib_Exec.all);
- end if;
+ if Ranlib_Name'Length > 0 then
+ Ranlib_Exec := OS_Lib.Locate_Exec_On_Path (Ranlib_Name.all);
+ if Ranlib_Exec /= null and then Opt.Verbose_Mode then
+ Write_Str ("found ");
+ Write_Line (Ranlib_Exec.all);
+ end if;
+ end if;
end if;
-
end Initialize;
-------------------
@@ -246,12 +290,12 @@ package body MLib.Utl is
-------------------
function Lib_Directory return String is
- Libgnat : constant String := Target.Libgnat;
+ Libgnat : constant String := Tgt.Libgnat;
begin
Name_Len := Libgnat'Length;
Name_Buffer (1 .. Name_Len) := Libgnat;
- Get_Name_String (Find_File (Name_Enter, Library));
+ Get_Name_String (Osint.Find_File (Name_Enter, Osint.Library));
-- Remove libgnat.a
diff --git a/gcc/ada/mlib-utl.ads b/gcc/ada/mlib-utl.ads
index 41bf3de3c15..b2d8da85892 100644
--- a/gcc/ada/mlib-utl.ads
+++ b/gcc/ada/mlib-utl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2002, Ada Core Technologies, Inc --
+-- Copyright (C) 2001-2003, Ada Core Technologies, Inc --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -20,7 +20,7 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -29,22 +29,34 @@
package MLib.Utl is
+ No_Argument_List : constant Argument_List := (1 .. 0 => null);
+ -- Comment needed ???
+
procedure Delete_File (Filename : in String);
- -- Delete the file Filename.
+ -- Delete the file Filename
+ -- Why is this different from the standard OS_Lib routine???
procedure Gcc
(Output_File : String;
Objects : Argument_List;
- Options : Argument_List);
- -- Invoke gcc to create a library.
+ Options : Argument_List;
+ Driver_Name : Name_Id := No_Name;
+ Options_2 : Argument_List := No_Argument_List);
+ -- Driver_Name indicates the "driver" to invoke; by default, the "driver"
+ -- is gcc.
+ -- This procedure invokes the driver to create a shared library.
+ -- Options are passed to gcc before the objects, Options_2 after.
+ -- Output_File is the name of the library file to create.
+ -- Objects are the names of the object files to put in the library.
procedure Ar
(Output_File : String;
Objects : Argument_List);
-- Run ar to move all the binaries inside the archive.
-- If ranlib is on the path, run it also.
+ -- Arguments need documenting ???
function Lib_Directory return String;
- -- Return the directory containing libgnat.
+ -- Return the directory containing libgnat
end MLib.Utl;
diff --git a/gcc/ada/mlib.adb b/gcc/ada/mlib.adb
index 1b2997fadc6..5016587d5f8 100644
--- a/gcc/ada/mlib.adb
+++ b/gcc/ada/mlib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2001, Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2003, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -20,19 +20,25 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
+
+with Hostparm;
with Opt;
-with Osint; use Osint;
-with Output; use Output;
-with MLib.Utl;
+with Output; use Output;
+with Namet; use Namet;
-package body MLib is
+with MLib.Utl; use MLib.Utl;
+
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+with System;
- package Tools renames MLib.Utl;
+package body MLib is
-------------------
-- Build_Library --
@@ -55,8 +61,7 @@ package body MLib is
Write_Line (Output_File);
end if;
- Tools.Ar (Output_Dir & "/lib" & Output_File & ".a", Objects => Ofiles);
-
+ Ar (Output_Dir & "/lib" & Output_File & ".a", Objects => Ofiles);
end Build_Library;
------------------------
@@ -70,9 +75,7 @@ package body MLib is
end if;
if Name'Length > Max_Characters_In_Library_Name then
- Fail ("illegal library name """,
- Name,
- """: too long");
+ Fail ("illegal library name """, Name, """: too long");
end if;
if not Is_Letter (Name (Name'First)) then
@@ -90,4 +93,205 @@ package body MLib is
end loop;
end Check_Library_Name;
+ --------------------
+ -- Copy_ALI_Files --
+ --------------------
+
+ procedure Copy_ALI_Files
+ (Files : Argument_List;
+ To : Name_Id;
+ Interfaces : String_List)
+ is
+ Success : Boolean := False;
+ To_Dir : constant String := Get_Name_String (To);
+ Interface : Boolean := False;
+
+ procedure Set_Readonly (Name : System.Address);
+ pragma Import (C, Set_Readonly, "__gnat_set_readonly");
+
+ procedure Verbose_Copy (Index : Positive);
+ -- In verbose mode, output a message that the indexed file is copied
+ -- to the destination directory.
+
+ ------------------
+ -- Verbose_Copy --
+ ------------------
+
+ procedure Verbose_Copy (Index : Positive) is
+ begin
+ if Opt.Verbose_Mode then
+ Write_Str ("Copying """);
+ Write_Str (Files (Index).all);
+ Write_Str (""" to """);
+ Write_Str (To_Dir);
+ Write_Line ("""");
+ end if;
+ end Verbose_Copy;
+
+ begin
+ if Interfaces'Length = 0 then
+
+ -- If there are no Interfaces, copy all the ALI files as is
+
+ for Index in Files'Range loop
+ Verbose_Copy (Index);
+ Copy_File
+ (Files (Index).all,
+ To_Dir,
+ Success,
+ Mode => Overwrite,
+ Preserve => Preserve);
+
+ exit when not Success;
+ end loop;
+
+ else
+ -- Copy only the interface ALI file, and put the special indicator
+ -- "SL" on the P line.
+
+ for Index in Files'Range loop
+
+ declare
+ File_Name : String := Base_Name (Files (Index).all);
+ begin
+ Canonical_Case_File_Name (File_Name);
+
+ -- Check if this is one of the interface ALIs
+
+ Interface := False;
+
+ for Index in Interfaces'Range loop
+ if File_Name = Interfaces (Index).all then
+ Interface := True;
+ exit;
+ end if;
+ end loop;
+
+ -- If it is an interface ALI, copy line by line. Insert
+ -- the interface indication at the end of the P line.
+ -- Do not copy ALI files that are not Interfaces.
+
+ if Interface then
+ Success := False;
+ Verbose_Copy (Index);
+
+ declare
+ FD : File_Descriptor;
+ Len : Integer;
+ Actual_Len : Integer;
+ S : String_Access;
+ Curr : Natural;
+ P_Line_Found : Boolean;
+ Status : Boolean;
+
+ begin
+ -- Open the file
+
+ Name_Len := Files (Index)'Length;
+ Name_Buffer (1 .. Name_Len) := Files (Index).all;
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := ASCII.NUL;
+
+ FD := Open_Read (Name_Buffer'Address, Binary);
+
+ if FD /= Invalid_FD then
+ Len := Integer (File_Length (FD));
+
+ S := new String (1 .. Len + 3);
+
+ -- Read the file. Note that the loop is not necessary
+ -- since the whole file is read at once except on VMS.
+
+ Curr := 1;
+ Actual_Len := Len;
+
+ while Actual_Len /= 0 loop
+ Actual_Len := Read (FD, S (Curr)'Address, Len);
+ Curr := Curr + Actual_Len;
+ end loop;
+
+ -- We are done with the input file, so we close it
+
+ Close (FD, Status);
+ -- We simply ignore any bad status
+
+ P_Line_Found := False;
+
+ -- Look for the P line. When found, add marker SL
+ -- at the beginning of the P line.
+
+ for Index in 1 .. Len - 3 loop
+ if (S (Index) = ASCII.LF or else
+ S (Index) = ASCII.CR)
+ and then
+ S (Index + 1) = 'P'
+ then
+ S (Index + 5 .. Len + 3) := S (Index + 2 .. Len);
+ S (Index + 2 .. Index + 4) := " SL";
+ P_Line_Found := True;
+ exit;
+ end if;
+ end loop;
+
+ if P_Line_Found then
+
+ -- Create new modified ALI file
+
+ Name_Len := To_Dir'Length;
+ Name_Buffer (1 .. Name_Len) := To_Dir;
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Directory_Separator;
+ Name_Buffer
+ (Name_Len + 1 .. Name_Len + File_Name'Length) :=
+ File_Name;
+ Name_Len := Name_Len + File_Name'Length + 1;
+ Name_Buffer (Name_Len) := ASCII.NUL;
+
+ FD := Create_File (Name_Buffer'Address, Binary);
+
+ -- Write the modified text and close the newly
+ -- created file.
+
+ if FD /= Invalid_FD then
+ Actual_Len := Write (FD, S (1)'Address, Len + 3);
+
+ Close (FD, Status);
+
+ -- Set Success to True only if the newly
+ -- created file has been correctly written.
+
+ Success := Status and Actual_Len = Len + 3;
+
+ if Success then
+ Set_Readonly (Name_Buffer'Address);
+ end if;
+ end if;
+ end if;
+ end if;
+ end;
+
+ else
+ -- This is not an interface ALI
+
+ Success := True;
+
+ end if;
+ end;
+
+ if not Success then
+ Fail ("could not copy ALI files to library dir");
+ end if;
+ end loop;
+ end if;
+ end Copy_ALI_Files;
+
+-- Package elaboration
+
+begin
+ if Hostparm.OpenVMS then
+
+ -- Copy_Attributes always fails on VMS
+
+ Preserve := None;
+ end if;
end MLib;
diff --git a/gcc/ada/mlib.ads b/gcc/ada/mlib.ads
index 396c0fbed1c..c844ccbb389 100644
--- a/gcc/ada/mlib.ads
+++ b/gcc/ada/mlib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2001, Ada Core Technologies, Inc. --
+-- Copyright (C) 1999-2003, Ada Core Technologies, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -20,7 +20,7 @@
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -28,14 +28,22 @@
-- and GNATMAKE to build libraries
with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Osint; use Osint;
+with Types; use Types;
package MLib is
- Tools_Error : exception;
- -- ??? needs comment
-
Max_Characters_In_Library_Name : constant := 20;
- -- ??? needs comment
+ -- Maximum number of characters in a library name.
+ -- Used by Check_Library_Name below.
+
+ type Fail_Proc is access procedure
+ (S1 : String; S2 : String := ""; S3 : String := "");
+
+ Fail : Fail_Proc := Osint.Fail'Access;
+ -- This procedure is used in the MLib hierarchy, instead of
+ -- directly calling Osint.Fail.
+ -- It is redirected to Make.Make_Failed by gnatmake.
procedure Check_Library_Name (Name : String);
-- Verify that the name of a library has the following characteristics
@@ -50,4 +58,17 @@ package MLib is
Output_Dir : String);
-- Build a static library from a set of object files
+ procedure Copy_ALI_Files
+ (Files : Argument_List;
+ To : Name_Id;
+ Interfaces : String_List);
+ -- Copy all ALI files Files to directory To.
+ -- Mark Interfaces ALI files as interfaces, if any.
+
+private
+
+ Preserve : Attribute := Time_Stamps;
+ -- Used by Copy_ALI_Files. Changed to None for OpenVMS, because
+ -- Copy_Attributes always fails on VMS.
+
end MLib;
diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb
index 22f3634b974..f99af5ff299 100644
--- a/gcc/ada/namet.adb
+++ b/gcc/ada/namet.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -119,6 +119,7 @@ package body Namet is
end loop;
end Add_Str_To_Name_Buffer;
+
--------------
-- Finalize --
--------------
@@ -266,16 +267,11 @@ package body Namet is
-- Here we have at least some encoding that we must decode
- -- Here we have to decode one or more Uhh or Whhhh sequences
-
- declare
+ Decode : declare
New_Len : Natural;
Old : Positive;
New_Buf : String (1 .. Name_Buffer'Last);
- procedure Insert_Character (C : Character);
- -- Insert a new character into output decoded name
-
procedure Copy_One_Character;
-- Copy a character from Name_Buffer to New_Buf. Includes case
-- of copying a Uhh or Whhhh sequence and decoding it.
@@ -283,26 +279,51 @@ package body Namet is
function Hex (N : Natural) return Natural;
-- Scans past N digits using Old pointer and returns hex value
+ procedure Insert_Character (C : Character);
+ -- Insert a new character into output decoded name
+
+ ------------------------
+ -- Copy_One_Character --
+ ------------------------
+
procedure Copy_One_Character is
C : Character;
begin
C := Name_Buffer (Old);
- if C = 'U' then
+ -- U (upper half insertion case)
+
+ if C = 'U'
+ and then Old < Name_Len
+ and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
+ and then Name_Buffer (Old + 1) /= '_'
+ then
Old := Old + 1;
Insert_Character (Character'Val (Hex (2)));
- elsif C = 'W' then
+ -- W (wide character insertion)
+
+ elsif C = 'W'
+ and then Old < Name_Len
+ and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
+ and then Name_Buffer (Old + 1) /= '_'
+ then
Old := Old + 1;
Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
+ -- Any other character is copied unchanged
+
else
- Insert_Character (Name_Buffer (Old));
+ Insert_Character (C);
Old := Old + 1;
end if;
end Copy_One_Character;
+ ---------
+ -- Hex --
+ ---------
+
function Hex (N : Natural) return Natural is
T : Natural := 0;
C : Character;
@@ -324,13 +345,17 @@ package body Namet is
return T;
end Hex;
+ ----------------------
+ -- Insert_Character --
+ ----------------------
+
procedure Insert_Character (C : Character) is
begin
New_Len := New_Len + 1;
New_Buf (New_Len) := C;
end Insert_Character;
- -- Actual decoding processing
+ -- Start of processing for Decode
begin
New_Len := 0;
@@ -342,7 +367,9 @@ package body Namet is
-- Case of character literal, put apostrophes around character
- if Name_Buffer (Old) = 'Q' then
+ if Name_Buffer (Old) = 'Q'
+ and then Old < Name_Len
+ then
Old := Old + 1;
Insert_Character (''');
Copy_One_Character;
@@ -350,7 +377,11 @@ package body Namet is
-- Case of operator name
- elsif Name_Buffer (Old) = 'O' then
+ elsif Name_Buffer (Old) = 'O'
+ and then Old < Name_Len
+ and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
+ and then Name_Buffer (Old + 1) /= '_'
+ then
Old := Old + 1;
declare
@@ -441,8 +472,7 @@ package body Namet is
Name_Len := New_Len;
Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
- end;
-
+ end Decode;
end Get_Decoded_Name_String;
-------------------------------------------
@@ -470,7 +500,10 @@ package body Namet is
P := 1;
while P < Name_Len loop
- if Name_Buffer (P) = 'U' then
+ if Name_Buffer (P + 1) in 'A' .. 'Z' then
+ P := P + 1;
+
+ elsif Name_Buffer (P) = 'U' then
for J in reverse P + 3 .. P + Name_Len loop
Name_Buffer (J + 3) := Name_Buffer (J);
end loop;
@@ -505,6 +538,24 @@ package body Namet is
end if;
end Get_Decoded_Name_String_With_Brackets;
+ ------------------------
+ -- Get_Last_Two_Chars --
+ ------------------------
+
+ procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character) is
+ NE : Name_Entry renames Name_Entries.Table (N);
+ NEL : constant Int := Int (NE.Name_Len);
+
+ begin
+ if NEL >= 2 then
+ C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1);
+ C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0);
+ else
+ C1 := ASCII.NUL;
+ C2 := ASCII.NUL;
+ end if;
+ end Get_Last_Two_Chars;
+
---------------------
-- Get_Name_String --
---------------------
@@ -605,7 +656,7 @@ package body Namet is
----------
function Hash return Hash_Index_Type is
- subtype Int_1_12 is Int range 1 .. 12;
+ subtype Int_0_12 is Int range 0 .. 12;
-- Used to avoid when others on case jump below
Even_Name_Len : Integer;
@@ -643,7 +694,10 @@ package body Namet is
-- hash. The positioning is randomized, with the bias that characters
-- later on participate fully (i.e. are added towards the right side).
- case Int_1_12 (Name_Len) is
+ case Int_0_12 (Name_Len) is
+
+ when 0 =>
+ return 0;
when 1 =>
return
@@ -889,7 +943,6 @@ package body Namet is
function Name_Enter return Name_Id is
begin
-
Name_Entries.Increment_Last;
Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
Name_Chars.Last;
@@ -1124,9 +1177,22 @@ package body Namet is
and then Name_Buffer (J) /= 'p';
end loop;
- -- Find rightmost __ or $ separator if one exists
+ -- Find rightmost __ or $ separator if one exists. First we position
+ -- to start the search. If we have a character constant, position
+ -- just before it, otherwise position to last character but one
+
+ if Name_Buffer (Name_Len) = ''' then
+ J := Name_Len - 2;
+ while J > 0 and then Name_Buffer (J) /= ''' loop
+ J := J - 1;
+ end loop;
+
+ else
+ J := Name_Len - 1;
+ end if;
+
+ -- Loop to search for rightmost __ or $ (homonym) separator
- J := Name_Len - 1;
while J > 1 loop
-- If $ separator, homonym separator, so strip it and keep looking
diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads
index 092be4a7cc1..4fd0120da8a 100644
--- a/gcc/ada/namet.ads
+++ b/gcc/ada/namet.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -53,22 +53,34 @@ package Namet is
-- stored in an encoded form (Uhh for upper half and
-- Whhhh for wide characters, as provided by the routine
-- Store_Encoded_Character, where hh are hex digits for
--- the character code using lower case a-f). Other
--- internally generated names use upper case letters
--- (other than O,Q,U,W) to ensure that they do not clash
--- with identifier names in the source program.
+-- the character code using lower case a-f). Normally
+-- the use of U or W in other internal names is avoided,
+-- but these letters may be used in internal names
+-- (without this special meaning), if the appear as
+-- the last character of the name, or they are followed
+-- by an upper case letter or an underscore.
+
-- Operator symbols Stored with an initial letter O, and the remainder
-- of the name is the lower case characters XXX where
-- the name is Name_Op_XXX, see Snames spec for a full
--- list of the operator names.
+-- list of the operator names. Normally the use of O
+-- in other internal names is avoided, but it may be
+-- used in internal names (without this special meaning)
+-- if it is the last character of the name, or if it is
+-- followed by an upper case letter or an underscore.
-- Character literals Character literals have names that are used only for
-- debugging and error message purposes. The form is a
--- upper case Q followed by a single letter, or by a Uxx
--- or Wxxxx encoding as described for identifiers. The
--- Set_Character_Literal_Name procedure should be used
--- to construct these encodings.
+-- upper case Q followed by a single lower case letter,
+-- or by a Uxx or Wxxxx encoding as described for
+-- identifiers. The Set_Character_Literal_Name procedure
+-- should be used to construct these encodings. Normally
+-- the use of O in other internal names is avoided, but
+-- it may be used in internal names (without this special
+-- meaning) if it is the last character of the name, or
+-- if it is followed by an upper case letter or an
+-- underscore.
-- Unit names Stored with upper case letters folded to lower case,
-- using Uhh/Whhhh encoding as described for identifiers,
@@ -224,7 +236,8 @@ package Namet is
-- table to see if the string has already been stored. If so the Id of
-- the existing entry is returned. Otherwise a new entry is created with
-- its Name_Table_Info field set to zero. The contents of Name_Buffer
- -- and Name_Len are not modified by this call.
+ -- and Name_Len are not modified by this call. Note that it is permissible
+ -- for Name_Len to be set to zero to lookup the null name string.
function Name_Enter return Name_Id;
-- Name_Enter has the same calling interface as Name_Find. The difference
@@ -325,6 +338,11 @@ package Namet is
procedure Tree_Write;
-- Writes out internal tables to current tree file using Tree_Write
+ procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character);
+ -- Obtains last two characters of a name. C1 is last but one character
+ -- and C2 is last character. If name is less than two characters long,
+ -- then both C1 and C2 are set to ASCII.NUL on return.
+
procedure Write_Name (Id : Name_Id);
-- Write_Name writes the characters of the specified name using the
-- standard output procedures in package Output. No end of line is
@@ -340,8 +358,8 @@ package Namet is
procedure Write_Name_Decoded (Id : Name_Id);
-- Like Write_Name, except that the name written is the decoded name, as
- -- described for Get_Name_Decoded, and the resulting value stored in
- -- Name_Len and Name_Buffer is the decoded name.
+ -- described for Get_Decoded_Name_String, and the resulting value stored
+ -- in Name_Len and Name_Buffer is the decoded name.
---------------------------
-- Table Data Structures --
diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h
index 6616405051a..97c72cf0eb0 100644
--- a/gcc/ada/namet.h
+++ b/gcc/ada/namet.h
@@ -6,8 +6,7 @@
* *
* C Header File *
* *
- * *
- * 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- *
@@ -116,11 +115,13 @@ typedef Nat Source_File_Index;
typedef Int Logical_Line_Number;
#define Debug_Source_Name sinput__debug_source_name
+#define Full_Debug_Name sinput__full_debug_name
#define Reference_Name sinput__reference_name
#define Get_Source_File_Index sinput__get_source_file_index
#define Get_Logical_Line_Number sinput__get_logical_line_number
extern File_Name_Type Debug_Source_Name PARAMS ((Source_File_Index));
+extern File_Name_Type Full_Debug_Name PARAMS ((Source_File_Index));
extern File_Name_Type Reference_Name PARAMS ((Source_File_Index));
extern Source_File_Index Get_Source_File_Index PARAMS ((Source_Ptr));
extern Logical_Line_Number Get_Logical_Line_Number PARAMS ((Source_Ptr));
diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads
index 2e89ff4ceb9..4eb3372a20d 100644
--- a/gcc/ada/nlists.ads
+++ b/gcc/ada/nlists.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 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- --
diff --git a/gcc/ada/nlists.h b/gcc/ada/nlists.h
index a71275e6d38..7477d7445fe 100644
--- a/gcc/ada/nlists.h
+++ b/gcc/ada/nlists.h
@@ -6,7 +6,6 @@
* *
* C Header File *
* *
- * *
* Copyright (C) 1992-2001, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
diff --git a/gcc/ada/nmake.adb b/gcc/ada/nmake.adb
index a16204c0ce7..9b199faa0d0 100644
--- a/gcc/ada/nmake.adb
+++ b/gcc/ada/nmake.adb
@@ -6,11 +6,7 @@
-- --
-- B o d y --
-- --
--- Generated by xnmake revision 1.29 using --
--- sinfo.ads revision 1.439 --
--- nmake.adt revision 1.12 --
--- --
--- Copyright (C) 1992-2001 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- --
@@ -1227,7 +1223,8 @@ package body Nmake is
Iteration_Scheme : Node_Id := Empty;
Statements : List_Id;
End_Label : Node_Id;
- Has_Created_Identifier : Boolean := False)
+ Has_Created_Identifier : Boolean := False;
+ Is_Null_Loop : Boolean := False)
return Node_Id
is
N : constant Node_Id :=
@@ -1238,6 +1235,7 @@ package body Nmake is
Set_Statements (N, Statements);
Set_End_Label (N, End_Label);
Set_Has_Created_Identifier (N, Has_Created_Identifier);
+ Set_Is_Null_Loop (N, Is_Null_Loop);
return N;
end Make_Loop_Statement;
@@ -2117,7 +2115,8 @@ package body Nmake is
function Make_Compilation_Unit_Aux (Sloc : Source_Ptr;
Declarations : List_Id := No_List;
Actions : List_Id := No_List;
- Pragmas_After : List_Id := No_List)
+ Pragmas_After : List_Id := No_List;
+ Config_Pragmas : List_Id := Empty_List)
return Node_Id
is
N : constant Node_Id :=
@@ -2126,13 +2125,15 @@ package body Nmake is
Set_Declarations (N, Declarations);
Set_Actions (N, Actions);
Set_Pragmas_After (N, Pragmas_After);
+ Set_Config_Pragmas (N, Config_Pragmas);
return N;
end Make_Compilation_Unit_Aux;
function Make_With_Clause (Sloc : Source_Ptr;
Name : Node_Id;
First_Name : Boolean := True;
- Last_Name : Boolean := True)
+ Last_Name : Boolean := True;
+ Limited_Present : Boolean := False)
return Node_Id
is
N : constant Node_Id :=
@@ -2141,6 +2142,7 @@ package body Nmake is
Set_Name (N, Name);
Set_First_Name (N, First_Name);
Set_Last_Name (N, Last_Name);
+ Set_Limited_Present (N, Limited_Present);
return N;
end Make_With_Clause;
diff --git a/gcc/ada/nmake.ads b/gcc/ada/nmake.ads
index 5439156699f..be05e7940b3 100644
--- a/gcc/ada/nmake.ads
+++ b/gcc/ada/nmake.ads
@@ -6,11 +6,7 @@
-- --
-- S p e c --
-- --
--- Generated by xnmake revision 1.29 using --
--- sinfo.ads revision 1.439 --
--- nmake.adt revision 1.12 --
--- --
--- Copyright (C) 1992-2001 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- --
@@ -602,7 +598,8 @@ package Nmake is
Iteration_Scheme : Node_Id := Empty;
Statements : List_Id;
End_Label : Node_Id;
- Has_Created_Identifier : Boolean := False)
+ Has_Created_Identifier : Boolean := False;
+ Is_Null_Loop : Boolean := False)
return Node_Id;
pragma Inline (Make_Loop_Statement);
@@ -1013,14 +1010,16 @@ package Nmake is
function Make_Compilation_Unit_Aux (Sloc : Source_Ptr;
Declarations : List_Id := No_List;
Actions : List_Id := No_List;
- Pragmas_After : List_Id := No_List)
+ Pragmas_After : List_Id := No_List;
+ Config_Pragmas : List_Id := Empty_List)
return Node_Id;
pragma Inline (Make_Compilation_Unit_Aux);
function Make_With_Clause (Sloc : Source_Ptr;
Name : Node_Id;
First_Name : Boolean := True;
- Last_Name : Boolean := True)
+ Last_Name : Boolean := True;
+ Limited_Present : Boolean := False)
return Node_Id;
pragma Inline (Make_With_Clause);
diff --git a/gcc/ada/nmake.adt b/gcc/ada/nmake.adt
index b7532cc8a45..42221c1190b 100644
--- a/gcc/ada/nmake.adt
+++ b/gcc/ada/nmake.adt
@@ -6,8 +6,7 @@
-- --
-- T e m p l a t e --
-- --
--- --
--- Copyright (C) 1992-2001 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- --
diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb
index 777b808d781..cce9b1e87aa 100644
--- a/gcc/ada/opt.adb
+++ b/gcc/ada/opt.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -31,20 +31,12 @@
-- --
------------------------------------------------------------------------------
-with Ada.Exceptions; use Ada.Exceptions;
with Gnatvsn; use Gnatvsn;
with System; use System;
with Tree_IO; use Tree_IO;
package body Opt is
- Tree_Version_String : String (Gnat_Version_String'Range);
- -- Used to store the compiler version string read from a tree file to
- -- check if it is the same as stored in the version ctring in Gnatvsn.
- -- Therefore its length is taken directly from the version string in
- -- Gnatvsn. If the length of the version string stored in the three is
- -- different, then versions are for sure different.
-
Immediate_Errors : Boolean := True;
-- This is an obsolete flag that is no longer present in opt.ads. We
-- retain it here because this flag was written to the tree and there
@@ -57,13 +49,14 @@ package body Opt is
procedure Register_Opt_Config_Switches is
begin
- Ada_83_Config := Ada_83;
- Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks;
- Extensions_Allowed_Config := Extensions_Allowed;
- External_Name_Exp_Casing_Config := External_Name_Exp_Casing;
- External_Name_Imp_Casing_Config := External_Name_Imp_Casing;
- Polling_Required_Config := Polling_Required;
- Use_VADS_Size_Config := Use_VADS_Size;
+ Ada_83_Config := Ada_83;
+ Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks;
+ Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed;
+ Extensions_Allowed_Config := Extensions_Allowed;
+ External_Name_Exp_Casing_Config := External_Name_Exp_Casing;
+ External_Name_Imp_Casing_Config := External_Name_Imp_Casing;
+ Polling_Required_Config := Polling_Required;
+ Use_VADS_Size_Config := Use_VADS_Size;
end Register_Opt_Config_Switches;
---------------------------------
@@ -72,14 +65,15 @@ package body Opt is
procedure Restore_Opt_Config_Switches (Save : Config_Switches_Type) is
begin
- Ada_83 := Save.Ada_83;
- Ada_95 := not Ada_83;
- Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks;
- Extensions_Allowed := Save.Extensions_Allowed;
- External_Name_Exp_Casing := Save.External_Name_Exp_Casing;
- External_Name_Imp_Casing := Save.External_Name_Imp_Casing;
- Polling_Required := Save.Polling_Required;
- Use_VADS_Size := Save.Use_VADS_Size;
+ Ada_83 := Save.Ada_83;
+ Ada_95 := not Ada_83;
+ Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks;
+ Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed;
+ Extensions_Allowed := Save.Extensions_Allowed;
+ External_Name_Exp_Casing := Save.External_Name_Exp_Casing;
+ External_Name_Imp_Casing := Save.External_Name_Imp_Casing;
+ Polling_Required := Save.Polling_Required;
+ Use_VADS_Size := Save.Use_VADS_Size;
end Restore_Opt_Config_Switches;
------------------------------
@@ -88,13 +82,14 @@ package body Opt is
procedure Save_Opt_Config_Switches (Save : out Config_Switches_Type) is
begin
- Save.Ada_83 := Ada_83;
- Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks;
- Save.Extensions_Allowed := Extensions_Allowed;
- Save.External_Name_Exp_Casing := External_Name_Exp_Casing;
- Save.External_Name_Imp_Casing := External_Name_Imp_Casing;
- Save.Polling_Required := Polling_Required;
- Save.Use_VADS_Size := Use_VADS_Size;
+ Save.Ada_83 := Ada_83;
+ Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks;
+ Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed;
+ Save.Extensions_Allowed := Extensions_Allowed;
+ Save.External_Name_Exp_Casing := External_Name_Exp_Casing;
+ Save.External_Name_Imp_Casing := External_Name_Imp_Casing;
+ Save.Polling_Required := Polling_Required;
+ Save.Use_VADS_Size := Use_VADS_Size;
end Save_Opt_Config_Switches;
-----------------------------
@@ -122,7 +117,8 @@ package body Opt is
Use_VADS_Size := Use_VADS_Size_Config;
end if;
- Polling_Required := Polling_Required_Config;
+ Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config;
+ Polling_Required := Polling_Required_Config;
end Set_Opt_Config_Switches;
---------------
@@ -133,12 +129,13 @@ package body Opt is
Tree_Version_String_Len : Nat;
begin
+ Tree_Read_Int (Tree_ASIS_Version_Number);
Tree_Read_Bool (Brief_Output);
Tree_Read_Bool (GNAT_Mode);
Tree_Read_Char (Identifier_Character_Set);
Tree_Read_Int (Maximum_File_Name_Length);
Tree_Read_Data (Suppress_Options'Address,
- Suppress_Record'Object_Size / Storage_Unit);
+ Suppress_Array'Object_Size / Storage_Unit);
Tree_Read_Bool (Verbose_Mode);
Tree_Read_Data (Warning_Mode'Address,
Warning_Mode_Type'Object_Size / Storage_Unit);
@@ -148,20 +145,23 @@ package body Opt is
Tree_Read_Bool (Enable_Overflow_Checks);
Tree_Read_Bool (Full_List);
- -- Read and check version string
+ -- Read version string: we have to check the length first
Tree_Read_Int (Tree_Version_String_Len);
if Tree_Version_String_Len = Tree_Version_String'Length then
Tree_Read_Data
- (Tree_Version_String'Address, Tree_Version_String'Length);
- end if;
+ (Tree_Version_String'Address, Tree_Version_String_Len);
+ else
+ Tree_Version_String := (others => '?');
+
+ declare
+ Tmp : String (1 .. Integer (Tree_Version_String_Len));
+ begin
+ Tree_Read_Data
+ (Tmp'Address, Tree_Version_String_Len);
+ end;
- if Tree_Version_String_Len /= Tree_Version_String'Length
- or else Tree_Version_String /= Gnat_Version_String
- then
- Raise_Exception
- (Program_Error'Identity, "Inconsistent versions of GNAT and ASIS");
end if;
Tree_Read_Data (Distribution_Stub_Mode'Address,
@@ -170,7 +170,7 @@ package body Opt is
Tree_Read_Bool (Inline_Active);
Tree_Read_Bool (Inline_Processing_Required);
Tree_Read_Bool (List_Units);
- Tree_Read_Bool (No_Run_Time);
+ Tree_Read_Bool (Configurable_Run_Time_Mode);
Tree_Read_Data (Operating_Mode'Address,
Operating_Mode_Type'Object_Size / Storage_Unit);
Tree_Read_Bool (Suppress_Checks);
@@ -187,12 +187,13 @@ package body Opt is
procedure Tree_Write is
begin
+ Tree_Write_Int (ASIS_Version_Number);
Tree_Write_Bool (Brief_Output);
Tree_Write_Bool (GNAT_Mode);
Tree_Write_Char (Identifier_Character_Set);
Tree_Write_Int (Maximum_File_Name_Length);
Tree_Write_Data (Suppress_Options'Address,
- Suppress_Record'Object_Size / Storage_Unit);
+ Suppress_Array'Object_Size / Storage_Unit);
Tree_Write_Bool (Verbose_Mode);
Tree_Write_Data (Warning_Mode'Address,
Warning_Mode_Type'Object_Size / Storage_Unit);
@@ -210,7 +211,7 @@ package body Opt is
Tree_Write_Bool (Inline_Active);
Tree_Write_Bool (Inline_Processing_Required);
Tree_Write_Bool (List_Units);
- Tree_Write_Bool (No_Run_Time);
+ Tree_Write_Bool (Configurable_Run_Time_Mode);
Tree_Write_Data (Operating_Mode'Address,
Operating_Mode_Type'Object_Size / Storage_Unit);
Tree_Write_Bool (Suppress_Checks);
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 83601c4c09f..356ed026927 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -36,9 +36,12 @@
-- the binder, gnatmake or other GNAT tools. The comments indicate which
-- options are used by which programs (GNAT, GNATBIND, GNATMAKE, etc).
-with Hostparm; use Hostparm;
-with Types; use Types;
+with Gnatvsn; use Gnatvsn;
+with Hostparm; use Hostparm;
+with Types; use Types;
+
with System.WCh_Con; use System.WCh_Con;
+with GNAT.Strings; use GNAT.Strings;
package Opt is
@@ -115,10 +118,23 @@ package Opt is
-- GNAT
-- Enable assertions made using pragma Assert.
+ ASIS_Mode : Boolean := False;
+ -- GNAT
+ -- Enable semantic checks and tree transformations that are important
+ -- for ASIS but that are usually skipped if Operating_Mode is set to
+ -- Check_Semantics. This flag does not have the corresponding option to set
+ -- it ON. It is set ON when Tree_Output is set ON, it can also be set ON
+ -- from the code of GNSA-based tool (a client may need to set ON the
+ -- Back_Annotate_Rep_Info flag in this case. At the moment this does not
+ -- make very much sense, because GNSA can not do back annotation).
+
Back_Annotate_Rep_Info : Boolean := False;
-- GNAT
- -- If set True (by use of -gnatB), enables back annotation of
- -- representation information by gigi, even in -gnatc mode.
+ -- If set True, enables back annotation of representation information
+ -- by gigi, even in -gnatc mode. This is set True by the use of -gnatR
+ -- (list representation information) or -gnatt (generate tree). It is
+ -- also set true if certain Unchecked_Conversion instantiations require
+ -- checking based on annotated values.
Bind_Alternate_Main_Name : Boolean := False;
-- GNATBIND
@@ -139,6 +155,11 @@ package Opt is
-- Set to True to skip compile and link steps
-- (except when Compile_Only and/or Link_Only are True).
+ Blank_Deleted_Lines : Boolean := False;
+ -- GNAT, GNATPREP
+ -- Output empty lines for each line of preprocessed input that is deleted
+ -- in the output, including preprocessor lines starting with a '#'.
+
Brief_Output : Boolean := False;
-- GNAT, GNATBIND
-- Force brief error messages to standard error, even if verbose mode is
@@ -188,21 +209,32 @@ package Opt is
-- Set to True to enable checking for unused withs, and also the case
-- of withing a package and using none of the entities in the package.
- Compile_Only : Boolean := False;
- -- GNATMAKE
- -- Set to True to skip bind and link steps (except when Bind_Only is True)
+ Comment_Deleted_Lines : Boolean := False;
+ -- GNATPREP
+ -- True if source lines removed by the preprocessor should be commented
+ -- in the output file.
- Compress_Debug_Names : Boolean := False;
- -- GNAT
- -- Set to True if the option to compress debug information is set (-gnatC)
+ Compile_Only : Boolean := False;
+ -- GNATMAKE, GNATCLEAN
+ -- GNATMAKE: set to True to skip bind and link steps (except when
+ -- Bind_Only is True).
+ -- GNATCLEAN: set to True to only the files produced by the compiler are to
+ -- be deleted, but not the library files or executable files.
Config_File : Boolean := True;
-- GNAT
-- Set to False to inhibit reading and processing of gnat.adc file
- Config_File_Name : String_Ptr := null;
+ Config_File_Names : String_List_Access := null;
-- GNAT
- -- File name of configuration pragmas file (given by switch -gnatec)
+ -- Names of configuration pragmas files (given by switches -gnatec)
+
+ Configurable_Run_Time_Mode : Boolean := False;
+ -- GNAT, GNATBIND
+ -- Set True if the compiler is operating in configurable run-time mode.
+ -- This happens if the flag Targparm.Configurable_Run_TimeMode_On_Target
+ -- is set True, or if pragma No_Run_Time is used. See the spec of Rtsfind
+ -- for details on the handling of the latter pragma.
Constant_Condition_Warnings : Boolean := False;
-- GNAT
@@ -278,10 +310,40 @@ package Opt is
-- Set to True if -gnato (enable overflow checks) switch is set,
-- but not -gnatp.
- type Exception_Mechanism_Type is (Setjmp_Longjmp, Front_End_ZCX, GCC_ZCX);
+ Exception_Locations_Suppressed : Boolean := False;
+ -- GNAT
+ -- This flag is set True if a Suppress_Exception_Locations configuration
+ -- pragma is currently active.
+
+ type Exception_Mechanism_Type is
+ -- Determines the handling of exceptions. See Exp_Ch11 for details
+ --
+ (Front_End_Setjmp_Longjmp_Exceptions,
+ -- Exceptions use setjmp/longjmp generated explicitly by the
+ -- front end (this includes gigi or other equivalent parts of
+ -- the code generator). AT END handlers are converted into
+ -- exception handlers by the front end in this mode.
+
+ Front_End_ZCX_Exceptions,
+ -- Exceptions use the zero cost table mechanism with explicit
+ -- tables and exception regions generated by the front end.
+ -- AT END handlers are converted into exception handlers by
+ -- the front end in this mode.
+
+ Back_End_ZCX_Exceptions);
+ -- Exceptions are handled by the back end. The front end simply
+ -- generates the handlers as they appear in the source, and AT
+ -- END handlers are left untouched (they are not converted into
+ -- exception handlers when operating in this mode. Note that the
+ -- name includes ZCX, since the expectation is that the back end
+ -- mechanism will in fact be a ZCX approach, but nothing in the
+ -- compiler depends on this, so for example if GNAT is run with
+ -- a version of GCC configured for setjmp/longjmp exception handling,
+ -- then everything will work fine.
pragma Convention (C, Exception_Mechanism_Type);
- Exception_Mechanism : Exception_Mechanism_Type := Setjmp_Longjmp;
+ Exception_Mechanism : Exception_Mechanism_Type :=
+ Front_End_Setjmp_Longjmp_Exceptions;
-- GNAT
-- Set to the appropriate value depending on the default as given in
-- system.ads (ZCX_By_Default, GCC_ZCX_Support, Front_End_ZCX_Support)
@@ -343,6 +405,11 @@ package Opt is
-- Force generation of ALI file even if errors are encountered.
-- Also forces generation of tree file if -gnatt is also set.
+ Force_Checking_Of_Elaboration_Flags : Boolean := False;
+ -- GNATBIND
+ -- True if binding with forced checking of the elaboration flags
+ -- (-F switch set).
+
Force_Compilations : Boolean := False;
-- GNATMAKE
-- Set to force recompilations even when the objects are up-to-date.
@@ -354,12 +421,19 @@ package Opt is
-- some future release. It is no longer documented. The proper way
-- to get this effect is to use -gnatE and suppress elab checks.
+ Full_Path_Name_For_Brief_Errors : Boolean := False;
+ -- GNAT, GNATMAKE, GNATCLEAN
+ -- When True, in Brief_Output mode, each error message line
+ -- will start with the full path name of the source.
+ -- When False, only the file name without directory information
+ -- is used.
+
Full_List : Boolean := False;
-- GNAT
-- Set True to generate full source listing with embedded errors
Global_Discard_Names : Boolean := False;
- -- GNAT
+ -- GNAT, GNATBIND
-- Set true if a pragma Discard_Names applies to the current unit
GNAT_Mode : Boolean := False;
@@ -405,7 +479,7 @@ package Opt is
-- controlled by use of -gnatwp/-gnatwP.
Init_Or_Norm_Scalars : Boolean := False;
- -- GNAT
+ -- GNAT, GANTBIND
-- Set True if a pragma Initialize_Scalars applies to the current unit.
-- Also set True if a pragma Normalize_Scalars applies.
@@ -414,20 +488,23 @@ package Opt is
-- Set True if a pragma Initialize_Scalars applies to the current unit.
-- Note that Init_Or_Norm_Scalars is also set to True if this is True.
- Initialize_Scalars_Mode : Character := 'I';
- -- GNATBIND
- -- Set to 'I' for -Sin (default), 'L' for -Slo, 'H' for -Shi, 'X' for -Sxx
-
- Initialize_Scalars_Val : String (1 .. 2);
+ Initialize_Scalars_Mode1 : Character := 'I';
+ Initialize_Scalars_Mode2 : Character := 'N';
-- GNATBIND
- -- Valid only if Initialize_Scalars_Mode is set to 'X' (-Shh). Contains
- -- the two hex bytes from the -Shh switch.
+ -- Set to two characters from -S switch (IN/LO/HI/EV/xx). The default
+ -- is IN (invalid values), used if no -S switch is used.
Inline_Active : Boolean := False;
-- GNAT
-- Set True to activate pragma Inline processing across modules. Default
-- for now is not to inline across module boundaries.
+ Interface_Library_Unit : Boolean := False;
+ -- GNATBIND
+ -- Set to True to indicate that at least one ALI file is an interface ALI:
+ -- then elaboration flag checks are to be generated in the binder
+ -- generated file.
+
Front_End_Inlining : Boolean := False;
-- GNAT
-- Set True to activate inlining by front-end expansion.
@@ -486,6 +563,17 @@ package Opt is
-- file) instead of stdout. For example, if file x.adb is compiled
-- using -gnatR2s then representation info is written to x.adb.ref.
+ List_Representation_Info_Mechanisms : Boolean := False;
+ -- GNAT
+ -- Set true by -gnatRm switch. Causes information on mechanisms to
+ -- be included in the representation output information.
+
+ List_Preprocessing_Symbols : Boolean := False;
+ -- GNAT, GNATPREP
+ -- Set to True if symbols for preprocessing a source are to be listed
+ -- before preprocessing occurs. Set to True by switch -s of gnatprep
+ -- or -s in preprocessing data file for the compiler.
+
type Creat_Repinfo_File_Proc is access procedure (Src : File_Name_Type);
type Write_Repinfo_Line_Proc is access procedure (Info : String);
type Close_Repinfo_File_Proc is access procedure;
@@ -503,17 +591,28 @@ package Opt is
-- unwanted units in the ASIS build.
Locking_Policy : Character := ' ';
- -- GNAT
+ -- GNAT, GNATBIND
-- Set to ' ' for the default case (no locking policy specified).
-- Reset to first character (uppercase) of locking policy name if a
-- valid pragma Locking_Policy is encountered.
+ Locking_Policy_Sloc : Source_Ptr := No_Location;
+ -- GNAT, GNATBIND
+ -- Remember location of previous Locking_Policy pragma. This is used
+ -- for inconsistency error messages. A value of System_Location is
+ -- used if the policy is set in package System.
+
Look_In_Primary_Dir : Boolean := True;
- -- GNAT, GNATBIND, GNATMAKE
+ -- GNAT, GNATBIND, GNATMAKE, GNATCLEAN
-- Set to False if a -I- was present on the command line.
-- When True we are allowed to look in the primary directory to locate
-- other source or library files.
+ Make_Steps : Boolean := False;
+ -- GNATMAKE
+ -- Set to True when either Compile_Only, Bind_Only or Link_Only is
+ -- set to True.
+
Mapping_File_Name : String_Ptr := null;
-- GNAT
-- File name of mapping between unit names, file names and path names.
@@ -521,7 +620,8 @@ package Opt is
Maximum_Errors : Int := 9999;
-- GNAT, GNATBIND
- -- Maximum number of errors before compilation is terminated
+ -- Maximum default number of errors before compilation is terminated.
+ -- Can be overridden using -gnatm (GNAT) or -m (GNATBIND) switch.
Maximum_File_Name_Length : Int;
-- GNAT, GNATBIND
@@ -551,15 +651,19 @@ package Opt is
-- Set to True if compilation/binding of a program without main
-- subprogram requested.
+ No_Run_Time_Mode : Boolean := False;
+ -- GNAT, GNATBIND
+ -- This flag is set True if a No_Run_Time pragma is encountered. See
+ -- spec of Rtsfind for a full description of handling of this pragma.
+
Normalize_Scalars : Boolean := False;
- -- GNAT
+ -- GNAT, GNATBIND
-- Set True if a pragma Normalize_Scalars applies to the current unit.
-- Note that Init_Or_Norm_Scalars is also set to True if this is True.
- No_Run_Time : Boolean := False;
- -- GNAT
- -- Set True if a valid pragma No_Run_Time is processed or if the
- -- flag Targparm.High_Integrity_Mode_On_Target is set True.
+ Object_Directory_Present : Boolean := False;
+ -- GNATMAKE
+ -- Set to True when an object directory is specified with option -D
type Operating_Mode_Type is (Check_Syntax, Check_Semantics, Generate_Code);
Operating_Mode : Operating_Mode_Type := Generate_Code;
@@ -568,9 +672,19 @@ package Opt is
-- code, which runs the parser, semantics and backend. Switches can be
-- used to set syntax checking only mode, or syntax and semantics checking
-- only mode. Operating_Mode can also be modified as a result of detecting
- -- errors during the compilation process. In particular if any error is
- -- detected then this flag is reset from Generate_Code to Check_Semantics
- -- after generating an error message.
+ -- errors during the compilation process. In particular if any serious
+ -- error is detected then this flag is reset from Generate_Code to
+ -- Check_Semantics after generating an error message.
+
+ Original_Operating_Mode : Operating_Mode_Type := Generate_Code;
+ -- GNAT
+ -- Indicates the original operating mode of the compiler as set by
+ -- compiler options. This is identical to Operating_Mode except that
+ -- this is not affected by errors.
+
+ Optimization_Level : Int;
+ pragma Import (C, Optimization_Level, "optimize");
+ -- This constant reflects the optimization level (0,1,2 for -O0,-O1,-O2)
Output_File_Name_Present : Boolean := False;
-- GNATBIND, GNAT, GNATMAKE
@@ -596,6 +710,10 @@ package Opt is
-- Set to True if polling for asynchronous abort is enabled by using
-- the -gnatP option for GNAT.
+ Preprocessing_Data_File : String_Ptr := null;
+ -- GNAT
+ -- Set by switch -gnatep=. The file name of the prepocessing data file.
+
Print_Generated_Code : Boolean := False;
-- GNAT
-- Set to True to enable output of generated code in source form. This
@@ -607,20 +725,43 @@ package Opt is
-- built for imported subprograms. Set True if a Propagate_Exceptions
-- pragma applies to the extended main unit.
- Queuing_Policy : Character := ' ';
+ type Usage is (Unknown, Not_In_Use, In_Use);
+ Project_File_In_Use : Usage := Unknown;
-- GNAT
+ -- Indicates if a project file is used or not.
+ -- Set to In_Use by the first SFNP pragma.
+
+ Queuing_Policy : Character := ' ';
+ -- GNAT, GNATBIND
-- Set to ' ' for the default case (no queuing policy specified).
-- Reset to first character (uppercase) of locking policy name if a valid
-- Queuing_Policy pragma is encountered.
+ Queuing_Policy_Sloc : Source_Ptr := No_Location;
+ -- GNAT, GNATBIND
+ -- Remember location of previous Queuing_Policy pragma. This is used
+ -- for inconsistency error messages. A value of System_Location is
+ -- used if the policy is set in package System.
+
Quiet_Output : Boolean := False;
- -- GNATMAKE
- -- Set to True if the list of compilation commands should not be output.
+ -- GNATMAKE, GNATCLEAN, GPR2MAKE
+ -- Set to True if the tool should not have any output if there are no
+ -- errors or warnings.
+
+ RTS_Lib_Path_Name : String_Ptr := null;
+ RTS_Src_Path_Name : String_Ptr := null;
+ -- GNAT
+ -- Set to the "adalib" and "adainclude" directories of the run time
+ -- specified by --RTS=.
RTS_Switch : Boolean := False;
-- GNAT, GNATMAKE, GNATBIND, GNATLS, GNATFIND, GNATXREF
-- Set to True when the --RTS switch is set
+ Run_Path_Option : Boolean := True;
+ -- GNATMAKE, GNATLINK
+ -- Set to False when no run_path_option should be issued to the linker
+
Shared_Libgnat : Boolean;
-- GNATBIND
-- Set to True if a shared libgnat is requested by using the -shared
@@ -648,6 +789,14 @@ package Opt is
-- in which case it points to the argument of the pragma, and the name can
-- be located as Chars (Expression (System_Extend_Pragma_Arg)).
+ System_Extend_Unit : Node_Id := Empty;
+ -- GNAT
+ -- This is set to Empty if GNAT_Mode is set, since pragma Extend_System
+ -- is never appropriate in GNAT_Mode (and causes troubles, including
+ -- bogus circularities, if we try to compile the run-time library with
+ -- a System extension). If GNAT_Mode is not set, then System_Extend_Unit
+ -- is a copy of the value set in System_Extend_Pragma_Ary.
+
Subunits_Missing : Boolean := False;
-- GNAT
-- This flag is set true if missing subunits are detected with code
@@ -657,13 +806,19 @@ package Opt is
-- GNAT
-- Set to True if -gnatp (suppress all checks) switch present.
- Suppress_Options : Suppress_Record;
+ Suppress_Options : Suppress_Array;
-- GNAT
-- Flags set True to suppress corresponding check, i.e. add an implicit
-- pragma Suppress at the outer level of each unit compiled. Note that
-- these suppress actions can be overridden by the use of the Unsuppress
-- pragma. This variable is initialized by Osint.Initialize.
+ Suppress_Back_Annotation : Boolean := False;
+ -- GNAT
+ -- This flag is set True if back annotation of representation information
+ -- is to be suppressed. This is set if neither -gnatt or -gnatR0-3 is set.
+ -- This avoids unnecessary time being spent on back annotation.
+
Table_Factor : Int := 1;
-- GNAT
-- Factor by which all initial table sizes set in Alloc are multiplied.
@@ -673,11 +828,17 @@ package Opt is
-- used if no -gnatT switch appears.
Task_Dispatching_Policy : Character := ' ';
- -- GNAT
+ -- GNAT, GNATBIND
-- Set to ' ' for the default case (no task dispatching policy specified).
-- Reset to first character (uppercase) of task dispatching policy name
-- if a valid Task_Dispatching_Policy pragma is encountered.
+ Task_Dispatching_Policy_Sloc : Source_Ptr := No_Location;
+ -- GNAT, GNATBIND
+ -- Remember location of previous Task_Dispatching_Policy pragma. This is
+ -- used for inconsistency error messages. A value of System_Location is
+ -- used if the policy is set in package System.
+
Tasking_Used : Boolean := False;
-- Set True if any tasking construct is encountered. Used to activate the
-- output of the Q, L and T lines in ALI files.
@@ -713,11 +874,24 @@ package Opt is
-- the other hand, most such blowups will be caught cleanly and simply
-- say compilation abandoned. This flag is set to True by -gnatq or -gnatQ.
+ Undefined_Symbols_Are_False : Boolean := False;
+ -- GNAT, GNATPREP
+ -- Set to True by switch -u of gnatprep or -u in the preprocessing data
+ -- file for the compiler. Indicates that while preprocessing sources,
+ -- symbols that are not defined have the value FALSE.
+
Unique_Error_Tag : Boolean := Tag_Errors;
-- GNAT
-- Indicates if error messages are to be prefixed by the string error:
-- Initialized from Tag_Errors, can be forced on with the -gnatU switch.
+ Universal_Addressing_On_AAMP : Boolean := False;
+ -- GNAAMP
+ -- Indicates if library-level objects should be accessed and updated
+ -- using universal addressing instructions on the AAMP architecture.
+ -- This flag is set to True when pragma Universal_Data is given as
+ -- a configuration pragma.
+
Unreserve_All_Interrupts : Boolean := False;
-- GNAT, GNATBIND
-- Normally set False, set True if a valid Unreserve_All_Interrupts
@@ -753,31 +927,63 @@ package Opt is
-- This flag is set to False by the -gnatp switch.
Verbose_Mode : Boolean := False;
- -- GNAT, GNATBIND, GNATMAKE, GNATLINK, GNATLS, GNATCHOP, GNATNAME
+ -- GNAT, GNATBIND, GNATMAKE, GNATLINK, GNATLS, GNATCHOP, GNATNAME,
+ -- GNATCLEAN
-- Set to True to get verbose mode (full error message text and location
-- information sent to standard output, also header, copyright and summary)
- Warn_On_Biased_Rounding : Boolean := False;
+ Warn_On_Constant : Boolean := False;
-- GNAT
- -- Set to True to generate warnings for static constants that are rounded
- -- in a manner inconsistent with unbiased rounding (round to even). Can
- -- be modified by use of -gnatwb/B.
+ -- Set to True to generate warnings for variables that could be declared
+ -- as constants. Modified by use of -gnatwk/K.
Warn_On_Dereference : Boolean := False;
-- GNAT
-- Set to True to generate warnings for implicit dereferences for array
-- indexing and record component access. Modified by use of -gnatwd/D.
+ Warn_On_Export_Import : Boolean := True;
+ -- GNAT
+ -- Set to True to generate warnings for suspicious use of export or
+ -- import pragmas. Modified by use of -gnatwx/X.
+
Warn_On_Hiding : Boolean := False;
-- GNAT
-- Set to True to generate warnings if a declared entity hides another
-- entity. The default is that this warning is suppressed.
+ Warn_On_Modified_Unread : Boolean := False;
+ -- GNAT
+ -- Set to True to generate warnings if a variable is assigned but is
+ -- never read. The default is that this warning is suppressed.
+
+ Warn_On_No_Value_Assigned : Boolean := True;
+ -- GNAT
+ -- Set to True to generate warnings if no value is ever assigned to a
+ -- variable that is at least partially uninitialized. Set to false to
+ -- suppress such warnings. The default is that such warnings are enabled.
+
+ Warn_On_Obsolescent_Feature : Boolean := False;
+ -- GNAT
+ -- Set to True to generate warnings on use of any feature in Annex J
+ -- or if a subprogram is called for which a pragma Obsolescent applies.
+
Warn_On_Redundant_Constructs : Boolean := False;
-- GNAT
-- Set to True to generate warnings for redundant constructs (e.g. useless
-- assignments/conversions). The default is that this warning is disabled.
+ Warn_On_Unchecked_Conversion : Boolean := True;
+ -- GNAT
+ -- Set to True to generate warnings for unchecked conversions that may have
+ -- non-portable semantics (e.g. because sizes of types differ). The default
+ -- is that this warning is enabled.
+
+ Warn_On_Unrecognized_Pragma : Boolean := True;
+ -- GNAT
+ -- Set to True to generate warnings for unrecognized pragmas. The default
+ -- is that this warning is enabled.
+
type Warning_Mode_Type is (Suppress, Normal, Treat_As_Error);
Warning_Mode : Warning_Mode_Type := Normal;
-- GNAT, GNATBIND
@@ -833,6 +1039,10 @@ package Opt is
-- Set True for dynamic elaboration checking mode, as set by the -gnatE
-- switch or by the use of pragma Elaboration_Checking (Dynamic).
+ Exception_Locations_Suppressed_Config : Boolean := False;
+ -- GNAT
+ -- Set True by use of the configuration pragma Suppress_Exception_Messages
+
Extensions_Allowed_Config : Boolean;
-- GNAT
-- This is the flag that indicates whether extensions are allowed.
@@ -927,16 +1137,41 @@ package Opt is
procedure Tree_Write;
-- Writes out switch settings to current tree file using Tree_Write
+ --------------------------
+ -- ASIS Version Control --
+ --------------------------
+
+ -- These two variables (Tree_Version_String and Tree_ASIS_Version_Number)
+ -- are supposed to be used in the GNAT/ASIS version check performed in
+ -- the ASIS code (this package is also a part of the ASIS implementation).
+ -- They are set by Tree_Read procedure, so they represent the version
+ -- number (and the version string) of the compiler which has created the
+ -- tree, and they are supposed to be compared with the corresponding values
+ -- from the Gnatvsn package which is a part of ASIS implementation.
+
+ Tree_Version_String : String (Gnat_Version_String'Range);
+ -- Used to store the compiler version string read from a tree file to
+ -- check if it is the same as stored in the version string in Gnatvsn.
+ -- Therefore its length is taken directly from the version string in
+ -- Gnatvsn. If the length of the version string stored in the tree is
+ -- different, then versions are for sure different, and a string containing
+ -- '?' characters is assigned to this variable as a result of tree read.
+
+ Tree_ASIS_Version_Number : Int;
+ -- Used to store the ASIS version number read from a tree file to check if
+ -- it is the same as stored in the ASIS version number in Gnatvsn.
+
private
type Config_Switches_Type is record
- Ada_83 : Boolean;
- Dynamic_Elaboration_Checks : Boolean;
- Extensions_Allowed : Boolean;
- External_Name_Exp_Casing : External_Casing_Type;
- External_Name_Imp_Casing : External_Casing_Type;
- Polling_Required : Boolean;
- Use_VADS_Size : Boolean;
+ Ada_83 : Boolean;
+ Dynamic_Elaboration_Checks : Boolean;
+ Exception_Locations_Suppressed : Boolean;
+ Extensions_Allowed : Boolean;
+ External_Name_Exp_Casing : External_Casing_Type;
+ External_Name_Imp_Casing : External_Casing_Type;
+ Polling_Required : Boolean;
+ Use_VADS_Size : Boolean;
end record;
end Opt;
diff --git a/gcc/ada/osint-b.adb b/gcc/ada/osint-b.adb
index fc4941e9567..a0ebff84330 100644
--- a/gcc/ada/osint-b.adb
+++ b/gcc/ada/osint-b.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -41,8 +41,15 @@ package body Osint.B is
-------------------------
procedure Close_Binder_Output is
+ Status : Boolean;
begin
- Close (Output_FD);
+ Close (Output_FD, Status);
+
+ if not Status then
+ Fail
+ ("error while closing generated file ",
+ Get_Name_String (Output_File_Name));
+ end if;
if Recording_Time_From_Last_Bind then
New_Binder_Output_Time_Stamp := File_Stamp (Output_File_Name);
diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb
index c7fd69569fa..d925abf7f77 100644
--- a/gcc/ada/osint-c.adb
+++ b/gcc/ada/osint-c.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -59,8 +59,15 @@ package body Osint.C is
----------------------
procedure Close_Debug_File is
+ Status : Boolean;
begin
- Close (Output_FD);
+ Close (Output_FD, Status);
+
+ if not Status then
+ Fail
+ ("error while closing expanded source file ",
+ Get_Name_String (Output_File_Name));
+ end if;
end Close_Debug_File;
-------------------------------
@@ -68,8 +75,15 @@ package body Osint.C is
-------------------------------
procedure Close_Output_Library_Info is
+ Status : Boolean;
begin
- Close (Output_FD);
+ Close (Output_FD, Status);
+
+ if not Status then
+ Fail
+ ("error while closing ALI file ",
+ Get_Name_String (Output_File_Name));
+ end if;
end Close_Output_Library_Info;
------------------------
@@ -77,8 +91,15 @@ package body Osint.C is
------------------------
procedure Close_Repinfo_File is
+ Status : Boolean;
begin
- Close (Output_FD);
+ Close (Output_FD, Status);
+
+ if not Status then
+ Fail
+ ("error while closing representation info file ",
+ Get_Name_String (Output_File_Name));
+ end if;
end Close_Repinfo_File;
---------------------------
@@ -299,9 +320,16 @@ package body Osint.C is
----------------
procedure Tree_Close is
+ Status : Boolean;
begin
Tree_Write_Terminate;
- Close (Output_FD);
+ Close (Output_FD, Status);
+
+ if not Status then
+ Fail
+ ("error while closing tree file ",
+ Get_Name_String (Output_File_Name));
+ end if;
end Tree_Close;
-----------------
@@ -324,7 +352,8 @@ package body Osint.C is
Name_Buffer (1 .. Name_Len) := Output_Object_File_Name.all;
end if;
- Dot_Index := 0;
+ Dot_Index := Name_Len + 1;
+
for J in reverse 1 .. Name_Len loop
if Name_Buffer (J) = '.' then
Dot_Index := J;
@@ -338,6 +367,7 @@ package body Osint.C is
-- Change exctension to adt
+ Name_Buffer (Dot_Index) := '.';
Name_Buffer (Dot_Index + 1) := 'a';
Name_Buffer (Dot_Index + 2) := 'd';
Name_Buffer (Dot_Index + 3) := 't';
diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb
index 5d90b1dd549..88fcd3fd94e 100644
--- a/gcc/ada/osint.adb
+++ b/gcc/ada/osint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -227,15 +227,22 @@ package body Osint is
-----------------------------
procedure Add_Default_Search_Dirs is
- Search_Dir : String_Access;
- Search_Path : String_Access;
+ Search_Dir : String_Access;
+ Search_Path : String_Access;
+ Path_File_Name : String_Access;
procedure Add_Search_Dir
+ (Search_Dir : String;
+ Additional_Source_Dir : Boolean);
+ procedure Add_Search_Dir
(Search_Dir : String_Access;
Additional_Source_Dir : Boolean);
-- Add a source search dir or a library search dir, depending on the
-- value of Additional_Source_Dir.
+ procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean);
+ -- Open a path file and read the directory to search, one per line
+
function Get_Libraries_From_Registry return String_Ptr;
-- On Windows systems, get the list of installed standard libraries
-- from the registry key:
@@ -248,6 +255,18 @@ package body Osint is
--------------------
procedure Add_Search_Dir
+ (Search_Dir : String;
+ Additional_Source_Dir : Boolean)
+ is
+ begin
+ if Additional_Source_Dir then
+ Add_Src_Search_Dir (Search_Dir);
+ else
+ Add_Lib_Search_Dir (Search_Dir);
+ end if;
+ end Add_Search_Dir;
+
+ procedure Add_Search_Dir
(Search_Dir : String_Access;
Additional_Source_Dir : Boolean)
is
@@ -259,6 +278,86 @@ package body Osint is
end if;
end Add_Search_Dir;
+ ------------------------
+ -- Get_Dirs_From_File --
+ ------------------------
+
+ procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is
+ File_FD : File_Descriptor;
+ Buffer : String (1 .. Path_File_Name'Length + 1);
+ Len : Natural;
+ Actual_Len : Natural;
+ S : String_Access;
+ Curr : Natural;
+ First : Natural;
+ Ch : Character;
+
+ Status : Boolean;
+ -- For the call to Close
+
+ begin
+ -- Construct a C compatible character string buffer.
+
+ Buffer (1 .. Buffer'Last - 1) := Path_File_Name.all;
+ Buffer (Buffer'Last) := ASCII.NUL;
+
+ File_FD := Open_Read (Buffer'Address, Binary);
+
+ -- If we cannot open the file, we ignore it, we don't fail
+
+ if File_FD = Invalid_FD then
+ return;
+ end if;
+
+ Len := Integer (File_Length (File_FD));
+
+ S := new String (1 .. Len);
+
+ -- Read the file. Note that the loop is not necessary since the
+ -- whole file is read at once except on VMS.
+
+ Curr := 1;
+ Actual_Len := Len;
+ while Curr <= Len and then Actual_Len /= 0 loop
+ Actual_Len := Read (File_FD, S (Curr)'Address, Len);
+ Curr := Curr + Actual_Len;
+ end loop;
+
+ -- We are done with the file, so we close it
+
+ Close (File_FD, Status);
+ -- We ignore any error here, because we have successfully read the
+ -- file.
+
+ -- Now, we read line by line
+
+ First := 1;
+ Curr := 0;
+
+ while Curr < Len loop
+ Ch := S (Curr + 1);
+
+ if Ch = ASCII.CR or else Ch = ASCII.LF
+ or else Ch = ASCII.FF or else Ch = ASCII.VT
+ then
+ if First <= Curr then
+ Add_Search_Dir (S (First .. Curr), Additional_Source_Dir);
+ end if;
+
+ First := Curr + 2;
+ end if;
+
+ Curr := Curr + 1;
+ end loop;
+
+ -- Last line is a special case, if the file does not end with
+ -- an end of line mark.
+
+ if First <= S'Last then
+ Add_Search_Dir (S (First .. S'Last), Additional_Source_Dir);
+ end if;
+ end Get_Dirs_From_File;
+
---------------------------------
-- Get_Libraries_From_Registry --
---------------------------------
@@ -299,7 +398,7 @@ package body Osint is
for Additional_Source_Dir in False .. True loop
if Additional_Source_Dir then
- Search_Path := Getenv ("ADA_INCLUDE_PATH");
+ Search_Path := Getenv (Ada_Include_Path);
if Search_Path'Length > 0 then
if Hostparm.OpenVMS then
Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:");
@@ -308,7 +407,7 @@ package body Osint is
end if;
end if;
else
- Search_Path := Getenv ("ADA_OBJECTS_PATH");
+ Search_Path := Getenv (Ada_Objects_Path);
if Search_Path'Length > 0 then
if Hostparm.OpenVMS then
Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:");
@@ -326,49 +425,77 @@ package body Osint is
end loop;
end loop;
- if not Opt.No_Stdinc then
- -- For WIN32 systems, look for any system libraries defined in
- -- the registry. These are added to both source and object
- -- directories.
+ -- Check for eventual project path file env vars
- Search_Path := String_Access (Get_Libraries_From_Registry);
- Get_Next_Dir_In_Path_Init (Search_Path);
- loop
- Search_Dir := Get_Next_Dir_In_Path (Search_Path);
- exit when Search_Dir = null;
- Add_Search_Dir (Search_Dir, False);
- Add_Search_Dir (Search_Dir, True);
- end loop;
+ Path_File_Name := Getenv (Project_Include_Path_File);
- -- The last place to look are the defaults
+ if Path_File_Name'Length > 0 then
+ Get_Dirs_From_File (Additional_Source_Dir => True);
+ end if;
- Search_Path := Read_Default_Search_Dirs
- (String_Access (Update_Path (Search_Dir_Prefix)),
- Include_Search_File,
- String_Access (Update_Path (Include_Dir_Default_Name)));
+ Path_File_Name := Getenv (Project_Objects_Path_File);
- Get_Next_Dir_In_Path_Init (Search_Path);
- loop
- Search_Dir := Get_Next_Dir_In_Path (Search_Path);
- exit when Search_Dir = null;
- Add_Search_Dir (Search_Dir, True);
- end loop;
+ if Path_File_Name'Length > 0 then
+ Get_Dirs_From_File (Additional_Source_Dir => False);
end if;
- if not Opt.No_Stdlib and not Opt.RTS_Switch then
- Search_Path := Read_Default_Search_Dirs
- (String_Access (Update_Path (Search_Dir_Prefix)),
- Objects_Search_File,
- String_Access (Update_Path (Object_Dir_Default_Name)));
+ -- For the compiler, if --RTS= was apecified, add the runtime
+ -- directories.
- Get_Next_Dir_In_Path_Init (Search_Path);
- loop
- Search_Dir := Get_Next_Dir_In_Path (Search_Path);
- exit when Search_Dir = null;
- Add_Search_Dir (Search_Dir, False);
- end loop;
- end if;
+ if RTS_Src_Path_Name /= null and then
+ RTS_Lib_Path_Name /= null
+ then
+ Add_Search_Dirs (RTS_Src_Path_Name, Include);
+ Add_Search_Dirs (RTS_Lib_Path_Name, Objects);
+
+ else
+ if not Opt.No_Stdinc then
+
+ -- For WIN32 systems, look for any system libraries defined in
+ -- the registry. These are added to both source and object
+ -- directories.
+
+ Search_Path := String_Access (Get_Libraries_From_Registry);
+
+ Get_Next_Dir_In_Path_Init (Search_Path);
+ loop
+ Search_Dir := Get_Next_Dir_In_Path (Search_Path);
+ exit when Search_Dir = null;
+ Add_Search_Dir (Search_Dir, False);
+ Add_Search_Dir (Search_Dir, True);
+ end loop;
+
+ -- The last place to look are the defaults
+
+ Search_Path :=
+ Read_Default_Search_Dirs
+ (String_Access (Update_Path (Search_Dir_Prefix)),
+ Include_Search_File,
+ String_Access (Update_Path (Include_Dir_Default_Name)));
+
+ Get_Next_Dir_In_Path_Init (Search_Path);
+ loop
+ Search_Dir := Get_Next_Dir_In_Path (Search_Path);
+ exit when Search_Dir = null;
+ Add_Search_Dir (Search_Dir, True);
+ end loop;
+ end if;
+ if not Opt.No_Stdlib and not Opt.RTS_Switch then
+ Search_Path :=
+ Read_Default_Search_Dirs
+ (String_Access (Update_Path (Search_Dir_Prefix)),
+ Objects_Search_File,
+ String_Access (Update_Path (Object_Dir_Default_Name)));
+
+ Get_Next_Dir_In_Path_Init (Search_Path);
+ loop
+ Search_Dir := Get_Next_Dir_In_Path (Search_Path);
+ exit when Search_Dir = null;
+ Add_Search_Dir (Search_Dir, False);
+ end loop;
+ end if;
+ end if;
end Add_Default_Search_Dirs;
--------------
@@ -598,11 +725,13 @@ package body Osint is
Get_Name_String (Name);
Exec_Suffix := Get_Executable_Suffix;
- for J in Exec_Suffix.all'Range loop
+ for J in Exec_Suffix'Range loop
Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Exec_Suffix.all (J);
+ Name_Buffer (Name_Len) := Exec_Suffix (J);
end loop;
+ Free (Exec_Suffix);
+
return Name_Enter;
end Executable_Name;
@@ -616,17 +745,23 @@ package body Osint is
-- 0 if the object file has been generated (with or without warnings)
-- 1 if recompilation was not needed (smart recompilation)
-- 2 if gnat1 has been killed by a signal (detected by GCC)
- -- 3 if no code has been generated (spec)
-- 4 for a fatal error
-- 5 if there were errors
+ -- 6 if no code has been generated (spec)
+ --
+ -- Note that exit code 3 is not used and must not be used as this is
+ -- the code returned by a program aborted via C abort() routine on
+ -- Windows. GCC checks for that case and thinks that the child process
+ -- has been aborted. This code (exit code 3) used to be the code used
+ -- for E_No_Code, but E_No_Code was changed to 6 for this reason.
case Exit_Code is
when E_Success => OS_Exit (0);
when E_Warnings => OS_Exit (0);
when E_No_Compile => OS_Exit (1);
- when E_No_Code => OS_Exit (3);
when E_Fatal => OS_Exit (4);
when E_Errors => OS_Exit (5);
+ when E_No_Code => OS_Exit (6);
when E_Abort => OS_Abort;
end case;
end Exit_Program;
@@ -636,7 +771,6 @@ package body Osint is
----------
procedure Fail (S1 : String; S2 : String := ""; S3 : String := "") is
-
begin
-- We use Output in case there is a special output set up.
-- In this case Set_Standard_Error will have no immediate effect.
@@ -734,7 +868,15 @@ package body Osint is
-- corresponding path name
if File /= No_File then
- return File;
+ -- For locally removed file, Error_Name is returned; then
+ -- return No_File, indicating the file is not a source.
+
+ if File = Error_Name then
+ return No_File;
+
+ else
+ return File;
+ end if;
end if;
-- First place to look is in the primary directory (i.e. the same
@@ -958,9 +1100,9 @@ package body Osint is
if Search_Dir (Search_Dir'Last) /= Directory_Separator then
Local_Search_Dir := new String'
- (Concat (Search_Dir, String' (1 => Directory_Separator)));
+ (Concat (Search_Dir, String'(1 => Directory_Separator)));
else
- Local_Search_Dir := new String' (Search_Dir);
+ Local_Search_Dir := new String'(Search_Dir);
end if;
if File_Type = Include then
@@ -968,7 +1110,7 @@ package body Osint is
Default_Suffix_Dir := new String'("adainclude");
else
Search_File := Objects_Search_File;
- Default_Suffix_Dir := new String' ("adalib");
+ Default_Suffix_Dir := new String'("adalib");
end if;
Norm_Search_Dir := To_Canonical_Path_Spec (Local_Search_Dir.all);
@@ -1015,14 +1157,10 @@ package body Osint is
end;
Norm_Search_Dir :=
- new String'
- (Concat (Current_Dir.all, Local_Search_Dir.all));
+ new String'(Concat (Current_Dir.all, Local_Search_Dir.all));
Result_Search_Dir :=
- Read_Default_Search_Dirs
- (String_Access (Update_Path (String_Ptr (Norm_Search_Dir))),
- Search_File,
- null);
+ Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
Default_Search_Dir :=
new String'
@@ -1041,13 +1179,11 @@ package body Osint is
Norm_Search_Dir :=
new String'
- (Concat (Search_Dir_Prefix.all, Local_Search_Dir.all));
+ (Concat (Update_Path (Search_Dir_Prefix).all,
+ Local_Search_Dir.all));
Result_Search_Dir :=
- Read_Default_Search_Dirs
- (String_Access (Update_Path (String_Ptr (Norm_Search_Dir))),
- Search_File,
- null);
+ Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
Default_Search_Dir :=
new String'
@@ -1065,16 +1201,14 @@ package body Osint is
-- We finally search in Search_Dir_Prefix/rts-Search_Dir
Temp_String :=
- new String'(Concat (Search_Dir_Prefix.all, "rts-"));
+ new String'
+ (Concat (Update_Path (Search_Dir_Prefix).all, "rts-"));
Norm_Search_Dir :=
- new String' (Concat (Temp_String.all, Local_Search_Dir.all));
+ new String'(Concat (Temp_String.all, Local_Search_Dir.all));
Result_Search_Dir :=
- Read_Default_Search_Dirs
- (String_Access (Update_Path (String_Ptr (Norm_Search_Dir))),
- Search_File,
- null);
+ Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
Default_Search_Dir :=
new String'
@@ -1095,6 +1229,39 @@ package body Osint is
end if;
end Get_RTS_Search_Dir;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Number_File_Names := 0;
+ Current_File_Name_Index := 0;
+
+ Src_Search_Directories.Init;
+ Lib_Search_Directories.Init;
+
+ -- Start off by setting all suppress options to False, these will
+ -- be reset later (turning some on if -gnato is not specified, and
+ -- turning all of them on if -gnatp is specified).
+
+ Suppress_Options := (others => False);
+
+ -- Reserve the first slot in the search paths table. This is the
+ -- directory of the main source file or main library file and is
+ -- filled in by each call to Next_Main_Source/Next_Main_Lib_File with
+ -- the directory specified for this main source or library file. This
+ -- is the directory which is searched first by default. This default
+ -- search is inhibited by the option -I- for both source and library
+ -- files.
+
+ Src_Search_Directories.Set_Last (Primary_Directory);
+ Src_Search_Directories.Table (Primary_Directory) := new String'("");
+
+ Lib_Search_Directories.Set_Last (Primary_Directory);
+ Lib_Search_Directories.Table (Primary_Directory) := new String'("");
+ end Initialize;
+
----------------------------
-- Is_Directory_Separator --
----------------------------
@@ -1181,7 +1348,7 @@ package body Osint is
if T = Library then
Dir_Name := Lib_Search_Directories.Table (Dir);
- else pragma Assert (T = Source);
+ else pragma Assert (T /= Config);
Dir_Name := Src_Search_Directories.Table (Dir);
end if;
@@ -1352,7 +1519,7 @@ package body Osint is
if Running_Program = Make then
declare
- Orig_Main : File_Name_Type := Current_Main;
+ Orig_Main : constant File_Name_Type := Current_Main;
begin
if Strip_Suffix (Orig_Main) = Orig_Main then
@@ -1378,14 +1545,53 @@ package body Osint is
------------------------------
function Normalize_Directory_Name (Directory : String) return String_Ptr is
+
+ function Is_Quoted (Path : String) return Boolean;
+ pragma Inline (Is_Quoted);
+ -- Returns true if Path is quoted (either double or single quotes)
+
+ ---------------
+ -- Is_Quoted --
+ ---------------
+
+ function Is_Quoted (Path : String) return Boolean is
+ First : constant Character := Path (Path'First);
+ Last : constant Character := Path (Path'Last);
+
+ begin
+ if (First = ''' and then Last = ''')
+ or else
+ (First = '"' and then Last = '"')
+ then
+ return True;
+ else
+ return False;
+ end if;
+ end Is_Quoted;
+
Result : String_Ptr;
+ -- Start of processing for Normalize_Directory_Name
+
begin
if Directory'Length = 0 then
Result := new String'(Hostparm.Normalized_CWD);
elsif Is_Directory_Separator (Directory (Directory'Last)) then
Result := new String'(Directory);
+
+ elsif Is_Quoted (Directory) then
+
+ -- This is a quoted string, it certainly means that the directory
+ -- contains some spaces for example. We can safely remove the quotes
+ -- here as the OS_Lib.Normalize_Arguments will be called before any
+ -- spawn routines. This ensure that quotes will be added when needed.
+
+ Result := new String (1 .. Directory'Length - 1);
+ Result (1 .. Directory'Length - 1) :=
+ Directory (Directory'First + 1 .. Directory'Last - 1);
+ Result (Result'Last) := Directory_Separator;
+
else
Result := new String (1 .. Directory'Length + 1);
Result (1 .. Directory'Length) := Directory;
@@ -1592,7 +1798,7 @@ package body Osint is
else
if Prev_Was_Separator and then Is_Relative (S.all, J) then
- S1 (J1 .. J1 + Prefix_Len) := Search_Dir_Prefix.all;
+ S1 (J1 .. J1 + Prefix_Len - 1) := Search_Dir_Prefix.all;
J1 := J1 + Prefix_Len;
end if;
@@ -1622,6 +1828,9 @@ package body Osint is
Text : Text_Buffer_Ptr;
-- Allocated text buffer.
+ Status : Boolean;
+ -- For the calls to Close
+
begin
Current_Full_Lib_Name := Find_File (Lib_File, Library);
Current_Full_Obj_Name := Object_File_Name (Current_Full_Lib_Name);
@@ -1670,12 +1879,16 @@ package body Osint is
elsif Fatal_Err then
Get_Name_String (Current_Full_Obj_Name);
- Close (Lib_FD);
+ Close (Lib_FD, Status);
+ -- No need to check the status, we fail anyway
+
Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
else
Current_Full_Obj_Stamp := Empty_Time_Stamp;
- Close (Lib_FD);
+ Close (Lib_FD, Status);
+ -- No need to check the status, we return null anyway
+
return null;
end if;
end if;
@@ -1685,11 +1898,14 @@ package body Osint is
if Current_Full_Lib_Stamp > Current_Full_Obj_Stamp then
if Fatal_Err then
Get_Name_String (Current_Full_Obj_Name);
- Close (Lib_FD);
+ Close (Lib_FD, Status);
+ -- No need to check the status, we fail anyway
Fail ("Bad time stamp: ", Name_Buffer (1 .. Name_Len));
else
Current_Full_Obj_Stamp := Empty_Time_Stamp;
- Close (Lib_FD);
+ Close (Lib_FD, Status);
+ -- No need to check the status, we return null anyway
+
return null;
end if;
end if;
@@ -1698,13 +1914,13 @@ package body Osint is
-- Read data from the file
declare
- Len : Integer := Integer (File_Length (Lib_FD));
+ Len : constant Integer := Integer (File_Length (Lib_FD));
-- Length of source file text. If it doesn't fit in an integer
-- we're probably stuck anyway (>2 gigs of source seems a lot!)
Actual_Len : Integer := 0;
- Lo : Text_Ptr := 0;
+ Lo : constant Text_Ptr := 0;
-- Low bound for allocated text buffer
Hi : Text_Ptr := Text_Ptr (Len);
@@ -1732,7 +1948,10 @@ package body Osint is
-- Read is complete, close file and we are done
- Close (Lib_FD);
+ Close (Lib_FD, Status);
+ -- The status should never be False. But, if it is, what can we do?
+ -- So, we don't test it.
+
return Text;
end Read_Library_Info;
@@ -1757,6 +1976,9 @@ package body Osint is
Actual_Len : Integer;
+ Status : Boolean;
+ -- For the call to Close
+
begin
Current_Full_Source_Name := Find_File (N, T);
Current_Full_Source_Stamp := File_Stamp (Current_Full_Source_Name);
@@ -1846,7 +2068,9 @@ package body Osint is
-- Read is complete, get time stamp and close file and we are done
- Close (Source_File_FD);
+ Close (Source_File_FD, Status);
+ -- The status should never be False. But, if it is, what can we do?
+ -- So, we don't test it.
end Read_Source_File;
@@ -2237,7 +2461,8 @@ package body Osint is
Unchecked_Conversion (Source => Address,
Target => Path_String_Access);
- Path_Access : Path_String_Access := Address_To_Access (Path_Addr);
+ Path_Access : constant Path_String_Access :=
+ Address_To_Access (Path_Addr);
Return_Val : String_Access;
@@ -2300,7 +2525,8 @@ package body Osint is
------------------------
procedure Write_Program_Name is
- Save_Buffer : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+ Save_Buffer : constant String (1 .. Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
begin
@@ -2367,9 +2593,6 @@ begin
-- Function to get maximum file name length for system
begin
- Src_Search_Directories.Init;
- Lib_Search_Directories.Init;
-
Identifier_Character_Set := Get_Default_Identifier_Character_Set;
Maximum_File_Name_Length := Get_Maximum_File_Name_Length;
@@ -2380,25 +2603,13 @@ begin
Maximum_File_Name_Length := Int'Last;
end if;
- -- Start off by setting all suppress options to False, these will
- -- be reset later (turning some on if -gnato is not specified, and
- -- turning all of them on if -gnatp is specified).
-
- Suppress_Options := (others => False);
-
- -- Reserve the first slot in the search paths table. This is the
- -- directory of the main source file or main library file and is
- -- filled in by each call to Next_Main_Source/Next_Main_Lib_File with
- -- the directory specified for this main source or library file. This
- -- is the directory which is searched first by default. This default
- -- search is inhibited by the option -I- for both source and library
- -- files.
-
Src_Search_Directories.Set_Last (Primary_Directory);
Src_Search_Directories.Table (Primary_Directory) := new String'("");
Lib_Search_Directories.Set_Last (Primary_Directory);
Lib_Search_Directories.Table (Primary_Directory) := new String'("");
+
+ Initialize;
end Initialization;
end Osint;
diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads
index 21505efdf14..ba586222675 100644
--- a/gcc/ada/osint.ads
+++ b/gcc/ada/osint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -36,12 +36,20 @@ pragma Elaborate (GNAT.OS_Lib);
package Osint is
+ Ada_Include_Path : constant String := "ADA_INCLUDE_PATH";
+ Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH";
+ Project_Include_Path_File : constant String := "ADA_PRJ_INCLUDE_FILE";
+ Project_Objects_Path_File : constant String := "ADA_PRJ_OBJECTS_FILE";
+
+ procedure Initialize;
+ -- Initialize internal tables
+
function Normalize_Directory_Name (Directory : String) return String_Ptr;
-- Verify and normalize a directory name. If directory name is invalid,
-- this will return an empty string. Otherwise it will insure a trailing
-- slash and make other normalizations.
- type File_Type is (Source, Library, Config);
+ type File_Type is (Source, Library, Config, Definition, Preprocessing_Data);
function Find_File
(N : File_Name_Type;
@@ -535,10 +543,10 @@ private
type File_Name_Array_Ptr is access File_Name_Array;
File_Names : File_Name_Array_Ptr :=
new File_Name_Array (1 .. Int (Argument_Count) + 2);
- -- As arguments are scanned in Initialize, file names are stored
- -- in this array. The string does not contain a terminating NUL.
- -- The array is "extensible" because when using project files,
- -- there may be more file names than argument on the command line.
+ -- As arguments are scanned, file names are stored in this array
+ -- The strings do not have terminating NUL files. The array is
+ -- extensible, because when using project files, there may be
+ -- more files than arguments on the command line.
Current_File_Name_Index : Int := 0;
-- The index in File_Names of the last file opened by Next_Main_Source
diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb
index 866feedd91f..00cbd9b1569 100644
--- a/gcc/ada/par-ch10.adb
+++ b/gcc/ada/par-ch10.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -405,8 +405,12 @@ package body Ch10 is
-- If we scanned a subprogram body, make sure we did not have private
elsif Private_Sloc /= No_Location
- and then Nkind (Unit (Comp_Unit_Node)) /= N_Function_Instantiation
- and then Nkind (Unit (Comp_Unit_Node)) /= N_Procedure_Instantiation
+ and then
+ Nkind (Unit (Comp_Unit_Node)) /= N_Function_Instantiation
+ and then
+ Nkind (Unit (Comp_Unit_Node)) /= N_Procedure_Instantiation
+ and then
+ Nkind (Unit (Comp_Unit_Node)) /= N_Subprogram_Renaming_Declaration
then
Error_Msg ("cannot have private subprogram body", Private_Sloc);
@@ -748,9 +752,10 @@ package body Ch10 is
-- Error recovery: Cannot raise Error_Resync
function P_Context_Clause return List_Id is
- Item_List : List_Id;
- With_Node : Node_Id;
- First_Flag : Boolean;
+ Item_List : List_Id;
+ Has_Limited : Boolean := False;
+ With_Node : Node_Id;
+ First_Flag : Boolean;
begin
Item_List := New_List;
@@ -772,6 +777,34 @@ package body Ch10 is
-- Processing for WITH clause
+ -- First check for LIMITED WITH
+
+ if Token = Tok_Limited then
+ Has_Limited := True;
+ Scan; -- past LIMITED
+
+ -- In the context, LIMITED can only appear in a with_clause
+
+ if Token /= Tok_With then
+ Error_Msg_SC ("unexpected LIMITED ignored");
+ end if;
+
+ if not Extensions_Allowed then
+ Error_Msg_SP ("`LIMITED WITH` is an Ada0X extension");
+
+ if OpenVMS then
+ Error_Msg_SP
+ ("\unit must be compiled with " &
+ "'/'E'X'T'E'N'S'I'O'N'S'_'A'L'L'O'W'E'D qualifier");
+ else
+ Error_Msg_SP
+ ("\unit must be compiled with -gnatX switch");
+ end if;
+ end if;
+ else
+ Has_Limited := False;
+ end if;
+
if Token = Tok_With then
Scan; -- past WITH
@@ -829,6 +862,7 @@ package body Ch10 is
Set_Name (With_Node, P_Qualified_Simple_Name);
Set_First_Name (With_Node, First_Flag);
+ Set_Limited_Present (With_Node, Has_Limited);
First_Flag := False;
exit when Token /= Tok_Comma;
Scan; -- past comma
diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb
index c475cc470a8..57f3c5db3b3 100644
--- a/gcc/ada/par-ch11.adb
+++ b/gcc/ada/par-ch11.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -214,7 +214,6 @@ package body Ch11 is
function Parse_Exception_Handlers return List_Id is
Handler : Node_Id;
Handlers_List : List_Id;
- Pragmas_List : List_Id;
begin
Handlers_List := New_List;
@@ -226,7 +225,6 @@ package body Ch11 is
else
loop
Handler := P_Exception_Handler;
- Pragmas_List := No_List;
Append (Handler, Handlers_List);
-- Note: no need to check for pragmas here. Although the
diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb
index ed96a7275b2..7064c5df578 100644
--- a/gcc/ada/par-ch2.adb
+++ b/gcc/ada/par-ch2.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- --
@@ -298,7 +298,20 @@ package body Ch2 is
Scan; -- past comma
end loop;
- T_Right_Paren;
+ -- If we have := for pragma Debug, it is worth special casing
+ -- the error message (it is easy to think of pragma Debug as
+ -- taking a statement, and an assignment statement is the most
+ -- likely candidate for this error)
+
+ if Token = Tok_Colon_Equal and then Pragma_Name = Name_Debug then
+ Error_Msg_SC ("argument for pragma Debug must be procedure call");
+ Resync_To_Semicolon;
+
+ -- Normal case, we expect a right paren here
+
+ else
+ T_Right_Paren;
+ end if;
end if;
Semicolon_Loc := Token_Ptr;
diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb
index 983ca8fe888..df156b93c05 100644
--- a/gcc/ada/par-ch3.adb
+++ b/gcc/ada/par-ch3.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- --
@@ -97,14 +97,24 @@ package body Ch3 is
function Init_Expr_Opt (P : Boolean := False) return Node_Id is
begin
- if Token = Tok_Colon_Equal
+ -- For colon, assume it means := unless it is at the end of
+ -- a line, in which case guess that it means a semicolon.
+
+ if Token = Tok_Colon then
+ if Token_Is_At_End_Of_Line then
+ T_Semicolon;
+ return Empty;
+ end if;
+
+ -- Here if := or something that we will take as equivalent
+
+ elsif Token = Tok_Colon_Equal
or else Token = Tok_Equal
- or else Token = Tok_Colon
or else Token = Tok_Is
then
null;
- -- One other possibility. If we have a literal followed by a semicolon,
+ -- Another possibility. If we have a literal followed by a semicolon,
-- we assume that we have a missing colon-equal.
elsif Token in Token_Class_Literal then
@@ -430,6 +440,19 @@ package body Ch3 is
when Tok_New =>
Typedef_Node := P_Derived_Type_Def_Or_Private_Ext_Decl;
+
+ if Nkind (Typedef_Node) = N_Derived_Type_Definition
+ and then Present (Record_Extension_Part (Typedef_Node))
+ then
+ End_Labl :=
+ Make_Identifier (Token_Ptr,
+ Chars => Chars (Ident_Node));
+ Set_Comes_From_Source (End_Labl, False);
+
+ Set_End_Label
+ (Record_Extension_Part (Typedef_Node), End_Labl);
+ end if;
+
TF_Semicolon;
exit;
@@ -678,7 +701,6 @@ package body Ch3 is
Set_Defining_Identifier (Decl_Node, Ident_Node);
Set_Discriminant_Specifications (Decl_Node, Discr_List);
return Decl_Node;
-
end P_Type_Declaration;
----------------------------------
@@ -775,7 +797,6 @@ package body Ch3 is
Set_Constraint (Indic_Node, Constr_Node);
return Indic_Node;
end if;
-
end P_Subtype_Indication;
-------------------------
@@ -936,7 +957,6 @@ package body Ch3 is
else
return Empty;
end if;
-
end P_Constraint_Opt;
------------------------------
@@ -1362,7 +1382,6 @@ package body Ch3 is
end loop Ident_Loop;
Done := False;
-
end P_Identifier_Declarations;
-------------------------------
@@ -2095,7 +2114,6 @@ package body Ch3 is
function P_Discrete_Subtype_Definition return Node_Id is
begin
-
-- The syntax of a discrete subtype definition is identical to that
-- of a discrete range, so we simply share the same parsing code.
@@ -2474,7 +2492,6 @@ package body Ch3 is
T_Right_Paren;
return Result_Node;
-
end P_Index_Or_Discriminant_Constraint;
-------------------------------------
@@ -2690,7 +2707,6 @@ package body Ch3 is
Set_Component_Items (Component_List_Node, Decls_List);
return Component_List_Node;
-
end P_Component_List;
-------------------------
@@ -2808,7 +2824,6 @@ package body Ch3 is
end loop Ident_Loop;
TF_Semicolon;
-
end P_Component_Items;
--------------------------------
@@ -2835,7 +2850,6 @@ package body Ch3 is
Variant_Part_Node : Node_Id;
Variants_List : List_Id;
Case_Node : Node_Id;
- Case_Sloc : Source_Ptr;
begin
Variant_Part_Node := New_Node (N_Variant_Part, Token_Ptr);
@@ -2846,7 +2860,6 @@ package body Ch3 is
Scan; -- past CASE
Case_Node := P_Expression;
- Case_Sloc := Token_Ptr;
Set_Name (Variant_Part_Node, Case_Node);
if Nkind (Case_Node) /= N_Identifier then
@@ -2884,7 +2897,6 @@ package body Ch3 is
Set_Variants (Variant_Part_Node, Variants_List);
return Variant_Part_Node;
-
end P_Variant_Part;
--------------------
@@ -3545,7 +3557,6 @@ package body Ch3 is
when Error_Resync =>
Resync_Past_Semicolon;
Done := False;
-
end P_Declarative_Items;
----------------------------------
@@ -3568,6 +3579,11 @@ package body Ch3 is
Done : Boolean;
begin
+ -- Indicate no bad declarations detected yet in the current context:
+ -- visible or private declarations of a package spec.
+
+ Missing_Begin_Msg := No_Error_Msg;
+
-- Get rid of active SIS entry from outer scope. This means we will
-- miss some nested cases, but it doesn't seem worth the effort. See
-- discussion in Par for further details
@@ -3737,7 +3753,6 @@ package body Ch3 is
-- hit the missing BEGIN, which will clean up the error message.
Done := False;
-
end Statement_When_Declaration_Expected;
end Ch3;
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index c9244a2c354..62c4e108c21 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -79,7 +79,7 @@ package body Ch4 is
procedure Set_Op_Name (Node : Node_Id) is
type Name_Of_Type is array (N_Op) of Name_Id;
- Name_Of : Name_Of_Type := Name_Of_Type'(
+ Name_Of : constant Name_Of_Type := Name_Of_Type'(
N_Op_And => Name_Op_And,
N_Op_Or => Name_Op_Or,
N_Op_Xor => Name_Op_Xor,
@@ -718,7 +718,7 @@ package body Ch4 is
-- a possible fix.
if Nkind (Expr_Node) = N_Op_Eq then
- Error_Msg_N ("\maybe `=>` was intended", Expr_Node);
+ Error_Msg_N ("\maybe `='>` was intended", Expr_Node);
end if;
-- We go back to scanning out expressions, so that we do not get
@@ -1271,6 +1271,17 @@ package body Ch4 is
"extension aggregate");
raise Error_Resync;
+ -- A range attribute can only appear as part of a discrete choice
+ -- list.
+
+ elsif Nkind (Expr_Node) = N_Attribute_Reference
+ and then Attribute_Name (Expr_Node) = Name_Range
+ and then Token /= Tok_Arrow
+ and then Token /= Tok_Vertical_Bar
+ then
+ Bad_Range_Attribute (Sloc (Expr_Node));
+ return Error;
+
-- Assume positional case if comma, right paren, or literal or
-- identifier or OTHERS follows (the latter cases are missing
-- comma cases). Also assume positional if a semicolon follows,
@@ -1284,7 +1295,7 @@ package body Ch4 is
then
if Present (Assoc_List) then
Error_Msg_BC
- ("""=>"" expected (positional association cannot follow " &
+ ("""='>"" expected (positional association cannot follow " &
"named association)");
end if;
@@ -1324,7 +1335,8 @@ package body Ch4 is
Expr_Node := Empty;
else
Save_Scan_State (Scan_State); -- at start of expression
- Expr_Node := P_Expression;
+ Expr_Node := P_Expression_Or_Range_Attribute;
+
end if;
end loop;
@@ -2142,7 +2154,7 @@ package body Ch4 is
begin
if Token = Tok_Box then
- Error_Msg_SC ("""<>"" should be ""/=""");
+ Error_Msg_SC ("""'<'>"" should be ""/=""");
end if;
Op_Kind := Relop_Node (Token);
diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb
index e201d02b29d..e8c6f3d65d6 100644
--- a/gcc/ada/par-ch5.adb
+++ b/gcc/ada/par-ch5.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -172,6 +172,10 @@ package body Ch5 is
procedure Test_Statement_Required;
-- Flag error if Statement_Required flag set
+ ----------------------
+ -- Junk_Declaration --
+ ----------------------
+
procedure Junk_Declaration is
begin
if (not Declaration_Found) or All_Errors_Mode then
@@ -182,6 +186,10 @@ package body Ch5 is
Skip_Declaration (Statement_List);
end Junk_Declaration;
+ -----------------------------
+ -- Test_Statement_Required --
+ -----------------------------
+
procedure Test_Statement_Required is
begin
if Statement_Required then
@@ -899,8 +907,9 @@ package body Ch5 is
if Nkind (Name_Node) = N_Indexed_Component then
declare
- Prefix_Node : Node_Id := Prefix (Name_Node);
- Exprs_Node : List_Id := Expressions (Name_Node);
+ Prefix_Node : constant Node_Id := Prefix (Name_Node);
+ Exprs_Node : constant List_Id := Expressions (Name_Node);
+
begin
Change_Node (Name_Node, N_Procedure_Call_Statement);
Set_Name (Name_Node, Prefix_Node);
@@ -912,8 +921,9 @@ package body Ch5 is
elsif Nkind (Name_Node) = N_Function_Call then
declare
- Fname_Node : Node_Id := Name (Name_Node);
- Params_List : List_Id := Parameter_Associations (Name_Node);
+ Fname_Node : constant Node_Id := Name (Name_Node);
+ Params_List : constant List_Id :=
+ Parameter_Associations (Name_Node);
begin
Change_Node (Name_Node, N_Procedure_Call_Statement);
@@ -979,7 +989,7 @@ package body Ch5 is
-- LABEL ::= <<label_STATEMENT_IDENTIFIER>>
- -- STATEMENT_IDENTIFIER ::= DIRECT_NAME
+ -- STATEMENT_INDENTIFIER ::= DIRECT_NAME
-- The IDENTIFIER of a STATEMENT_IDENTIFIER shall be an identifier
-- (not an OPERATOR_SYMBOL)
@@ -1246,13 +1256,28 @@ package body Ch5 is
-- to reconstruct the tree correctly in this case, but we do at least
-- give an accurate error message.
- while Token = Tok_Colon_Equal loop
- Error_Msg_SC (""":="" should be ""=""");
- Scan; -- past junk :=
- Discard_Junk_Node (P_Expression_No_Right_Paren);
- end loop;
+ if Token = Tok_Colon_Equal then
+ while Token = Tok_Colon_Equal loop
+ Error_Msg_SC (""":="" should be ""=""");
+ Scan; -- past junk :=
+ Discard_Junk_Node (P_Expression_No_Right_Paren);
+ end loop;
+
+ return Cond;
+
+ -- Otherwise check for redundant parens
+
+ else
+ if Warn_On_Redundant_Constructs
+ and then Paren_Count (Cond) > 0
+ then
+ Error_Msg_F ("redundant parentheses?", Cond);
+ end if;
+
+ -- And return the result
- return Cond;
+ return Cond;
+ end if;
end P_Condition;
-------------------------
@@ -1410,7 +1435,8 @@ package body Ch5 is
-- Error recovery : cannot raise Error_Resync
function P_Loop_Statement (Loop_Name : Node_Id := Empty) return Node_Id is
- Loop_Node : Node_Id;
+ Loop_Node : Node_Id;
+ Created_Name : Node_Id;
begin
Push_Scope_Stack;
@@ -1423,15 +1449,18 @@ package body Ch5 is
TF_Loop;
if No (Loop_Name) then
+ Created_Name :=
+ Make_Identifier (Sloc (Loop_Node),
+ Chars => Set_Loop_Block_Name ('L'));
+ Set_Comes_From_Source (Created_Name, False);
Set_Has_Created_Identifier (Loop_Node, True);
- Set_Identifier (Loop_Node,
- Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')));
+ Set_Identifier (Loop_Node, Created_Name);
+ Scope.Table (Scope.Last).Labl := Created_Name;
else
Set_Identifier (Loop_Node, Loop_Name);
end if;
Append_Elmt (Loop_Node, Label_List);
-
Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
End_Statements (Loop_Node);
return Loop_Node;
@@ -1453,6 +1482,7 @@ package body Ch5 is
Loop_Node : Node_Id;
Iter_Scheme_Node : Node_Id;
Loop_For_Flag : Boolean;
+ Created_Name : Node_Id;
begin
Push_Scope_Stack;
@@ -1483,24 +1513,26 @@ package body Ch5 is
else
Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
- TF_Loop;
- Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
- End_Statements (Loop_Node);
- Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
if No (Loop_Name) then
+ Created_Name :=
+ Make_Identifier (Sloc (Loop_Node),
+ Chars => Set_Loop_Block_Name ('L'));
+ Set_Comes_From_Source (Created_Name, False);
Set_Has_Created_Identifier (Loop_Node, True);
- Set_Identifier (Loop_Node,
- Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')));
+ Set_Identifier (Loop_Node, Created_Name);
+ Scope.Table (Scope.Last).Labl := Created_Name;
else
Set_Identifier (Loop_Node, Loop_Name);
end if;
+ TF_Loop;
+ Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
+ End_Statements (Loop_Node);
+ Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
Append_Elmt (Loop_Node, Label_List);
-
return Loop_Node;
end if;
-
end P_For_Statement;
-- P_While_Statement
@@ -1517,6 +1549,7 @@ package body Ch5 is
Loop_Node : Node_Id;
Iter_Scheme_Node : Node_Id;
Loop_While_Flag : Boolean;
+ Created_Name : Node_Id;
begin
Push_Scope_Stack;
@@ -1547,23 +1580,25 @@ package body Ch5 is
else
Loop_Node := New_Node (N_Loop_Statement, Token_Ptr);
TF_Loop;
- Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
- End_Statements (Loop_Node);
- Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
if No (Loop_Name) then
+ Created_Name :=
+ Make_Identifier (Sloc (Loop_Node),
+ Chars => Set_Loop_Block_Name ('L'));
+ Set_Comes_From_Source (Created_Name, False);
Set_Has_Created_Identifier (Loop_Node, True);
- Set_Identifier (Loop_Node,
- Make_Identifier (Sloc (Loop_Node), Set_Loop_Block_Name ('L')));
+ Set_Identifier (Loop_Node, Created_Name);
+ Scope.Table (Scope.Last).Labl := Created_Name;
else
Set_Identifier (Loop_Node, Loop_Name);
end if;
+ Set_Statements (Loop_Node, P_Sequence_Of_Statements (SS_Sreq));
+ End_Statements (Loop_Node);
+ Set_Iteration_Scheme (Loop_Node, Iter_Scheme_Node);
Append_Elmt (Loop_Node, Label_List);
-
return Loop_Node;
end if;
-
end P_While_Statement;
---------------------------------------
@@ -1644,7 +1679,8 @@ package body Ch5 is
(Block_Name : Node_Id := Empty)
return Node_Id
is
- Block_Node : Node_Id;
+ Block_Node : Node_Id;
+ Created_Name : Node_Id;
begin
Block_Node := New_Node (N_Block_Statement, Token_Ptr);
@@ -1659,9 +1695,13 @@ package body Ch5 is
Scan; -- past DECLARE
if No (Block_Name) then
+ Created_Name :=
+ Make_Identifier (Sloc (Block_Node),
+ Chars => Set_Loop_Block_Name ('B'));
+ Set_Comes_From_Source (Created_Name, False);
Set_Has_Created_Identifier (Block_Node, True);
- Set_Identifier (Block_Node,
- Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')));
+ Set_Identifier (Block_Node, Created_Name);
+ Scope.Table (Scope.Last).Labl := Created_Name;
else
Set_Identifier (Block_Node, Block_Name);
end if;
@@ -1683,7 +1723,8 @@ package body Ch5 is
(Block_Name : Node_Id := Empty)
return Node_Id
is
- Block_Node : Node_Id;
+ Block_Node : Node_Id;
+ Created_Name : Node_Id;
begin
Block_Node := New_Node (N_Block_Statement, Token_Ptr);
@@ -1696,9 +1737,13 @@ package body Ch5 is
Scope.Table (Scope.Last).Sloc := Token_Ptr;
if No (Block_Name) then
+ Created_Name :=
+ Make_Identifier (Sloc (Block_Node),
+ Chars => Set_Loop_Block_Name ('B'));
+ Set_Comes_From_Source (Created_Name, False);
Set_Has_Created_Identifier (Block_Node, True);
- Set_Identifier (Block_Node,
- Make_Identifier (Sloc (Block_Node), Set_Loop_Block_Name ('B')));
+ Set_Identifier (Block_Node, Created_Name);
+ Scope.Table (Scope.Last).Labl := Created_Name;
else
Set_Identifier (Block_Node, Block_Name);
end if;
@@ -1740,6 +1785,10 @@ package body Ch5 is
-- WHEN token, and returns True if a semicolon is missing before
-- the WHEN as in the above example.
+ -------------------------------
+ -- Missing_Semicolon_On_Exit --
+ -------------------------------
+
function Missing_Semicolon_On_Exit return Boolean is
State : Saved_Scan_State;
@@ -1781,8 +1830,9 @@ package body Ch5 is
Check_No_Exit_Name :
for J in reverse 1 .. Scope.Last loop
if Scope.Table (J).Etyp = E_Loop then
- if Present (Scope.Table (J).Labl) then
-
+ if Present (Scope.Table (J).Labl)
+ and then Comes_From_Source (Scope.Table (J).Labl)
+ then
-- Innermost loop in fact had a name, style check fails
Style.No_Exit_Name (Scope.Table (J).Labl);
diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb
index 52ccea85d22..e5dc9ffff68 100644
--- a/gcc/ada/par-ch6.adb
+++ b/gcc/ada/par-ch6.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -206,7 +206,7 @@ package body Ch6 is
if Token = Tok_New then
if not Pf_Flags.Gins then
- Error_Msg_SC ("generic instantiation not allowed here!");
+ Error_Msg_SC ("generic instantation not allowed here!");
end if;
Scan; -- past NEW
@@ -1007,6 +1007,7 @@ package body Ch6 is
end;
if Token = Tok_Semicolon then
+ Save_Scan_State (Scan_State);
Scan; -- past semicolon
-- If we have RETURN or IS after the semicolon, then assume
@@ -1017,6 +1018,15 @@ package body Ch6 is
exit Specification_Loop;
end if;
+ -- If we have a declaration keyword after the semicolon, then
+ -- assume we had a missing right parenthesis and terminate list
+
+ if Token in Token_Class_Declk then
+ Error_Msg_AP ("missing "")""");
+ Restore_Scan_State (Scan_State);
+ exit Specification_Loop;
+ end if;
+
elsif Token = Tok_Right_Paren then
Scan; -- past right paren
exit Specification_Loop;
@@ -1081,7 +1091,7 @@ package body Ch6 is
end if;
if Token = Tok_In then
- Error_Msg_SC ("IN must precede OUT in parameter mode");
+ Error_Msg_SC ("IN must preceed OUT in parameter mode");
Scan; -- past IN
Set_In_Present (Node, True);
end if;
diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb
index f80aadd2f61..e68c972d63f 100644
--- a/gcc/ada/par-ch9.adb
+++ b/gcc/ada/par-ch9.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -789,6 +789,7 @@ package body Ch9 is
exception
when Error_Resync =>
Resync_Past_Semicolon;
+ Pop_Scope_Stack; -- discard unused entry
return Error;
end P_Accept_Statement;
@@ -1153,8 +1154,9 @@ package body Ch9 is
if Nkind (Ecall_Node) = N_Indexed_Component then
declare
- Prefix_Node : Node_Id := Prefix (Ecall_Node);
- Exprs_Node : List_Id := Expressions (Ecall_Node);
+ Prefix_Node : constant Node_Id := Prefix (Ecall_Node);
+ Exprs_Node : constant List_Id := Expressions (Ecall_Node);
+
begin
Change_Node (Ecall_Node, N_Procedure_Call_Statement);
Set_Name (Ecall_Node, Prefix_Node);
@@ -1163,8 +1165,9 @@ package body Ch9 is
elsif Nkind (Ecall_Node) = N_Function_Call then
declare
- Fname_Node : Node_Id := Name (Ecall_Node);
- Params_List : List_Id := Parameter_Associations (Ecall_Node);
+ Fname_Node : constant Node_Id := Name (Ecall_Node);
+ Params_List : constant List_Id :=
+ Parameter_Associations (Ecall_Node);
begin
Change_Node (Ecall_Node, N_Procedure_Call_Statement);
diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb
index 57561aab673..2aabe2f643c 100644
--- a/gcc/ada/par-endh.adb
+++ b/gcc/ada/par-endh.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -114,12 +114,17 @@ package body Endh is
-- Local Subprograms --
-----------------------
- procedure Evaluate_End_Entry (SS_Index : Int);
+ procedure Evaluate_End_Entry (SS_Index : Nat);
-- Compare scanned END entry (as recorded by a prior call to P_End_Scan)
-- with a specified entry in the scope stack (the single parameter is the
-- entry index in the scope stack). Note that Scan is not called. The above
-- variables xxx_OK are set to indicate the result of the evaluation.
+ function Explicit_Start_Label (SS_Index : Nat) return Boolean;
+ -- Determines whether the specified entry in the scope stack has an
+ -- explicit start label (i.e. one other than one that was created by
+ -- the parser when no explicit label was present)
+
procedure Output_End_Deleted;
-- Output a message complaining that the current END structure does not
-- match anything and is being deleted.
@@ -298,7 +303,7 @@ package body Endh is
-- Case of child unit name
if Nkind (End_Labl) = N_Defining_Program_Unit_Name then
- declare
+ Child_End : declare
Eref : constant Node_Id :=
Make_Identifier (Token_Ptr,
Chars =>
@@ -307,6 +312,10 @@ package body Endh is
function Copy_Name (N : Node_Id) return Node_Id;
-- Copies a selected component or identifier
+ ---------------
+ -- Copy_Name --
+ ---------------
+
function Copy_Name (N : Node_Id) return Node_Id is
R : Node_Id;
@@ -328,6 +337,8 @@ package body Endh is
end if;
end Copy_Name;
+ -- Start of processing for Child_End
+
begin
Set_Comes_From_Source (Eref, False);
@@ -335,7 +346,7 @@ package body Endh is
Make_Designator (Token_Ptr,
Name => Copy_Name (Name (End_Labl)),
Identifier => Eref);
- end;
+ end Child_End;
-- Simple identifier case
@@ -364,7 +375,7 @@ package body Endh is
if Style_Check
and then End_Type = E_Name
- and then Present (Scope.Table (Scope.Last).Labl)
+ and then Explicit_Start_Label (Scope.Last)
then
Style.No_End_Name (Scope.Table (Scope.Last).Labl);
end if;
@@ -655,7 +666,7 @@ package body Endh is
-- Evaluate End Entry --
------------------------
- procedure Evaluate_End_Entry (SS_Index : Int) is
+ procedure Evaluate_End_Entry (SS_Index : Nat) is
begin
Column_OK := (End_Column = Scope.Table (SS_Index).Ecol);
@@ -692,6 +703,7 @@ package body Endh is
begin
if Nkind (End_Labl) in N_Has_Chars
+ and then Comes_From_Source (Nam)
and then Nkind (Nam) in N_Has_Chars
and then Chars (End_Labl) > Error_Name
and then Chars (Nam) > Error_Name
@@ -701,7 +713,8 @@ package body Endh is
if Error_Msg_Name_1 > Error_Name then
declare
- S : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+ S : constant String (1 .. Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
begin
Get_Name_String (Error_Msg_Name_1);
@@ -724,13 +737,14 @@ package body Endh is
-- case, this is acceptable only if the loop is unlabeled.
elsif End_Type = E_Loop then
- Syntax_OK := (Scope.Table (SS_Index).Labl = Empty);
+ Syntax_OK := not Explicit_Start_Label (SS_Index);
-- Cases where a label is definitely allowed on the END line
elsif End_Type = E_Name then
- Syntax_OK := (Scope.Table (SS_Index).Labl = Empty or else
- not Scope.Table (SS_Index).Lreq);
+ Syntax_OK := (not Explicit_Start_Label (SS_Index))
+ or else
+ (not Scope.Table (SS_Index).Lreq);
-- Otherwise we have cases which don't allow labels anyway, so we
-- certainly accept an END which does not have a label.
@@ -740,6 +754,23 @@ package body Endh is
end if;
end Evaluate_End_Entry;
+ --------------------------
+ -- Explicit_Start_Label --
+ --------------------------
+
+ function Explicit_Start_Label (SS_Index : Nat) return Boolean is
+ L : constant Node_Id := Scope.Table (SS_Index).Labl;
+
+ begin
+ if No (L) then
+ return False;
+ elsif Comes_From_Source (L) then
+ return True;
+ else
+ return False;
+ end if;
+ end Explicit_Start_Label;
+
------------------------
-- Output End Deleted --
------------------------
@@ -784,9 +815,14 @@ package body Endh is
End_Type := Scope.Table (Scope.Last).Etyp;
Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
- Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
+ if Explicit_Start_Label (Scope.Last) then
+ Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
+ else
+ Error_Msg_Node_1 := Empty;
+ end if;
+
-- Suppress message if error was posted on opening label
if Error_Msg_Node_1 > Empty_Or_Error
@@ -853,9 +889,14 @@ package body Endh is
end if;
End_Type := Scope.Table (Scope.Last).Etyp;
- Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
Error_Msg_Sloc := Scope.Table (Scope.Last).Sloc;
+ if Explicit_Start_Label (Scope.Last) then
+ Error_Msg_Node_1 := Scope.Table (Scope.Last).Labl;
+ else
+ Error_Msg_Node_1 := Empty;
+ end if;
+
if End_Type = E_Case then
Error_Msg_BC ("missing `END CASE;` for CASE#!");
@@ -1014,9 +1055,9 @@ package body Endh is
and then
(Scope.Last = 1
or else
- (No (Scope.Table (Scope.Last - 1).Labl)
- or else
- not Same_Label
+ (not Explicit_Start_Label (Scope.Last - 1))
+ or else
+ (not Same_Label
(End_Labl,
Scope.Table (Scope.Last - 1).Labl)))
then
diff --git a/gcc/ada/par-labl.adb b/gcc/ada/par-labl.adb
index f3fa8f5292d..835be36e337 100644
--- a/gcc/ada/par-labl.adb
+++ b/gcc/ada/par-labl.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1998, 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- --
@@ -183,6 +183,13 @@ begin
Set_Defining_Identifier (Label_Decl_Node, Defining_Ident_Node);
Set_Label_Construct (Label_Decl_Node, Label_Node);
+ -- The following makes sure that Comes_From_Source is appropriately
+ -- set for the entity, depending on whether the label appeared in
+ -- the source explicitly or not.
+
+ Set_Comes_From_Source
+ (Defining_Ident_Node, Comes_From_Source (Identifier (Label_Node)));
+
-- Now attach the implicit label declaration to the appropriate
-- declarative region, creating a declaration list if none exists
diff --git a/gcc/ada/par-load.adb b/gcc/ada/par-load.adb
index 2b5e5cf9cfb..fb0f2684f6c 100644
--- a/gcc/ada/par-load.adb
+++ b/gcc/ada/par-load.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -48,7 +48,7 @@ procedure Load is
File_Name : File_Name_Type;
-- Name of file for current unit, derived from unit name
- Cur_Unum : Unit_Number_Type := Current_Source_Unit;
+ Cur_Unum : constant Unit_Number_Type := Current_Source_Unit;
-- Unit number of unit that we just finished parsing. Note that we need
-- to capture this, because Source_Unit will change as we parse new
-- source files in the multiple main source file case.
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index 927664ad5a2..2f5482fd70a 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -70,8 +70,8 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
-- an error message and raise Error_Resync.
procedure Check_No_Identifier (Arg : Node_Id);
- -- Checks that the given argument does not have an identifier. If an
- -- identifier is present, then an error message is issued, and
+ -- Checks that the given argument does not have an identifier. If
+ -- an identifier is present, then an error message is issued, and
-- Error_Resync is raised.
procedure Check_Optional_Identifier (Arg : Node_Id; Id : Name_Id);
@@ -353,11 +353,12 @@ begin
List_Pragmas.Increment_Last;
List_Pragmas.Table (List_Pragmas.Last) := (Page, Semi);
- -----------------------------
- -- Source_File_Name (GNAT) --
- -----------------------------
+ ----------------------------------------------------------
+ -- Source_File_Name and Source_File_Name_Project (GNAT) --
+ ----------------------------------------------------------
- -- There are five forms of this pragma:
+ -- These two pragmas have the same syntax and semantics.
+ -- There are five forms of these pragmas:
-- pragma Source_File_Name (
-- [UNIT_NAME =>] unit_NAME,
@@ -384,242 +385,281 @@ begin
-- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
+ -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
+ -- Source_File_Name (SFN), however their usage is exclusive:
+ -- SFN can only be used when no project file is used, while
+ -- SFNP can only be used when a project file is used.
+
+ -- The Project Manager produces a configuration pragmas file that
+ -- is communicated to the compiler with -gnatec switch. This file
+ -- contains only SFNP pragmas (at least two for the default naming
+ -- scheme. As this configuration pragmas file is always the first
+ -- processed by the compiler, it prevents the use of pragmas SFN in
+ -- other config files when a project file is in use.
+
-- Note: we process this during parsing, since we need to have the
-- source file names set well before the semantic analysis starts,
-- since we load the spec and with'ed packages before analysis.
- when Pragma_Source_File_Name => Source_File_Name : declare
- Unam : Unit_Name_Type;
- Expr1 : Node_Id;
- Pat : String_Ptr;
- Typ : Character;
- Dot : String_Ptr;
- Cas : Casing_Type;
- Nast : Nat;
+ when Pragma_Source_File_Name | Pragma_Source_File_Name_Project =>
+ Source_File_Name : declare
+ Unam : Unit_Name_Type;
+ Expr1 : Node_Id;
+ Pat : String_Ptr;
+ Typ : Character;
+ Dot : String_Ptr;
+ Cas : Casing_Type;
+ Nast : Nat;
- function Get_Fname (Arg : Node_Id) return Name_Id;
- -- Process file name from unit name form of pragma
+ function Get_Fname (Arg : Node_Id) return Name_Id;
+ -- Process file name from unit name form of pragma
- function Get_String_Argument (Arg : Node_Id) return String_Ptr;
- -- Process string literal value from argument
+ function Get_String_Argument (Arg : Node_Id) return String_Ptr;
+ -- Process string literal value from argument
- procedure Process_Casing (Arg : Node_Id);
- -- Process Casing argument of pattern form of pragma
+ procedure Process_Casing (Arg : Node_Id);
+ -- Process Casing argument of pattern form of pragma
- procedure Process_Dot_Replacement (Arg : Node_Id);
- -- Process Dot_Replacement argument of patterm form of pragma
+ procedure Process_Dot_Replacement (Arg : Node_Id);
+ -- Process Dot_Replacement argument of patterm form of pragma
- ---------------
- -- Get_Fname --
- ---------------
+ ---------------
+ -- Get_Fname --
+ ---------------
- function Get_Fname (Arg : Node_Id) return Name_Id is
- begin
- String_To_Name_Buffer (Strval (Expression (Arg)));
+ function Get_Fname (Arg : Node_Id) return Name_Id is
+ begin
+ String_To_Name_Buffer (Strval (Expression (Arg)));
- for J in 1 .. Name_Len loop
- if Is_Directory_Separator (Name_Buffer (J)) then
- Error_Msg
- ("directory separator character not allowed",
- Sloc (Expression (Arg)) + Source_Ptr (J));
- end if;
- end loop;
+ for J in 1 .. Name_Len loop
+ if Is_Directory_Separator (Name_Buffer (J)) then
+ Error_Msg
+ ("directory separator character not allowed",
+ Sloc (Expression (Arg)) + Source_Ptr (J));
+ end if;
+ end loop;
- return Name_Find;
- end Get_Fname;
+ return Name_Find;
+ end Get_Fname;
- -------------------------
- -- Get_String_Argument --
- -------------------------
+ -------------------------
+ -- Get_String_Argument --
+ -------------------------
- function Get_String_Argument (Arg : Node_Id) return String_Ptr is
- Str : String_Id;
+ function Get_String_Argument (Arg : Node_Id) return String_Ptr is
+ Str : String_Id;
- begin
- if Nkind (Expression (Arg)) /= N_String_Literal
- and then
- Nkind (Expression (Arg)) /= N_Operator_Symbol
- then
- Error_Msg_N
- ("argument for pragma% must be string literal", Arg);
- raise Error_Resync;
- end if;
+ begin
+ if Nkind (Expression (Arg)) /= N_String_Literal
+ and then
+ Nkind (Expression (Arg)) /= N_Operator_Symbol
+ then
+ Error_Msg_N
+ ("argument for pragma% must be string literal", Arg);
+ raise Error_Resync;
+ end if;
- Str := Strval (Expression (Arg));
+ Str := Strval (Expression (Arg));
- -- Check string has no wide chars
+ -- Check string has no wide chars
- for J in 1 .. String_Length (Str) loop
- if Get_String_Char (Str, J) > 255 then
- Error_Msg
- ("wide character not allowed in pattern for pragma%",
- Sloc (Expression (Arg2)) + Text_Ptr (J) - 1);
+ for J in 1 .. String_Length (Str) loop
+ if Get_String_Char (Str, J) > 255 then
+ Error_Msg
+ ("wide character not allowed in pattern for pragma%",
+ Sloc (Expression (Arg2)) + Text_Ptr (J) - 1);
+ end if;
+ end loop;
+
+ -- Acquire string
+
+ String_To_Name_Buffer (Str);
+ return new String'(Name_Buffer (1 .. Name_Len));
+ end Get_String_Argument;
+
+ --------------------
+ -- Process_Casing --
+ --------------------
+
+ procedure Process_Casing (Arg : Node_Id) is
+ Expr : constant Node_Id := Expression (Arg);
+
+ begin
+ Check_Required_Identifier (Arg, Name_Casing);
+
+ if Nkind (Expr) = N_Identifier then
+ if Chars (Expr) = Name_Lowercase then
+ Cas := All_Lower_Case;
+ return;
+ elsif Chars (Expr) = Name_Uppercase then
+ Cas := All_Upper_Case;
+ return;
+ elsif Chars (Expr) = Name_Mixedcase then
+ Cas := Mixed_Case;
+ return;
+ end if;
end if;
- end loop;
- -- Acquire string
+ Error_Msg_N
+ ("Casing argument for pragma% must be " &
+ "one of Mixedcase, Lowercase, Uppercase",
+ Arg);
+ end Process_Casing;
- String_To_Name_Buffer (Str);
- return new String'(Name_Buffer (1 .. Name_Len));
- end Get_String_Argument;
+ -----------------------------
+ -- Process_Dot_Replacement --
+ -----------------------------
- --------------------
- -- Process_Casing --
- --------------------
+ procedure Process_Dot_Replacement (Arg : Node_Id) is
+ begin
+ Check_Required_Identifier (Arg, Name_Dot_Replacement);
+ Dot := Get_String_Argument (Arg);
+ end Process_Dot_Replacement;
- procedure Process_Casing (Arg : Node_Id) is
- Expr : constant Node_Id := Expression (Arg);
+ -- Start of processing for Source_File_Name and
+ -- Source_File_Name_Project pragmas.
begin
- Check_Required_Identifier (Arg, Name_Casing);
-
- if Nkind (Expr) = N_Identifier then
- if Chars (Expr) = Name_Lowercase then
- Cas := All_Lower_Case;
- return;
- elsif Chars (Expr) = Name_Uppercase then
- Cas := All_Upper_Case;
- return;
- elsif Chars (Expr) = Name_Mixedcase then
- Cas := Mixed_Case;
- return;
- end if;
- end if;
- Error_Msg_N
- ("Casing argument for pragma% must be " &
- "one of Mixedcase, Lowercase, Uppercase",
- Arg);
- end Process_Casing;
+ if Get_Pragma_Id (Pragma_Name) = Pragma_Source_File_Name then
+ if Project_File_In_Use = In_Use then
+ Error_Msg
+ ("pragma Source_File_Name cannot be used " &
+ "with a project file", Pragma_Sloc);
- -----------------------------
- -- Process_Dot_Replacement --
- -----------------------------
+ else
+ Project_File_In_Use := Not_In_Use;
+ end if;
- procedure Process_Dot_Replacement (Arg : Node_Id) is
- begin
- Check_Required_Identifier (Arg, Name_Dot_Replacement);
- Dot := Get_String_Argument (Arg);
- end Process_Dot_Replacement;
+ else
+ if Project_File_In_Use = Not_In_Use then
+ Error_Msg
+ ("pragma Source_File_Name_Project should only be used " &
+ "with a project file", Pragma_Sloc);
- -- Start of processing for Source_File_Name pragma
+ else
+ Project_File_In_Use := In_Use;
+ end if;
+ end if;
- begin
- -- We permit from 1 to 3 arguments
+ -- We permit from 1 to 3 arguments
- if Arg_Count not in 1 .. 3 then
- Check_Arg_Count (1);
- end if;
+ if Arg_Count not in 1 .. 3 then
+ Check_Arg_Count (1);
+ end if;
- Expr1 := Expression (Arg1);
+ Expr1 := Expression (Arg1);
- -- If first argument is identifier or selected component, then
- -- we have the specific file case of the Source_File_Name pragma,
- -- and the first argument is a unit name.
+ -- If first argument is identifier or selected component, then
+ -- we have the specific file case of the Source_File_Name pragma,
+ -- and the first argument is a unit name.
- if Nkind (Expr1) = N_Identifier
- or else
- (Nkind (Expr1) = N_Selected_Component
- and then
- Nkind (Selector_Name (Expr1)) = N_Identifier)
- then
if Nkind (Expr1) = N_Identifier
- and then Chars (Expr1) = Name_System
+ or else
+ (Nkind (Expr1) = N_Selected_Component
+ and then
+ Nkind (Selector_Name (Expr1)) = N_Identifier)
then
- Error_Msg_N
- ("pragma Source_File_Name may not be used for System", Arg1);
- return Error;
- end if;
+ if Nkind (Expr1) = N_Identifier
+ and then Chars (Expr1) = Name_System
+ then
+ Error_Msg_N
+ ("pragma Source_File_Name may not be used for System",
+ Arg1);
+ return Error;
+ end if;
- Check_Arg_Count (2);
+ Check_Arg_Count (2);
- Check_Optional_Identifier (Arg1, Name_Unit_Name);
- Unam := Get_Unit_Name (Expr1);
+ Check_Optional_Identifier (Arg1, Name_Unit_Name);
+ Unam := Get_Unit_Name (Expr1);
- Check_Arg_Is_String_Literal (Arg2);
+ Check_Arg_Is_String_Literal (Arg2);
- if Chars (Arg2) = Name_Spec_File_Name then
- Set_File_Name (Get_Spec_Name (Unam), Get_Fname (Arg2));
+ if Chars (Arg2) = Name_Spec_File_Name then
+ Set_File_Name (Get_Spec_Name (Unam), Get_Fname (Arg2));
- elsif Chars (Arg2) = Name_Body_File_Name then
- Set_File_Name (Unam, Get_Fname (Arg2));
+ elsif Chars (Arg2) = Name_Body_File_Name then
+ Set_File_Name (Unam, Get_Fname (Arg2));
- else
- Error_Msg_N ("pragma% argument has incorrect identifier", Arg2);
- return Pragma_Node;
- end if;
+ else
+ Error_Msg_N
+ ("pragma% argument has incorrect identifier", Arg2);
+ return Pragma_Node;
+ end if;
- -- If the first argument is not an identifier, then we must have
- -- the pattern form of the pragma, and the first argument must be
- -- the pattern string with an appropriate name.
+ -- If the first argument is not an identifier, then we must have
+ -- the pattern form of the pragma, and the first argument must be
+ -- the pattern string with an appropriate name.
- else
- if Chars (Arg1) = Name_Spec_File_Name then
- Typ := 's';
+ else
+ if Chars (Arg1) = Name_Spec_File_Name then
+ Typ := 's';
- elsif Chars (Arg1) = Name_Body_File_Name then
- Typ := 'b';
+ elsif Chars (Arg1) = Name_Body_File_Name then
+ Typ := 'b';
- elsif Chars (Arg1) = Name_Subunit_File_Name then
- Typ := 'u';
+ elsif Chars (Arg1) = Name_Subunit_File_Name then
+ Typ := 'u';
- elsif Chars (Arg1) = Name_Unit_Name then
- Error_Msg_N
- ("Unit_Name parameter for pragma% must be an identifier",
- Arg1);
- raise Error_Resync;
+ elsif Chars (Arg1) = Name_Unit_Name then
+ Error_Msg_N
+ ("Unit_Name parameter for pragma% must be an identifier",
+ Arg1);
+ raise Error_Resync;
- else
- Error_Msg_N ("pragma% argument has incorrect identifier", Arg1);
- raise Error_Resync;
- end if;
+ else
+ Error_Msg_N
+ ("pragma% argument has incorrect identifier", Arg1);
+ raise Error_Resync;
+ end if;
- Pat := Get_String_Argument (Arg1);
+ Pat := Get_String_Argument (Arg1);
- -- Check pattern has exactly one asterisk
+ -- Check pattern has exactly one asterisk
- Nast := 0;
- for J in Pat'Range loop
- if Pat (J) = '*' then
- Nast := Nast + 1;
- end if;
- end loop;
+ Nast := 0;
+ for J in Pat'Range loop
+ if Pat (J) = '*' then
+ Nast := Nast + 1;
+ end if;
+ end loop;
- if Nast /= 1 then
- Error_Msg_N
- ("file name pattern must have exactly one * character",
- Arg2);
- return Pragma_Node;
- end if;
+ if Nast /= 1 then
+ Error_Msg_N
+ ("file name pattern must have exactly one * character",
+ Arg2);
+ return Pragma_Node;
+ end if;
- -- Set defaults for Casing and Dot_Separator parameters
+ -- Set defaults for Casing and Dot_Separator parameters
- Cas := All_Lower_Case;
+ Cas := All_Lower_Case;
- Dot := new String'(".");
+ Dot := new String'(".");
- -- Process second and third arguments if present
+ -- Process second and third arguments if present
- if Arg_Count > 1 then
- if Chars (Arg2) = Name_Casing then
- Process_Casing (Arg2);
+ if Arg_Count > 1 then
+ if Chars (Arg2) = Name_Casing then
+ Process_Casing (Arg2);
- if Arg_Count = 3 then
- Process_Dot_Replacement (Arg3);
- end if;
+ if Arg_Count = 3 then
+ Process_Dot_Replacement (Arg3);
+ end if;
- else
- Process_Dot_Replacement (Arg2);
+ else
+ Process_Dot_Replacement (Arg2);
- if Arg_Count = 3 then
- Process_Casing (Arg3);
+ if Arg_Count = 3 then
+ Process_Casing (Arg3);
+ end if;
end if;
end if;
- end if;
- Set_File_Name_Pattern (Pat, Typ, Dot, Cas);
- end if;
- end Source_File_Name;
+ Set_File_Name_Pattern (Pat, Typ, Dot, Cas);
+ end if;
+ end Source_File_Name;
-----------------------------
-- Source_Reference (GNAT) --
@@ -736,7 +776,7 @@ begin
S := Strval (A);
declare
- Slen : Natural := Natural (String_Length (S));
+ Slen : constant Natural := Natural (String_Length (S));
Options : String (1 .. Slen);
J : Natural;
Ptr : Natural;
@@ -825,124 +865,145 @@ begin
-- For all other pragmas, checking and processing is handled
-- entirely in Sem_Prag, and no further checking is done by Par.
- when Pragma_Abort_Defer |
- Pragma_AST_Entry |
- Pragma_All_Calls_Remote |
- Pragma_Annotate |
- Pragma_Assert |
- Pragma_Asynchronous |
- Pragma_Atomic |
- Pragma_Atomic_Components |
- Pragma_Attach_Handler |
- Pragma_Convention_Identifier |
- Pragma_CPP_Class |
- Pragma_CPP_Constructor |
- Pragma_CPP_Virtual |
- Pragma_CPP_Vtable |
- Pragma_C_Pass_By_Copy |
- Pragma_Comment |
- Pragma_Common_Object |
- Pragma_Complex_Representation |
- Pragma_Component_Alignment |
- Pragma_Controlled |
- Pragma_Convention |
- Pragma_Discard_Names |
- Pragma_Eliminate |
- Pragma_Elaborate |
- Pragma_Elaborate_All |
- Pragma_Elaborate_Body |
- Pragma_Elaboration_Checks |
- Pragma_Export |
- Pragma_Export_Exception |
- Pragma_Export_Function |
- Pragma_Export_Object |
- Pragma_Export_Procedure |
- Pragma_Export_Valued_Procedure |
- Pragma_Extend_System |
- Pragma_External |
- Pragma_External_Name_Casing |
- Pragma_Finalize_Storage_Only |
- Pragma_Float_Representation |
- Pragma_Ident |
- Pragma_Import |
- Pragma_Import_Exception |
- Pragma_Import_Function |
- Pragma_Import_Object |
- Pragma_Import_Procedure |
- Pragma_Import_Valued_Procedure |
- Pragma_Initialize_Scalars |
- Pragma_Inline |
- Pragma_Inline_Always |
- Pragma_Inline_Generic |
- Pragma_Inspection_Point |
- Pragma_Interface |
- Pragma_Interface_Name |
- Pragma_Interrupt_Handler |
- Pragma_Interrupt_Priority |
- Pragma_Java_Constructor |
- Pragma_Java_Interface |
- Pragma_License |
- Pragma_Link_With |
- Pragma_Linker_Alias |
- Pragma_Linker_Options |
- Pragma_Linker_Section |
- Pragma_Locking_Policy |
- Pragma_Long_Float |
- Pragma_Machine_Attribute |
- Pragma_Main |
- Pragma_Main_Storage |
- Pragma_Memory_Size |
- Pragma_No_Return |
- Pragma_No_Run_Time |
- Pragma_Normalize_Scalars |
- Pragma_Optimize |
- Pragma_Pack |
- Pragma_Passive |
- Pragma_Polling |
- Pragma_Preelaborate |
- Pragma_Priority |
- Pragma_Propagate_Exceptions |
- Pragma_Psect_Object |
- Pragma_Pure |
- Pragma_Pure_Function |
- Pragma_Queuing_Policy |
- Pragma_Remote_Call_Interface |
- Pragma_Remote_Types |
- Pragma_Restrictions |
- Pragma_Restricted_Run_Time |
- Pragma_Ravenscar |
- Pragma_Reviewable |
- Pragma_Share_Generic |
- Pragma_Shared |
- Pragma_Shared_Passive |
- Pragma_Storage_Size |
- Pragma_Storage_Unit |
- Pragma_Stream_Convert |
- Pragma_Subtitle |
- Pragma_Suppress |
- Pragma_Suppress_All |
- Pragma_Suppress_Debug_Info |
- Pragma_Suppress_Initialization |
- Pragma_System_Name |
- Pragma_Task_Dispatching_Policy |
- Pragma_Task_Info |
- Pragma_Task_Name |
- Pragma_Task_Storage |
- Pragma_Time_Slice |
- Pragma_Title |
- Pragma_Unchecked_Union |
- Pragma_Unimplemented_Unit |
- Pragma_Universal_Data |
- Pragma_Unreferenced |
- Pragma_Unreserve_All_Interrupts |
- Pragma_Unsuppress |
- Pragma_Use_VADS_Size |
- Pragma_Volatile |
- Pragma_Volatile_Components |
- Pragma_Weak_External |
- Pragma_Validity_Checks =>
+ when Pragma_Abort_Defer |
+ Pragma_AST_Entry |
+ Pragma_All_Calls_Remote |
+ Pragma_Annotate |
+ Pragma_Assert |
+ Pragma_Asynchronous |
+ Pragma_Atomic |
+ Pragma_Atomic_Components |
+ Pragma_Attach_Handler |
+ Pragma_Compile_Time_Warning |
+ Pragma_Convention_Identifier |
+ Pragma_CPP_Class |
+ Pragma_CPP_Constructor |
+ Pragma_CPP_Virtual |
+ Pragma_CPP_Vtable |
+ Pragma_C_Pass_By_Copy |
+ Pragma_Comment |
+ Pragma_Common_Object |
+ Pragma_Complex_Representation |
+ Pragma_Component_Alignment |
+ Pragma_Controlled |
+ Pragma_Convention |
+ Pragma_Discard_Names |
+ Pragma_Eliminate |
+ Pragma_Elaborate |
+ Pragma_Elaborate_All |
+ Pragma_Elaborate_Body |
+ Pragma_Elaboration_Checks |
+ Pragma_Explicit_Overriding |
+ Pragma_Export |
+ Pragma_Export_Exception |
+ Pragma_Export_Function |
+ Pragma_Export_Object |
+ Pragma_Export_Procedure |
+ Pragma_Export_Value |
+ Pragma_Export_Valued_Procedure |
+ Pragma_Extend_System |
+ Pragma_External |
+ Pragma_External_Name_Casing |
+ Pragma_Finalize_Storage_Only |
+ Pragma_Float_Representation |
+ Pragma_Ident |
+ Pragma_Import |
+ Pragma_Import_Exception |
+ Pragma_Import_Function |
+ Pragma_Import_Object |
+ Pragma_Import_Procedure |
+ Pragma_Import_Valued_Procedure |
+ Pragma_Initialize_Scalars |
+ Pragma_Inline |
+ Pragma_Inline_Always |
+ Pragma_Inline_Generic |
+ Pragma_Inspection_Point |
+ Pragma_Interface |
+ Pragma_Interface_Name |
+ Pragma_Interrupt_Handler |
+ Pragma_Interrupt_State |
+ Pragma_Interrupt_Priority |
+ Pragma_Java_Constructor |
+ Pragma_Java_Interface |
+ Pragma_Keep_Names |
+ Pragma_License |
+ Pragma_Link_With |
+ Pragma_Linker_Alias |
+ Pragma_Linker_Options |
+ Pragma_Linker_Section |
+ Pragma_Locking_Policy |
+ Pragma_Long_Float |
+ Pragma_Machine_Attribute |
+ Pragma_Main |
+ Pragma_Main_Storage |
+ Pragma_Memory_Size |
+ Pragma_No_Return |
+ Pragma_Obsolescent |
+ Pragma_No_Run_Time |
+ Pragma_Normalize_Scalars |
+ Pragma_Optimize |
+ Pragma_Optional_Overriding |
+ Pragma_Overriding |
+ Pragma_Pack |
+ Pragma_Passive |
+ Pragma_Polling |
+ Pragma_Persistent_Data |
+ Pragma_Persistent_Object |
+ Pragma_Preelaborate |
+ Pragma_Priority |
+ Pragma_Propagate_Exceptions |
+ Pragma_Psect_Object |
+ Pragma_Pure |
+ Pragma_Pure_Function |
+ Pragma_Queuing_Policy |
+ Pragma_Remote_Call_Interface |
+ Pragma_Remote_Types |
+ Pragma_Restrictions |
+ Pragma_Restriction_Warnings |
+ Pragma_Restricted_Run_Time |
+ Pragma_Ravenscar |
+ Pragma_Reviewable |
+ Pragma_Share_Generic |
+ Pragma_Shared |
+ Pragma_Shared_Passive |
+ Pragma_Storage_Size |
+ Pragma_Storage_Unit |
+ Pragma_Stream_Convert |
+ Pragma_Subtitle |
+ Pragma_Suppress |
+ Pragma_Suppress_All |
+ Pragma_Suppress_Debug_Info |
+ Pragma_Suppress_Exception_Locations |
+ Pragma_Suppress_Initialization |
+ Pragma_System_Name |
+ Pragma_Task_Dispatching_Policy |
+ Pragma_Task_Info |
+ Pragma_Task_Name |
+ Pragma_Task_Storage |
+ Pragma_Time_Slice |
+ Pragma_Title |
+ Pragma_Unchecked_Union |
+ Pragma_Unimplemented_Unit |
+ Pragma_Universal_Data |
+ Pragma_Unreferenced |
+ Pragma_Unreserve_All_Interrupts |
+ Pragma_Unsuppress |
+ Pragma_Use_VADS_Size |
+ Pragma_Volatile |
+ Pragma_Volatile_Components |
+ Pragma_Weak_External |
+ Pragma_Validity_Checks =>
null;
+ --------------------
+ -- Unknown_Pragma --
+ --------------------
+
+ -- Should be impossible, since we excluded this case earlier on
+
+ when Unknown_Pragma =>
+ raise Program_Error;
+
end case;
return Pragma_Node;
diff --git a/gcc/ada/par-sync.adb b/gcc/ada/par-sync.adb
index a9646b0f7c3..8ff527853fe 100644
--- a/gcc/ada/par-sync.adb
+++ b/gcc/ada/par-sync.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -180,11 +180,46 @@ package body Sync is
end if;
end loop;
- -- Fall out of loop with resyncrhonization complete
+ -- Fall out of loop with resynchronization complete
Resync_Resume;
end Resync_Past_Semicolon;
+ -------------------------
+ -- Resync_To_Semicolon --
+ -------------------------
+
+ procedure Resync_To_Semicolon is
+ begin
+ Resync_Init;
+
+ loop
+ -- Done if we are at a semicolon
+
+ if Token = Tok_Semicolon then
+ exit;
+
+ -- Done if we are at a token which normally appears only after
+ -- a semicolon. One special glitch is that the keyword private is
+ -- in this category only if it does NOT appear after WITH.
+
+ elsif Token in Token_Class_After_SM
+ and then (Token /= Tok_Private or else Prev_Token /= Tok_With)
+ then
+ exit;
+
+ -- Otherwise keep going
+
+ else
+ Scan;
+ end if;
+ end loop;
+
+ -- Fall out of loop with resynchronization complete
+
+ Resync_Resume;
+ end Resync_To_Semicolon;
+
----------------------------------------------
-- Resync_Past_Semicolon_Or_To_Loop_Or_Then --
----------------------------------------------
@@ -204,9 +239,8 @@ package body Sync is
-- a semicolon. One special glitch is that the keyword private is
-- in this category only if it does NOT appear after WITH.
- elsif (Token in Token_Class_After_SM
- and then (Token /= Tok_Private
- or else Prev_Token /= Tok_With))
+ elsif Token in Token_Class_After_SM
+ and then (Token /= Tok_Private or else Prev_Token /= Tok_With)
then
exit;
diff --git a/gcc/ada/par-tchk.adb b/gcc/ada/par-tchk.adb
index cff60de5000..cdb5418fc26 100644
--- a/gcc/ada/par-tchk.adb
+++ b/gcc/ada/par-tchk.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -84,15 +84,15 @@ package body Tchk is
-- A little recovery helper, accept then in place of =>
elsif Token = Tok_Then then
- Error_Msg_BC ("missing ""=>""");
+ Error_Msg_BC ("missing ""='>""");
Scan; -- past THEN used in place of =>
elsif Token = Tok_Colon_Equal then
- Error_Msg_SC (""":="" should be ""=>""");
+ Error_Msg_SC (""":="" should be ""='>""");
Scan; -- past := used in place of =>
else
- Error_Msg_AP ("missing ""=>""");
+ Error_Msg_AP ("missing ""='>""");
end if;
end T_Arrow;
@@ -123,7 +123,7 @@ package body Tchk is
if Token = Tok_Box then
Scan;
else
- Error_Msg_AP ("missing ""<>""");
+ Error_Msg_AP ("missing ""'<'>""");
end if;
end T_Box;
@@ -223,7 +223,7 @@ package body Tchk is
if Token = Tok_Greater_Greater then
Scan;
else
- Error_Msg_AP ("missing "">>""");
+ Error_Msg_AP ("missing ""'>'>""");
end if;
end T_Greater_Greater;
@@ -399,17 +399,22 @@ package body Tchk is
Scan;
end if;
+ return;
+
elsif Token = Tok_Colon then
Error_Msg_SC (""":"" should be "";""");
Scan;
+ return;
elsif Token = Tok_Comma then
Error_Msg_SC (""","" should be "";""");
Scan;
+ return;
elsif Token = Tok_Dot then
Error_Msg_SC ("""."" should be "";""");
Scan;
+ return;
-- An interesting little kludge here. If the previous token is a
-- semicolon, then there is no way that we can legitimately need
@@ -427,14 +432,27 @@ package body Tchk is
elsif Token = Tok_Vertical_Bar then
Error_Msg_SC ("unexpected occurrence of ""'|"", did you mean OR'?");
Resync_Past_Semicolon;
+ return;
- -- Otherwise we really do have a missing semicolon
+ -- Deal with pragma. If pragma is not at start of line, it is
+ -- considered misplaced otherwise we treat it as a normal
+ -- missing semicolong case.
- else
- Error_Msg_AP ("|missing "";""");
- return;
+ elsif Token = Tok_Pragma
+ and then not Token_Is_At_Start_Of_Line
+ then
+ P_Pragmas_Misplaced;
+
+ if Token = Tok_Semicolon then
+ Scan;
+ return;
+ end if;
end if;
+ -- If none of those tests return, we really have a missing semicolon
+
+ Error_Msg_AP ("|missing "";""");
+ return;
end T_Semicolon;
------------
@@ -660,7 +678,13 @@ package body Tchk is
return;
else
- if Token = Tok_Pragma then
+ -- Deal with pragma. If pragma is not at start of line, it is
+ -- considered misplaced otherwise we treat it as a normal
+ -- missing semicolong case.
+
+ if Token = Tok_Pragma
+ and then not Token_Is_At_Start_Of_Line
+ then
P_Pragmas_Misplaced;
if Token = Tok_Semicolon then
@@ -669,7 +693,12 @@ package body Tchk is
end if;
end if;
- T_Semicolon; -- give missing semicolon message
+ -- Here we definitely have a missing semicolon, so give message
+
+ T_Semicolon;
+
+ -- Scan out junk on rest of line
+
Save_Scan_State (Scan_State); -- at start of junk tokens
loop
diff --git a/gcc/ada/par-util.adb b/gcc/ada/par-util.adb
index 3782ae62222..d7e2e15e33a 100644
--- a/gcc/ada/par-util.adb
+++ b/gcc/ada/par-util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -493,7 +493,8 @@ package body Util is
Get_Name_String (Chars (Token_Node));
declare
- Buf : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+ Buf : constant String (1 .. Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
begin
Get_Name_String (Chars (Prev));
@@ -628,6 +629,28 @@ package body Util is
end;
end Signal_Bad_Attribute;
+ -----------------------------
+ -- Token_Is_At_End_Of_Line --
+ -----------------------------
+
+ function Token_Is_At_End_Of_Line return Boolean is
+ S : Source_Ptr;
+
+ begin
+ -- Skip past blanks and horizontal tabs
+
+ S := Scan_Ptr;
+ while Source (S) = ' ' or else Source (S) = ASCII.HT loop
+ S := S + 1;
+ end loop;
+
+ -- We are at end of line if at a control character (CR/LF/VT/FF/EOF)
+ -- or if we are at the start of an end of line comment sequence.
+
+ return Source (S) < ' '
+ or else (Source (S) = '-' and then Source (S + 1) = '-');
+ end Token_Is_At_End_Of_Line;
+
-------------------------------
-- Token_Is_At_Start_Of_Line --
-------------------------------
diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb
index 412759e80bf..b5365332fb3 100644
--- a/gcc/ada/par.adb
+++ b/gcc/ada/par.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- --
@@ -45,6 +45,7 @@ with Sinfo; use Sinfo;
with Snames; use Snames;
with Style;
with Table;
+with Tbuild; use Tbuild;
function Par (Configuration_Pragmas : Boolean) return List_Id is
@@ -52,9 +53,6 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- Count number of units parsed (relevant only in syntax check only mode,
-- since in semantics check mode only a single unit is permitted anyway)
- Unit_Node : Node_Id;
- -- Stores compilation unit node for current unit
-
Save_Config_Switches : Config_Switches_Type;
-- Variable used to save values of config switches while we parse the
-- new unit, to be restored on exit for proper recursive behavior.
@@ -733,6 +731,10 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- starts a declaration (but we make sure to skip at least one token
-- in this case, to avoid getting stuck in a loop).
+ procedure Resync_To_Semicolon;
+ -- Similar to Resync_Past_Semicolon, except that the scan pointer is
+ -- left pointing to the semicolon rather than past it.
+
procedure Resync_Past_Semicolon_Or_To_Loop_Or_Then;
-- Used if an error occurs while scanning a sequence of statements.
-- The scan pointer is positioned past the next semicolon, or to the
@@ -748,7 +750,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- Used if an error occurs while scanning a parenthesized list of items
-- separated by semicolons. The scan pointer is advanced to the next
-- semicolon or right parenthesis at the outer parenthesis level, or
- -- to the next is or RETURN keyword occurrence, whichever comes first.
+ -- to the next is or RETURN keyword occurence, whichever comes first.
procedure Resync_Cunit;
-- Synchronize to next token which could be the start of a compilation
@@ -956,6 +958,9 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
pragma Inline (Token_Is_At_Start_Of_Line);
-- Determines if the current token is the first token on the line
+ function Token_Is_At_End_Of_Line return Boolean;
+ -- Determines if the current token is the last token on the line
+
end Util;
---------------------------------------
@@ -1057,8 +1062,8 @@ begin
if Configuration_Pragmas then
declare
- Ecount : constant Int := Total_Errors_Detected;
- Pragmas : List_Id := Empty_List;
+ Ecount : constant Int := Serious_Errors_Detected;
+ Pragmas : constant List_Id := Empty_List;
P_Node : Node_Id;
begin
@@ -1073,7 +1078,7 @@ begin
else
P_Node := P_Pragma;
- if Total_Errors_Detected > Ecount then
+ if Serious_Errors_Detected > Ecount then
return Error_List;
end if;
@@ -1146,7 +1151,7 @@ begin
Last_Resync_Point := No_Location;
Label_List := New_Elmt_List;
- Unit_Node := P_Compilation_Unit;
+ Discard_Node (P_Compilation_Unit);
-- If we are not at an end of file, then this means that we are
-- in syntax scan mode, and we can have another compilation unit,
@@ -1154,7 +1159,6 @@ begin
exit when Token = Tok_EOF;
Restore_Opt_Config_Switches (Save_Config_Switches);
- Set_Comes_From_Source_Default (False);
end loop;
-- Now that we have completely parsed the source file, we can
diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb
new file mode 100644
index 00000000000..6b9000c7a0c
--- /dev/null
+++ b/gcc/ada/prep.adb
@@ -0,0 +1,1446 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- P R E P --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Csets; use Csets;
+with Err_Vars; use Err_Vars;
+with Namet; use Namet;
+with Opt; use Opt;
+with Osint; use Osint;
+with Output; use Output;
+with Scans; use Scans;
+with Snames; use Snames;
+with Sinput;
+with Stringt; use Stringt;
+with Table;
+with Types; use Types;
+
+with GNAT.Heap_Sort_G;
+
+package body Prep is
+
+ use Symbol_Table;
+
+ type Token_Name_Array is array (Token_Type) of Name_Id;
+ Token_Names : constant Token_Name_Array :=
+ (Tok_Abort => Name_Abort,
+ Tok_Abs => Name_Abs,
+ Tok_Abstract => Name_Abstract,
+ Tok_Accept => Name_Accept,
+ Tok_Aliased => Name_Aliased,
+ Tok_All => Name_All,
+ Tok_Array => Name_Array,
+ Tok_And => Name_And,
+ Tok_At => Name_At,
+ Tok_Begin => Name_Begin,
+ Tok_Body => Name_Body,
+ Tok_Case => Name_Case,
+ Tok_Constant => Name_Constant,
+ Tok_Declare => Name_Declare,
+ Tok_Delay => Name_Delay,
+ Tok_Delta => Name_Delta,
+ Tok_Digits => Name_Digits,
+ Tok_Else => Name_Else,
+ Tok_Elsif => Name_Elsif,
+ Tok_End => Name_End,
+ Tok_Entry => Name_Entry,
+ Tok_Exception => Name_Exception,
+ Tok_Exit => Name_Exit,
+ Tok_For => Name_For,
+ Tok_Function => Name_Function,
+ Tok_Generic => Name_Generic,
+ Tok_Goto => Name_Goto,
+ Tok_If => Name_If,
+ Tok_Is => Name_Is,
+ Tok_Limited => Name_Limited,
+ Tok_Loop => Name_Loop,
+ Tok_Mod => Name_Mod,
+ Tok_New => Name_New,
+ Tok_Null => Name_Null,
+ Tok_Of => Name_Of,
+ Tok_Or => Name_Or,
+ Tok_Others => Name_Others,
+ Tok_Out => Name_Out,
+ Tok_Package => Name_Package,
+ Tok_Pragma => Name_Pragma,
+ Tok_Private => Name_Private,
+ Tok_Procedure => Name_Procedure,
+ Tok_Protected => Name_Protected,
+ Tok_Raise => Name_Raise,
+ Tok_Range => Name_Range,
+ Tok_Record => Name_Record,
+ Tok_Rem => Name_Rem,
+ Tok_Renames => Name_Renames,
+ Tok_Requeue => Name_Requeue,
+ Tok_Return => Name_Return,
+ Tok_Reverse => Name_Reverse,
+ Tok_Select => Name_Select,
+ Tok_Separate => Name_Separate,
+ Tok_Subtype => Name_Subtype,
+ Tok_Tagged => Name_Tagged,
+ Tok_Task => Name_Task,
+ Tok_Terminate => Name_Terminate,
+ Tok_Then => Name_Then,
+ Tok_Type => Name_Type,
+ Tok_Until => Name_Until,
+ Tok_Use => Name_Use,
+ Tok_When => Name_When,
+ Tok_While => Name_While,
+ Tok_With => Name_With,
+ Tok_Xor => Name_Xor,
+ others => No_Name);
+
+ Already_Initialized : Boolean := False;
+ -- Used to avoid repetition of the part of the initialisation that needs
+ -- to be done only once.
+
+ Empty_String : String_Id;
+ -- "", as a string_id
+
+ String_False : String_Id;
+ -- "false", as a string_id
+
+ Name_Defined : Name_Id;
+ -- defined, as a name_id
+
+ ---------------
+ -- Behaviour --
+ ---------------
+
+ -- Accesses to procedure specified by procedure Initialize.
+
+ Error_Msg : Error_Msg_Proc;
+ -- Report an error
+
+ Scan : Scan_Proc;
+ -- Scan one token
+
+ Set_Ignore_Errors : Set_Ignore_Errors_Proc;
+ -- Indicate if error should be taken into account
+
+ Put_Char : Put_Char_Proc;
+ -- Output one character
+
+ New_EOL : New_EOL_Proc;
+ -- Output an end of line indication
+
+ -------------------------------
+ -- State of the Preprocessor --
+ -------------------------------
+
+ type Pp_State is record
+ If_Ptr : Source_Ptr;
+ -- The location of the #if statement.
+ -- Used to flag #if with no corresponding #end if, at the end.
+
+ Else_Ptr : Source_Ptr;
+ -- The location of the #else statement.
+ -- Used to detect multiple #else.
+
+ Deleting : Boolean;
+ -- Set to True when the code should be deleted or commented out.
+
+ Match_Seen : Boolean;
+ -- Set to True when a condition in an #if or an #elsif is True.
+ -- Also set to True if Deleting at the previous level is True.
+ -- Used to decide if Deleting should be set to True in a following
+ -- #elsif or #else.
+
+ end record;
+
+ type Pp_Depth is new Nat;
+
+ Ground : constant Pp_Depth := 0;
+
+ package Pp_States is new Table.Table
+ (Table_Component_Type => Pp_State,
+ Table_Index_Type => Pp_Depth,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 10,
+ Table_Name => "Prep.Pp_States");
+ -- A stack of the states of the preprocessor, for nested #if
+
+ type Operator is (None, Op_Or, Op_And);
+
+ -----------------
+ -- Subprograms --
+ -----------------
+
+ function Deleting return Boolean;
+ -- Return True if code should be deleted or commented out
+
+ function Expression (Evaluate_It : Boolean) return Boolean;
+ -- Evaluate a condition in an #if or an #elsif statement.
+ -- If Evaluate_It is False, the condition is effectively evaluated,
+ -- otherwise, only the syntax is checked.
+
+ procedure Go_To_End_Of_Line;
+ -- Advance the scan pointer until we reach an end of line or the end
+ -- of the buffer.
+
+ function Matching_Strings (S1, S2 : String_Id) return Boolean;
+ -- Returns True if the two string parameters are equal (case insensitive)
+
+ ---------------------------------------
+ -- Change_Reserved_Keyword_To_Symbol --
+ ---------------------------------------
+
+ procedure Change_Reserved_Keyword_To_Symbol
+ (All_Keywords : Boolean := False)
+ is
+ New_Name : constant Name_Id := Token_Names (Token);
+
+ begin
+ if New_Name /= No_Name then
+ case Token is
+ when Tok_If | Tok_Else | Tok_Elsif | Tok_End |
+ Tok_And | Tok_Or | Tok_Then =>
+ if All_Keywords then
+ Token := Tok_Identifier;
+ Token_Name := New_Name;
+ end if;
+
+ when others =>
+ Token := Tok_Identifier;
+ Token_Name := New_Name;
+ end case;
+ end if;
+ end Change_Reserved_Keyword_To_Symbol;
+
+ ------------------------------------------
+ -- Check_Command_Line_Symbol_Definition --
+ ------------------------------------------
+
+ procedure Check_Command_Line_Symbol_Definition
+ (Definition : String;
+ Data : out Symbol_Data)
+ is
+ Index : Natural := 0;
+ Result : Symbol_Data;
+
+ begin
+ -- Look for the character '='
+
+ for J in Definition'Range loop
+ if Definition (J) = '=' then
+ Index := J;
+ exit;
+ end if;
+ end loop;
+
+ -- If no character '=', then the value is True
+
+ if Index = 0 then
+ -- Put the symbol in the name buffer
+
+ Name_Len := Definition'Length;
+ Name_Buffer (1 .. Name_Len) := Definition;
+ Result := True_Value;
+
+ elsif Index = Definition'First then
+ Fail ("invalid symbol definition """, Definition, """");
+
+ else
+ -- Put the symbol in the name buffer
+
+ Name_Len := Index - Definition'First;
+ Name_Buffer (1 .. Name_Len) :=
+ String'(Definition (Definition'First .. Index - 1));
+
+ -- Check the syntax of the value
+
+ if Definition (Index + 1) /= '"'
+ or else Definition (Definition'Last) /= '"'
+ then
+ for J in Index + 1 .. Definition'Last loop
+ case Definition (J) is
+ when '_' | '.' | '0' .. '9' |
+ 'a' .. 'z' | 'A' .. 'Z' =>
+ null;
+
+ when others =>
+ Fail ("illegal value """,
+ Definition (Index + 1 .. Definition'Last),
+ """");
+ end case;
+ end loop;
+ end if;
+
+ -- And put the value in the result
+
+ Result.Is_A_String := False;
+ Start_String;
+ Store_String_Chars (Definition (Index + 1 .. Definition'Last));
+ Result.Value := End_String;
+ end if;
+
+ -- Now, check the syntax of the symbol (we don't allow accented and
+ -- wide characters)
+
+ if Name_Buffer (1) not in 'a' .. 'z'
+ and then Name_Buffer (1) not in 'A' .. 'Z'
+ then
+ Fail ("symbol """,
+ Name_Buffer (1 .. Name_Len),
+ """ does not start with a letter");
+ end if;
+
+ for J in 2 .. Name_Len loop
+ case Name_Buffer (J) is
+ when 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' =>
+ null;
+
+ when '_' =>
+ if J = Name_Len then
+ Fail ("symbol """,
+ Name_Buffer (1 .. Name_Len),
+ """ end with a '_'");
+
+ elsif Name_Buffer (J + 1) = '_' then
+ Fail ("symbol """,
+ Name_Buffer (1 .. Name_Len),
+ """ contains consecutive '_'");
+ end if;
+
+ when others =>
+ Fail ("symbol """,
+ Name_Buffer (1 .. Name_Len),
+ """ contains illegal character(s)");
+ end case;
+ end loop;
+
+ Result.On_The_Command_Line := True;
+
+ -- Put the symbol name in the result
+
+ declare
+ Sym : constant String :=
+ Name_Buffer (1 .. Name_Len);
+
+ begin
+ for Index in 1 .. Name_Len loop
+ Name_Buffer (Index) := Fold_Lower (Name_Buffer (Index));
+ end loop;
+
+ Result.Symbol := Name_Find;
+ Name_Len := Sym'Length;
+ Name_Buffer (1 .. Name_Len) := Sym;
+ Result.Original := Name_Find;
+ end;
+
+ Data := Result;
+ end Check_Command_Line_Symbol_Definition;
+
+ --------------
+ -- Deleting --
+ --------------
+
+ function Deleting return Boolean is
+ begin
+ -- Always return False when not inside an #if statement
+
+ if Pp_States.Last = Ground then
+ return False;
+
+ else
+ return Pp_States.Table (Pp_States.Last).Deleting;
+ end if;
+ end Deleting;
+
+ ----------------
+ -- Expression --
+ ----------------
+
+ function Expression (Evaluate_It : Boolean) return Boolean is
+ Evaluation : Boolean := Evaluate_It;
+ -- Is set to False after an "or else" when left term is True and
+ -- after an "and then" when left term is False.
+
+ Final_Result : Boolean := False;
+
+ Current_Result : Boolean := False;
+ -- Value of a term
+
+ Current_Operator : Operator := None;
+ Symbol1 : Symbol_Id;
+ Symbol2 : Symbol_Id;
+ Symbol_Name1 : Name_Id;
+ Symbol_Name2 : Name_Id;
+ Symbol_Pos1 : Source_Ptr;
+ Symbol_Pos2 : Source_Ptr;
+ Symbol_Value1 : String_Id;
+ Symbol_Value2 : String_Id;
+
+ begin
+ -- Loop for each term
+
+ loop
+ Change_Reserved_Keyword_To_Symbol;
+
+ Current_Result := False;
+
+ case Token is
+
+ when Tok_Left_Paren =>
+
+ -- ( expression )
+
+ Scan.all;
+ Current_Result := Expression (Evaluation);
+
+ if Token = Tok_Right_Paren then
+ Scan.all;
+
+ else
+ Error_Msg ("`)` expected", Token_Ptr);
+ end if;
+
+ when Tok_Not =>
+
+ -- not expression
+
+ Scan.all;
+ Current_Result := not Expression (Evaluation);
+
+ when Tok_Identifier =>
+ Symbol_Name1 := Token_Name;
+ Symbol_Pos1 := Token_Ptr;
+ Scan.all;
+
+ if Token = Tok_Apostrophe then
+ -- symbol'Defined
+
+ Scan.all;
+
+ if Token = Tok_Identifier
+ and then Token_Name = Name_Defined
+ then
+ Scan.all;
+
+ else
+ Error_Msg ("identifier `Defined` expected", Token_Ptr);
+ end if;
+
+ if Evaluation then
+ Current_Result := Index_Of (Symbol_Name1) /= No_Symbol;
+ end if;
+
+ elsif Token = Tok_Equal then
+ Scan.all;
+
+ Change_Reserved_Keyword_To_Symbol;
+
+ if Token = Tok_Identifier then
+
+ -- symbol = symbol
+
+ Symbol_Name2 := Token_Name;
+ Symbol_Pos2 := Token_Ptr;
+ Scan.all;
+
+ if Evaluation then
+ Symbol1 := Index_Of (Symbol_Name1);
+
+ if Symbol1 = No_Symbol then
+ if Undefined_Symbols_Are_False then
+ Symbol_Value1 := String_False;
+
+ else
+ Error_Msg_Name_1 := Symbol_Name1;
+ Error_Msg ("unknown symbol %", Symbol_Pos1);
+ Symbol_Value1 := No_String;
+ end if;
+
+ else
+ Symbol_Value1 :=
+ Mapping.Table (Symbol1).Value;
+ end if;
+
+ Symbol2 := Index_Of (Symbol_Name2);
+
+ if Symbol2 = No_Symbol then
+ if Undefined_Symbols_Are_False then
+ Symbol_Value2 := String_False;
+
+ else
+ Error_Msg_Name_1 := Symbol_Name2;
+ Error_Msg ("unknown symbol %", Symbol_Pos2);
+ Symbol_Value2 := No_String;
+ end if;
+
+ else
+ Symbol_Value2 := Mapping.Table (Symbol2).Value;
+ end if;
+
+ if Symbol_Value1 /= No_String
+ and then Symbol_Value2 /= No_String
+ then
+ Current_Result := Matching_Strings
+ (Symbol_Value1, Symbol_Value2);
+ end if;
+ end if;
+
+ elsif Token = Tok_String_Literal then
+
+ -- symbol = "value"
+
+ if Evaluation then
+ Symbol1 := Index_Of (Symbol_Name1);
+
+ if Symbol1 = No_Symbol then
+ if Undefined_Symbols_Are_False then
+ Symbol_Value1 := String_False;
+
+ else
+ Error_Msg_Name_1 := Symbol_Name1;
+ Error_Msg ("unknown symbol %", Symbol_Pos1);
+ Symbol_Value1 := No_String;
+ end if;
+
+ else
+ Symbol_Value1 := Mapping.Table (Symbol1).Value;
+ end if;
+
+ if Symbol_Value1 /= No_String then
+ Current_Result :=
+ Matching_Strings
+ (Symbol_Value1,
+ String_Literal_Id);
+ end if;
+ end if;
+
+ Scan.all;
+
+ else
+ Error_Msg
+ ("symbol or literal string expected", Token_Ptr);
+ end if;
+
+ else
+ -- symbol (True or False)
+
+ if Evaluation then
+ Symbol1 := Index_Of (Symbol_Name1);
+
+ if Symbol1 = No_Symbol then
+ if Undefined_Symbols_Are_False then
+ Symbol_Value1 := String_False;
+
+ else
+ Error_Msg_Name_1 := Symbol_Name1;
+ Error_Msg ("unknown symbol %", Symbol_Pos1);
+ Symbol_Value1 := No_String;
+ end if;
+
+ else
+ Symbol_Value1 := Mapping.Table (Symbol1).Value;
+ end if;
+
+ if Symbol_Value1 /= No_String then
+ String_To_Name_Buffer (Symbol_Value1);
+
+ for Index in 1 .. Name_Len loop
+ Name_Buffer (Index) :=
+ Fold_Lower (Name_Buffer (Index));
+ end loop;
+
+ if Name_Buffer (1 .. Name_Len) = "true" then
+ Current_Result := True;
+
+ elsif Name_Buffer (1 .. Name_Len) = "false" then
+ Current_Result := False;
+
+ else
+ Error_Msg_Name_1 := Symbol_Name1;
+ Error_Msg
+ ("value of symbol % is not True or False",
+ Symbol_Pos1);
+ end if;
+ end if;
+ end if;
+ end if;
+
+ when others =>
+ Error_Msg ("`(`, NOT or symbol expected", Token_Ptr);
+ end case;
+
+ -- Update the cumulative final result
+
+ case Current_Operator is
+ when None =>
+ Final_Result := Current_Result;
+
+ when Op_Or =>
+ Final_Result := Final_Result or Current_Result;
+
+ when Op_And =>
+ Final_Result := Final_Result and Current_Result;
+ end case;
+
+ -- Check the next operator
+
+ if Token = Tok_And then
+ if Current_Operator = Op_Or then
+ Error_Msg ("mixing OR and AND is not allowed", Token_Ptr);
+ end if;
+
+ Current_Operator := Op_And;
+ Scan.all;
+
+ if Token = Tok_Then then
+ Scan.all;
+
+ if Final_Result = False then
+ Evaluation := False;
+ end if;
+ end if;
+
+ elsif Token = Tok_Or then
+ if Current_Operator = Op_And then
+ Error_Msg ("mixing AND and OR is not allowed", Token_Ptr);
+ end if;
+
+ Current_Operator := Op_Or;
+ Scan.all;
+
+ if Token = Tok_Else then
+ Scan.all;
+
+ if Final_Result then
+ Evaluation := False;
+ end if;
+ end if;
+
+ else
+ -- No operator: exit the term loop
+
+ exit;
+ end if;
+ end loop;
+
+ return Final_Result;
+ end Expression;
+
+ -----------------------
+ -- Go_To_End_Of_Line --
+ -----------------------
+
+ procedure Go_To_End_Of_Line is
+ begin
+ -- Scan until we get an end of line or we reach the end of the buffer
+
+ while Token /= Tok_End_Of_Line
+ and then Token /= Tok_EOF
+ loop
+ Scan.all;
+ end loop;
+ end Go_To_End_Of_Line;
+
+ --------------
+ -- Index_Of --
+ --------------
+
+ function Index_Of (Symbol : Name_Id) return Symbol_Id is
+ begin
+ if Mapping.Table /= null then
+ for J in Symbol_Id range 1 .. Symbol_Table.Last (Mapping) loop
+ if Mapping.Table (J).Symbol = Symbol then
+ return J;
+ end if;
+ end loop;
+ end if;
+
+ return No_Symbol;
+ end Index_Of;
+
+ ----------------
+ -- Preprocess --
+ ----------------
+
+ procedure Preprocess is
+ Start_Of_Processing : Source_Ptr;
+ Cond : Boolean;
+ Preprocessor_Line : Boolean := False;
+
+ procedure Output (From, To : Source_Ptr);
+ -- Output the characters with indices From .. To in the buffer
+ -- to the output file.
+
+ procedure Output_Line (From, To : Source_Ptr);
+ -- Output a line or the end of a line from the buffer to the output
+ -- file, followed by an end of line terminator.
+ -- Depending on the value of Deleting and the switches, the line
+ -- may be commented out, blank or not output at all.
+
+ ------------
+ -- Output --
+ ------------
+
+ procedure Output (From, To : Source_Ptr) is
+ begin
+ for J in From .. To loop
+ Put_Char (Sinput.Source (J));
+ end loop;
+ end Output;
+
+ -----------------
+ -- Output_Line --
+ -----------------
+
+ procedure Output_Line (From, To : Source_Ptr) is
+ begin
+ if Deleting or Preprocessor_Line then
+ if Blank_Deleted_Lines then
+ New_EOL.all;
+
+ elsif Comment_Deleted_Lines then
+ Put_Char ('-');
+ Put_Char ('-');
+ Put_Char ('!');
+
+ if From < To then
+ Put_Char (' ');
+ Output (From, To);
+ end if;
+
+ New_EOL.all;
+ end if;
+
+ else
+ Output (From, To);
+ New_EOL.all;
+ end if;
+ end Output_Line;
+
+ -- Start of processing for Preprocess
+
+ begin
+ Start_Of_Processing := Scan_Ptr;
+
+ -- We need to call Scan for the first time, because Initialyze_Scanner
+ -- is no longer doing it.
+
+ Scan.all;
+
+ Input_Line_Loop :
+ loop
+ exit Input_Line_Loop when Token = Tok_EOF;
+
+ Preprocessor_Line := False;
+
+ if Token /= Tok_End_Of_Line then
+
+ -- Preprocessor line
+
+ if Token = Tok_Special and then Special_Character = '#' then
+ Preprocessor_Line := True;
+ Scan.all;
+
+ case Token is
+
+ when Tok_If =>
+ -- #if
+
+ declare
+ If_Ptr : constant Source_Ptr := Token_Ptr;
+
+ begin
+ Scan.all;
+ Cond := Expression (not Deleting);
+
+ -- Check for an eventual "then"
+
+ if Token = Tok_Then then
+ Scan.all;
+ end if;
+
+ -- It is an error to have trailing characters after
+ -- the condition or "then".
+
+ if Token /= Tok_End_Of_Line
+ and then Token /= Tok_EOF
+ then
+ Error_Msg
+ ("extraneous text on preprocessor line",
+ Token_Ptr);
+ Go_To_End_Of_Line;
+ end if;
+
+ declare
+ -- Set the initial state of this new "#if".
+ -- This must be done before incrementing the
+ -- Last of the table, otherwise function
+ -- Deleting does not report the correct value.
+
+ New_State : constant Pp_State :=
+ (If_Ptr => If_Ptr,
+ Else_Ptr => 0,
+ Deleting => Deleting or (not Cond),
+ Match_Seen => Deleting or Cond);
+
+ begin
+ Pp_States.Increment_Last;
+ Pp_States.Table (Pp_States.Last) := New_State;
+ end;
+ end;
+
+ when Tok_Elsif =>
+ -- #elsif
+
+ Cond := False;
+
+ if Pp_States.Last = 0
+ or else Pp_States.Table (Pp_States.Last).Else_Ptr
+ /= 0
+ then
+ Error_Msg ("no IF for this ELSIF", Token_Ptr);
+
+ else
+ Cond :=
+ not Pp_States.Table (Pp_States.Last).Match_Seen;
+ end if;
+
+ Scan.all;
+ Cond := Expression (Cond);
+
+ -- Check for an eventual "then"
+
+ if Token = Tok_Then then
+ Scan.all;
+ end if;
+
+ -- It is an error to have trailing characters after
+ -- the condition or "then".
+
+ if Token /= Tok_End_Of_Line
+ and then Token /= Tok_EOF
+ then
+ Error_Msg
+ ("extraneous text on preprocessor line",
+ Token_Ptr);
+
+ Go_To_End_Of_Line;
+ end if;
+
+ -- Depending on the value of the condition, set the
+ -- new values of Deleting and Match_Seen.
+ if Pp_States.Last > 0 then
+ if Pp_States.Table (Pp_States.Last).Match_Seen then
+ Pp_States.Table (Pp_States.Last).Deleting :=
+ True;
+ else
+ if Cond then
+ Pp_States.Table (Pp_States.Last).Match_Seen :=
+ True;
+ Pp_States.Table (Pp_States.Last).Deleting :=
+ False;
+ end if;
+ end if;
+ end if;
+
+ when Tok_Else =>
+ -- #else
+
+ if Pp_States.Last = 0 then
+ Error_Msg ("no IF for this ELSE", Token_Ptr);
+
+ elsif
+ Pp_States.Table (Pp_States.Last).Else_Ptr /= 0
+ then
+ Error_Msg ("duplicate ELSE line", Token_Ptr);
+ end if;
+
+ -- Set the possibly new values of Deleting and
+ -- Match_Seen.
+
+ if Pp_States.Last > 0 then
+ if Pp_States.Table (Pp_States.Last).Match_Seen then
+ Pp_States.Table (Pp_States.Last).Deleting :=
+ True;
+
+ else
+ Pp_States.Table (Pp_States.Last).Match_Seen :=
+ True;
+ Pp_States.Table (Pp_States.Last).Deleting :=
+ False;
+ end if;
+
+ -- Set the Else_Ptr to check for illegal #elsif
+ -- later.
+
+ Pp_States.Table (Pp_States.Last).Else_Ptr :=
+ Token_Ptr;
+ end if;
+
+ Scan.all;
+
+ -- It is an error to have characters after "#else"
+ if Token /= Tok_End_Of_Line
+ and then Token /= Tok_EOF
+ then
+ Error_Msg
+ ("extraneous text on preprocessor line",
+ Token_Ptr);
+ Go_To_End_Of_Line;
+ end if;
+
+ when Tok_End =>
+ -- #end if;
+
+ if Pp_States.Last = 0 then
+ Error_Msg ("no IF for this END", Token_Ptr);
+ end if;
+
+ Scan.all;
+
+ if Token /= Tok_If then
+ Error_Msg ("IF expected", Token_Ptr);
+
+ else
+ Scan.all;
+
+ if Token /= Tok_Semicolon then
+ Error_Msg ("`;` Expected", Token_Ptr);
+
+ else
+ Scan.all;
+
+ -- It is an error to have character after
+ -- "#end if;".
+ if Token /= Tok_End_Of_Line
+ and then Token /= Tok_EOF
+ then
+ Error_Msg
+ ("extraneous text on preprocessor line",
+ Token_Ptr);
+ end if;
+ end if;
+ end if;
+
+ -- In case of one of the errors above, skip the tokens
+ -- until the end of line is reached.
+
+ Go_To_End_Of_Line;
+
+ -- Decrement the depth of the #if stack.
+
+ if Pp_States.Last > 0 then
+ Pp_States.Decrement_Last;
+ end if;
+
+ when others =>
+ -- Illegal preprocessor line
+
+ if Pp_States.Last = 0 then
+ Error_Msg ("IF expected", Token_Ptr);
+
+ elsif
+ Pp_States.Table (Pp_States.Last).Else_Ptr = 0
+ then
+ Error_Msg ("IF, ELSIF, ELSE, or `END IF` expected",
+ Token_Ptr);
+
+ else
+ Error_Msg ("IF or `END IF` expected", Token_Ptr);
+ end if;
+
+ -- Skip to the end of this illegal line
+
+ Go_To_End_Of_Line;
+ end case;
+
+ -- Not a preprocessor line
+
+ else
+ -- Do not report errors for those lines, even if there are
+ -- Ada parsing errors.
+
+ Set_Ignore_Errors (To => True);
+
+ if Deleting then
+ Go_To_End_Of_Line;
+
+ else
+ while Token /= Tok_End_Of_Line
+ and then Token /= Tok_EOF
+ loop
+ if Token = Tok_Special
+ and then Special_Character = '$'
+ then
+ declare
+ Dollar_Ptr : constant Source_Ptr := Token_Ptr;
+ Symbol : Symbol_Id;
+
+ begin
+ Scan.all;
+ Change_Reserved_Keyword_To_Symbol;
+
+ if Token = Tok_Identifier
+ and then Token_Ptr = Dollar_Ptr + 1
+ then
+ -- $symbol
+
+ Symbol := Index_Of (Token_Name);
+
+ -- If there is such a symbol, replace it by its
+ -- value.
+
+ if Symbol /= No_Symbol then
+ Output (Start_Of_Processing, Dollar_Ptr - 1);
+ Start_Of_Processing := Scan_Ptr;
+ String_To_Name_Buffer
+ (Mapping.Table (Symbol).Value);
+
+ if Mapping.Table (Symbol).Is_A_String then
+
+ -- Value is an Ada string
+
+ Put_Char ('"');
+
+ for J in 1 .. Name_Len loop
+ Put_Char (Name_Buffer (J));
+
+ if Name_Buffer (J) = '"' then
+ Put_Char ('"');
+ end if;
+ end loop;
+
+ Put_Char ('"');
+
+ else
+ -- Value is a sequence of characters, not
+ -- an Ada string.
+
+ for J in 1 .. Name_Len loop
+ Put_Char (Name_Buffer (J));
+ end loop;
+ end if;
+ end if;
+ end if;
+ end;
+ end if;
+
+ Scan.all;
+ end loop;
+ end if;
+
+ Set_Ignore_Errors (To => False);
+ end if;
+ end if;
+
+ pragma Assert (Token = Tok_End_Of_Line or Token = Tok_EOF);
+
+ -- At this point, the token is either end of line or EOF.
+ -- The line to possibly output stops just before the token.
+
+ Output_Line (Start_Of_Processing, Token_Ptr - 1);
+
+ -- If we are at the end of a line, the scan pointer is at the first
+ -- non blank character, not necessarily the first character of the
+ -- line; so, we have to deduct Start_Of_Processing from the token
+ -- pointer.
+
+ if Token = Tok_End_Of_Line then
+ if (Sinput.Source (Token_Ptr) = ASCII.CR
+ and then Sinput.Source (Token_Ptr + 1) = ASCII.LF)
+ or else
+ (Sinput.Source (Token_Ptr) = ASCII.CR
+ and then Sinput.Source (Token_Ptr + 1) = ASCII.LF)
+ then
+ Start_Of_Processing := Token_Ptr + 2;
+
+ else
+ Start_Of_Processing := Token_Ptr + 1;
+ end if;
+ end if;
+
+ -- Now, we scan the first token of the next line.
+ -- If the token is EOF, the scan ponter will not move, and the token
+ -- will still be EOF.
+
+ Scan.all;
+ end loop Input_Line_Loop;
+
+ -- Report an error for any missing some "#end if;"
+
+ for Level in reverse 1 .. Pp_States.Last loop
+ Error_Msg ("no `END IF` for this IF", Pp_States.Table (Level).If_Ptr);
+ end loop;
+ end Preprocess;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize
+ (Error_Msg : Error_Msg_Proc;
+ Scan : Scan_Proc;
+ Set_Ignore_Errors : Set_Ignore_Errors_Proc;
+ Put_Char : Put_Char_Proc;
+ New_EOL : New_EOL_Proc)
+ is
+ begin
+ if not Already_Initialized then
+ Start_String;
+ Store_String_Chars ("True");
+ True_Value.Value := End_String;
+
+ Start_String;
+ Empty_String := End_String;
+
+ Name_Len := 7;
+ Name_Buffer (1 .. Name_Len) := "defined";
+ Name_Defined := Name_Find;
+
+ Start_String;
+ Store_String_Chars ("False");
+ String_False := End_String;
+
+ Already_Initialized := True;
+ end if;
+
+ Prep.Error_Msg := Error_Msg;
+ Prep.Scan := Scan;
+ Prep.Set_Ignore_Errors := Set_Ignore_Errors;
+ Prep.Put_Char := Put_Char;
+ Prep.New_EOL := New_EOL;
+ end Initialize;
+
+ ------------------
+ -- List_Symbols --
+ ------------------
+
+ procedure List_Symbols (Foreword : String) is
+ Order : array (0 .. Integer (Symbol_Table.Last (Mapping)))
+ of Symbol_Id;
+ -- After alphabetical sorting, this array stores thehe indices of
+ -- the symbols in the order they are displayed.
+
+ function Lt (Op1, Op2 : Natural) return Boolean;
+ -- Comparison routine for sort call
+
+ procedure Move (From : Natural; To : Natural);
+ -- Move routine for sort call
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (Op1, Op2 : Natural) return Boolean is
+ S1 : constant String :=
+ Get_Name_String (Mapping.Table (Order (Op1)).Symbol);
+ S2 : constant String :=
+ Get_Name_String (Mapping.Table (Order (Op2)).Symbol);
+
+ begin
+ return S1 < S2;
+ end Lt;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ Order (To) := Order (From);
+ end Move;
+
+ package Sort_Syms is new GNAT.Heap_Sort_G (Move, Lt);
+
+ Max_L : Natural;
+ -- Maximum length of any symbol
+
+ -- Start of processing for List_Symbols_Case
+
+ begin
+ if Symbol_Table.Last (Mapping) = 0 then
+ return;
+ end if;
+
+ if Foreword'Length > 0 then
+ Write_Eol;
+ Write_Line (Foreword);
+
+ for J in Foreword'Range loop
+ Write_Char ('=');
+ end loop;
+ end if;
+
+ -- Initialize the order
+
+ for J in Order'Range loop
+ Order (J) := Symbol_Id (J);
+ end loop;
+
+ -- Sort alphabetically
+
+ Sort_Syms.Sort (Order'Last);
+
+ Max_L := 7;
+
+ for J in 1 .. Symbol_Table.Last (Mapping) loop
+ Get_Name_String (Mapping.Table (J).Original);
+ Max_L := Integer'Max (Max_L, Name_Len);
+ end loop;
+
+ Write_Eol;
+ Write_Str ("Symbol");
+
+ for J in 1 .. Max_L - 5 loop
+ Write_Char (' ');
+ end loop;
+
+ Write_Line ("Value");
+
+ Write_Str ("------");
+
+ for J in 1 .. Max_L - 5 loop
+ Write_Char (' ');
+ end loop;
+
+ Write_Line ("------");
+
+ for J in 1 .. Order'Last loop
+ declare
+ Data : constant Symbol_Data := Mapping.Table (Order (J));
+
+ begin
+ Get_Name_String (Data.Original);
+ Write_Str (Name_Buffer (1 .. Name_Len));
+
+ for K in Name_Len .. Max_L loop
+ Write_Char (' ');
+ end loop;
+
+ String_To_Name_Buffer (Data.Value);
+
+ if Data.Is_A_String then
+ Write_Char ('"');
+
+ for J in 1 .. Name_Len loop
+ Write_Char (Name_Buffer (J));
+
+ if Name_Buffer (J) = '"' then
+ Write_Char ('"');
+ end if;
+ end loop;
+
+ Write_Char ('"');
+
+ else
+ Write_Str (Name_Buffer (1 .. Name_Len));
+ end if;
+ end;
+
+ Write_Eol;
+ end loop;
+
+ Write_Eol;
+ end List_Symbols;
+
+ ----------------------
+ -- Matching_Strings --
+ ----------------------
+
+ function Matching_Strings (S1, S2 : String_Id) return Boolean is
+ begin
+ String_To_Name_Buffer (S1);
+
+ for Index in 1 .. Name_Len loop
+ Name_Buffer (Index) := Fold_Lower (Name_Buffer (Index));
+ end loop;
+
+ declare
+ String1 : constant String := Name_Buffer (1 .. Name_Len);
+
+ begin
+ String_To_Name_Buffer (S2);
+
+ for Index in 1 .. Name_Len loop
+ Name_Buffer (Index) := Fold_Lower (Name_Buffer (Index));
+ end loop;
+
+ return String1 = Name_Buffer (1 .. Name_Len);
+ end;
+ end Matching_Strings;
+
+ --------------------
+ -- Parse_Def_File --
+ --------------------
+
+ procedure Parse_Def_File is
+ Symbol : Symbol_Id;
+ Symbol_Name : Name_Id;
+ Original_Name : Name_Id;
+ Data : Symbol_Data;
+ Value_Start : Source_Ptr;
+ Value_End : Source_Ptr;
+ Ch : Character;
+
+ use ASCII;
+
+ begin
+ Def_Line_Loop :
+ loop
+ Scan.all;
+
+ exit Def_Line_Loop when Token = Tok_EOF;
+
+ if Token /= Tok_End_Of_Line then
+ Change_Reserved_Keyword_To_Symbol;
+
+ if Token /= Tok_Identifier then
+ Error_Msg ("identifier expected", Token_Ptr);
+ goto Cleanup;
+ end if;
+
+ Symbol_Name := Token_Name;
+ Name_Len := 0;
+
+ for Ptr in Token_Ptr .. Scan_Ptr - 1 loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Sinput.Source (Ptr);
+ end loop;
+
+ Original_Name := Name_Find;
+ Scan.all;
+
+ if Token /= Tok_Colon_Equal then
+ Error_Msg ("`:=` expected", Token_Ptr);
+ goto Cleanup;
+ end if;
+
+ Scan.all;
+
+ if Token = Tok_String_Literal then
+ Data := (Symbol => Symbol_Name,
+ Original => Original_Name,
+ On_The_Command_Line => False,
+ Is_A_String => True,
+ Value => String_Literal_Id);
+
+ Scan.all;
+
+ if Token /= Tok_End_Of_Line and then Token /= Tok_EOF then
+ Error_Msg ("extraneous text in definition", Token_Ptr);
+ goto Cleanup;
+ end if;
+
+ elsif Token = Tok_End_Of_Line or Token = Tok_EOF then
+ Data := (Symbol => Symbol_Name,
+ Original => Original_Name,
+ On_The_Command_Line => False,
+ Is_A_String => False,
+ Value => Empty_String);
+
+ else
+ Value_Start := Token_Ptr;
+ Value_End := Token_Ptr - 1;
+ Scan_Ptr := Token_Ptr;
+
+ Value_Chars_Loop :
+ loop
+ Ch := Sinput.Source (Scan_Ptr);
+
+ case Ch is
+ when '_' | '.' | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' =>
+ Value_End := Scan_Ptr;
+ Scan_Ptr := Scan_Ptr + 1;
+
+ when ' ' | HT | VT | CR | LF | FF =>
+ exit Value_Chars_Loop;
+
+ when others =>
+ Error_Msg ("illegal character", Scan_Ptr);
+ goto Cleanup;
+ end case;
+ end loop Value_Chars_Loop;
+
+ Scan.all;
+
+ if Token /= Tok_End_Of_Line and then Token /= Tok_EOF then
+ Error_Msg ("extraneous text in definition", Token_Ptr);
+ goto Cleanup;
+ end if;
+
+ Start_String;
+
+ while Value_Start <= Value_End loop
+ Store_String_Char (Sinput.Source (Value_Start));
+ Value_Start := Value_Start + 1;
+ end loop;
+
+ Data := (Symbol => Symbol_Name,
+ Original => Original_Name,
+ On_The_Command_Line => False,
+ Is_A_String => False,
+ Value => End_String);
+ end if;
+
+ -- Now that we have the value, get the symbol index
+
+ Symbol := Index_Of (Symbol_Name);
+
+ if Symbol /= No_Symbol then
+ -- If we already have an entry for this symbol, replace it
+ -- with the new value, except if the symbol was declared
+ -- on the command line.
+
+ if Mapping.Table (Symbol).On_The_Command_Line then
+ goto Continue;
+ end if;
+
+ else
+ -- As it is the first time we see this symbol, create a new
+ -- entry in the table.
+
+ if Mapping.Table = null then
+ Symbol_Table.Init (Mapping);
+ end if;
+
+ Symbol_Table.Increment_Last (Mapping);
+ Symbol := Symbol_Table.Last (Mapping);
+ end if;
+
+ Mapping.Table (Symbol) := Data;
+ goto Continue;
+
+ <<Cleanup>>
+ Set_Ignore_Errors (To => True);
+
+ while Token /= Tok_End_Of_Line and Token /= Tok_EOF loop
+ Scan.all;
+ end loop;
+
+ Set_Ignore_Errors (To => False);
+
+ <<Continue>>
+ null;
+ end if;
+ end loop Def_Line_Loop;
+ end Parse_Def_File;
+
+end Prep;
diff --git a/gcc/ada/prep.ads b/gcc/ada/prep.ads
new file mode 100644
index 00000000000..7e0c0ec62a0
--- /dev/null
+++ b/gcc/ada/prep.ads
@@ -0,0 +1,130 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- P R E P --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with GNAT.Dynamic_Tables;
+
+with Types; use Types;
+
+package Prep is
+
+ -----------------
+ -- Symbol Data --
+ -----------------
+
+ type Symbol_Data is record
+ Symbol : Name_Id := No_Name;
+ -- The symbol in lower case
+
+ Original : Name_Id := No_Name;
+ -- The symbol as originally given in the definition file or on
+ -- the command line.
+
+ On_The_Command_Line : Boolean := False;
+ -- Set to True if symbol is defined on the command line.
+ -- Used to prevent replacement of command line symbols by definition
+ -- file symbols.
+
+ Is_A_String : Boolean := False;
+ -- Indicate if the value of the symbol has been specified as a string
+ -- or simply as a sequence of characters.
+
+ Value : String_Id := No_String;
+ -- The value of the symbol (string or sequence of characters)
+
+ end record;
+
+ True_Value : Symbol_Data :=
+ (Symbol => No_Name,
+ Original => No_Name,
+ On_The_Command_Line => False,
+ Is_A_String => False,
+ Value => No_String);
+
+ type Symbol_Id is new Nat;
+ No_Symbol : constant Symbol_Id := 0;
+
+ package Symbol_Table is new GNAT.Dynamic_Tables
+ (Table_Component_Type => Symbol_Data,
+ Table_Index_Type => Symbol_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 10);
+ -- The table of all symbols
+
+ Mapping : Symbol_Table.Instance;
+ -- The mapping table of symbols to values used by procedure Parse_Def_File
+ -- and Preprocess.
+
+ function Index_Of (Symbol : Name_Id) return Symbol_Id;
+ -- Return the index in the Mapping table of Symbol.
+ -- Return No_Symbol if Symbol in not in the Mapping table.
+
+ -- Access to procedure types used by procedure Initialize below:
+
+ type Error_Msg_Proc is access procedure
+ (Msg : String; Flag_Location : Source_Ptr);
+
+ type Scan_Proc is access procedure;
+
+ type Set_Ignore_Errors_Proc is access procedure (To : Boolean);
+
+ type Put_Char_Proc is access procedure (C : Character);
+
+ type New_EOL_Proc is access procedure;
+
+ procedure Initialize
+ (Error_Msg : Error_Msg_Proc;
+ Scan : Scan_Proc;
+ Set_Ignore_Errors : Set_Ignore_Errors_Proc;
+ Put_Char : Put_Char_Proc;
+ New_EOL : New_EOL_Proc);
+
+ procedure Parse_Def_File;
+ -- Parse the definition file. The definition file must have already been
+ -- loaded and the scanner initialized.
+
+ procedure Preprocess;
+ -- Preprocess the input file. The input file must have already been loaded
+ -- and the scanner initialized.
+
+ procedure Check_Command_Line_Symbol_Definition
+ (Definition : String;
+ Data : out Symbol_Data);
+ -- Check the validity of a command line definition <symbol>=<value>.
+ -- Return the symbol and its value in Data if the definition is valid,
+ -- fail if it is not valid.
+
+ procedure Change_Reserved_Keyword_To_Symbol
+ (All_Keywords : Boolean := False);
+ -- If Token is an Ada reserved word (other than IF, ELSIF, ELSE,
+ -- END, AND, OR, THEN when All_Keywords is False), change it to
+ -- Tok_Identifier with the corresponding Token_Name.
+
+ procedure List_Symbols (Foreword : String);
+ -- List the symbols used por preprocessing a file, with their values.
+ -- If Foreword is not empty, Output Foreword before the list.
+
+end Prep;
diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb
new file mode 100644
index 00000000000..f131d7e4d13
--- /dev/null
+++ b/gcc/ada/prepcomp.adb
@@ -0,0 +1,783 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- P R E P C O M P --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+with Errout; use Errout;
+with Namet; use Namet;
+with Lib.Writ; use Lib.Writ;
+with Opt; use Opt;
+with Osint; use Osint;
+with Prep; use Prep;
+with Scans; use Scans;
+with Scn; use Scn;
+with Sinput.L; use Sinput.L;
+with Stringt; use Stringt;
+with Table;
+
+package body Prepcomp is
+
+ No_Preprocessing : Boolean := True;
+ -- Set to True if there is at least one source that needs to be
+ -- preprocessed.
+
+ Source_Index_Of_Preproc_Data_File : Source_File_Index := No_Source_File;
+
+ -- The following variable should be a constant, but this is not
+ -- possible. Warnings are Off because it is never assigned a value.
+
+ pragma Warnings (Off);
+ No_Mapping : Prep.Symbol_Table.Instance;
+ pragma Warnings (On);
+
+ type String_Ptr is access String;
+ type String_Array is array (Positive range <>) of String_Ptr;
+ type String_Array_Ptr is access String_Array;
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (String_Array, String_Array_Ptr);
+
+ Symbol_Definitions : String_Array_Ptr := new String_Array (1 .. 4);
+ -- An extensible array to temporarily stores symbol definitions specified
+ -- on the command line with -gnateD switches.
+
+ Last_Definition : Natural := 0;
+ -- Index of last symbol definition in array Symbol_Definitions
+
+ type Preproc_Data is record
+ Mapping : Symbol_Table.Instance;
+ File_Name : Name_Id := No_Name;
+ Deffile : String_Id := No_String;
+ Undef_False : Boolean := False;
+ Always_Blank : Boolean := False;
+ Comments : Boolean := False;
+ List_Symbols : Boolean := False;
+ Processed : Boolean := False;
+ end record;
+ -- Structure to keep the preprocessing data for a file name or for the
+ -- default (when Name_Id = No_Name).
+
+ No_Preproc_Data : constant Preproc_Data :=
+ (Mapping => No_Mapping,
+ File_Name => No_Name,
+ Deffile => No_String,
+ Undef_False => False,
+ Always_Blank => False,
+ Comments => False,
+ List_Symbols => False,
+ Processed => False);
+
+ Default_Data : Preproc_Data := No_Preproc_Data;
+ -- The preprocessing data to be used when no specific preprocessing data
+ -- is specified for a source.
+
+ Default_Data_Defined : Boolean := False;
+ -- True if source for which no specific preprocessing is specified need to
+ -- be preprocess with the Default_Data.
+
+ Current_Data : Preproc_Data := No_Preproc_Data;
+
+ package Preproc_Data_Table is new Table.Table
+ (Table_Component_Type => Preproc_Data,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 1,
+ Table_Initial => 5,
+ Table_Increment => 5,
+ Table_Name => "Prepcomp.Preproc_Data_Table");
+ -- Table to store the specific preprocessing data
+
+ Command_Line_Symbols : Symbol_Table.Instance;
+ -- A table to store symbol definitions specified on the command line with
+ -- -gnateD switches.
+
+ package Dependencies is new Table.Table
+ (Table_Component_Type => Source_File_Index,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 1,
+ Table_Initial => 5,
+ Table_Increment => 5,
+ Table_Name => "Prepcomp.Dependencies");
+ -- Table to store the dependencies on preprocessing files
+
+ procedure Add_Command_Line_Symbols;
+ -- Add the command line symbol definitions, if any, to the
+ -- Prep.Mapping table.
+
+ procedure Skip_To_End_Of_Line;
+ -- Ignore errors and scan up to the next end of line or the end of file
+
+ ------------------------------
+ -- Add_Command_Line_Symbols --
+ ------------------------------
+
+ procedure Add_Command_Line_Symbols is
+ Symbol_Id : Prep.Symbol_Id;
+ begin
+ for J in 1 .. Symbol_Table.Last (Command_Line_Symbols) loop
+ Symbol_Id := Prep.Index_Of (Command_Line_Symbols.Table (J).Symbol);
+
+ if Symbol_Id = No_Symbol then
+ Symbol_Table.Increment_Last (Prep.Mapping);
+ Symbol_Id := Symbol_Table.Last (Prep.Mapping);
+ end if;
+
+ Prep.Mapping.Table (Symbol_Id) := Command_Line_Symbols.Table (J);
+ end loop;
+ end Add_Command_Line_Symbols;
+
+ ----------------------
+ -- Add_Dependencies --
+ ----------------------
+
+ procedure Add_Dependencies is
+ begin
+ for Index in 1 .. Dependencies.Last loop
+ Add_Preprocessing_Dependency (Dependencies.Table (Index));
+ end loop;
+ end Add_Dependencies;
+
+ ---------------------------
+ -- Add_Symbol_Definition --
+ ---------------------------
+
+ procedure Add_Symbol_Definition (Def : String) is
+ begin
+ -- If Symbol_Definitions is not large enough, double it
+
+ if Last_Definition = Symbol_Definitions'Last then
+ declare
+ New_Symbol_Definitions : constant String_Array_Ptr :=
+ new String_Array (1 .. 2 * Last_Definition);
+
+ begin
+ New_Symbol_Definitions (Symbol_Definitions'Range) :=
+ Symbol_Definitions.all;
+ Free (Symbol_Definitions);
+ Symbol_Definitions := New_Symbol_Definitions;
+ end;
+ end if;
+
+ Last_Definition := Last_Definition + 1;
+ Symbol_Definitions (Last_Definition) := new String'(Def);
+ end Add_Symbol_Definition;
+
+ -------------------
+ -- Check_Symbols --
+ -------------------
+
+ procedure Check_Symbols is
+ begin
+ -- If there is at least one switch -gnateD specified
+
+ if Symbol_Table.Last (Command_Line_Symbols) >= 1 then
+ Current_Data := No_Preproc_Data;
+ No_Preprocessing := False;
+ Current_Data.Processed := True;
+
+ -- Start with an empty, initialized mapping table; use Prep.Mapping,
+ -- because Prep.Index_Of uses Prep.Mapping.
+
+ Prep.Mapping := No_Mapping;
+ Symbol_Table.Init (Prep.Mapping);
+
+ -- Add the command line symbols
+
+ Add_Command_Line_Symbols;
+
+ -- Put the resulting Prep.Mapping in Current_Data, and immediately
+ -- set Prep.Mapping to nil.
+
+ Current_Data.Mapping := Prep.Mapping;
+ Prep.Mapping := No_Mapping;
+
+ -- Set the default data
+
+ Default_Data := Current_Data;
+ Default_Data_Defined := True;
+ end if;
+ end Check_Symbols;
+
+ ------------------------------
+ -- Parse_Preprocessing_Data --
+ ------------------------------
+
+ procedure Parse_Preprocessing_Data_File (N : File_Name_Type) is
+ OK : Boolean := False;
+ Dash_Location : Source_Ptr;
+ Symbol_Data : Prep.Symbol_Data;
+ Symbol_Id : Prep.Symbol_Id;
+ T : constant Nat := Total_Errors_Detected;
+
+ begin
+ -- Load the preprocessing data file
+
+ Source_Index_Of_Preproc_Data_File := Load_Preprocessing_Data_File (N);
+
+ -- Fail if preprocessing data file cannot be found
+
+ if Source_Index_Of_Preproc_Data_File = No_Source_File then
+ Get_Name_String (N);
+ Fail ("preprocessing data file """,
+ Name_Buffer (1 .. Name_Len),
+ """ not found");
+ end if;
+
+ -- Initialize the sanner and set its behavior for a processing data file
+ Scn.Scanner.Initialize_Scanner
+ (No_Unit, Source_Index_Of_Preproc_Data_File);
+ Scn.Scanner.Set_End_Of_Line_As_Token (True);
+ Scn.Scanner.Reset_Special_Characters;
+
+ For_Each_Line :
+ loop
+ <<Scan_Line>>
+ Scan;
+
+ exit For_Each_Line when Token = Tok_EOF;
+
+ if Token = Tok_End_Of_Line then
+ goto Scan_Line;
+ end if;
+
+ -- Line is not empty
+
+ OK := False;
+ No_Preprocessing := False;
+ Current_Data := No_Preproc_Data;
+
+ case Token is
+ when Tok_Asterisk =>
+
+ -- Default data
+
+ if Default_Data_Defined then
+ Error_Msg
+ ("multiple default preprocessing data", Token_Ptr);
+
+ else
+ OK := True;
+ Default_Data_Defined := True;
+ end if;
+
+ when Tok_String_Literal =>
+
+ -- Specific data
+
+ String_To_Name_Buffer (String_Literal_Id);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Current_Data.File_Name := Name_Find;
+ OK := True;
+
+ for Index in 1 .. Preproc_Data_Table.Last loop
+ if Current_Data.File_Name =
+ Preproc_Data_Table.Table (Index).File_Name
+ then
+ Error_Msg_Name_1 := Current_Data.File_Name;
+ Error_Msg
+ ("multiple preprocessing data for{", Token_Ptr);
+ OK := False;
+ exit;
+ end if;
+ end loop;
+
+ when others =>
+ Error_Msg ("`'*` or literal string expected", Token_Ptr);
+ end case;
+
+ -- If there is a problem, skip the line
+
+ if not OK then
+ Skip_To_End_Of_Line;
+ goto Scan_Line;
+ end if;
+
+ -- Scan past the * or the literal string
+
+ Scan;
+
+ -- A literal string in second position is a definition file
+
+ if Token = Tok_String_Literal then
+ Current_Data.Deffile := String_Literal_Id;
+ Current_Data.Processed := False;
+ Scan;
+
+ else
+ -- If there is no definition file, set Processed to True now
+
+ Current_Data.Processed := True;
+ end if;
+
+ -- Start with an empty, initialized mapping table; use Prep.Mapping,
+ -- because Prep.Index_Of uses Prep.Mapping.
+
+ Prep.Mapping := No_Mapping;
+ Symbol_Table.Init (Prep.Mapping);
+
+ -- Check the switches that may follow
+
+ while Token /= Tok_End_Of_Line and then Token /= Tok_EOF loop
+
+ if Token /= Tok_Minus then
+ Error_Msg ("`'-` expected", Token_Ptr);
+ Skip_To_End_Of_Line;
+ goto Scan_Line;
+ end if;
+
+ -- Keep the location of the '-' for possible error reporting
+
+ Dash_Location := Token_Ptr;
+
+ -- Scan past the '-'
+
+ Scan;
+ OK := False;
+ Change_Reserved_Keyword_To_Symbol;
+
+ -- An identifier (or a reserved word converted to an
+ -- identifier) is expected and there must be no blank space
+ -- between the '-' and the identifier.
+
+ if Token = Tok_Identifier
+ and then Token_Ptr = Dash_Location + 1
+ then
+ Get_Name_String (Token_Name);
+
+ -- Check the character in the source, because the case is
+ -- significant.
+
+ case Sinput.Source (Token_Ptr) is
+ when 'u' =>
+
+ -- Undefined symbol are False
+
+ if Name_Len = 1 then
+ Current_Data.Undef_False := True;
+ OK := True;
+ end if;
+
+ when 'b' =>
+
+ -- Blank lines
+
+ if Name_Len = 1 then
+ Current_Data.Always_Blank := True;
+ OK := True;
+ end if;
+
+ when 'c' =>
+
+ -- Comment removed lines
+
+ if Name_Len = 1 then
+ Current_Data.Comments := True;
+ OK := True;
+ end if;
+
+ when 's' =>
+
+ -- List symbols
+
+ if Name_Len = 1 then
+ Current_Data.List_Symbols := True;
+ OK := True;
+ end if;
+
+ when 'D' =>
+
+ -- Symbol definition
+
+ OK := Name_Len > 1;
+
+ if OK then
+
+ -- A symbol must be an Ada identifier; it cannot start
+ -- with an underline or a digit.
+
+ if Name_Buffer (2) = '_'
+ or Name_Buffer (2) in '0' .. '9'
+ then
+ Error_Msg ("symbol expected", Token_Ptr + 1);
+ Skip_To_End_Of_Line;
+ goto Scan_Line;
+ end if;
+
+ -- Get the name id of the symbol
+
+ Symbol_Data.On_The_Command_Line := True;
+ Name_Buffer (1 .. Name_Len - 1) :=
+ Name_Buffer (2 .. Name_Len);
+ Name_Len := Name_Len - 1;
+ Symbol_Data.Symbol := Name_Find;
+
+ if Name_Buffer (1 .. Name_Len) = "if"
+ or else Name_Buffer (1 .. Name_Len) = "else"
+ or else Name_Buffer (1 .. Name_Len) = "elsif"
+ or else Name_Buffer (1 .. Name_Len) = "end"
+ or else Name_Buffer (1 .. Name_Len) = "not"
+ or else Name_Buffer (1 .. Name_Len) = "and"
+ or else Name_Buffer (1 .. Name_Len) = "then"
+ then
+ Error_Msg ("symbol expected", Token_Ptr + 1);
+ Skip_To_End_Of_Line;
+ goto Scan_Line;
+ end if;
+
+ -- Get the name id of the original symbol, with
+ -- possibly capital letters.
+
+ Name_Len := Integer (Scan_Ptr - Token_Ptr - 1);
+
+ for J in 1 .. Name_Len loop
+ Name_Buffer (J) :=
+ Sinput.Source (Token_Ptr + Text_Ptr (J));
+ end loop;
+
+ Symbol_Data.Original := Name_Find;
+
+ -- Scan past D<symbol>
+
+ Scan;
+
+ if Token /= Tok_Equal then
+ Error_Msg ("`=` expected", Token_Ptr);
+ Skip_To_End_Of_Line;
+ goto Scan_Line;
+ end if;
+
+ -- Scan past '='
+
+ Scan;
+
+ -- Here any reserved word is OK
+
+ Change_Reserved_Keyword_To_Symbol
+ (All_Keywords => True);
+
+ -- Value can be an identifier (or a reserved word)
+ -- or a literal string.
+
+ case Token is
+ when Tok_String_Literal =>
+ Symbol_Data.Is_A_String := True;
+ Symbol_Data.Value := String_Literal_Id;
+
+ when Tok_Identifier =>
+ Symbol_Data.Is_A_String := False;
+ Start_String;
+
+ for J in Token_Ptr .. Scan_Ptr - 1 loop
+ Store_String_Char (Sinput.Source (J));
+ end loop;
+
+ Symbol_Data.Value := End_String;
+
+ when others =>
+ Error_Msg
+ ("literal string or identifier expected",
+ Token_Ptr);
+ Skip_To_End_Of_Line;
+ goto Scan_Line;
+ end case;
+
+ -- If symbol already exists, replace old definition
+ -- by new one.
+
+ Symbol_Id := Prep.Index_Of (Symbol_Data.Symbol);
+
+ -- Otherwise, add a new entry in the table.
+
+ if Symbol_Id = No_Symbol then
+ Symbol_Table.Increment_Last (Prep.Mapping);
+ Symbol_Id := Symbol_Table.Last (Mapping);
+ end if;
+
+ Prep.Mapping.Table (Symbol_Id) := Symbol_Data;
+ end if;
+
+ when others =>
+ null;
+ end case;
+
+ Scan;
+ end if;
+
+ if not OK then
+ Error_Msg ("invalid switch", Dash_Location);
+ Skip_To_End_Of_Line;
+ goto Scan_Line;
+ end if;
+ end loop;
+
+ -- Add the command line symbols, if any, possibly replacing symbols
+ -- just defined.
+
+ Add_Command_Line_Symbols;
+
+ -- Put the resulting Prep.Mapping in Current_Data, and immediately
+ -- set Prep.Mapping to nil.
+
+ Current_Data.Mapping := Prep.Mapping;
+ Prep.Mapping := No_Mapping;
+
+ -- Record Current_Data
+
+ if Current_Data.File_Name = No_Name then
+ Default_Data := Current_Data;
+
+ else
+ Preproc_Data_Table.Increment_Last;
+ Preproc_Data_Table.Table (Preproc_Data_Table.Last) := Current_Data;
+ end if;
+
+ Current_Data := No_Preproc_Data;
+ end loop For_Each_Line;
+
+ Scn.Scanner.Set_End_Of_Line_As_Token (False);
+
+ -- Fail if there were errors in the preprocessing data file
+
+ if Total_Errors_Detected > T then
+ Errout.Finalize;
+ Fail ("errors found in preprocessing data file """,
+ Get_Name_String (N),
+ """");
+ end if;
+
+ -- Record the dependency on the preprocessor data file
+
+ Dependencies.Increment_Last;
+ Dependencies.Table (Dependencies.Last) :=
+ Source_Index_Of_Preproc_Data_File;
+ end Parse_Preprocessing_Data_File;
+
+ ---------------------------
+ -- Prepare_To_Preprocess --
+ ---------------------------
+
+ procedure Prepare_To_Preprocess
+ (Source : File_Name_Type;
+ Preprocessing_Needed : out Boolean)
+ is
+ Default : Boolean := False;
+ Index : Int := 0;
+
+ begin
+ -- By default, preprocessing is not needed
+
+ Preprocessing_Needed := False;
+
+ if No_Preprocessing then
+ return;
+ end if;
+
+ -- First, look for preprocessing data specific to the current source
+
+ for J in 1 .. Preproc_Data_Table.Last loop
+ if Preproc_Data_Table.Table (J).File_Name = Source then
+ Index := J;
+ Current_Data := Preproc_Data_Table.Table (J);
+ exit;
+ end if;
+ end loop;
+
+ -- If no specific preprocessing data, then take the default
+
+ if Index = 0 then
+ if Default_Data_Defined then
+ Current_Data := Default_Data;
+ Default := True;
+
+ else
+ -- If no default, then nothing to do
+
+ return;
+ end if;
+ end if;
+
+ -- Set the preprocessing flags according to the preprocessing data
+
+ if Current_Data.Comments and then not Current_Data.Always_Blank then
+ Comment_Deleted_Lines := True;
+ Blank_Deleted_Lines := False;
+
+ else
+ Comment_Deleted_Lines := False;
+ Blank_Deleted_Lines := True;
+ end if;
+
+ Undefined_Symbols_Are_False := Current_Data.Undef_False;
+ List_Preprocessing_Symbols := Current_Data.List_Symbols;
+
+ -- If not already done it, process the definition file
+
+ if Current_Data.Processed then
+ -- Set Prep.Mapping
+
+ Prep.Mapping := Current_Data.Mapping;
+
+ else
+ -- First put the mapping in Prep.Mapping, because Prep.Parse_Def_File
+ -- works on Prep.Mapping.
+
+ Prep.Mapping := Current_Data.Mapping;
+
+ String_To_Name_Buffer (Current_Data.Deffile);
+
+ declare
+ N : constant Name_Id := Name_Find;
+ Deffile : constant Source_File_Index := Load_Definition_File (N);
+ Add_Deffile : Boolean := True;
+ T : constant Nat := Total_Errors_Detected;
+
+ begin
+ if Deffile = No_Source_File then
+ Fail ("definition file """,
+ Get_Name_String (N),
+ """ cannot be found");
+ end if;
+
+ -- Initialize the preprocessor and set the characteristics of the
+ -- scanner for a definition file.
+
+ Prep.Initialize
+ (Error_Msg => Errout.Error_Msg'Access,
+ Scan => Scn.Scanner.Scan'Access,
+ Set_Ignore_Errors => Errout.Set_Ignore_Errors'Access,
+ Put_Char => null,
+ New_EOL => null);
+
+ Scn.Scanner.Set_End_Of_Line_As_Token (True);
+ Scn.Scanner.Reset_Special_Characters;
+
+ -- Initialize the scanner and process the definition file
+
+ Scn.Scanner.Initialize_Scanner (No_Unit, Deffile);
+ Prep.Parse_Def_File;
+
+ -- Reset the behaviour of the scanner to the default
+
+ Scn.Scanner.Set_End_Of_Line_As_Token (False);
+
+ -- Fail if errors were found while processing the definition file
+
+ if T /= Total_Errors_Detected then
+ Errout.Finalize;
+ Fail ("errors found in definition file """,
+ Get_Name_String (N),
+ """");
+ end if;
+
+ for Index in 1 .. Dependencies.Last loop
+ if Dependencies.Table (Index) = Deffile then
+ Add_Deffile := False;
+ exit;
+ end if;
+ end loop;
+
+ if Add_Deffile then
+ Dependencies.Increment_Last;
+ Dependencies.Table (Dependencies.Last) := Deffile;
+ end if;
+ end;
+
+ -- Get back the mapping, indicate that the definition file is
+ -- processed and store back the preprocessing data.
+
+ Current_Data.Mapping := Prep.Mapping;
+ Current_Data.Processed := True;
+
+ if Default then
+ Default_Data := Current_Data;
+
+ else
+ Preproc_Data_Table.Table (Index) := Current_Data;
+ end if;
+ end if;
+
+ Preprocessing_Needed := True;
+ end Prepare_To_Preprocess;
+
+ ---------------------------------------------
+ -- Process_Command_Line_Symbol_Definitions --
+ ---------------------------------------------
+
+ procedure Process_Command_Line_Symbol_Definitions is
+ Symbol_Data : Prep.Symbol_Data;
+ Found : Boolean := False;
+
+ begin
+ Symbol_Table.Init (Command_Line_Symbols);
+
+ -- The command line definitions have been stored temporarily in
+ -- array Symbol_Definitions.
+
+ for Index in 1 .. Last_Definition loop
+ -- Check each symbol definition, fail immediately if syntax is not
+ -- correct.
+
+ Check_Command_Line_Symbol_Definition
+ (Definition => Symbol_Definitions (Index).all,
+ Data => Symbol_Data);
+ Found := False;
+
+ -- If there is already a definition for this symbol, replace the old
+ -- definition by this one.
+
+ for J in 1 .. Symbol_Table.Last (Command_Line_Symbols) loop
+ if Command_Line_Symbols.Table (J).Symbol = Symbol_Data.Symbol then
+ Command_Line_Symbols.Table (J) := Symbol_Data;
+ Found := True;
+ exit;
+ end if;
+ end loop;
+
+ -- Otherwise, create a new entry in the table
+
+ if not Found then
+ Symbol_Table.Increment_Last (Command_Line_Symbols);
+ Command_Line_Symbols.Table
+ (Symbol_Table.Last (Command_Line_Symbols)) := Symbol_Data;
+ end if;
+ end loop;
+ end Process_Command_Line_Symbol_Definitions;
+
+ -------------------------
+ -- Skip_To_End_Of_Line --
+ -------------------------
+
+ procedure Skip_To_End_Of_Line is
+ begin
+ Set_Ignore_Errors (To => True);
+
+ while Token /= Tok_End_Of_Line and then Token /= Tok_EOF loop
+ Scan;
+ end loop;
+
+ Set_Ignore_Errors (To => False);
+ end Skip_To_End_Of_Line;
+
+end Prepcomp;
diff --git a/gcc/ada/prepcomp.ads b/gcc/ada/prepcomp.ads
new file mode 100644
index 00000000000..f5687f0dce3
--- /dev/null
+++ b/gcc/ada/prepcomp.ads
@@ -0,0 +1,67 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- P R E P C O M P --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package stores all preprocessing data for the compiler
+
+with Types; use Types;
+
+package Prepcomp is
+
+ procedure Add_Dependencies;
+ -- Add dependencies on the preprocessing data file and the
+ -- preprocessing definition files, if any.
+
+ procedure Add_Symbol_Definition (Def : String);
+ -- Add a symbol definition from the command line.
+ -- Fail if definition is illegal.
+
+ procedure Check_Symbols;
+ -- Check if there are preprocessing symbols on the command line and
+ -- set preprocessing if there are some: all files are preprocessed with
+ -- these symbols. This procedure should not be called if there is a
+ -- preprocessing data file specified on the command line. Procedure
+ -- Parse_Preprocessing_Data_File should be called instead.
+
+ procedure Parse_Preprocessing_Data_File (N : File_Name_Type);
+ -- Parse a preprocessing data file, specified with a -gnatep= switch.
+
+ procedure Prepare_To_Preprocess
+ (Source : File_Name_Type;
+ Preprocessing_Needed : out Boolean);
+ -- Prepare, if necessary, the preprocessor for a source file.
+ -- If the source file needs to be preprocessed, Preprocessing_Needed
+ -- is set to True. Otherwise, Preprocessing_Needed is set to False
+ -- and no preprocessing needs to be done.
+
+ procedure Process_Command_Line_Symbol_Definitions;
+ -- Check symbol definitions that have been added by calls to procedure
+ -- Add_Symbol_Definition and stored as pointers to string, and put them in
+ -- a table. The reason the definitions were stored as pointer to strings is
+ -- that the name table is not yest initialized when we process the command
+ -- line switches. These symbol definitions will be later used in
+ -- the call to Prepare_To_Preprocess.
+
+end Prepcomp;
diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb
index a7a0125dd0c..e3fb2c0ef38 100644
--- a/gcc/ada/prj-attr.adb
+++ b/gcc/ada/prj-attr.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- P R J . A T T R --
+-- P R J . A T T R --
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -26,6 +26,7 @@
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Namet; use Namet;
+with Osint; use Osint;
with Output; use Output;
package body Prj.Attr is
@@ -44,6 +45,8 @@ package body Prj.Attr is
-- 'V' for single variable
-- 'A' for associative array
-- 'a' for case insensitive associative array
+ -- 'b' for associative array, case insensitive if file names are case
+ -- insensitive
-- End is indicated by two consecutive '#'.
@@ -55,40 +58,52 @@ package body Prj.Attr is
"SVexec_dir#" &
"LVsource_dirs#" &
"LVsource_files#" &
+ "LVlocally_removed_files#" &
"SVsource_list_file#" &
"SVlibrary_dir#" &
"SVlibrary_name#" &
"SVlibrary_kind#" &
- "SVlibrary_elaboration#" &
"SVlibrary_version#" &
+ "LVlibrary_interface#" &
+ "SVlibrary_auto_init#" &
+ "LVlibrary_options#" &
+ "SVlibrary_src_dir#" &
+ "SVlibrary_gcc#" &
"LVmain#" &
"LVlanguages#" &
+ "SVmain_language#" &
-- package Naming
"Pnaming#" &
"Saspecification_suffix#" &
+ "Saspec_suffix#" &
"Saimplementation_suffix#" &
+ "Sabody_suffix#" &
"SVseparate_suffix#" &
"SVcasing#" &
"SVdot_replacement#" &
"SAspecification#" &
+ "SAspec#" &
"SAimplementation#" &
- "LAspecification_exceptions#" &
- "LAimplementation_exceptions#" &
+ "SAbody#" &
+ "Laspecification_exceptions#" &
+ "Laimplementation_exceptions#" &
-- package Compiler
"Pcompiler#" &
"Ladefault_switches#" &
- "LAswitches#" &
+ "Lbswitches#" &
"SVlocal_configuration_pragmas#" &
-- package Builder
"Pbuilder#" &
"Ladefault_switches#" &
- "LAswitches#" &
+ "Lbswitches#" &
+ "SAexecutable#" &
+ "SVexecutable_suffix#" &
"SVglobal_configuration_pragmas#" &
-- package gnatls
@@ -100,35 +115,52 @@ package body Prj.Attr is
"Pbinder#" &
"Ladefault_switches#" &
- "LAswitches#" &
+ "Lbswitches#" &
-- package Linker
"Plinker#" &
"Ladefault_switches#" &
- "LAswitches#" &
+ "Lbswitches#" &
+ "LVlinker_options#" &
-- package Cross_Reference
"Pcross_reference#" &
"Ladefault_switches#" &
- "LAswitches#" &
+ "Lbswitches#" &
-- package Finder
"Pfinder#" &
"Ladefault_switches#" &
- "LAswitches#" &
+ "Lbswitches#" &
- -- package Gnatstub
+ -- package Pretty_Printer
+
+ "Ppretty_printer#" &
+ "Ladefault_switches#" &
+ "Lbswitches#" &
+
+ -- package gnatstub
"Pgnatstub#" &
- "LVswitches#" &
+ "Ladefault_switches#" &
+ "Lbswitches#" &
+
+ -- package Eliminate
+
+ "Peliminate#" &
+ "Ladefault_switches#" &
+ "Lbswitches#" &
-- package Ide
"Pide#" &
+ "Ladefault_switches#" &
"SVremote_host#" &
+ "SVprogram_host#" &
+ "SVcommunication_protocol#" &
"Sacompiler_command#" &
"SVdebugger_command#" &
"SVgnatlist#" &
@@ -157,8 +189,8 @@ package body Prj.Attr is
begin
-- Make sure the two tables are empty
- Attributes.Set_Last (Attributes.First);
- Package_Attributes.Set_Last (Package_Attributes.First);
+ Attributes.Init;
+ Package_Attributes.Init;
while Initialization_Data (Start) /= '#' loop
Is_An_Attribute := True;
@@ -214,10 +246,20 @@ package body Prj.Attr is
case Initialization_Data (Start) is
when 'V' =>
Kind_2 := Single;
+
when 'A' =>
Kind_2 := Associative_Array;
+
when 'a' =>
Kind_2 := Case_Insensitive_Associative_Array;
+
+ when 'b' =>
+ if File_Names_Case_Sensitive then
+ Kind_2 := Case_Insensitive_Associative_Array;
+ else
+ Kind_2 := Case_Insensitive_Associative_Array;
+ end if;
+
when others =>
raise Program_Error;
end case;
diff --git a/gcc/ada/prj-attr.ads b/gcc/ada/prj-attr.ads
index c19061f36f3..cf3c140b11f 100644
--- a/gcc/ada/prj-attr.ads
+++ b/gcc/ada/prj-attr.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- P R J . A T T R --
+-- P R J . A T T R --
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -45,7 +45,7 @@ package Prj.Attr is
range Attribute_Node_Low_Bound .. Attribute_Node_High_Bound;
First_Attribute_Node_Id : constant Attribute_Node_Id :=
- Attribute_Node_Low_Bound;
+ Attribute_Node_Low_Bound + 1;
Empty_Attribute : constant Attribute_Node_Id :=
Attribute_Node_Low_Bound;
@@ -70,12 +70,12 @@ package Prj.Attr is
Table_Increment => Attributes_Increment,
Table_Name => "Prj.Attr.Attributes");
- Attribute_First : constant Attribute_Node_Id := First_Attribute_Node_Id + 1;
+ Attribute_First : constant Attribute_Node_Id := First_Attribute_Node_Id;
-- Define the allowed packages
Packages_Initial : constant := 10;
- Packages_Increment : constant := 10;
+ Packages_Increment : constant := 50;
Package_Node_Low_Bound : constant := 0;
Package_Node_High_Bound : constant := 099_999_999;
@@ -84,7 +84,7 @@ package Prj.Attr is
range Package_Node_Low_Bound .. Package_Node_High_Bound;
First_Package_Node_Id : constant Package_Node_Id :=
- Package_Node_Low_Bound;
+ Package_Node_Low_Bound + 1;
Empty_Package : constant Package_Node_Id := Package_Node_Low_Bound;
@@ -101,7 +101,7 @@ package Prj.Attr is
Table_Increment => Packages_Increment,
Table_Name => "Prj.Attr.Packages");
- Package_First : constant Package_Node_Id := Package_Node_Low_Bound + 1;
+ Package_First : constant Package_Node_Id := First_Package_Node_Id;
procedure Initialize;
-- Initialize the two tables above (Attributes and Package_Attributes).
diff --git a/gcc/ada/prj-com.adb b/gcc/ada/prj-com.adb
index 5c37b185bd4..6610fdf1c2f 100644
--- a/gcc/ada/prj-com.adb
+++ b/gcc/ada/prj-com.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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- --
diff --git a/gcc/ada/prj-com.ads b/gcc/ada/prj-com.ads
index 98baa446bbd..a7420447011 100644
--- a/gcc/ada/prj-com.ads
+++ b/gcc/ada/prj-com.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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- --
@@ -28,6 +28,7 @@
-- These data types are used in the bodies of the Prj hierarchy.
with GNAT.HTable;
+with Osint;
with Table;
with Types; use Types;
@@ -37,6 +38,15 @@ package Prj.Com is
-- It cannot be private, because it is used outside of
-- the Prj hierarchy.
+ type Fail_Proc is access procedure
+ (S1 : String; S2 : String := ""; S3 : String := "");
+
+ Fail : Fail_Proc := Osint.Fail'Access;
+ -- This procedure is used in the project facility, instead of
+ -- directly calling Osint.Fail.
+ -- It may be specified by tools to do clean up before calling
+ -- Osint.Fail, or to simply report an error and return.
+
Tool_Name : Name_Id := No_Name;
Current_Verbosity : Verbosity := Default;
@@ -46,7 +56,9 @@ package Prj.Com is
type File_Name_Data is record
Name : Name_Id := No_Name;
+ Display_Name : Name_Id := No_Name;
Path : Name_Id := No_Name;
+ Display_Path : Name_Id := No_Name;
Project : Project_Id := No_Project;
Needs_Pragma : Boolean := False;
end record;
diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb
index 37513fe986b..9865dff63c1 100644
--- a/gcc/ada/prj-dect.adb
+++ b/gcc/ada/prj-dect.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc --
+-- Copyright (C) 2001-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- --
@@ -24,19 +24,22 @@
-- --
------------------------------------------------------------------------------
-with Errout; use Errout;
+with Err_Vars; use Err_Vars;
with Namet; use Namet;
+with Prj.Err; use Prj.Err;
with Prj.Strt; use Prj.Strt;
with Prj.Tree; use Prj.Tree;
with Scans; use Scans;
-with Sinfo; use Sinfo;
+with Snames;
with Types; use Types;
with Prj.Attr; use Prj.Attr;
package body Prj.Dect is
type Zone is (In_Project, In_Package, In_Case_Construction);
- -- Needs a comment ???
+ -- Used to indicate if we are parsing a package (In_Package),
+ -- a case construction (In_Case_Construction) or none of those two
+ -- (In_Project).
procedure Parse_Attribute_Declaration
(Attribute : out Project_Node_Id;
@@ -93,7 +96,7 @@ package body Prj.Dect is
begin
Declarations := Default_Project_Node (Of_Kind => N_Project_Declaration);
Set_Location_Of (Declarations, To => Token_Ptr);
- Set_Modified_Project_Of (Declarations, To => Extends);
+ Set_Extended_Project_Of (Declarations, To => Extends);
Set_Project_Declaration_Of (Current_Project, Declarations);
Parse_Declarative_Items
(Declarations => First_Declarative_Item,
@@ -115,7 +118,9 @@ package body Prj.Dect is
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id)
is
- Current_Attribute : Attribute_Node_Id := First_Attribute;
+ Current_Attribute : Attribute_Node_Id := First_Attribute;
+ Full_Associative_Array : Boolean := False;
+ Attribute_Name : Name_Id := No_Name;
begin
Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration);
@@ -125,12 +130,22 @@ package body Prj.Dect is
Scan;
+ -- Body may be an attribute name
+
+ if Token = Tok_Body then
+ Token := Tok_Identifier;
+ Token_Name := Snames.Name_Body;
+ end if;
+
Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
+ Attribute_Name := Token_Name;
Set_Name_Of (Attribute, To => Token_Name);
Set_Location_Of (Attribute, To => Token_Ptr);
+ -- Find the attribute
+
while Current_Attribute /= Empty_Attribute
and then
Attributes.Table (Current_Attribute).Name /= Token_Name
@@ -138,22 +153,81 @@ package body Prj.Dect is
Current_Attribute := Attributes.Table (Current_Attribute).Next;
end loop;
+ -- If not a valid attribute name, issue an error, or a warning
+ -- if inside a package that does not need to be checked.
+
if Current_Attribute = Empty_Attribute then
- Error_Msg ("undefined attribute """ &
- Get_Name_String (Name_Of (Attribute)) &
- """",
- Token_Ptr);
+ declare
+ Message : constant String :=
+ "undefined attribute """ &
+ Get_Name_String (Name_Of (Attribute)) & '"';
+
+ Warning : Boolean :=
+ Current_Package /= Empty_Node
+ and then Current_Packages_To_Check /= All_Packages;
+
+ begin
+ if Warning then
+
+ -- Check that we are not in a package to check
+
+ Get_Name_String (Name_Of (Current_Package));
+
+ for Index in Current_Packages_To_Check'Range loop
+ if Name_Buffer (1 .. Name_Len) =
+ Current_Packages_To_Check (Index).all
+ then
+ Warning := False;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ if Warning then
+ Error_Msg ('?' & Message, Token_Ptr);
+
+ else
+ Error_Msg (Message, Token_Ptr);
+ end if;
+ end;
+
+ -- Set, if appropriate the index case insensitivity flag
elsif Attributes.Table (Current_Attribute).Kind_2 =
- Case_Insensitive_Associative_Array
+ Case_Insensitive_Associative_Array
then
Set_Case_Insensitive (Attribute, To => True);
end if;
- Scan;
+ Scan; -- past the attribute name
end if;
+ -- Change obsolete names of attributes to the new names
+
+ case Name_Of (Attribute) is
+ when Snames.Name_Specification =>
+ Set_Name_Of (Attribute, To => Snames.Name_Spec);
+
+ when Snames.Name_Specification_Suffix =>
+ Set_Name_Of (Attribute, To => Snames.Name_Spec_Suffix);
+
+ when Snames.Name_Implementation =>
+ Set_Name_Of (Attribute, To => Snames.Name_Body);
+
+ when Snames.Name_Implementation_Suffix =>
+ Set_Name_Of (Attribute, To => Snames.Name_Body_Suffix);
+
+ when others =>
+ null;
+ end case;
+
+ -- Associative array attributes
+
if Token = Tok_Left_Paren then
+
+ -- If the attribute is not an associative array attribute, report
+ -- an error.
+
if Current_Attribute /= Empty_Attribute
and then Attributes.Table (Current_Attribute).Kind_2 = Single
then
@@ -164,69 +238,235 @@ package body Prj.Dect is
Location_Of (Attribute));
end if;
- Scan;
+ Scan; -- past the left parenthesis
Expect (Tok_String_Literal, "literal string");
if Token = Tok_String_Literal then
- Set_Associative_Array_Index_Of (Attribute, Strval (Token_Node));
- Scan;
+ Set_Associative_Array_Index_Of (Attribute, Token_Name);
+ Scan; -- past the literal string index
end if;
- Expect (Tok_Right_Paren, ")");
+ Expect (Tok_Right_Paren, "`)`");
if Token = Tok_Right_Paren then
- Scan;
+ Scan; -- past the right parenthesis
end if;
else
+ -- If it is an associative array attribute and there are no left
+ -- parenthesis, then this is a full associative array declaration.
+ -- Flag it as such for later processing of its value.
+
if Current_Attribute /= Empty_Attribute
and then
Attributes.Table (Current_Attribute).Kind_2 /= Single
then
- Error_Msg ("the attribute """ &
- Get_Name_String
- (Attributes.Table (Current_Attribute).Name) &
- """ needs to be an associative array",
- Location_Of (Attribute));
+ Full_Associative_Array := True;
end if;
end if;
+ -- Set the expression kind of the attribute
+
if Current_Attribute /= Empty_Attribute then
Set_Expression_Kind_Of
(Attribute, To => Attributes.Table (Current_Attribute).Kind_1);
end if;
- Expect (Tok_Use, "use");
+ Expect (Tok_Use, "USE");
if Token = Tok_Use then
Scan;
- declare
- Expression_Location : constant Source_Ptr := Token_Ptr;
- Expression : Project_Node_Id := Empty_Node;
+ if Full_Associative_Array then
- begin
- Parse_Expression
- (Expression => Expression,
- Current_Project => Current_Project,
- Current_Package => Current_Package);
- Set_Expression_Of (Attribute, To => Expression);
-
- if Current_Attribute /= Empty_Attribute
- and then Expression /= Empty_Node
- and then Attributes.Table (Current_Attribute).Kind_1 /=
- Expression_Kind_Of (Expression)
- then
- Error_Msg
- ("wrong expression kind for attribute """ &
- Get_Name_String
- (Attributes.Table (Current_Attribute).Name) &
- """",
- Expression_Location);
- end if;
- end;
+ -- Expect <project>'<same_attribute_name>, or
+ -- <project>.<same_package_name>'<same_attribute_name>
+
+ declare
+ The_Project : Project_Node_Id := Empty_Node;
+ -- The node of the project where the associative array is
+ -- declared.
+
+ The_Package : Project_Node_Id := Empty_Node;
+ -- The node of the package where the associative array is
+ -- declared, if any.
+
+ Project_Name : Name_Id := No_Name;
+ -- The name of the project where the associative array is
+ -- declared.
+
+ Location : Source_Ptr := No_Location;
+ -- The location of the project name
+
+ begin
+ Expect (Tok_Identifier, "identifier");
+
+ if Token = Tok_Identifier then
+ Location := Token_Ptr;
+
+ -- Find the project node in the imported project or
+ -- in the project being extended.
+
+ The_Project := Imported_Or_Extended_Project_Of
+ (Current_Project, Token_Name);
+
+ if The_Project = Empty_Node then
+ Error_Msg ("unknown project", Location);
+ Scan; -- past the project name
+
+ else
+ Project_Name := Token_Name;
+ Scan; -- past the project name
+
+ -- If this is inside a package, a dot followed by the
+ -- name of the package must followed the project name.
+
+ if Current_Package /= Empty_Node then
+ Expect (Tok_Dot, "`.`");
+
+ if Token /= Tok_Dot then
+ The_Project := Empty_Node;
+
+ else
+ Scan; -- past the dot
+ Expect (Tok_Identifier, "identifier");
+
+ if Token /= Tok_Identifier then
+ The_Project := Empty_Node;
+
+ -- If it is not the same package name, issue error
+
+ elsif Token_Name /= Name_Of (Current_Package) then
+ The_Project := Empty_Node;
+ Error_Msg
+ ("not the same package as " &
+ Get_Name_String (Name_Of (Current_Package)),
+ Token_Ptr);
+
+ else
+ The_Package := First_Package_Of (The_Project);
+
+ -- Look for the package node
+
+ while The_Package /= Empty_Node
+ and then Name_Of (The_Package) /= Token_Name
+ loop
+ The_Package :=
+ Next_Package_In_Project (The_Package);
+ end loop;
+
+ -- If the package cannot be found in the
+ -- project, issue an error.
+
+ if The_Package = Empty_Node then
+ The_Project := Empty_Node;
+ Error_Msg_Name_2 := Project_Name;
+ Error_Msg_Name_1 := Token_Name;
+ Error_Msg
+ ("package % not declared in project %",
+ Token_Ptr);
+ end if;
+
+ Scan; -- past the package name
+ end if;
+ end if;
+ end if;
+ end if;
+ end if;
+
+ if The_Project /= Empty_Node then
+
+ -- Looking for '<same attribute name>
+
+ Expect (Tok_Apostrophe, "`''`");
+
+ if Token /= Tok_Apostrophe then
+ The_Project := Empty_Node;
+
+ else
+ Scan; -- past the apostrophe
+ Expect (Tok_Identifier, "identifier");
+
+ if Token /= Tok_Identifier then
+ The_Project := Empty_Node;
+
+ else
+ -- If it is not the same attribute name, issue error
+
+ if Token_Name /= Attribute_Name then
+ The_Project := Empty_Node;
+ Error_Msg_Name_1 := Attribute_Name;
+ Error_Msg ("invalid name, should be %", Token_Ptr);
+ end if;
+
+ Scan; -- past the attribute name
+ end if;
+ end if;
+ end if;
+
+ if The_Project = Empty_Node then
+
+ -- If there were any problem, set the attribute id to null,
+ -- so that the node will not be recorded.
+
+ Current_Attribute := Empty_Attribute;
+
+ else
+ -- Set the appropriate field in the node.
+ -- Note that the index and the expression are nil. This
+ -- characterizes full associative array attribute
+ -- declarations.
+
+ Set_Associative_Project_Of (Attribute, The_Project);
+ Set_Associative_Package_Of (Attribute, The_Package);
+ end if;
+ end;
+
+ -- Other attribute declarations (not full associative array)
+
+ else
+ declare
+ Expression_Location : constant Source_Ptr := Token_Ptr;
+ -- The location of the first token of the expression
+
+ Expression : Project_Node_Id := Empty_Node;
+ -- The expression, value for the attribute declaration
+
+ begin
+ -- Get the expression value and set it in the attribute node
+
+ Parse_Expression
+ (Expression => Expression,
+ Current_Project => Current_Project,
+ Current_Package => Current_Package);
+ Set_Expression_Of (Attribute, To => Expression);
+
+ -- If the expression is legal, but not of the right kind
+ -- for the attribute, issue an error.
+
+ if Current_Attribute /= Empty_Attribute
+ and then Expression /= Empty_Node
+ and then Attributes.Table (Current_Attribute).Kind_1 /=
+ Expression_Kind_Of (Expression)
+ then
+ Error_Msg
+ ("wrong expression kind for attribute """ &
+ Get_Name_String
+ (Attributes.Table (Current_Attribute).Name) &
+ """",
+ Expression_Location);
+ end if;
+ end;
+ end if;
end if;
+ -- If the attribute was not recognized, return an empty node.
+ -- It may be that it is not in a package to check, and the node will
+ -- not be added to the tree.
+
+ if Current_Attribute = Empty_Attribute then
+ Attribute := Empty_Node;
+ end if;
end Parse_Attribute_Declaration;
-----------------------------
@@ -292,7 +532,7 @@ package body Prj.Dect is
end if;
end if;
- Expect (Tok_Is, "is");
+ Expect (Tok_Is, "IS");
if Token = Tok_Is then
@@ -330,7 +570,7 @@ package body Prj.Dect is
Scan;
- Expect (Tok_Arrow, "=>");
+ Expect (Tok_Arrow, "`=>`");
-- Empty_Node in Field1 of a Case_Item indicates
-- the "when others =>" branch.
@@ -355,7 +595,7 @@ package body Prj.Dect is
Parse_Choice_List (First_Choice => First_Choice);
Set_First_Choice_Of (Current_Item, To => First_Choice);
- Expect (Tok_Arrow, "=>");
+ Expect (Tok_Arrow, "`=>`");
Parse_Declarative_Items
(Declarations => First_Declarative_Item,
@@ -372,7 +612,7 @@ package body Prj.Dect is
End_Case_Construction;
- Expect (Tok_End, "end case");
+ Expect (Tok_End, "`END CASE`");
if Token = Tok_End then
@@ -380,7 +620,7 @@ package body Prj.Dect is
Scan;
- Expect (Tok_Case, "case");
+ Expect (Tok_Case, "CASE");
end if;
@@ -388,7 +628,7 @@ package body Prj.Dect is
Scan;
- Expect (Tok_Semicolon, ";");
+ Expect (Tok_Semicolon, "`;`");
end Parse_Case_Construction;
@@ -486,24 +726,29 @@ package body Prj.Dect is
end case;
- Expect (Tok_Semicolon, "; after declarative items");
+ Expect (Tok_Semicolon, "`;` after declarative items");
- if Current_Declarative_Item = Empty_Node then
- Current_Declarative_Item :=
- Default_Project_Node (Of_Kind => N_Declarative_Item);
- Declarations := Current_Declarative_Item;
+ -- Insert an N_Declarative_Item in the tree, but only if
+ -- Current_Declaration is not an empty node.
- else
- Next_Declarative_Item :=
- Default_Project_Node (Of_Kind => N_Declarative_Item);
- Set_Next_Declarative_Item
- (Current_Declarative_Item, To => Next_Declarative_Item);
- Current_Declarative_Item := Next_Declarative_Item;
- end if;
+ if Current_Declaration /= Empty_Node then
+ if Current_Declarative_Item = Empty_Node then
+ Current_Declarative_Item :=
+ Default_Project_Node (Of_Kind => N_Declarative_Item);
+ Declarations := Current_Declarative_Item;
+
+ else
+ Next_Declarative_Item :=
+ Default_Project_Node (Of_Kind => N_Declarative_Item);
+ Set_Next_Declarative_Item
+ (Current_Declarative_Item, To => Next_Declarative_Item);
+ Current_Declarative_Item := Next_Declarative_Item;
+ end if;
- Set_Current_Item_Node
- (Current_Declarative_Item, To => Current_Declaration);
- Set_Location_Of (Current_Declarative_Item, To => Item_Location);
+ Set_Current_Item_Node
+ (Current_Declarative_Item, To => Current_Declaration);
+ Set_Location_Of (Current_Declarative_Item, To => Item_Location);
+ end if;
end loop;
@@ -546,11 +791,16 @@ package body Prj.Dect is
end loop;
if Current_Package = Empty_Package then
- Error_Msg ("""" &
+ Error_Msg ("?""" &
Get_Name_String (Name_Of (Package_Declaration)) &
""" is not an allowed package name",
Token_Ptr);
+ -- Set the package declaration to "ignored" so that it is not
+ -- processed by Prj.Proc.Process.
+
+ Set_Expression_Kind_Of (Package_Declaration, Ignored);
+
else
Set_Package_Id_Of (Package_Declaration, To => Current_Package);
@@ -598,22 +848,37 @@ package body Prj.Dect is
if Token = Tok_Identifier then
declare
- Project_Name : Name_Id := Token_Name;
+ Project_Name : constant Name_Id := Token_Name;
Clause : Project_Node_Id :=
First_With_Clause_Of (Current_Project);
The_Project : Project_Node_Id := Empty_Node;
-
+ Extended : constant Project_Node_Id :=
+ Extended_Project_Of
+ (Project_Declaration_Of (Current_Project));
begin
while Clause /= Empty_Node loop
- The_Project := Project_Node_Of (Clause);
- exit when Name_Of (The_Project) = Project_Name;
+ -- Only non limited imported projects may be used
+ -- in a renames declaration.
+
+ The_Project := Non_Limited_Project_Node_Of (Clause);
+ exit when The_Project /= Empty_Node
+ and then Name_Of (The_Project) = Project_Name;
Clause := Next_With_Clause_Of (Clause);
end loop;
if Clause = Empty_Node then
- Error_Msg ("""" &
- Get_Name_String (Project_Name) &
- """ is not an imported project", Token_Ptr);
+ -- As we have not found the project in the imports, we check
+ -- if it's the name of an eventual extended project.
+
+ if Extended /= Empty_Node
+ and then Name_Of (Extended) = Project_Name then
+ Set_Project_Of_Renamed_Package_Of
+ (Package_Declaration, To => Extended);
+ else
+ Error_Msg_Name_1 := Project_Name;
+ Error_Msg
+ ("% is not an imported or extended project", Token_Ptr);
+ end if;
else
Set_Project_Of_Renamed_Package_Of
(Package_Declaration, To => The_Project);
@@ -621,7 +886,7 @@ package body Prj.Dect is
end;
Scan;
- Expect (Tok_Dot, ".");
+ Expect (Tok_Dot, "`.`");
if Token = Tok_Dot then
Scan;
@@ -662,7 +927,7 @@ package body Prj.Dect is
end if;
end if;
- Expect (Tok_Semicolon, ";");
+ Expect (Tok_Semicolon, "`;`");
elsif Token = Tok_Is then
@@ -676,7 +941,7 @@ package body Prj.Dect is
Set_First_Declarative_Item_Of
(Package_Declaration, To => First_Declarative_Item);
- Expect (Tok_End, "end");
+ Expect (Tok_End, "END");
if Token = Tok_End then
@@ -704,10 +969,10 @@ package body Prj.Dect is
Scan;
end if;
- Expect (Tok_Semicolon, ";");
+ Expect (Tok_Semicolon, "`;`");
else
- Error_Msg ("expected ""is"" or ""renames""", Token_Ptr);
+ Error_Msg ("expected IS or RENAMES", Token_Ptr);
end if;
end Parse_Package_Declaration;
@@ -775,13 +1040,13 @@ package body Prj.Dect is
Scan;
end if;
- Expect (Tok_Is, "is");
+ Expect (Tok_Is, "IS");
if Token = Tok_Is then
Scan;
end if;
- Expect (Tok_Left_Paren, "(");
+ Expect (Tok_Left_Paren, "`(`");
if Token = Tok_Left_Paren then
Scan;
@@ -790,7 +1055,7 @@ package body Prj.Dect is
Parse_String_Type_List (First_String => First_String);
Set_First_Literal_String (String_Type, To => First_String);
- Expect (Tok_Right_Paren, ")");
+ Expect (Tok_Right_Paren, "`)`");
if Token = Tok_Right_Paren then
Scan;
@@ -814,6 +1079,7 @@ package body Prj.Dect is
Project_Location : Source_Ptr := No_Location;
Expression : Project_Node_Id := Empty_Node;
Variable_Name : constant Name_Id := Token_Name;
+ OK : Boolean := True;
begin
Variable :=
@@ -833,7 +1099,9 @@ package body Prj.Dect is
Set_Kind_Of (Variable, N_Typed_Variable_Declaration);
Expect (Tok_Identifier, "identifier");
- if Token = Tok_Identifier then
+ OK := Token = Tok_Identifier;
+
+ if OK then
String_Type_Name := Token_Name;
Type_Location := Token_Ptr;
Scan;
@@ -852,11 +1120,11 @@ package body Prj.Dect is
Type_Location := Token_Ptr;
Scan;
else
- String_Type_Name := No_Name;
+ OK := False;
end if;
end if;
- if String_Type_Name /= No_Name then
+ if OK then
declare
Current : Project_Node_Id :=
First_String_Type_Of (Current_Project);
@@ -900,6 +1168,7 @@ package body Prj.Dect is
Get_Name_String (String_Type_Name) &
"""",
Type_Location);
+ OK := False;
else
Set_String_Type_Of
(Variable, To => Current);
@@ -909,7 +1178,9 @@ package body Prj.Dect is
end if;
end if;
- Expect (Tok_Colon_Equal, ":=");
+ Expect (Tok_Colon_Equal, "`:=`");
+
+ OK := OK and (Token = Tok_Colon_Equal);
if Token = Tok_Colon_Equal then
Scan;
@@ -926,57 +1197,68 @@ package body Prj.Dect is
Set_Expression_Of (Variable, To => Expression);
if Expression /= Empty_Node then
+ -- A typed string must have a single string value, not a list
+
+ if Kind_Of (Variable) = N_Typed_Variable_Declaration
+ and then Expression_Kind_Of (Expression) = List
+ then
+ Error_Msg
+ ("expression must be a single string", Expression_Location);
+ end if;
+
Set_Expression_Kind_Of
(Variable, To => Expression_Kind_Of (Expression));
end if;
- declare
- The_Variable : Project_Node_Id := Empty_Node;
-
- begin
- if Current_Package /= Empty_Node then
- The_Variable := First_Variable_Of (Current_Package);
- elsif Current_Project /= Empty_Node then
- The_Variable := First_Variable_Of (Current_Project);
- end if;
-
- while The_Variable /= Empty_Node
- and then Name_Of (The_Variable) /= Variable_Name
- loop
- The_Variable := Next_Variable (The_Variable);
- end loop;
+ if OK then
+ declare
+ The_Variable : Project_Node_Id := Empty_Node;
- if The_Variable = Empty_Node then
+ begin
if Current_Package /= Empty_Node then
- Set_Next_Variable
- (Variable, To => First_Variable_Of (Current_Package));
- Set_First_Variable_Of (Current_Package, To => Variable);
-
+ The_Variable := First_Variable_Of (Current_Package);
elsif Current_Project /= Empty_Node then
- Set_Next_Variable
- (Variable, To => First_Variable_Of (Current_Project));
- Set_First_Variable_Of (Current_Project, To => Variable);
+ The_Variable := First_Variable_Of (Current_Project);
end if;
- else
- if Expression_Kind_Of (Variable) /= Undefined then
- if Expression_Kind_Of (The_Variable) = Undefined then
- Set_Expression_Kind_Of
- (The_Variable, To => Expression_Kind_Of (Variable));
+ while The_Variable /= Empty_Node
+ and then Name_Of (The_Variable) /= Variable_Name
+ loop
+ The_Variable := Next_Variable (The_Variable);
+ end loop;
- else
- if Expression_Kind_Of (The_Variable) /=
- Expression_Kind_Of (Variable)
- then
- Error_Msg ("wrong expression kind for variable """ &
- Get_Name_String (Name_Of (The_Variable)) &
- """",
- Expression_Location);
+ if The_Variable = Empty_Node then
+ if Current_Package /= Empty_Node then
+ Set_Next_Variable
+ (Variable, To => First_Variable_Of (Current_Package));
+ Set_First_Variable_Of (Current_Package, To => Variable);
+
+ elsif Current_Project /= Empty_Node then
+ Set_Next_Variable
+ (Variable, To => First_Variable_Of (Current_Project));
+ Set_First_Variable_Of (Current_Project, To => Variable);
+ end if;
+
+ else
+ if Expression_Kind_Of (Variable) /= Undefined then
+ if Expression_Kind_Of (The_Variable) = Undefined then
+ Set_Expression_Kind_Of
+ (The_Variable, To => Expression_Kind_Of (Variable));
+
+ else
+ if Expression_Kind_Of (The_Variable) /=
+ Expression_Kind_Of (Variable)
+ then
+ Error_Msg ("wrong expression kind for variable """ &
+ Get_Name_String (Name_Of (The_Variable)) &
+ """",
+ Expression_Location);
+ end if;
end if;
end if;
end if;
- end if;
- end;
+ end;
+ end if;
end Parse_Variable_Declaration;
diff --git a/gcc/ada/prj-dect.ads b/gcc/ada/prj-dect.ads
index fdf8e94a378..487fbeb7c5b 100644
--- a/gcc/ada/prj-dect.ads
+++ b/gcc/ada/prj-dect.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb
index 3faf0814b3e..9df20fa8eec 100644
--- a/gcc/ada/prj-env.adb
+++ b/gcc/ada/prj-env.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -24,28 +24,43 @@
-- --
------------------------------------------------------------------------------
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Namet; use Namet;
+with Namet; use Namet;
with Opt;
-with Osint; use Osint;
-with Output; use Output;
-with Prj.Com; use Prj.Com;
-with Prj.Util;
-with Snames; use Snames;
-with Stringt; use Stringt;
+with Osint; use Osint;
+with Output; use Output;
+with Prj.Com; use Prj.Com;
with Table;
+with Tempdir;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
package body Prj.Env is
type Naming_Id is new Nat;
- Ada_Path_Buffer : String_Access := new String (1 .. 1_000);
+ Current_Source_Path_File : Name_Id := No_Name;
+ -- Current value of project source path file env var.
+ -- Used to avoid setting the env var to the same value.
+
+ Current_Object_Path_File : Name_Id := No_Name;
+ -- Current value of project object path file env var.
+ -- Used to avoid setting the env var to the same value.
+
+ Ada_Path_Buffer : String_Access := new String (1 .. 1024);
-- A buffer where values for ADA_INCLUDE_PATH
-- and ADA_OBJECTS_PATH are stored.
Ada_Path_Length : Natural := 0;
-- Index of the last valid character in Ada_Path_Buffer.
+ Ada_Prj_Include_File_Set : Boolean := False;
+ Ada_Prj_Objects_File_Set : Boolean := False;
+ -- These flags are set to True when the corresponding environment variables
+ -- are set and are used to give these environment variables an empty string
+ -- value at the end of the program. This has no practical effect on most
+ -- platforms, except on VMS where the logical names are deassigned, thus
+ -- avoiding the pollution of the environment of the caller.
+
package Namings is new Table.Table (
Table_Component_Type => Naming_Data,
Table_Index_Type => Naming_Id,
@@ -56,11 +71,22 @@ package body Prj.Env is
Default_Naming : constant Naming_Id := Namings.First;
- Global_Configuration_Pragmas : Name_Id;
- Local_Configuration_Pragmas : Name_Id;
-
Fill_Mapping_File : Boolean := True;
+ package Path_Files is new Table.Table (
+ Table_Component_Type => Name_Id,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 50,
+ Table_Increment => 50,
+ Table_Name => "Prj.Env.Path_Files");
+ -- Table storing all the temp path file names.
+ -- Used by Delete_All_Path_Files.
+
+ type Project_Flags is array (Project_Id range <>) of Boolean;
+ -- A Boolean array type used in Create_Mapping_File to select the projects
+ -- in the closure of a specific project.
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -77,9 +103,36 @@ package body Prj.Env is
-- Add to Ada_Path_Buffer all the source directories in string list
-- Source_Dirs, if any. Increment Ada_Path_Length.
- procedure Add_To_Path (Path : String);
- -- Add Path to global variable Ada_Path_Buffer
- -- Increment Ada_Path_Length
+ procedure Add_To_Path (Dir : String);
+ -- If Dir is not already in the global variable Ada_Path_Buffer, add it.
+ -- Increment Ada_Path_Length.
+ -- If Ada_Path_Length /= 0, prepend a Path_Separator character to
+ -- Path.
+
+ procedure Add_To_Path_File
+ (Source_Dirs : String_List_Id;
+ Path_File : File_Descriptor);
+ -- Add to Ada_Path_Buffer all the source directories in string list
+ -- Source_Dirs, if any. Increment Ada_Path_Length.
+
+ procedure Add_To_Path_File
+ (Path : String;
+ Path_File : File_Descriptor);
+ -- Add Path to path file
+
+ procedure Create_New_Path_File
+ (Path_FD : out File_Descriptor;
+ Path_Name : out Name_Id);
+ -- Create a new temporary path file. Get the file name in Path_Name.
+ -- The name is normally obtained by increasing the number in
+ -- Temp_Path_File_Name by 1.
+
+ procedure Set_Path_File_Var (Name : String; Value : String);
+ -- Call Setenv, after calling To_Host_File_Spec
+
+ function Ultimate_Extension_Of (Project : in Project_Id) return Project_Id;
+ -- Return a project that is either Project or an extended ancestor of
+ -- Project that itself is not extended.
----------------------
-- Ada_Include_Path --
@@ -90,7 +143,7 @@ package body Prj.Env is
procedure Add (Project : Project_Id);
-- Add all the source directories of a project to the path only if
-- this project has not been visited. Calls itself recursively for
- -- projects being modified, and imported projects. Adds the project
+ -- projects being extended, and imported projects. Adds the project
-- to the list Seen if this is the call to Add for this project.
---------
@@ -105,7 +158,7 @@ package body Prj.Env is
Projects.Table (Project).Seen := True;
declare
- Data : Project_Data := Projects.Table (Project);
+ Data : constant Project_Data := Projects.Table (Project);
List : Project_List := Data.Imported_Projects;
begin
@@ -113,10 +166,10 @@ package body Prj.Env is
Add_To_Path (Data.Source_Dirs);
- -- Call Add to the project being modified, if any
+ -- Call Add to the project being extended, if any
- if Data.Modifies /= No_Project then
- Add (Data.Modifies);
+ if Data.Extends /= No_Project then
+ Add (Data.Extends);
end if;
-- Call Add for each imported project, if any
@@ -135,7 +188,7 @@ package body Prj.Env is
-- If it is the first time we call this function for
-- this project, compute the source path
- if Projects.Table (Project).Include_Path = null then
+ if Projects.Table (Project).Ada_Include_Path = null then
Ada_Path_Length := 0;
for Index in 1 .. Projects.Last loop
@@ -143,11 +196,11 @@ package body Prj.Env is
end loop;
Add (Project);
- Projects.Table (Project).Include_Path :=
+ Projects.Table (Project).Ada_Include_Path :=
new String'(Ada_Path_Buffer (1 .. Ada_Path_Length));
end if;
- return Projects.Table (Project).Include_Path;
+ return Projects.Table (Project).Ada_Include_Path;
end Ada_Include_Path;
function Ada_Include_Path
@@ -177,7 +230,7 @@ package body Prj.Env is
procedure Add (Project : Project_Id);
-- Add all the object directories of a project to the path only if
-- this project has not been visited. Calls itself recursively for
- -- projects being modified, and imported projects. Adds the project
+ -- projects being extended, and imported projects. Adds the project
-- to the list Seen if this is the first call to Add for this project.
---------
@@ -192,7 +245,7 @@ package body Prj.Env is
Projects.Table (Project).Seen := True;
declare
- Data : Project_Data := Projects.Table (Project);
+ Data : constant Project_Data := Projects.Table (Project);
List : Project_List := Data.Imported_Projects;
begin
@@ -206,35 +259,22 @@ package body Prj.Env is
and then
(not Including_Libraries or else not Data.Library))
then
- if Ada_Path_Length > 0 then
- Add_To_Path (Path => (1 => Path_Separator));
- end if;
-
- -- For a library project, att the library directory
+ -- For a library project, add the library directory
if Data.Library then
- declare
- New_Path : constant String :=
- Get_Name_String (Data.Library_Dir);
- begin
- Add_To_Path (New_Path);
- end;
- else
+ Add_To_Path (Get_Name_String (Data.Library_Dir));
+ else
-- For a non library project, add the object directory
- declare
- New_Path : constant String :=
- Get_Name_String (Data.Object_Directory);
- begin
- Add_To_Path (New_Path);
- end;
+
+ Add_To_Path (Get_Name_String (Data.Object_Directory));
end if;
end if;
- -- Call Add to the project being modified, if any
+ -- Call Add to the project being extended, if any
- if Data.Modifies /= No_Project then
- Add (Data.Modifies);
+ if Data.Extends /= No_Project then
+ Add (Data.Extends);
end if;
-- Call Add for each imported project, if any
@@ -254,7 +294,7 @@ package body Prj.Env is
-- If it is the first time we call this function for
-- this project, compute the objects path
- if Projects.Table (Project).Objects_Path = null then
+ if Projects.Table (Project).Ada_Objects_Path = null then
Ada_Path_Length := 0;
for Index in 1 .. Projects.Last loop
@@ -262,11 +302,11 @@ package body Prj.Env is
end loop;
Add (Project);
- Projects.Table (Project).Objects_Path :=
+ Projects.Table (Project).Ada_Objects_Path :=
new String'(Ada_Path_Buffer (1 .. Ada_Path_Length));
end if;
- return Projects.Table (Project).Objects_Path;
+ return Projects.Table (Project).Ada_Objects_Path;
end Ada_Objects_Path;
-----------------
@@ -279,47 +319,123 @@ package body Prj.Env is
begin
while Current /= Nil_String loop
- if Ada_Path_Length > 0 then
- Add_To_Path (Path => (1 => Path_Separator));
- end if;
-
Source_Dir := String_Elements.Table (Current);
- String_To_Name_Buffer (Source_Dir.Value);
-
- declare
- New_Path : constant String :=
- Name_Buffer (1 .. Name_Len);
- begin
- Add_To_Path (New_Path);
- end;
-
+ Add_To_Path (Get_Name_String (Source_Dir.Value));
Current := Source_Dir.Next;
end loop;
end Add_To_Path;
- procedure Add_To_Path (Path : String) is
+ procedure Add_To_Path (Dir : String) is
+ Len : Natural;
+ New_Buffer : String_Access;
+ Min_Len : Natural;
+
+ function Is_Present (Path : String; Dir : String) return Boolean;
+ -- Return True if Dir is part of Path
+
+ ----------------
+ -- Is_Present --
+ ----------------
+
+ function Is_Present (Path : String; Dir : String) return Boolean is
+ Last : constant Integer := Path'Last - Dir'Length + 1;
+ begin
+ for J in Path'First .. Last loop
+ -- Note: the order of the conditions below is important, since
+ -- it ensures a minimal number of string comparisons.
+
+ if (J = Path'First
+ or else Path (J - 1) = Path_Separator)
+ and then
+ (J + Dir'Length > Path'Last
+ or else Path (J + Dir'Length) = Path_Separator)
+ and then Dir = Path (J .. J + Dir'Length - 1)
+ then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end Is_Present;
+
begin
- -- If Ada_Path_Buffer is too small, double it
+ if Is_Present (Ada_Path_Buffer (1 .. Ada_Path_Length), Dir) then
+ -- Dir is already in the path, nothing to do
- if Ada_Path_Length + Path'Length > Ada_Path_Buffer'Last then
- declare
- New_Ada_Path_Buffer : constant String_Access :=
- new String
- (1 .. Ada_Path_Buffer'Last +
- Ada_Path_Buffer'Last);
+ return;
+ end if;
- begin
- New_Ada_Path_Buffer (1 .. Ada_Path_Length) :=
- Ada_Path_Buffer (1 .. Ada_Path_Length);
- Ada_Path_Buffer := New_Ada_Path_Buffer;
- end;
+ Min_Len := Ada_Path_Length + Dir'Length;
+
+ if Ada_Path_Length > 0 then
+ -- Add 1 for the Path_Separator character
+
+ Min_Len := Min_Len + 1;
+ end if;
+
+ -- If Ada_Path_Buffer is too small, increase it
+
+ Len := Ada_Path_Buffer'Last;
+
+ if Len < Min_Len then
+ loop
+ Len := Len * 2;
+ exit when Len >= Min_Len;
+ end loop;
+
+ New_Buffer := new String (1 .. Len);
+ New_Buffer (1 .. Ada_Path_Length) :=
+ Ada_Path_Buffer (1 .. Ada_Path_Length);
+ Free (Ada_Path_Buffer);
+ Ada_Path_Buffer := New_Buffer;
+ end if;
+
+ if Ada_Path_Length > 0 then
+ Ada_Path_Length := Ada_Path_Length + 1;
+ Ada_Path_Buffer (Ada_Path_Length) := Path_Separator;
end if;
Ada_Path_Buffer
- (Ada_Path_Length + 1 .. Ada_Path_Length + Path'Length) := Path;
- Ada_Path_Length := Ada_Path_Length + Path'Length;
+ (Ada_Path_Length + 1 .. Ada_Path_Length + Dir'Length) := Dir;
+ Ada_Path_Length := Ada_Path_Length + Dir'Length;
end Add_To_Path;
+ ----------------------
+ -- Add_To_Path_File --
+ ----------------------
+
+ procedure Add_To_Path_File
+ (Source_Dirs : String_List_Id;
+ Path_File : File_Descriptor)
+ is
+ Current : String_List_Id := Source_Dirs;
+ Source_Dir : String_Element;
+
+ begin
+ while Current /= Nil_String loop
+ Source_Dir := String_Elements.Table (Current);
+ Add_To_Path_File (Get_Name_String (Source_Dir.Value), Path_File);
+ Current := Source_Dir.Next;
+ end loop;
+ end Add_To_Path_File;
+
+ procedure Add_To_Path_File
+ (Path : String;
+ Path_File : File_Descriptor)
+ is
+ Line : String (1 .. Path'Length + 1);
+ Len : Natural;
+
+ begin
+ Line (1 .. Path'Length) := Path;
+ Line (Line'Last) := ASCII.LF;
+ Len := Write (Path_File, Line (1)'Address, Line'Length);
+
+ if Len /= Line'Length then
+ Prj.Com.Fail ("disk full");
+ end if;
+ end Add_To_Path_File;
+
-----------------------
-- Body_Path_Name_Of --
-----------------------
@@ -346,13 +462,12 @@ package body Prj.Env is
-- For each source directory
while Current_Source /= Nil_String loop
- String_To_Name_Buffer
- (String_Elements.Table (Current_Source).Value);
Path :=
Locate_Regular_File
- (Namet.Get_Name_String
- (Data.File_Names (Body_Part).Name),
- Name_Buffer (1 .. Name_Len));
+ (Namet.Get_Name_String
+ (Data.File_Names (Body_Part).Name),
+ Namet.Get_Name_String
+ (String_Elements.Table (Current_Source).Value));
-- If the file is in this directory,
-- then we store the path, and we are done.
@@ -383,15 +498,15 @@ package body Prj.Env is
--------------------------------
procedure Create_Config_Pragmas_File
- (For_Project : Project_Id;
- Main_Project : Project_Id)
+ (For_Project : Project_Id;
+ Main_Project : Project_Id;
+ Include_Config_Files : Boolean := True)
is
- File_Name : Temp_File_Name;
- File : File_Descriptor := Invalid_FD;
+ pragma Unreferenced (Main_Project);
+ pragma Unreferenced (Include_Config_Files);
- The_Packages : Package_Id;
- Gnatmake : Prj.Package_Id;
- Compiler : Prj.Package_Id;
+ File_Name : Name_Id := No_Name;
+ File : File_Descriptor := Invalid_FD;
Current_Unit : Unit_Id := Units.First;
@@ -400,11 +515,8 @@ package body Prj.Env is
Current_Project : Project_List;
Current_Naming : Naming_Id;
- Global_Attribute : Variable_Value := Nil_Variable_Value;
- Local_Attribute : Variable_Value := Nil_Variable_Value;
-
- Global_Attribute_Present : Boolean := False;
- Local_Attribute_Present : Boolean := False;
+ Status : Boolean;
+ -- For call to Close
procedure Check (Project : Project_Id);
@@ -413,9 +525,6 @@ package body Prj.Env is
-- If not, create one, and put its name in the project data,
-- with the indication that it is a temporary file.
- procedure Copy_File (Name : String_Id);
- -- Copy a configuration pragmas file into the temp file.
-
procedure Put
(Unit_Name : Name_Id;
File_Name : Name_Id;
@@ -483,7 +592,7 @@ package body Prj.Env is
-- Spec
Put_Line
- (File, "pragma Source_File_Name");
+ (File, "pragma Source_File_Name_Project");
Put_Line
(File, " (Spec_File_Name => ""*" &
Namet.Get_Name_String (Data.Naming.Current_Spec_Suffix) &
@@ -499,10 +608,10 @@ package body Prj.Env is
-- and body
Put_Line
- (File, "pragma Source_File_Name");
+ (File, "pragma Source_File_Name_Project");
Put_Line
(File, " (Body_File_Name => ""*" &
- Namet.Get_Name_String (Data.Naming.Current_Impl_Suffix) &
+ Namet.Get_Name_String (Data.Naming.Current_Body_Suffix) &
""",");
Put_Line
(File, " Casing => " &
@@ -515,10 +624,10 @@ package body Prj.Env is
-- and maybe separate
if
- Data.Naming.Current_Impl_Suffix /= Data.Naming.Separate_Suffix
+ Data.Naming.Current_Body_Suffix /= Data.Naming.Separate_Suffix
then
Put_Line
- (File, "pragma Source_File_Name");
+ (File, "pragma Source_File_Name_Project");
Put_Line
(File, " (Subunit_File_Name => ""*" &
Namet.Get_Name_String (Data.Naming.Separate_Suffix) &
@@ -534,8 +643,8 @@ package body Prj.Env is
end if;
end if;
- if Data.Modifies /= No_Project then
- Check (Data.Modifies);
+ if Data.Extends /= No_Project then
+ Check (Data.Extends);
end if;
declare
@@ -557,66 +666,19 @@ package body Prj.Env is
procedure Check_Temp_File is
begin
if File = Invalid_FD then
- GNAT.OS_Lib.Create_Temp_File (File, Name => File_Name);
+ Tempdir.Create_Temp_File (File, Name => File_Name);
+
if File = Invalid_FD then
- Osint.Fail
+ Prj.Com.Fail
("unable to create temporary configuration pragmas file");
elsif Opt.Verbose_Mode then
Write_Str ("Creating temp file """);
- Write_Str (File_Name);
+ Write_Str (Get_Name_String (File_Name));
Write_Line ("""");
end if;
end if;
end Check_Temp_File;
- ---------------
- -- Copy_File --
- ---------------
-
- procedure Copy_File (Name : in String_Id) is
- Input : File_Descriptor;
- Buffer : String (1 .. 1_000);
- Input_Length : Integer;
- Output_Length : Integer;
-
- begin
- Check_Temp_File;
- String_To_Name_Buffer (Name);
-
- if Opt.Verbose_Mode then
- Write_Str ("Copying config pragmas file """);
- Write_Str (Name_Buffer (1 .. Name_Len));
- Write_Line (""" into temp file");
- end if;
-
- declare
- Name : constant String :=
- Name_Buffer (1 .. Name_Len) & ASCII.NUL;
- begin
- Input := Open_Read (Name'Address, Binary);
- end;
-
- if Input = Invalid_FD then
- Osint.Fail
- ("cannot open configuration pragmas file " &
- Name_Buffer (1 .. Name_Len));
- end if;
-
- loop
- Input_Length := Read (Input, Buffer'Address, Buffer'Length);
- Output_Length := Write (File, Buffer'Address, Input_Length);
-
- if Output_Length /= Input_Length then
- Osint.Fail ("disk full");
- end if;
-
- exit when Input_Length < Buffer'Length;
- end loop;
-
- Close (Input);
-
- end Copy_File;
-
---------
-- Put --
---------
@@ -633,7 +695,7 @@ package body Prj.Env is
-- Put the pragma SFN for the unit kind (spec or body)
- Put (File, "pragma Source_File_Name (");
+ Put (File, "pragma Source_File_Name_Project (");
Put (File, Namet.Get_Name_String (Unit_Name));
if Unit_Kind = Specification then
@@ -653,7 +715,7 @@ package body Prj.Env is
Last := Write (File, S (S'First)'Address, S'Length);
if Last /= S'Length then
- Osint.Fail ("Disk full");
+ Prj.Com.Fail ("Disk full");
end if;
if Current_Verbosity = High then
@@ -681,7 +743,7 @@ package body Prj.Env is
Last := Write (File, S0'Address, S0'Length);
if Last /= S'Length + 1 then
- Osint.Fail ("Disk full");
+ Prj.Com.Fail ("Disk full");
end if;
if Current_Verbosity = High then
@@ -726,73 +788,41 @@ package body Prj.Env is
end;
end loop;
- The_Packages := Projects.Table (Main_Project).Decl.Packages;
- Gnatmake :=
- Prj.Util.Value_Of
- (Name => Name_Builder,
- In_Packages => The_Packages);
-
- if Gnatmake /= No_Package then
- Global_Attribute := Prj.Util.Value_Of
- (Variable_Name => Global_Configuration_Pragmas,
- In_Variables => Packages.Table (Gnatmake).Decl.Attributes);
- Global_Attribute_Present :=
- Global_Attribute /= Nil_Variable_Value
- and then String_Length (Global_Attribute.Value) > 0;
- end if;
+ -- If there are no non standard naming scheme, issue the GNAT
+ -- standard naming scheme. This will tell the compiler that
+ -- a project file is used and will forbid any pragma SFN.
- The_Packages := Projects.Table (For_Project).Decl.Packages;
- Compiler :=
- Prj.Util.Value_Of
- (Name => Name_Compiler,
- In_Packages => The_Packages);
-
- if Compiler /= No_Package then
- Local_Attribute := Prj.Util.Value_Of
- (Variable_Name => Local_Configuration_Pragmas,
- In_Variables => Packages.Table (Compiler).Decl.Attributes);
- Local_Attribute_Present :=
- Local_Attribute /= Nil_Variable_Value
- and then String_Length (Local_Attribute.Value) > 0;
- end if;
+ if File = Invalid_FD then
+ Check_Temp_File;
- if Global_Attribute_Present then
- if File /= Invalid_FD
- or else Local_Attribute_Present
- then
- Copy_File (Global_Attribute.Value);
+ Put_Line (File, "pragma Source_File_Name_Project");
+ Put_Line (File, " (Spec_File_Name => ""*.ads"",");
+ Put_Line (File, " Dot_Replacement => ""-"",");
+ Put_Line (File, " Casing => lowercase);");
- else
- String_To_Name_Buffer (Global_Attribute.Value);
- Projects.Table (For_Project).Config_File_Name := Name_Find;
- end if;
+ Put_Line (File, "pragma Source_File_Name_Project");
+ Put_Line (File, " (Body_File_Name => ""*.adb"",");
+ Put_Line (File, " Dot_Replacement => ""-"",");
+ Put_Line (File, " Casing => lowercase);");
end if;
- if Local_Attribute_Present then
- if File /= Invalid_FD then
- Copy_File (Local_Attribute.Value);
+ -- Close the temporary file
- else
- String_To_Name_Buffer (Local_Attribute.Value);
- Projects.Table (For_Project).Config_File_Name := Name_Find;
- end if;
- end if;
-
- if File /= Invalid_FD then
- GNAT.OS_Lib.Close (File);
+ GNAT.OS_Lib.Close (File, Status);
- if Opt.Verbose_Mode then
- Write_Str ("Closing configuration file """);
- Write_Str (File_Name);
- Write_Line ("""");
- end if;
+ if not Status then
+ Prj.Com.Fail ("disk full");
+ end if;
- Name_Len := File_Name'Length;
- Name_Buffer (1 .. Name_Len) := File_Name;
- Projects.Table (For_Project).Config_File_Name := Name_Find;
- Projects.Table (For_Project).Config_File_Temp := True;
+ if Opt.Verbose_Mode then
+ Write_Str ("Closing configuration file """);
+ Write_Str (Get_Name_String (File_Name));
+ Write_Line ("""");
end if;
+ Projects.Table (For_Project).Config_File_Name := File_Name;
+ Projects.Table (For_Project).Config_File_Temp := True;
+
Projects.Table (For_Project).Config_Checked := True;
end if;
end Create_Config_Pragmas_File;
@@ -801,11 +831,22 @@ package body Prj.Env is
-- Create_Mapping_File --
-------------------------
- procedure Create_Mapping_File (Name : in out Temp_File_Name) is
+ procedure Create_Mapping_File
+ (Project : Project_Id;
+ Name : out Name_Id)
+ is
File : File_Descriptor := Invalid_FD;
The_Unit_Data : Unit_Data;
Data : File_Name_Data;
+ Status : Boolean;
+ -- For call to Close
+
+ Present : Project_Flags (No_Project .. Projects.Last) :=
+ (others => False);
+ -- For each project in the closure of Project, the corresponding flag
+ -- will be set to True;
+
procedure Put_Name_Buffer;
-- Put the line contained in the Name_Buffer in the mapping file
@@ -813,6 +854,10 @@ package body Prj.Env is
-- Put the mapping of the spec or body contained in Data in the file
-- (3 lines).
+ procedure Recursive_Flag (Prj : Project_Id);
+ -- Set the flags corresponding to Prj, the projects it imports
+ -- (directly or indirectly) or extends to True. Call itself recursively.
+
---------
-- Put --
---------
@@ -826,7 +871,7 @@ package body Prj.Env is
Last := Write (File, Name_Buffer (1)'Address, Name_Len);
if Last /= Name_Len then
- Osint.Fail ("Disk full");
+ Prj.Com.Fail ("Disk full");
end if;
end Put_Name_Buffer;
@@ -851,7 +896,7 @@ package body Prj.Env is
Put_Name_Buffer;
- -- Line with the file nale
+ -- Line with the file name
Get_Name_String (Data.Name);
Put_Name_Buffer;
@@ -863,18 +908,57 @@ package body Prj.Env is
end Put_Data;
+ --------------------
+ -- Recursive_Flag --
+ --------------------
+
+ procedure Recursive_Flag (Prj : Project_Id) is
+ Imported : Project_List;
+ Proj : Project_Id;
+
+ begin
+ -- Nothing to do for non existent project or project that has
+ -- already been flagged.
+
+ if Prj = No_Project or else Present (Prj) then
+ return;
+ end if;
+
+ -- Flag the current project
+
+ Present (Prj) := True;
+ Imported := Projects.Table (Prj).Imported_Projects;
+
+ -- Call itself for each project directly imported
+
+ while Imported /= Empty_Project_List loop
+ Proj := Project_Lists.Table (Imported).Project;
+ Imported := Project_Lists.Table (Imported).Next;
+ Recursive_Flag (Proj);
+ end loop;
+
+ -- Call itself for an eventual project being extended
+
+ Recursive_Flag (Projects.Table (Prj).Extends);
+ end Recursive_Flag;
+
-- Start of processing for Create_Mapping_File
begin
- GNAT.OS_Lib.Create_Temp_File (File, Name => Name);
+ -- Flag the necessary projects
+
+ Recursive_Flag (Project);
+
+ -- Create the temporary file
+
+ Tempdir.Create_Temp_File (File, Name => Name);
if File = Invalid_FD then
- Osint.Fail
- ("unable to create temporary mapping file");
+ Prj.Com.Fail ("unable to create temporary mapping file");
elsif Opt.Verbose_Mode then
Write_Str ("Creating temp mapping file """);
- Write_Str (Name);
+ Write_Str (Get_Name_String (Name));
Write_Line ("""");
end if;
@@ -889,17 +973,19 @@ package body Prj.Env is
if The_Unit_Data.Name /= No_Name then
Data := The_Unit_Data.File_Names (Specification);
- -- If there is a spec, put it mapping in the file
+ -- If there is a spec, put it mapping in the file if it is
+ -- from a project in the closure of Project.
- if Data.Name /= No_Name then
+ if Data.Name /= No_Name and then Present (Data.Project) then
Put_Data (Spec => True);
end if;
Data := The_Unit_Data.File_Names (Body_Part);
-- If there is a body (or subunit) put its mapping in the file
+ -- if it is from a project in the closure of Project.
- if Data.Name /= No_Name then
+ if Data.Name /= No_Name and then Present (Data.Project) then
Put_Data (Spec => False);
end if;
@@ -907,20 +993,78 @@ package body Prj.Env is
end loop;
end if;
- GNAT.OS_Lib.Close (File);
+ GNAT.OS_Lib.Close (File, Status);
+
+ if not Status then
+ Prj.Com.Fail ("disk full");
+ end if;
end Create_Mapping_File;
+ --------------------------
+ -- Create_New_Path_File --
+ --------------------------
+
+ procedure Create_New_Path_File
+ (Path_FD : out File_Descriptor;
+ Path_Name : out Name_Id)
+ is
+ begin
+ Tempdir.Create_Temp_File (Path_FD, Path_Name);
+
+ if Path_Name /= No_Name then
+
+ -- Record the name, so that the temp path file will be deleted
+ -- at the end of the program.
+
+ Path_Files.Increment_Last;
+ Path_Files.Table (Path_Files.Last) := Path_Name;
+ end if;
+ end Create_New_Path_File;
+
+ ---------------------------
+ -- Delete_All_Path_Files --
+ ---------------------------
+
+ procedure Delete_All_Path_Files is
+ Disregard : Boolean := True;
+
+ begin
+ for Index in 1 .. Path_Files.Last loop
+ if Path_Files.Table (Index) /= No_Name then
+ Delete_File
+ (Get_Name_String (Path_Files.Table (Index)), Disregard);
+ end if;
+ end loop;
+
+ -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or
+ -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
+ -- the empty string. On VMS, this has the effect of deassigning
+ -- the logical names.
+
+ if Ada_Prj_Include_File_Set then
+ Setenv (Project_Include_Path_File, "");
+ Ada_Prj_Include_File_Set := False;
+ end if;
+
+ if Ada_Prj_Objects_File_Set then
+ Setenv (Project_Objects_Path_File, "");
+ Ada_Prj_Objects_File_Set := False;
+ end if;
+ end Delete_All_Path_Files;
+
------------------------------------
-- File_Name_Of_Library_Unit_Body --
------------------------------------
function File_Name_Of_Library_Unit_Body
- (Name : String;
- Project : Project_Id)
- return String
+ (Name : String;
+ Project : Project_Id;
+ Main_Project_Only : Boolean := True)
+ return String
is
- Data : constant Project_Data := Projects.Table (Project);
+ The_Project : Project_Id := Project;
+ Data : Project_Data := Projects.Table (Project);
Original_Name : String := Name;
Extended_Spec_Name : String :=
@@ -928,7 +1072,7 @@ package body Prj.Env is
(Data.Naming.Current_Spec_Suffix);
Extended_Body_Name : String :=
Name & Namet.Get_Name_String
- (Data.Naming.Current_Impl_Suffix);
+ (Data.Naming.Current_Body_Suffix);
Unit : Unit_Data;
@@ -967,109 +1111,127 @@ package body Prj.Env is
Write_Eol;
end if;
- -- For every unit
-
- for Current in reverse Units.First .. Units.Last loop
- Unit := Units.Table (Current);
+ -- For extending project, search in the extended project
+ -- if the source is not found. For non extending projects,
+ -- this loop will be run only once.
- -- Case of unit of the same project
+ loop
+ -- For every unit
- if Unit.File_Names (Body_Part).Project = Project then
- declare
- Current_Name : constant Name_Id :=
- Unit.File_Names (Body_Part).Name;
+ for Current in reverse Units.First .. Units.Last loop
+ Unit := Units.Table (Current);
- begin
- -- Case of a body present
+ -- Check for body
- if Current_Name /= No_Name then
- if Current_Verbosity = High then
- Write_Str (" Comparing with """);
- Write_Str (Get_Name_String (Current_Name));
- Write_Char ('"');
- Write_Eol;
- end if;
+ if not Main_Project_Only
+ or else Unit.File_Names (Body_Part).Project = The_Project
+ then
+ declare
+ Current_Name : constant Name_Id :=
+ Unit.File_Names (Body_Part).Name;
- -- If it has the name of the original name,
- -- return the original name
+ begin
+ -- Case of a body present
- if Unit.Name = The_Original_Name
- or else Current_Name = The_Original_Name
- then
+ if Current_Name /= No_Name then
if Current_Verbosity = High then
- Write_Line (" OK");
+ Write_Str (" Comparing with """);
+ Write_Str (Get_Name_String (Current_Name));
+ Write_Char ('"');
+ Write_Eol;
end if;
- return Get_Name_String (Current_Name);
+ -- If it has the name of the original name,
+ -- return the original name
- -- If it has the name of the extended body name,
- -- return the extended body name
+ if Unit.Name = The_Original_Name
+ or else Current_Name = The_Original_Name
+ then
+ if Current_Verbosity = High then
+ Write_Line (" OK");
+ end if;
- elsif Current_Name = The_Body_Name then
- if Current_Verbosity = High then
- Write_Line (" OK");
- end if;
+ return Get_Name_String (Current_Name);
- return Extended_Body_Name;
+ -- If it has the name of the extended body name,
+ -- return the extended body name
- else
- if Current_Verbosity = High then
- Write_Line (" not good");
- end if;
- end if;
- end if;
- end;
- end if;
+ elsif Current_Name = The_Body_Name then
+ if Current_Verbosity = High then
+ Write_Line (" OK");
+ end if;
- -- Case of a unit of the same project
+ return Extended_Body_Name;
- if Units.Table (Current).File_Names (Specification).Project =
- Project
- then
- declare
- Current_Name : constant Name_Id :=
- Unit.File_Names (Specification).Name;
+ else
+ if Current_Verbosity = High then
+ Write_Line (" not good");
+ end if;
+ end if;
+ end if;
+ end;
+ end if;
- begin
- -- Case of spec present
+ -- Check for spec
- if Current_Name /= No_Name then
- if Current_Verbosity = High then
- Write_Str (" Comparing with """);
- Write_Str (Get_Name_String (Current_Name));
- Write_Char ('"');
- Write_Eol;
- end if;
+ if not Main_Project_Only
+ or else Unit.File_Names (Specification).Project = The_Project
+ then
+ declare
+ Current_Name : constant Name_Id :=
+ Unit.File_Names (Specification).Name;
- -- If name same as the original name, return original name
+ begin
+ -- Case of spec present
- if Unit.Name = The_Original_Name
- or else Current_Name = The_Original_Name
- then
+ if Current_Name /= No_Name then
if Current_Verbosity = High then
- Write_Line (" OK");
+ Write_Str (" Comparing with """);
+ Write_Str (Get_Name_String (Current_Name));
+ Write_Char ('"');
+ Write_Eol;
end if;
- return Get_Name_String (Current_Name);
+ -- If name same as the original name, return original
+ -- name.
- -- If it has the same name as the extended spec name,
- -- return the extended spec name.
+ if Unit.Name = The_Original_Name
+ or else Current_Name = The_Original_Name
+ then
+ if Current_Verbosity = High then
+ Write_Line (" OK");
+ end if;
- elsif Current_Name = The_Spec_Name then
- if Current_Verbosity = High then
- Write_Line (" OK");
- end if;
+ return Get_Name_String (Current_Name);
- return Extended_Spec_Name;
+ -- If it has the same name as the extended spec name,
+ -- return the extended spec name.
- else
- if Current_Verbosity = High then
- Write_Line (" not good");
+ elsif Current_Name = The_Spec_Name then
+ if Current_Verbosity = High then
+ Write_Line (" OK");
+ end if;
+
+ return Extended_Spec_Name;
+
+ else
+ if Current_Verbosity = High then
+ Write_Line (" not good");
+ end if;
end if;
end if;
- end if;
- end;
- end if;
+ end;
+ end if;
+ end loop;
+
+ -- If we are not in an extending project, give up
+
+ exit when (not Main_Project_Only) or else Data.Extends = No_Project;
+
+ -- Otherwise, look in the project we are extending
+
+ The_Project := Data.Extends;
+ Data := Projects.Table (The_Project);
end loop;
-- We don't know this file name, return an empty string
@@ -1087,7 +1249,7 @@ package body Prj.Env is
procedure Add (Project : Project_Id);
-- Process a project. Remember the processes visited to avoid
-- processing a project twice. Recursively process an eventual
- -- modified project, and all imported projects.
+ -- extended project, and all imported projects.
---------
-- Add --
@@ -1146,8 +1308,8 @@ package body Prj.Env is
-- If we are extending a project, visit it
- if Data.Modifies /= No_Project then
- Add (Data.Modifies);
+ if Data.Extends /= No_Project then
+ Add (Data.Extends);
end if;
-- And visit all imported projects
@@ -1177,7 +1339,7 @@ package body Prj.Env is
procedure Add (Project : Project_Id);
-- Process a project. Remember the processes visited to avoid
-- processing a project twice. Recursively process an eventual
- -- modified project, and all imported projects.
+ -- extended project, and all imported projects.
---------
-- Add --
@@ -1235,16 +1397,15 @@ package body Prj.Env is
while Current /= Nil_String loop
The_String := String_Elements.Table (Current);
- String_To_Name_Buffer (The_String.Value);
- Action (Name_Buffer (1 .. Name_Len));
+ Action (Get_Name_String (The_String.Value));
Current := The_String.Next;
end loop;
end;
-- If we are extending a project, visit it
- if Data.Modifies /= No_Project then
- Add (Data.Modifies);
+ if Data.Extends /= No_Project then
+ Add (Data.Extends);
end if;
-- And visit all imported projects
@@ -1299,8 +1460,9 @@ package body Prj.Env is
(Unit.File_Names (Specification).Path) =
Original_Name)
then
- Project := Unit.File_Names (Specification).Project;
- Path := Unit.File_Names (Specification).Path;
+ Project := Ultimate_Extension_Of
+ (Unit.File_Names (Specification).Project);
+ Path := Unit.File_Names (Specification).Display_Path;
if Current_Verbosity > Default then
Write_Str ("Done: Specification.");
@@ -1318,8 +1480,9 @@ package body Prj.Env is
(Unit.File_Names (Body_Part).Path) =
Original_Name)
then
- Project := Unit.File_Names (Body_Part).Project;
- Path := Unit.File_Names (Body_Part).Path;
+ Project := Ultimate_Extension_Of
+ (Unit.File_Names (Body_Part).Project);
+ Path := Unit.File_Names (Body_Part).Display_Path;
if Current_Verbosity > Default then
Write_Str ("Done: Body.");
@@ -1346,20 +1509,10 @@ package body Prj.Env is
----------------
procedure Initialize is
- Global : constant String := "global_configuration_pragmas";
- Local : constant String := "local_configuration_pragmas";
-
begin
- -- Put the standard GNAT naming scheme in the Namings table
-
- Namings.Increment_Last;
- Namings.Table (Namings.Last) := Standard_Naming_Data;
- Name_Len := Global'Length;
- Name_Buffer (1 .. Name_Len) := Global;
- Global_Configuration_Pragmas := Name_Find;
- Name_Len := Local'Length;
- Name_Buffer (1 .. Name_Len) := Local;
- Local_Configuration_Pragmas := Name_Find;
+ -- There is nothing to do anymore
+
+ null;
end Initialize;
------------------------------------
@@ -1379,7 +1532,7 @@ package body Prj.Env is
(Data.Naming.Current_Spec_Suffix);
Extended_Body_Name : String :=
Name & Namet.Get_Name_String
- (Data.Naming.Current_Impl_Suffix);
+ (Data.Naming.Current_Body_Suffix);
First : Unit_Id := Units.First;
Current : Unit_Id;
@@ -1388,7 +1541,7 @@ package body Prj.Env is
begin
Canonical_Case_File_Name (Original_Name);
Canonical_Case_File_Name (Extended_Spec_Name);
- Canonical_Case_File_Name (Extended_Spec_Name);
+ Canonical_Case_File_Name (Extended_Body_Name);
if Current_Verbosity = High then
Write_Str ("Looking for path name of """);
@@ -1548,6 +1701,206 @@ package body Prj.Env is
Write_Line ("end of List of Sources.");
end Print_Sources;
+ -------------------
+ -- Set_Ada_Paths --
+ -------------------
+
+ procedure Set_Ada_Paths
+ (Project : Project_Id;
+ Including_Libraries : Boolean)
+ is
+ Source_FD : File_Descriptor := Invalid_FD;
+ Object_FD : File_Descriptor := Invalid_FD;
+
+ Process_Source_Dirs : Boolean := False;
+ Process_Object_Dirs : Boolean := False;
+
+ Status : Boolean;
+ -- For calls to Close
+
+ procedure Add (Project : Project_Id);
+ -- Add all the source/object directories of a project to the path only
+ -- if this project has not been visited. Calls itself recursively for
+ -- projects being extended, and imported projects.
+
+ ---------
+ -- Add --
+ ---------
+
+ procedure Add (Project : Project_Id) is
+ begin
+ -- If Seen is False, then the project has not yet been visited
+
+ if not Projects.Table (Project).Seen then
+ Projects.Table (Project).Seen := True;
+
+ declare
+ Data : constant Project_Data := Projects.Table (Project);
+ List : Project_List := Data.Imported_Projects;
+
+ begin
+ if Process_Source_Dirs then
+
+ -- Add to path all source directories of this project
+
+ Add_To_Path_File (Data.Source_Dirs, Source_FD);
+ end if;
+
+ if Process_Object_Dirs then
+
+ -- Add to path the object directory of this project
+ -- except if we don't include library project and
+ -- this is a library project.
+
+ if (Data.Library and then Including_Libraries)
+ or else
+ (Data.Object_Directory /= No_Name
+ and then
+ (not Including_Libraries or else not Data.Library))
+ then
+ -- For a library project, add the library directory
+
+ if Data.Library then
+ declare
+ New_Path : constant String :=
+ Get_Name_String (Data.Library_Dir);
+
+ begin
+ Add_To_Path_File (New_Path, Object_FD);
+ end;
+
+ else
+ -- For a non library project, add the object directory
+
+ declare
+ New_Path : constant String :=
+ Get_Name_String (Data.Object_Directory);
+ begin
+ Add_To_Path_File (New_Path, Object_FD);
+ end;
+ end if;
+ end if;
+ end if;
+
+ -- Call Add to the project being extended, if any
+
+ if Data.Extends /= No_Project then
+ Add (Data.Extends);
+ end if;
+
+ -- Call Add for each imported project, if any
+
+ while List /= Empty_Project_List loop
+ Add (Project_Lists.Table (List).Project);
+ List := Project_Lists.Table (List).Next;
+ end loop;
+ end;
+ end if;
+ end Add;
+
+ -- Start of processing for Set_Ada_Paths
+
+ begin
+ -- If it is the first time we call this procedure for
+ -- this project, compute the source path and/or the object path.
+
+ if Projects.Table (Project).Include_Path_File = No_Name then
+ Process_Source_Dirs := True;
+ Create_New_Path_File
+ (Source_FD, Projects.Table (Project).Include_Path_File);
+ end if;
+
+ -- For the object path, we make a distinction depending on
+ -- Including_Libraries.
+
+ if Including_Libraries then
+ if Projects.Table (Project).Objects_Path_File_With_Libs = No_Name then
+ Process_Object_Dirs := True;
+ Create_New_Path_File
+ (Object_FD, Projects.Table (Project).
+ Objects_Path_File_With_Libs);
+ end if;
+
+ else
+ if
+ Projects.Table (Project).Objects_Path_File_Without_Libs = No_Name
+ then
+ Process_Object_Dirs := True;
+ Create_New_Path_File
+ (Object_FD, Projects.Table (Project).
+ Objects_Path_File_Without_Libs);
+ end if;
+ end if;
+
+ -- If there is something to do, set Seen to False for all projects,
+ -- then call the recursive procedure Add for Project.
+
+ if Process_Source_Dirs or Process_Object_Dirs then
+ for Index in 1 .. Projects.Last loop
+ Projects.Table (Index).Seen := False;
+ end loop;
+
+ Add (Project);
+ end if;
+
+ -- Close any file that has been created.
+
+ if Source_FD /= Invalid_FD then
+ Close (Source_FD, Status);
+
+ if not Status then
+ Prj.Com.Fail ("disk full");
+ end if;
+ end if;
+
+ if Object_FD /= Invalid_FD then
+ Close (Object_FD, Status);
+
+ if not Status then
+ Prj.Com.Fail ("disk full");
+ end if;
+ end if;
+
+ -- Set the env vars, if they need to be changed, and set the
+ -- corresponding flags.
+
+ if
+ Current_Source_Path_File /= Projects.Table (Project).Include_Path_File
+ then
+ Current_Source_Path_File :=
+ Projects.Table (Project).Include_Path_File;
+ Set_Path_File_Var
+ (Project_Include_Path_File,
+ Get_Name_String (Current_Source_Path_File));
+ Ada_Prj_Include_File_Set := True;
+ end if;
+
+ if Including_Libraries then
+ if Current_Object_Path_File
+ /= Projects.Table (Project).Objects_Path_File_With_Libs
+ then
+ Current_Object_Path_File :=
+ Projects.Table (Project).Objects_Path_File_With_Libs;
+ Set_Path_File_Var
+ (Project_Objects_Path_File,
+ Get_Name_String (Current_Object_Path_File));
+ Ada_Prj_Objects_File_Set := True;
+ end if;
+
+ else
+ if Current_Object_Path_File
+ /= Projects.Table (Project).Objects_Path_File_Without_Libs
+ then
+ Current_Object_Path_File :=
+ Projects.Table (Project).Objects_Path_File_Without_Libs;
+ Set_Path_File_Var
+ (Project_Objects_Path_File,
+ Get_Name_String (Current_Object_Path_File));
+ Ada_Prj_Objects_File_Set := True;
+ end if;
+ end if;
+ end Set_Ada_Paths;
+
---------------------------------------------
-- Set_Mapping_File_Initial_State_To_Empty --
---------------------------------------------
@@ -1558,6 +1911,23 @@ package body Prj.Env is
end Set_Mapping_File_Initial_State_To_Empty;
-----------------------
+ -- Set_Path_File_Var --
+ -----------------------
+
+ procedure Set_Path_File_Var (Name : String; Value : String) is
+ Host_Spec : String_Access := To_Host_File_Spec (Value);
+
+ begin
+ if Host_Spec = null then
+ Prj.Com.Fail
+ ("could not convert file name """, Value, """ to host spec");
+ else
+ Setenv (Name, Host_Spec.all);
+ Free (Host_Spec);
+ end if;
+ end Set_Path_File_Var;
+
+ -----------------------
-- Spec_Path_Name_Of --
-----------------------
@@ -1576,12 +1946,11 @@ package body Prj.Env is
Data.File_Names (Specification).Name;
while Current_Source /= Nil_String loop
- String_To_Name_Buffer
- (String_Elements.Table (Current_Source).Value);
Path := Locate_Regular_File
(Namet.Get_Name_String
(Data.File_Names (Specification).Name),
- Name_Buffer (1 .. Name_Len));
+ Namet.Get_Name_String
+ (String_Elements.Table (Current_Source).Value));
if Path /= null then
Name_Len := Path'Length;
@@ -1601,4 +1970,22 @@ package body Prj.Env is
return Namet.Get_Name_String (Data.File_Names (Specification).Path);
end Spec_Path_Name_Of;
+ ---------------------------
+ -- Ultimate_Extension_Of --
+ ---------------------------
+
+ function Ultimate_Extension_Of (Project : in Project_Id) return Project_Id
+ is
+ Result : Project_Id := Project;
+
+ begin
+ while Projects.Table (Result).Extended_By /= No_Project loop
+ Result := Projects.Table (Result).Extended_By;
+ end loop;
+
+ return Result;
+ end Ultimate_Extension_Of;
+
+begin
+ Path_Files.Set_Last (0);
end Prj.Env;
diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads
index ffcc39e4a23..e03d54afb39 100644
--- a/gcc/ada/prj-env.ads
+++ b/gcc/ada/prj-env.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc --
+-- Copyright (C) 2001-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- --
@@ -37,8 +37,11 @@ package Prj.Env is
procedure Print_Sources;
-- Output the list of sources, after Project files have been scanned
- procedure Create_Mapping_File (Name : in out Temp_File_Name);
- -- Create a temporary mapping file. For each unit, put the mapping of
+ procedure Create_Mapping_File
+ (Project : Project_Id;
+ Name : out Name_Id);
+ -- Create a temporary mapping file for project Project. For each unit
+ -- in the closure of immediate sources of Project, put the mapping of
-- its spec and or body to its file name and path name in this file.
procedure Set_Mapping_File_Initial_State_To_Empty;
@@ -46,15 +49,16 @@ package Prj.Env is
-- when run time source files are found in the project files.
procedure Create_Config_Pragmas_File
- (For_Project : Project_Id;
- Main_Project : Project_Id);
+ (For_Project : Project_Id;
+ Main_Project : Project_Id;
+ Include_Config_Files : Boolean := True);
-- If there needs to have SFN pragmas, either for non standard naming
- -- schemes or for individual units, or if Global_Configuration_Pragmas
- -- has been specified in package gnatmake of the main project, or if
- -- Local_Configuration_Pragmas has been specified in package Compiler
- -- of the main project, build (if needed) a temporary file that contains
- -- all configuration pragmas, and specify the configuration pragmas file
- -- in the project data.
+ -- schemes or for individual units, or (when Include_Config_Files is True)
+ -- if Global_Configuration_Pragmas has been specified in package gnatmake
+ -- of the main project, or if Local_Configuration_Pragmas has been
+ -- specified in package Compiler of the main project, build (if needed)
+ -- a temporary file that contains all configuration pragmas, and specify
+ -- the configuration pragmas file in the project data.
function Ada_Include_Path (Project : Project_Id) return String_Access;
-- Get the ADA_INCLUDE_PATH of a Project file. For the first call, compute
@@ -78,6 +82,16 @@ package Prj.Env is
-- it and cache it. When Including_Libraries is False, do not include the
-- object directories of the library projects, and do not cache the result.
+ procedure Set_Ada_Paths
+ (Project : Project_Id;
+ Including_Libraries : Boolean);
+ -- Set the env vars for additional project path files, after
+ -- creating if necessary the path files.
+
+ procedure Delete_All_Path_Files;
+ -- Delete all temporary path files that have been created by
+ -- calls to Set_Ada_Paths.
+
function Path_Name_Of_Library_Unit_Body
(Name : String;
Project : Project_Id)
@@ -85,20 +99,24 @@ package Prj.Env is
-- Returns the Path of a library unit.
function File_Name_Of_Library_Unit_Body
- (Name : String;
- Project : Project_Id)
- return String;
+ (Name : String;
+ Project : Project_Id;
+ Main_Project_Only : Boolean := True)
+ return String;
-- Returns the file name of a library unit, in canonical case. Name may or
-- may not have an extension (corresponding to the naming scheme of the
-- project). If there is no body with this name, but there is a spec, the
-- name of the spec is returned. If neither a body or a spec can be found,
-- return an empty string.
+ -- If Main_Project_Only is True, the unit must be an immediate source of
+ -- Project. If it is False, it may be a source of one of its imported
+ -- projects.
procedure Get_Reference
(Source_File_Name : String;
Project : out Project_Id;
Path : out Name_Id);
- -- Returns the project of a source.
+ -- Returns the project of a source and its path in displayable form
generic
with procedure Action (Path : String);
diff --git a/gcc/ada/prj-err.adb b/gcc/ada/prj-err.adb
new file mode 100644
index 00000000000..b3d4b5641aa
--- /dev/null
+++ b/gcc/ada/prj-err.adb
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- P R J . E R R --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Namet; use Namet;
+with Output; use Output;
+with Scans; use Scans;
+with Stringt; use Stringt;
+
+package body Prj.Err is
+
+ ---------------
+ -- Post_Scan --
+ ---------------
+
+ procedure Post_Scan is
+ Debug_Tokens : constant Boolean := False;
+
+ begin
+ -- Change operator symbol to literal strings, since that's the way
+ -- we treat all strings in a project file.
+
+ if Token = Tok_Operator_Symbol
+ or else Token = Tok_String_Literal
+ then
+ Token := Tok_String_Literal;
+ String_To_Name_Buffer (String_Literal_Id);
+ Token_Name := Name_Find;
+ end if;
+
+ if Debug_Tokens then
+ Write_Line (Token_Type'Image (Token));
+
+ if Token = Tok_Identifier
+ or else Token = Tok_String_Literal
+ then
+ Write_Line (" " & Get_Name_String (Token_Name));
+ end if;
+ end if;
+ end Post_Scan;
+
+end Prj.Err;
diff --git a/gcc/ada/prj-err.ads b/gcc/ada/prj-err.ads
new file mode 100644
index 00000000000..bfbdd28bfea
--- /dev/null
+++ b/gcc/ada/prj-err.ads
@@ -0,0 +1,100 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- P R J . E R R --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains the routines to output error messages and the
+-- scanner for the project files. It replaces Errout and Scn.
+-- It is not dependent on the GNAT tree packages (Atree, Sinfo, ...).
+-- It uses the same global variables as Errout, located in package
+-- Err_Vars. Like Errout, it also uses the common variables and routines
+-- in package Erroutc.
+
+with Scng;
+with Errutil;
+with Types; use Types;
+
+package Prj.Err is
+
+ ---------------------------------------------------------
+ -- Error Message Text and Message Insertion Characters --
+ ---------------------------------------------------------
+
+ -- See errutil.ads
+
+ -----------------------------------------------------
+ -- Format of Messages and Manual Quotation Control --
+ -----------------------------------------------------
+
+ -- See errutil.ads
+
+ ------------------------------
+ -- Error Output Subprograms --
+ ------------------------------
+
+ procedure Initialize renames Errutil.Initialize;
+ -- Initializes for output of error messages. Must be called for each
+ -- file before using any of the other routines in the package.
+
+ procedure Finalize (Source_Type : String := "project")
+ renames Errutil.Finalize;
+ -- Finalize processing of error messages for one file and output message
+ -- indicating the number of detected errors.
+
+ procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr)
+ renames Errutil.Error_Msg;
+ -- Output a message at specified location.
+
+ procedure Error_Msg_S (Msg : String) renames Errutil.Error_Msg_S;
+ -- Output a message at current scan pointer location.
+
+ procedure Error_Msg_SC (Msg : String) renames Errutil.Error_Msg_SC;
+ -- Output a message at the start of the current token, unless we are at
+ -- the end of file, in which case we always output the message after the
+ -- last real token in the file.
+
+ procedure Error_Msg_SP (Msg : String) renames Errutil.Error_Msg_SP;
+ -- Output a message at the start of the previous token.
+
+ -------------
+ -- Scanner --
+ -------------
+
+ package Style renames Errutil.Style;
+ -- Instantiation of the generic style package, needed for the instantiation
+ -- of the generic scanner below.
+
+ procedure Post_Scan;
+ -- Convert an Ada operator symbol into a standard string
+
+ package Scanner is new Scng
+ (Post_Scan => Post_Scan,
+ Error_Msg => Error_Msg,
+ Error_Msg_S => Error_Msg_S,
+ Error_Msg_SC => Error_Msg_SC,
+ Error_Msg_SP => Error_Msg_SP,
+ Style => Style);
+ -- Instantiation of the generic scanner
+
+end Prj.Err;
diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb
index 0f9939b3219..5d8368f145a 100644
--- a/gcc/ada/prj-ext.adb
+++ b/gcc/ada/prj-ext.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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- --
@@ -24,22 +24,28 @@
-- --
------------------------------------------------------------------------------
+with Namet; use Namet;
+with Osint; use Osint;
+with Prj.Com; use Prj.Com;
+with Types; use Types;
+
with GNAT.HTable;
with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Namet; use Namet;
-with Prj.Com; use Prj.Com;
-with Stringt; use Stringt;
-with Types; use Types;
package body Prj.Ext is
package Htable is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
- Element => String_Id,
- No_Element => No_String,
+ Element => Name_Id,
+ No_Element => No_Name,
Key => Name_Id,
Hash => Hash,
Equal => "=");
+ -- External references are stored in this hash table, either by procedure
+ -- Add (directly or through a call to function Check) or by function
+ -- Value_Of when an environment variable is found non empty. Value_Of
+ -- first for external reference in this table, before checking the
+ -- environment. Htable is emptied (reset) by procedure Reset.
---------
-- Add --
@@ -50,14 +56,15 @@ package body Prj.Ext is
Value : String)
is
The_Key : Name_Id;
- The_Value : String_Id;
+ The_Value : Name_Id;
begin
- Start_String;
- Store_String_Chars (Value);
- The_Value := End_String;
+ Name_Len := Value'Length;
+ Name_Buffer (1 .. Name_Len) := Value;
+ The_Value := Name_Find;
Name_Len := External_Name'Length;
Name_Buffer (1 .. Name_Len) := External_Name;
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
The_Key := Name_Find;
Htable.Set (The_Key, The_Value);
end Add;
@@ -69,7 +76,6 @@ package body Prj.Ext is
function Check (Declaration : String) return Boolean is
begin
for Equal_Pos in Declaration'Range loop
-
if Declaration (Equal_Pos) = '=' then
exit when Equal_Pos = Declaration'First;
exit when Equal_Pos = Declaration'Last;
@@ -80,27 +86,39 @@ package body Prj.Ext is
Declaration (Equal_Pos + 1 .. Declaration'Last));
return True;
end if;
-
end loop;
return False;
end Check;
+ -----------
+ -- Reset --
+ -----------
+
+ procedure Reset is
+ begin
+ Htable.Reset;
+ end Reset;
+
--------------
-- Value_Of --
--------------
function Value_Of
(External_Name : Name_Id;
- With_Default : String_Id := No_String)
- return String_Id
+ With_Default : Name_Id := No_Name)
+ return Name_Id
is
- The_Value : String_Id;
+ The_Value : Name_Id;
+ Name : String := Get_Name_String (External_Name);
begin
- The_Value := Htable.Get (External_Name);
+ Canonical_Case_File_Name (Name);
+ Name_Len := Name'Length;
+ Name_Buffer (1 .. Name_Len) := Name;
+ The_Value := Htable.Get (Name_Find);
- if The_Value /= No_String then
+ if The_Value /= No_Name then
return The_Value;
end if;
@@ -108,18 +126,19 @@ package body Prj.Ext is
-- If it is, put the value in the hash table.
declare
- Env_Value : constant String_Access :=
- Getenv (Get_Name_String (External_Name));
+ Env_Value : String_Access := Getenv (Name);
begin
if Env_Value /= null and then Env_Value'Length > 0 then
- Start_String;
- Store_String_Chars (Env_Value.all);
- The_Value := End_String;
+ Name_Len := Env_Value'Length;
+ Name_Buffer (1 .. Name_Len) := Env_Value.all;
+ The_Value := Name_Find;
Htable.Set (External_Name, The_Value);
+ Free (Env_Value);
return The_Value;
else
+ Free (Env_Value);
return With_Default;
end if;
end;
diff --git a/gcc/ada/prj-ext.ads b/gcc/ada/prj-ext.ads
index f234ea0f5e6..5fc2f4b01eb 100644
--- a/gcc/ada/prj-ext.ads
+++ b/gcc/ada/prj-ext.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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- --
@@ -24,8 +24,8 @@
-- --
------------------------------------------------------------------------------
--- Set, Get and cache External reference, to be used as External functions
--- in project files.
+-- Subprograms to set, get and cache external references, to be used as
+-- External functions in project files.
with Types; use Types;
@@ -38,12 +38,16 @@ package Prj.Ext is
function Value_Of
(External_Name : Name_Id;
- With_Default : String_Id := No_String)
- return String_Id;
+ With_Default : Name_Id := No_Name)
+ return Name_Id;
-- Get the value of an external reference, and cache it for future uses.
function Check (Declaration : String) return Boolean;
-- Check that an external declaration <external>=<value> is correct.
-- If it is correct, the external reference is Added.
+ procedure Reset;
+ -- Clear the internal data structure that stores the external references
+ -- and free any allocated memory.
+
end Prj.Ext;
diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb
index 8278910825e..efbbad2a0b8 100644
--- a/gcc/ada/prj-makr.adb
+++ b/gcc/ada/prj-makr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -30,11 +30,11 @@ with Opt;
with Output;
with Osint; use Osint;
with Prj; use Prj;
+with Prj.Com;
with Prj.Part;
with Prj.PP;
with Prj.Tree; use Prj.Tree;
with Snames; use Snames;
-with Stringt; use Stringt;
with Table; use Table;
with Ada.Characters.Handling; use Ada.Characters.Handling;
@@ -46,6 +46,9 @@ with GNAT.Regpat; use GNAT.Regpat;
package body Prj.Makr is
+ Non_Empty_Node : constant Project_Node_Id := 1;
+ -- Used for the With_Clause of the naming project
+
type Matched_Type is (True, False, Excluded);
Naming_File_Suffix : constant String := "_naming";
@@ -63,6 +66,14 @@ package body Prj.Makr is
procedure Write_A_String (S : String);
-- Write a String to Output_FD
+ package Processed_Directories is new Table.Table
+ (Table_Component_Type => String_Access,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 0,
+ Table_Initial => 10,
+ Table_Increment => 10,
+ Table_Name => "Prj.Makr.Processed_Directories");
+
----------
-- Make --
----------
@@ -73,10 +84,12 @@ package body Prj.Makr is
Directories : Argument_List;
Name_Patterns : Argument_List;
Excluded_Patterns : Argument_List;
+ Foreign_Patterns : Argument_List;
+ Preproc_Switches : Argument_List;
Very_Verbose : Boolean)
is
Path_Name : String (1 .. File_Path'Length +
- Project_File_Extension'Length);
+ Project_File_Extension'Length);
Path_Last : Natural := File_Path'Length;
Directory_Last : Natural := 0;
@@ -95,41 +108,36 @@ package body Prj.Makr is
Naming_Package : Project_Node_Id := Empty_Node;
Project_Naming_File_Name : String (1 .. Output_Name'Length +
- Naming_File_Suffix'Length);
+ Naming_File_Suffix'Length);
Project_Naming_Last : Natural;
Project_Naming_Id : Name_Id := No_Name;
Excluded_Expressions : array (Excluded_Patterns'Range) of Regexp;
Regular_Expressions : array (Name_Patterns'Range) of Regexp;
+ Foreign_Expressions : array (Foreign_Patterns'Range) of Regexp;
Source_List_Path : String (1 .. Output_Name'Length +
- Source_List_File_Suffix'Length);
+ Source_List_File_Suffix'Length);
Source_List_Last : Natural;
Source_List_FD : File_Descriptor;
- Str : String (1 .. 2_000);
- Last : Natural;
- Dir : Dir_Type;
-
- PD : Process_Descriptor;
- Result : Expect_Match;
Matcher : constant Pattern_Matcher :=
Compile (Expression => "expected|Unit.*\)|No such");
- Args : Argument_List :=
- (1 => new String'("-c"),
- 2 => new String'("-gnats"),
- 3 => new String'("-gnatu"),
- 4 => new String'("-x"),
- 5 => new String'("ada"),
- 6 => null);
+ Args : Argument_List (1 .. Preproc_Switches'Length + 6);
+-- (1 => new String'("-c"),
+-- 2 => new String'("-gnats"),
+-- 3 => new String'("-gnatu"),
+-- 4 => new String'("-x"),
+-- 5 => new String'("ada"),
+-- 6 => null);
type SFN_Pragma is record
- Unit : String_Access;
- File : String_Access;
- Spec : Boolean;
+ Unit : String_Access;
+ File : String_Access;
+ Spec : Boolean;
end record;
package SFN_Pragmas is new Table.Table
@@ -140,6 +148,338 @@ package body Prj.Makr is
Table_Increment => 50,
Table_Name => "Prj.Makr.SFN_Pragmas");
+ procedure Process_Directory (Dir_Name : String; Recursively : Boolean);
+ -- Look for Ada and foreign sources in a directory, according to the
+ -- patterns. When Recursively is True, after looking for sources in
+ -- Dir_Name, look also in its subdirectories, if any.
+
+ -----------------------
+ -- Process_Directory --
+ -----------------------
+
+ procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is
+ Matched : Matched_Type := False;
+ Str : String (1 .. 2_000);
+ Last : Natural;
+ Dir : Dir_Type;
+ Process : Boolean := True;
+
+ begin
+ if Opt.Verbose_Mode then
+ Output.Write_Str ("Processing directory """);
+ Output.Write_Str (Dir_Name);
+ Output.Write_Line ("""");
+ end if;
+
+ -- Avoid processing several times the same directory.
+
+ for Index in 1 .. Processed_Directories.Last loop
+ if Processed_Directories.Table (Index).all = Dir_Name then
+ Process := False;
+ exit;
+ end if;
+ end loop;
+
+ if Process then
+ Processed_Directories. Increment_Last;
+ Processed_Directories.Table (Processed_Directories.Last) :=
+ new String'(Dir_Name);
+ -- Get the source file names from the directory.
+ -- Fails if the directory does not exist.
+
+ begin
+ Open (Dir, Dir_Name);
+
+ exception
+ when Directory_Error =>
+ Prj.Com.Fail ("cannot open directory """, Dir_Name, """");
+ end;
+
+ -- Process each regular file in the directory
+
+ loop
+ Read (Dir, Str, Last);
+ exit when Last = 0;
+
+ if Is_Regular_File
+ (Dir_Name & Directory_Separator & Str (1 .. Last))
+ then
+ Matched := True;
+
+ -- First, check if the file name matches at least one of
+ -- the excluded expressions;
+
+ for Index in Excluded_Expressions'Range loop
+ if
+ Match (Str (1 .. Last), Excluded_Expressions (Index))
+ then
+ Matched := Excluded;
+ exit;
+ end if;
+ end loop;
+
+ -- If it does not match any of the excluded expressions,
+ -- check if the file name matches at least one of the
+ -- regular expressions.
+
+ if Matched = True then
+ Matched := False;
+
+ for Index in Regular_Expressions'Range loop
+ if
+ Match (Str (1 .. Last), Regular_Expressions (Index))
+ then
+ Matched := True;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ if Very_Verbose
+ or else (Matched = True and then Opt.Verbose_Mode)
+ then
+ Output.Write_Str (" Checking """);
+ Output.Write_Str (Str (1 .. Last));
+ Output.Write_Str (""": ");
+ end if;
+
+ -- If the file name matches one of the regular expressions,
+ -- parse it to get its unit name.
+
+ if Matched = True then
+ declare
+ PD : Process_Descriptor;
+ Result : Expect_Match;
+
+ begin
+ Args (Args'Last) := new String'
+ (Dir_Name &
+ Directory_Separator &
+ Str (1 .. Last));
+
+ begin
+ Non_Blocking_Spawn
+ (PD, "gcc", Args, Err_To_Out => True);
+ Expect (PD, Result, Matcher);
+
+ exception
+ when Process_Died =>
+ if Opt.Verbose_Mode then
+ Output.Write_Str ("(process died) ");
+ end if;
+
+ Result := Expect_Timeout;
+ end;
+
+ if Result /= Expect_Timeout then
+
+ -- If we got a unit name, this is a valid source
+ -- file.
+
+ declare
+ S : constant String := Expect_Out_Match (PD);
+
+ begin
+ if S'Length >= 13
+ and then S (S'First .. S'First + 3) = "Unit"
+ then
+ if Opt.Verbose_Mode then
+ Output.Write_Str
+ (S (S'Last - 4 .. S'Last - 1));
+ Output.Write_Str (" of ");
+ Output.Write_Line
+ (S (S'First + 5 .. S'Last - 7));
+ end if;
+
+ if Project_File then
+
+ -- Add the corresponding attribute in the
+ -- Naming package of the naming project.
+
+ declare
+ Decl_Item : constant Project_Node_Id :=
+ Default_Project_Node
+ (Of_Kind =>
+ N_Declarative_Item);
+
+ Attribute : constant Project_Node_Id :=
+ Default_Project_Node
+ (Of_Kind =>
+ N_Attribute_Declaration);
+
+ Expression : constant Project_Node_Id :=
+ Default_Project_Node
+ (Of_Kind => N_Expression,
+ And_Expr_Kind => Single);
+
+ Term : constant Project_Node_Id :=
+ Default_Project_Node
+ (Of_Kind => N_Term,
+ And_Expr_Kind => Single);
+
+ Value : constant Project_Node_Id :=
+ Default_Project_Node
+ (Of_Kind => N_Literal_String,
+ And_Expr_Kind => Single);
+
+ begin
+ Set_Next_Declarative_Item
+ (Decl_Item,
+ To => First_Declarative_Item_Of
+ (Naming_Package));
+ Set_First_Declarative_Item_Of
+ (Naming_Package, To => Decl_Item);
+ Set_Current_Item_Node
+ (Decl_Item, To => Attribute);
+
+ if
+ S (S'Last - 5 .. S'Last) = "(spec)"
+ then
+ Set_Name_Of
+ (Attribute, To => Name_Spec);
+ else
+ Set_Name_Of
+ (Attribute,
+ To => Name_Body);
+ end if;
+
+ Name_Len := S'Last - S'First - 11;
+ Name_Buffer (1 .. Name_Len) :=
+ (To_Lower
+ (S (S'First + 5 .. S'Last - 7)));
+ Set_Associative_Array_Index_Of
+ (Attribute, To => Name_Find);
+
+ Set_Expression_Of
+ (Attribute, To => Expression);
+ Set_First_Term (Expression, To => Term);
+ Set_Current_Term (Term, To => Value);
+
+ Name_Len := Last;
+ Name_Buffer (1 .. Name_Len) :=
+ Str (1 .. Last);
+ Set_String_Value_Of
+ (Value, To => Name_Find);
+ end;
+
+ -- Add source file name to source list
+ -- file.
+
+ Last := Last + 1;
+ Str (Last) := ASCII.LF;
+
+ if Write (Source_List_FD,
+ Str (1)'Address,
+ Last) /= Last
+ then
+ Prj.Com.Fail ("disk full");
+ end if;
+ else
+ -- Add an entry in the SFN_Pragmas table
+
+ SFN_Pragmas.Increment_Last;
+ SFN_Pragmas.Table (SFN_Pragmas.Last) :=
+ (Unit => new String'
+ (S (S'First + 5 .. S'Last - 7)),
+ File => new String'(Str (1 .. Last)),
+ Spec => S (S'Last - 5 .. S'Last)
+ = "(spec)");
+ end if;
+
+ else
+ if Opt.Verbose_Mode then
+ Output.Write_Line ("not a unit");
+ end if;
+ end if;
+ end;
+
+ else
+ if Opt.Verbose_Mode then
+ Output.Write_Line ("not a unit");
+ end if;
+ end if;
+
+ Close (PD);
+ end;
+
+ else
+ if Matched = False then
+ -- Look if this is a foreign source
+
+ for Index in Foreign_Expressions'Range loop
+ if Match (Str (1 .. Last),
+ Foreign_Expressions (Index))
+ then
+ Matched := True;
+ exit;
+ end if;
+ end loop;
+ end if;
+
+ if Very_Verbose then
+ case Matched is
+ when False =>
+ Output.Write_Line ("no match");
+
+ when Excluded =>
+ Output.Write_Line ("excluded");
+
+ when True =>
+ Output.Write_Line ("foreign source");
+ end case;
+ end if;
+
+ if Project_File and Matched = True then
+
+ -- Add source file name to source list file
+
+ Last := Last + 1;
+ Str (Last) := ASCII.LF;
+
+ if Write (Source_List_FD,
+ Str (1)'Address,
+ Last) /= Last
+ then
+ Prj.Com.Fail ("disk full");
+ end if;
+ end if;
+ end if;
+ end if;
+ end loop;
+
+ Close (Dir);
+ end if;
+
+ -- If Recursively is True, call itself for each subdirectory.
+ -- We do that, even when this directory has already been processed,
+ -- because all of its subdirectories may not have been processed.
+
+ if Recursively then
+ Open (Dir, Dir_Name);
+
+ loop
+ Read (Dir, Str, Last);
+ exit when Last = 0;
+
+ -- Do not call itself for "." or ".."
+
+ if Is_Directory
+ (Dir_Name & Directory_Separator & Str (1 .. Last))
+ and then Str (1 .. Last) /= "."
+ and then Str (1 .. Last) /= ".."
+ then
+ Process_Directory
+ (Dir_Name & Directory_Separator & Str (1 .. Last),
+ Recursively => True);
+ end if;
+ end loop;
+
+ Close (Dir);
+ end if;
+ end Process_Directory;
+
+ -- Start of processing for Make
+
begin
-- Do some needed initializations
@@ -150,6 +490,17 @@ package body Prj.Makr is
SFN_Pragmas.Set_Last (0);
+ Processed_Directories.Set_Last (0);
+
+ -- Initialize the compiler switches
+
+ Args (1) := new String'("-c");
+ Args (2) := new String'("-gnats");
+ Args (3) := new String'("-gnatu");
+ Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
+ Args (4 + Preproc_Switches'Length) := new String'("-x");
+ Args (5 + Preproc_Switches'Length) := new String'("ada");
+
-- Get the path and file names
if File_Names_Case_Sensitive then
@@ -173,8 +524,8 @@ package body Prj.Makr is
if Project_File then
if Path_Last < Project_File_Extension'Length + 1
or else Path_Name
- (Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
- /= Project_File_Extension
+ (Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
+ /= Project_File_Extension
then
Path_Last := Path_Name'Last;
end if;
@@ -201,7 +552,7 @@ package body Prj.Makr is
Output_Name (1 .. Project_Naming_Last);
Project_Naming_File_Name
(Project_Naming_Last + 1 ..
- Project_Naming_Last + Naming_File_Suffix'Length) :=
+ Project_Naming_Last + Naming_File_Suffix'Length) :=
Naming_File_Suffix;
Project_Naming_Last :=
Project_Naming_Last + Naming_File_Suffix'Length;
@@ -215,7 +566,7 @@ package body Prj.Makr is
Project_Naming_File_Name
(Project_Naming_Last + 1 ..
- Project_Naming_Last + Project_File_Extension'Length) :=
+ Project_Naming_Last + Project_File_Extension'Length) :=
Project_File_Extension;
Project_Naming_Last :=
Project_Naming_Last + Project_File_Extension'Length;
@@ -227,7 +578,7 @@ package body Prj.Makr is
Output_Name (1 .. Source_List_Last);
Source_List_Path
(Source_List_Last + 1 ..
- Source_List_Last + Source_List_File_Suffix'Length) :=
+ Source_List_Last + Source_List_File_Suffix'Length) :=
Source_List_File_Suffix;
Source_List_Last := Source_List_Last + Source_List_File_Suffix'Length;
@@ -235,7 +586,7 @@ package body Prj.Makr is
Output_Name
(Output_Name_Last + 1 ..
- Output_Name_Last + Project_File_Extension'Length) :=
+ Output_Name_Last + Project_File_Extension'Length) :=
Project_File_Extension;
Output_Name_Last := Output_Name_Last + Project_File_Extension'Length;
end if;
@@ -248,8 +599,10 @@ package body Prj.Makr is
Change_Dir (Path_Name (1 .. Directory_Last));
exception
when Directory_Error =>
- Fail ("unknown directory """ &
- Path_Name (1 .. Directory_Last) & '"');
+ Prj.Com.Fail
+ ("unknown directory """,
+ Path_Name (1 .. Directory_Last),
+ """");
end;
end if;
@@ -274,8 +627,10 @@ package body Prj.Makr is
Fmode => Text);
if Source_List_FD = Invalid_FD then
- Fail ("cannot create file """ &
- Source_List_Path (1 .. Source_List_Last) & '"');
+ Prj.Com.Fail
+ ("cannot create file """,
+ Source_List_Path (1 .. Source_List_Last),
+ """");
end if;
end if;
@@ -283,26 +638,62 @@ package body Prj.Makr is
-- the specified strings is in error.
for Index in Excluded_Expressions'Range loop
+ if Very_Verbose then
+ Output.Write_Str ("Excluded pattern: """);
+ Output.Write_Str (Excluded_Patterns (Index).all);
+ Output.Write_Line ("""");
+ end if;
+
begin
Excluded_Expressions (Index) :=
Compile (Pattern => Excluded_Patterns (Index).all, Glob => True);
exception
when Error_In_Regexp =>
- Fail ("invalid regular expression """ &
- Excluded_Patterns (Index).all & '"');
+ Prj.Com.Fail
+ ("invalid regular expression """,
+ Excluded_Patterns (Index).all,
+ """");
+ end;
+ end loop;
+
+ for Index in Foreign_Expressions'Range loop
+ if Very_Verbose then
+ Output.Write_Str ("Foreign pattern: """);
+ Output.Write_Str (Foreign_Patterns (Index).all);
+ Output.Write_Line ("""");
+ end if;
+
+ begin
+ Foreign_Expressions (Index) :=
+ Compile (Pattern => Foreign_Patterns (Index).all, Glob => True);
+
+ exception
+ when Error_In_Regexp =>
+ Prj.Com.Fail
+ ("invalid regular expression """,
+ Foreign_Patterns (Index).all,
+ """");
end;
end loop;
for Index in Regular_Expressions'Range loop
+ if Very_Verbose then
+ Output.Write_Str ("Pattern: """);
+ Output.Write_Str (Name_Patterns (Index).all);
+ Output.Write_Line ("""");
+ end if;
+
begin
Regular_Expressions (Index) :=
Compile (Pattern => Name_Patterns (Index).all, Glob => True);
exception
when Error_In_Regexp =>
- Fail ("invalid regular expression """ &
- Name_Patterns (Index).all & '"');
+ Prj.Com.Fail
+ ("invalid regular expression """,
+ Name_Patterns (Index).all,
+ """");
end;
end loop;
@@ -370,8 +761,9 @@ package body Prj.Makr is
declare
Declaration : Project_Node_Id :=
- First_Declarative_Item_Of
- (Project_Declaration_Of (Project_Node));
+ First_Declarative_Item_Of
+ (Project_Declaration_Of
+ (Project_Node));
Previous : Project_Node_Id := Empty_Node;
Current_Node : Project_Node_Id := Empty_Node;
@@ -381,14 +773,14 @@ package body Prj.Makr is
if (Kind_Of (Current_Node) = N_Attribute_Declaration
and then
- (Tree.Name_Of (Current_Node) = Name_Source_Files
- or else Tree.Name_Of (Current_Node) =
- Name_Source_List_File
- or else Tree.Name_Of (Current_Node) =
- Name_Source_Dirs))
+ (Tree.Name_Of (Current_Node) = Name_Source_Files
+ or else Tree.Name_Of (Current_Node) =
+ Name_Source_List_File
+ or else Tree.Name_Of (Current_Node) =
+ Name_Source_Dirs))
or else
- (Kind_Of (Current_Node) = N_Package_Declaration
- and then Tree.Name_Of (Current_Node) = Name_Naming)
+ (Kind_Of (Current_Node) = N_Package_Declaration
+ and then Tree.Name_Of (Current_Node) = Name_Naming)
then
if Previous = Empty_Node then
Set_First_Declarative_Item_Of
@@ -482,10 +874,17 @@ package body Prj.Makr is
(With_Clause, To => First_With_Clause_Of (Project_Node));
Set_First_With_Clause_Of (Project_Node, To => With_Clause);
Set_Name_Of (With_Clause, To => Project_Naming_Id);
- Start_String;
- Store_String_Chars
- (Project_Naming_File_Name (1 .. Project_Naming_Last));
- Set_String_Value_Of (With_Clause, To => End_String);
+
+ -- We set the project node to something different than
+ -- Empty_Node, so that Prj.PP does not generate a limited
+ -- with clause.
+
+ Set_Project_Node_Of (With_Clause, Non_Empty_Node);
+
+ Name_Len := Project_Naming_Last;
+ Name_Buffer (1 .. Name_Len) :=
+ Project_Naming_File_Name (1 .. Project_Naming_Last);
+ Set_String_Value_Of (With_Clause, To => Name_Find);
end;
Project_Declaration := Project_Declaration_Of (Project_Node);
@@ -586,9 +985,10 @@ package body Prj.Makr is
Set_Expression_Of (Attribute, To => Expression);
Set_First_Term (Expression, To => Term);
Set_Current_Term (Term, To => Value);
- Start_String;
- Store_String_Chars (Source_List_Path (1 .. Source_List_Last));
- Set_String_Value_Of (Value, To => End_String);
+ Name_Len := Source_List_Last;
+ Name_Buffer (1 .. Name_Len) :=
+ Source_List_Path (1 .. Source_List_Last);
+ Set_String_Value_Of (Value, To => Name_Find);
end;
end if;
@@ -597,14 +997,15 @@ package body Prj.Makr is
for Index in Directories'Range loop
declare
- Dir_Name : constant String := Directories (Index).all;
- Matched : Matched_Type := False;
-
+ Dir_Name : constant String := Directories (Index).all;
+ Last : Natural := Dir_Name'Last;
+ Recursively : Boolean := False;
begin
- if Opt.Verbose_Mode then
- Output.Write_Str ("Processing directory """);
- Output.Write_Str (Dir_Name);
- Output.Write_Line ("""");
+ if Dir_Name'Length >= 4
+ and then (Dir_Name (Last - 2 .. Last) = "/**")
+ then
+ Last := Last - 3;
+ Recursively := True;
end if;
if Project_File then
@@ -639,233 +1040,15 @@ package body Prj.Makr is
Current_Source_Dir := Expression;
Set_First_Term (Expression, To => Term);
Set_Current_Term (Term, To => Value);
- Start_String;
- Store_String_Chars (S => Dir_Name);
- Set_String_Value_Of (Value, To => End_String);
+ Name_Len := Dir_Name'Length;
+ Name_Buffer (1 .. Name_Len) := Dir_Name;
+ Set_String_Value_Of (Value, To => Name_Find);
end;
end if;
- -- Get the source file names from the directory.
- -- Fails if the directory does not exist.
-
- begin
- Open (Dir, Dir_Name);
-
- exception
- when Directory_Error =>
- Fail ("cannot open directory """ & Dir_Name & '"');
- end;
-
- -- Process each regular file in the directory
-
- loop
- Read (Dir, Str, Last);
- exit when Last = 0;
-
- if Is_Regular_File
- (Dir_Name & Directory_Separator & Str (1 .. Last))
- then
- Matched := True;
-
- -- First, check if the file name matches at least one of
- -- the excluded expressions;
-
- for Index in Excluded_Expressions'Range loop
- if
- Match (Str (1 .. Last), Excluded_Expressions (Index))
- then
- Matched := Excluded;
- exit;
- end if;
- end loop;
-
- -- If it does not match any of the excluded expressions,
- -- check if the file name matches at least one of the
- -- regular expressions.
-
- if Matched = True then
- Matched := False;
- for Index in Regular_Expressions'Range loop
- if
- Match (Str (1 .. Last), Regular_Expressions (Index))
- then
- Matched := True;
- exit;
- end if;
- end loop;
- end if;
-
- if Very_Verbose
- or else (Matched = True and then Opt.Verbose_Mode)
- then
- Output.Write_Str (" Checking """);
- Output.Write_Str (Str (1 .. Last));
- Output.Write_Str (""": ");
- end if;
-
- -- If the file name matches one of the regular expressions,
- -- parse it to get its unit name.
-
- if Matched = True then
- Args (6) := new String'
- (Dir_Name &
- Directory_Separator &
- Str (1 .. Last));
-
- begin
- Non_Blocking_Spawn
- (PD, "gcc", Args, Err_To_Out => True);
- Expect (PD, Result, Matcher);
-
- exception
- when Process_Died =>
- if Opt.Verbose_Mode then
- Output.Write_Str ("(process died) ");
- end if;
-
- Result := Expect_Timeout;
- end;
-
- if Result /= Expect_Timeout then
-
- -- If we got a unit name, this is a valid source file
-
- declare
- S : constant String := Expect_Out_Match (PD);
-
- begin
- if S'Length >= 13
- and then S (S'First .. S'First + 3) = "Unit"
- then
- if Opt.Verbose_Mode then
- Output.Write_Str
- (S (S'Last - 4 .. S'Last - 1));
- Output.Write_Str (" of ");
- Output.Write_Line
- (S (S'First + 5 .. S'Last - 7));
- end if;
-
- if Project_File then
-
- -- Add the corresponding attribute in the
- -- Naming package of the naming project.
-
- declare
- Decl_Item : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind =>
- N_Declarative_Item);
-
- Attribute : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind =>
- N_Attribute_Declaration);
-
- Expression : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Expression,
- And_Expr_Kind => Single);
-
- Term : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Term,
- And_Expr_Kind => Single);
-
- Value : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Literal_String,
- And_Expr_Kind => Single);
-
- begin
- Set_Next_Declarative_Item
- (Decl_Item,
- To => First_Declarative_Item_Of
- (Naming_Package));
- Set_First_Declarative_Item_Of
- (Naming_Package, To => Decl_Item);
- Set_Current_Item_Node
- (Decl_Item, To => Attribute);
-
- if S (S'Last - 5 .. S'Last) = "(spec)" then
- Set_Name_Of
- (Attribute, To => Name_Specification);
- else
- Set_Name_Of
- (Attribute,
- To => Name_Implementation);
- end if;
-
- Start_String;
- Store_String_Chars
- (To_Lower
- (S (S'First + 5 .. S'Last - 7)));
- Set_Associative_Array_Index_Of
- (Attribute, To => End_String);
-
- Set_Expression_Of
- (Attribute, To => Expression);
- Set_First_Term (Expression, To => Term);
- Set_Current_Term (Term, To => Value);
-
- Start_String;
- Store_String_Chars (Str (1 .. Last));
- Set_String_Value_Of
- (Value, To => End_String);
- end;
-
- -- Add source file name to source list file
-
- Last := Last + 1;
- Str (Last) := ASCII.LF;
-
- if Write (Source_List_FD,
- Str (1)'Address,
- Last) /= Last
- then
- Fail ("disk full");
- end if;
- else
- -- Add an entry in the SFN_Pragmas table
-
- SFN_Pragmas.Increment_Last;
- SFN_Pragmas.Table (SFN_Pragmas.Last) :=
- (Unit => new String'
- (S (S'First + 5 .. S'Last - 7)),
- File => new String'(Str (1 .. Last)),
- Spec => S (S'Last - 5 .. S'Last)
- = "(spec)");
- end if;
-
- else
- if Opt.Verbose_Mode then
- Output.Write_Line ("not a unit");
- end if;
- end if;
- end;
-
- else
- if Opt.Verbose_Mode then
- Output.Write_Line ("not a unit");
- end if;
- end if;
-
- Close (PD);
-
- else
- if Very_Verbose then
- if Matched = False then
- Output.Write_Line ("no match");
-
- else
- Output.Write_Line ("excluded");
- end if;
- end if;
- end if;
- end if;
- end loop;
-
- Close (Dir);
+ Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively);
end;
+
end loop;
if Project_File then
@@ -897,7 +1080,8 @@ package body Prj.Makr is
-- Fails if project file cannot be created
if Output_FD = Invalid_FD then
- Fail ("cannot create new """ & Path_Name (1 .. Path_Last) & '"');
+ Prj.Com.Fail
+ ("cannot create new """, Path_Name (1 .. Path_Last), """");
end if;
if Project_File then
@@ -908,7 +1092,8 @@ package body Prj.Makr is
(Project_Node,
W_Char => Write_A_Char'Access,
W_Eol => Write_Eol'Access,
- W_Str => Write_A_String'Access);
+ W_Str => Write_A_String'Access,
+ Backward_Compatibility => False);
Close (Output_FD);
-- Delete the naming project file if it already exists
@@ -922,7 +1107,7 @@ package body Prj.Makr is
if Opt.Verbose_Mode then
Output.Write_Str ("Creating new naming project file """);
Output.Write_Str (Project_Naming_File_Name
- (1 .. Project_Naming_Last));
+ (1 .. Project_Naming_Last));
Output.Write_Line ("""");
end if;
@@ -933,9 +1118,10 @@ package body Prj.Makr is
-- Fails if naming project file cannot be created
if Output_FD = Invalid_FD then
- Fail ("cannot create new """ &
- Project_Naming_File_Name (1 .. Project_Naming_Last) &
- '"');
+ Prj.Com.Fail
+ ("cannot create new """,
+ Project_Naming_File_Name (1 .. Project_Naming_Last),
+ """");
end if;
-- Output the naming project file
@@ -944,7 +1130,8 @@ package body Prj.Makr is
(Project_Naming_Node,
W_Char => Write_A_Char'Access,
W_Eol => Write_Eol'Access,
- W_Str => Write_A_String'Access);
+ W_Str => Write_A_String'Access,
+ Backward_Compatibility => False);
Close (Output_FD);
else
@@ -1006,7 +1193,7 @@ package body Prj.Makr is
Str := S;
if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
- Fail ("disk full");
+ Prj.Com.Fail ("disk full");
end if;
end if;
end Write_A_String;
diff --git a/gcc/ada/prj-makr.ads b/gcc/ada/prj-makr.ads
index 868e9a91876..3cf53b587a6 100644
--- a/gcc/ada/prj-makr.ads
+++ b/gcc/ada/prj-makr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -39,6 +39,8 @@ package Prj.Makr is
Directories : Argument_List;
Name_Patterns : Argument_List;
Excluded_Patterns : Argument_List;
+ Foreign_Patterns : Argument_List;
+ Preproc_Switches : Argument_List;
Very_Verbose : Boolean);
-- Create a project file or a configuration pragmas file
--
@@ -59,5 +61,11 @@ package Prj.Makr is
-- all the specs and bodies for the project.
-- A file containing the source file names is automatically
-- generated and used as the Source_File_List for the project file.
+ -- It includes all sources that follow the Foreign_Patterns (except those
+ -- that follow Excluded_Patterns).
+
+ -- Preproc_switches is a list of optional preprocessor switches -gnatep=
+ -- and -gnateD that are used when invoking the compiler to find the
+ -- unit name and kind.
end Prj.Makr;
diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb
index 38e5c579a47..27662a3f89e 100644
--- a/gcc/ada/prj-nmsc.adb
+++ b/gcc/ada/prj-nmsc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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- --
@@ -24,17 +24,20 @@
-- --
------------------------------------------------------------------------------
-with Errout;
+with Err_Vars; use Err_Vars;
+with Fmap; use Fmap;
with Hostparm;
with MLib.Tgt;
with Namet; use Namet;
with Osint; use Osint;
with Output; use Output;
+with MLib.Tgt; use MLib.Tgt;
with Prj.Com; use Prj.Com;
with Prj.Env; use Prj.Env;
+with Prj.Err;
with Prj.Util; use Prj.Util;
+with Sinput.P;
with Snames; use Snames;
-with Stringt; use Stringt;
with Types; use Types;
with Ada.Characters.Handling; use Ada.Characters.Handling;
@@ -45,36 +48,77 @@ with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.HTable;
package body Prj.Nmsc is
- Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator;
-
Error_Report : Put_Line_Access := null;
- Current_Project : Project_Id := No_Project;
- procedure Check_Ada_Naming_Scheme (Naming : Naming_Data);
+ ALI_Suffix : constant String := ".ali";
+
+ type Name_Location is record
+ Name : Name_Id;
+ Location : Source_Ptr;
+ Found : Boolean := False;
+ end record;
+ -- Information about file names found in string list attribute
+ -- Source_Files or in a source list file, stored in hash table
+ -- Source_Names, used by procedure
+ -- Ada_Check.Get_Path_Names_And_Record_Sources.
+
+ No_Name_Location : constant Name_Location :=
+ (Name => No_Name, Location => No_Location, Found => False);
+
+ package Source_Names is new GNAT.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Name_Location,
+ No_Element => No_Name_Location,
+ Key => Name_Id,
+ Hash => Hash,
+ Equal => "=");
+ -- Hash table to store file names found in string list attribute
+ -- Source_Files or in a source list file, stored in hash table
+ -- Source_Names, used by procedure
+ -- Ada_Check.Get_Path_Names_And_Record_Sources.
+
+ package Recursive_Dirs is new GNAT.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => Name_Id,
+ Hash => Hash,
+ Equal => "=");
+ -- Hash table to store recursive source directories, to avoid looking
+ -- several times, and to avoid cycles that may be introduced by symbolic
+ -- links.
+
+ function ALI_File_Name (Source : String) return String;
+ -- Return the ALI file name corresponding to a source.
+
+ procedure Check_Ada_Naming_Scheme
+ (Project : Project_Id;
+ Naming : Naming_Data);
-- Check that the package Naming is correct.
procedure Check_Ada_Name
- (Name : Name_Id;
+ (Name : String;
Unit : out Name_Id);
-- Check that a name is a valid Ada unit name.
- procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
+ procedure Error_Msg
+ (Project : Project_Id;
+ Msg : String;
+ Flag_Location : Source_Ptr);
-- Output an error message. If Error_Report is null, simply call
- -- Errout.Error_Msg. Otherwise, disregard Flag_Location and use
+ -- Prj.Err.Error_Msg. Otherwise, disregard Flag_Location and use
-- Error_Report.
- function Get_Name_String (S : String_Id) return String;
- -- Get the string from a String_Id
-
procedure Get_Unit
- (File_Name : Name_Id;
- Naming : Naming_Data;
- Unit_Name : out Name_Id;
- Unit_Kind : out Spec_Or_Body;
- Needs_Pragma : out Boolean);
+ (Canonical_File_Name : Name_Id;
+ Naming : Naming_Data;
+ Unit_Name : out Name_Id;
+ Unit_Kind : out Spec_Or_Body;
+ Needs_Pragma : out Boolean);
-- Find out, from a file name, the unit name, the unit kind and if a
-- specific SFN pragma is needed. If the file name corresponds to no
-- unit, then Unit_Name will be No_Name.
@@ -87,61 +131,163 @@ package body Prj.Nmsc is
-- a spec suffix, a body suffix or a separate suffix.
procedure Record_Source
- (File_Name : Name_Id;
- Path_Name : Name_Id;
- Project : Project_Id;
- Data : in out Project_Data;
- Location : Source_Ptr;
- Current_Source : in out String_List_Id);
+ (File_Name : Name_Id;
+ Path_Name : Name_Id;
+ Project : Project_Id;
+ Data : in out Project_Data;
+ Location : Source_Ptr;
+ Current_Source : in out String_List_Id;
+ Source_Recorded : in out Boolean);
-- Put a unit in the list of units of a project, if the file name
-- corresponds to a valid unit name.
procedure Show_Source_Dirs (Project : Project_Id);
-- List all the source directories of a project.
- function Locate_Directory
- (Name : Name_Id;
- Parent : Name_Id)
- return Name_Id;
+ procedure Locate_Directory
+ (Name : Name_Id;
+ Parent : Name_Id;
+ Dir : out Name_Id;
+ Display : out Name_Id);
-- Locate a directory.
-- Returns No_Name if directory does not exist.
function Path_Name_Of
- (File_Name : String_Id;
+ (File_Name : Name_Id;
Directory : Name_Id)
return String;
-- Returns the path name of a (non project) file.
-- Returns an empty string if file cannot be found.
- ---------------
- -- Ada_Check --
- ---------------
+ function Project_Extends
+ (Extending : Project_Id;
+ Extended : Project_Id)
+ return Boolean;
+ -- Returns True if Extending is extending directly or indirectly Extended.
+
+ procedure Check_Naming_Scheme
+ (Data : in out Project_Data;
+ Project : Project_Id);
+ -- Check the naming scheme part of Data
+
+ type Unit_Info is record
+ Kind : Spec_Or_Body;
+ Unit : Name_Id;
+ end record;
+ No_Unit : constant Unit_Info := (Specification, No_Name);
+
+ package Naming_Exceptions is new GNAT.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Unit_Info,
+ No_Element => No_Unit,
+ Key => Name_Id,
+ Hash => Hash,
+ Equal => "=");
+
+ function Hash (Unit : Unit_Info) return Header_Num;
+
+ package Reverse_Naming_Exceptions is new GNAT.HTable.Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Name_Id,
+ No_Element => No_Name,
+ Key => Unit_Info,
+ Hash => Hash,
+ Equal => "=");
+ -- A table to check if a unit with an exceptional name will hide
+ -- a source with a file name following the naming convention.
+
+ procedure Prepare_Naming_Exceptions
+ (List : Array_Element_Id;
+ Kind : Spec_Or_Body);
+ -- Prepare the internal hash tables used for checking naming exceptions.
+ -- Insert all elements of List in the tables.
+
+ procedure Free_Naming_Exceptions;
+ -- Free the internal hash tables used for checking naming exceptions
+
+ function Compute_Directory_Last (Dir : String) return Natural;
+ -- Return the index of the last significant character in Dir. This is used
+ -- to avoid duplicates '/' at the end of directory names
+
+ ----------------------------
+ -- Compute_Directory_Last --
+ ----------------------------
+
+ function Compute_Directory_Last (Dir : String) return Natural is
+ begin
+ if Dir'Length > 1
+ and then (Dir (Dir'Last - 1) = Directory_Separator
+ or else Dir (Dir'Last - 1) = '/')
+ then
+ return Dir'Last - 1;
+ else
+ return Dir'Last;
+ end if;
+ end Compute_Directory_Last;
- procedure Ada_Check
- (Project : Project_Id;
- Report_Error : Put_Line_Access)
+
+ -------------------------------
+ -- Prepare_Naming_Exceptions --
+ -------------------------------
+
+ procedure Prepare_Naming_Exceptions
+ (List : Array_Element_Id;
+ Kind : Spec_Or_Body)
is
- Data : Project_Data;
- Languages : Variable_Value := Nil_Variable_Value;
+ Current : Array_Element_Id := List;
+ Element : Array_Element;
- procedure Check_Unit_Names (List : Array_Element_Id);
- -- Check that a list of unit names contains only valid names.
+ begin
+ while Current /= No_Array_Element loop
+ Element := Array_Elements.Table (Current);
+
+ if Element.Index /= No_Name then
+ Naming_Exceptions.Set
+ (Element.Value.Value,
+ (Kind => Kind, Unit => Element.Index));
+ Reverse_Naming_Exceptions.Set
+ ((Kind => Kind, Unit => Element.Index),
+ Element.Value.Value);
+ end if;
- procedure Find_Sources;
- -- Find all the sources in all of the source directories
- -- of a project.
+ Current := Element.Next;
+ end loop;
+ end Prepare_Naming_Exceptions;
- procedure Get_Path_Name_And_Record_Source
- (File_Name : String;
- Location : Source_Ptr;
- Current_Source : in out String_List_Id);
- -- Find the path name of a source in the source directories and
- -- record the source, if found.
+ ----------
+ -- Hash --
+ ----------
- procedure Get_Sources_From_File
- (Path : String;
- Location : Source_Ptr);
- -- Get the sources of a project from a text file
+ function Hash (Unit : Unit_Info) return Header_Num is
+ begin
+ return Header_Num (Unit.Unit mod 2048);
+ end Hash;
+
+ ----------------------------
+ -- Free_Naming_Exceptions --
+ ----------------------------
+
+ procedure Free_Naming_Exceptions is
+ begin
+ Naming_Exceptions.Reset;
+ Reverse_Naming_Exceptions.Reset;
+ end Free_Naming_Exceptions;
+
+ -------------------------
+ -- Check_Naming_Scheme --
+ -------------------------
+
+ procedure Check_Naming_Scheme
+ (Data : in out Project_Data;
+ Project : Project_Id)
+ is
+ Naming_Id : constant Package_Id :=
+ Util.Value_Of (Name_Naming, Data.Decl.Packages);
+
+ Naming : Package_Element;
+
+ procedure Check_Unit_Names (List : Array_Element_Id);
+ -- Check that a list of unit names contains only valid names.
----------------------
-- Check_Unit_Names --
@@ -158,19 +304,27 @@ package body Prj.Nmsc is
while Current /= No_Array_Element loop
Element := Array_Elements.Table (Current);
+ -- Put file name in canonical case
+
+ Get_Name_String (Element.Value.Value);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Element.Value.Value := Name_Find;
+
-- Check that it contains a valid unit name
- Check_Ada_Name (Element.Index, Unit_Name);
+ Get_Name_String (Element.Index);
+ Check_Ada_Name (Name_Buffer (1 .. Name_Len), Unit_Name);
if Unit_Name = No_Name then
- Errout.Error_Msg_Name_1 := Element.Index;
+ Err_Vars.Error_Msg_Name_1 := Element.Index;
Error_Msg
- ("{ is not a valid unit name.",
+ (Project,
+ "{ is not a valid unit name.",
Element.Value.Location);
else
if Current_Verbosity = High then
- Write_Str (" Body_Part (""");
+ Write_Str (" Unit (""");
Write_Str (Get_Name_String (Unit_Name));
Write_Line (""")");
end if;
@@ -183,15 +337,325 @@ package body Prj.Nmsc is
end loop;
end Check_Unit_Names;
+ -- Start of processing for Check_Naming_Scheme
+
+ begin
+ -- If there is a package Naming, we will put in Data.Naming what is in
+ -- this package Naming.
+
+ if Naming_Id /= No_Package then
+ Naming := Packages.Table (Naming_Id);
+
+ if Current_Verbosity = High then
+ Write_Line ("Checking ""Naming"" for Ada.");
+ end if;
+
+ declare
+ Bodies : constant Array_Element_Id :=
+ Util.Value_Of (Name_Body, Naming.Decl.Arrays);
+
+ Specs : constant Array_Element_Id :=
+ Util.Value_Of (Name_Spec, Naming.Decl.Arrays);
+
+ begin
+ if Bodies /= No_Array_Element then
+
+ -- We have elements in the array Body_Part
+
+ if Current_Verbosity = High then
+ Write_Line ("Found Bodies.");
+ end if;
+
+ Data.Naming.Bodies := Bodies;
+ Check_Unit_Names (Bodies);
+
+ else
+ if Current_Verbosity = High then
+ Write_Line ("No Bodies.");
+ end if;
+ end if;
+
+ if Specs /= No_Array_Element then
+
+ -- We have elements in the array Specs
+
+ if Current_Verbosity = High then
+ Write_Line ("Found Specs.");
+ end if;
+
+ Data.Naming.Specs := Specs;
+ Check_Unit_Names (Specs);
+
+ else
+ if Current_Verbosity = High then
+ Write_Line ("No Specs.");
+ end if;
+ end if;
+ end;
+
+ -- We are now checking if variables Dot_Replacement, Casing,
+ -- Spec_Suffix, Body_Suffix and/or Separate_Suffix
+ -- exist.
+
+ -- For each variable, if it does not exist, we do nothing,
+ -- because we already have the default.
+
+ -- Check Dot_Replacement
+
+ declare
+ Dot_Replacement : constant Variable_Value :=
+ Util.Value_Of
+ (Name_Dot_Replacement,
+ Naming.Decl.Attributes);
+
+ begin
+ pragma Assert (Dot_Replacement.Kind = Single,
+ "Dot_Replacement is not a single string");
+
+ if not Dot_Replacement.Default then
+ Get_Name_String (Dot_Replacement.Value);
+
+ if Name_Len = 0 then
+ Error_Msg
+ (Project,
+ "Dot_Replacement cannot be empty",
+ Dot_Replacement.Location);
+
+ else
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Data.Naming.Dot_Replacement := Name_Find;
+ Data.Naming.Dot_Repl_Loc := Dot_Replacement.Location;
+ end if;
+ end if;
+ end;
+
+ if Current_Verbosity = High then
+ Write_Str (" Dot_Replacement = """);
+ Write_Str (Get_Name_String (Data.Naming.Dot_Replacement));
+ Write_Char ('"');
+ Write_Eol;
+ end if;
+
+ -- Check Casing
+
+ declare
+ Casing_String : constant Variable_Value :=
+ Util.Value_Of
+ (Name_Casing, Naming.Decl.Attributes);
+
+ begin
+ pragma Assert (Casing_String.Kind = Single,
+ "Casing is not a single string");
+
+ if not Casing_String.Default then
+ declare
+ Casing_Image : constant String :=
+ Get_Name_String (Casing_String.Value);
+ begin
+ declare
+ Casing : constant Casing_Type := Value (Casing_Image);
+ begin
+ Data.Naming.Casing := Casing;
+ end;
+
+ exception
+ when Constraint_Error =>
+ if Casing_Image'Length = 0 then
+ Error_Msg
+ (Project,
+ "Casing cannot be an empty string",
+ Casing_String.Location);
+
+ else
+ Name_Len := Casing_Image'Length;
+ Name_Buffer (1 .. Name_Len) := Casing_Image;
+ Err_Vars.Error_Msg_Name_1 := Name_Find;
+ Error_Msg
+ (Project,
+ "{ is not a correct Casing",
+ Casing_String.Location);
+ end if;
+ end;
+ end if;
+ end;
+
+ if Current_Verbosity = High then
+ Write_Str (" Casing = ");
+ Write_Str (Image (Data.Naming.Casing));
+ Write_Char ('.');
+ Write_Eol;
+ end if;
+
+ -- Check Spec_Suffix
+
+ declare
+ Ada_Spec_Suffix : constant Variable_Value :=
+ Prj.Util.Value_Of
+ (Index => Name_Ada,
+ In_Array => Data.Naming.Spec_Suffix);
+
+ begin
+ if Ada_Spec_Suffix.Kind = Single
+ and then Get_Name_String (Ada_Spec_Suffix.Value) /= ""
+ then
+ Data.Naming.Current_Spec_Suffix := Ada_Spec_Suffix.Value;
+ Data.Naming.Spec_Suffix_Loc := Ada_Spec_Suffix.Location;
+
+ else
+ Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
+ end if;
+ end;
+
+ if Current_Verbosity = High then
+ Write_Str (" Spec_Suffix = """);
+ Write_Str (Get_Name_String (Data.Naming.Current_Spec_Suffix));
+ Write_Char ('"');
+ Write_Eol;
+ end if;
+
+ -- Check Body_Suffix
+
+ declare
+ Ada_Body_Suffix : constant Variable_Value :=
+ Prj.Util.Value_Of
+ (Index => Name_Ada,
+ In_Array => Data.Naming.Body_Suffix);
+
+ begin
+ if Ada_Body_Suffix.Kind = Single
+ and then Get_Name_String (Ada_Body_Suffix.Value) /= ""
+ then
+ Data.Naming.Current_Body_Suffix := Ada_Body_Suffix.Value;
+ Data.Naming.Body_Suffix_Loc := Ada_Body_Suffix.Location;
+
+ else
+ Data.Naming.Current_Body_Suffix := Default_Ada_Body_Suffix;
+ end if;
+ end;
+
+ if Current_Verbosity = High then
+ Write_Str (" Body_Suffix = """);
+ Write_Str (Get_Name_String (Data.Naming.Current_Body_Suffix));
+ Write_Char ('"');
+ Write_Eol;
+ end if;
+
+ -- Check Separate_Suffix
+
+ declare
+ Ada_Sep_Suffix : constant Variable_Value :=
+ Prj.Util.Value_Of
+ (Variable_Name => Name_Separate_Suffix,
+ In_Variables => Naming.Decl.Attributes);
+
+ begin
+ if Ada_Sep_Suffix.Default then
+ Data.Naming.Separate_Suffix :=
+ Data.Naming.Current_Body_Suffix;
+
+ else
+ if Get_Name_String (Ada_Sep_Suffix.Value) = "" then
+ Error_Msg
+ (Project,
+ "Separate_Suffix cannot be empty",
+ Ada_Sep_Suffix.Location);
+
+ else
+ Data.Naming.Separate_Suffix := Ada_Sep_Suffix.Value;
+ Data.Naming.Sep_Suffix_Loc := Ada_Sep_Suffix.Location;
+ end if;
+ end if;
+ end;
+
+ if Current_Verbosity = High then
+ Write_Str (" Separate_Suffix = """);
+ Write_Str (Get_Name_String (Data.Naming.Separate_Suffix));
+ Write_Char ('"');
+ Write_Eol;
+ end if;
+
+ -- Check if Data.Naming is valid
+
+ Check_Ada_Naming_Scheme (Project, Data.Naming);
+
+ else
+ Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
+ Data.Naming.Current_Body_Suffix := Default_Ada_Body_Suffix;
+ Data.Naming.Separate_Suffix := Default_Ada_Body_Suffix;
+ end if;
+ end Check_Naming_Scheme;
+
+ ---------------
+ -- Ada_Check --
+ ---------------
+
+ procedure Ada_Check
+ (Project : Project_Id;
+ Report_Error : Put_Line_Access)
+ is
+ Data : Project_Data;
+ Languages : Variable_Value := Nil_Variable_Value;
+
+ Extending : Boolean := False;
+
+ function Check_Project (P : Project_Id) return Boolean;
+ -- Returns True if P is Project or a project extended by Project
+
+ procedure Find_Sources;
+ -- Find all the sources in all of the source directories
+ -- of a project.
+
+ procedure Get_Path_Names_And_Record_Sources;
+ -- Find the path names of the source files in the Source_Names table
+ -- in the source directories and record those that are Ada sources.
+
+ procedure Get_Sources_From_File
+ (Path : String;
+ Location : Source_Ptr);
+ -- Get the sources of a project from a text file
+
+ procedure Warn_If_Not_Sources
+ (Conventions : Array_Element_Id;
+ Specs : Boolean);
+ -- Check that individual naming conventions apply to immediate
+ -- sources of the project; if not, issue a warning.
+
+ -------------------
+ -- Check_Project --
+ -------------------
+
+ function Check_Project (P : Project_Id) return Boolean is
+ begin
+ if P = Project then
+ return True;
+ elsif Extending then
+ declare
+ Data : Project_Data := Projects.Table (Project);
+
+ begin
+ while Data.Extends /= No_Project loop
+ if P = Data.Extends then
+ return True;
+ end if;
+
+ Data := Projects.Table (Data.Extends);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Check_Project;
+
------------------
-- Find_Sources --
------------------
procedure Find_Sources is
- Source_Dir : String_List_Id := Data.Source_Dirs;
- Element : String_Element;
- Dir : Dir_Type;
- Current_Source : String_List_Id := Nil_String;
+ Source_Dir : String_List_Id := Data.Source_Dirs;
+ Element : String_Element;
+ Dir : Dir_Type;
+ Current_Source : String_List_Id := Nil_String;
+ Source_Recorded : Boolean := False;
begin
if Current_Verbosity = High then
@@ -202,14 +666,14 @@ package body Prj.Nmsc is
while Source_Dir /= Nil_String loop
begin
+ Source_Recorded := False;
Element := String_Elements.Table (Source_Dir);
- if Element.Value /= No_String then
+ if Element.Value /= No_Name then
declare
- Source_Directory : String
- (1 .. Integer (String_Length (Element.Value)));
+ Source_Directory : constant String :=
+ Get_Name_String (Element.Value);
+
begin
- String_To_Name_Buffer (Element.Value);
- Source_Directory := Name_Buffer (1 .. Name_Len);
if Current_Verbosity = High then
Write_Str ("Source_Dir = ");
Write_Line (Source_Directory);
@@ -219,6 +683,8 @@ package body Prj.Nmsc is
Open (Dir, Source_Directory);
+ -- Canonical_Case_File_Name (Source_Directory);
+
loop
Read (Dir, Name_Buffer, Name_Len);
@@ -229,22 +695,27 @@ package body Prj.Nmsc is
exit when Name_Len = 0;
- declare
- Path_Access : constant GNAT.OS_Lib.String_Access :=
- Locate_Regular_File
- (Name_Buffer (1 .. Name_Len),
- Source_Directory);
+ -- Canonical_Case_File_Name
+ -- (Name_Buffer (1 .. Name_Len));
- File_Name : Name_Id;
+ declare
+ File_Name : constant Name_Id := Name_Find;
+ Dir : constant String :=
+ Source_Directory &
+ Directory_Separator;
+ Dir_Last : constant Natural :=
+ Compute_Directory_Last (Dir);
+ Path : constant String :=
+ Normalize_Pathname
+ (Name => Name_Buffer (1 .. Name_Len),
+ Directory => Dir (Dir'First .. Dir_Last));
Path_Name : Name_Id;
begin
- -- If it is a regular file
+ if Is_Regular_File (Path) then
- if Path_Access /= null then
- File_Name := Name_Find;
- Name_Len := Path_Access'Length;
- Name_Buffer (1 .. Name_Len) := Path_Access.all;
+ Name_Len := Path'Length;
+ Name_Buffer (1 .. Name_Len) := Path;
Path_Name := Name_Find;
-- We attempt to register it as a source.
@@ -254,18 +725,13 @@ package body Prj.Nmsc is
-- duplicate unit name.
Record_Source
- (File_Name => File_Name,
- Path_Name => Path_Name,
- Project => Project,
- Data => Data,
- Location => No_Location,
- Current_Source => Current_Source);
-
- else
- if Current_Verbosity = High then
- Write_Line
- (" Not a regular file.");
- end if;
+ (File_Name => File_Name,
+ Path_Name => Path_Name,
+ Project => Project,
+ Data => Data,
+ Location => No_Location,
+ Current_Source => Current_Source,
+ Source_Recorded => Source_Recorded);
end if;
end;
end loop;
@@ -279,6 +745,10 @@ package body Prj.Nmsc is
null;
end;
+ if Source_Recorded then
+ String_Elements.Table (Source_Dir).Flag := True;
+ end if;
+
Source_Dir := Element.Next;
end loop;
@@ -287,100 +757,136 @@ package body Prj.Nmsc is
end if;
-- If we have looked for sources and found none, then
- -- it is an error. If a project is not supposed to contain
+ -- it is an error, except if it is an extending project.
+ -- If a non extending project is not supposed to contain
-- any source, then we never call Find_Sources.
- if Current_Source = Nil_String then
- Error_Msg ("there are no sources in this project",
- Data.Location);
+ if Data.Extends = No_Project
+ and then Current_Source = Nil_String
+ then
+ Error_Msg
+ (Project,
+ "there are no Ada sources in this project",
+ Data.Location);
end if;
end Find_Sources;
- -------------------------------------
- -- Get_Path_Name_And_Record_Source --
- -------------------------------------
+ ---------------------------------------
+ -- Get_Path_Names_And_Record_Sources --
+ ---------------------------------------
- procedure Get_Path_Name_And_Record_Source
- (File_Name : String;
- Location : Source_Ptr;
- Current_Source : in out String_List_Id)
- is
+ procedure Get_Path_Names_And_Record_Sources is
Source_Dir : String_List_Id := Data.Source_Dirs;
Element : String_Element;
- Path_Name : GNAT.OS_Lib.String_Access;
- File : Name_Id;
Path : Name_Id;
- Found : Boolean := False;
- Fname : String := File_Name;
+ Dir : Dir_Type;
+ Name : Name_Id;
+ Canonical_Name : Name_Id;
+ Name_Str : String (1 .. 1_024);
+ Last : Natural := 0;
+ NL : Name_Location;
- begin
- Canonical_Case_File_Name (Fname);
- Name_Len := Fname'Length;
- Name_Buffer (1 .. Name_Len) := Fname;
- File := Name_Find;
+ Current_Source : String_List_Id := Nil_String;
- if Current_Verbosity = High then
- Write_Str (" Checking """);
- Write_Str (Fname);
- Write_Line (""".");
- end if;
+ First_Error : Boolean := True;
+ Source_Recorded : Boolean := False;
+
+ begin
-- We look in all source directories for this file name
while Source_Dir /= Nil_String loop
+ Source_Recorded := False;
Element := String_Elements.Table (Source_Dir);
- if Current_Verbosity = High then
- Write_Str (" """);
- Write_Str (Get_Name_String (Element.Value));
- Write_Str (""": ");
- end if;
-
- Path_Name :=
- Locate_Regular_File
- (Fname,
- Get_Name_String (Element.Value));
-
- if Path_Name /= null then
+ declare
+ Dir_Path : constant String := Get_Name_String (Element.Value);
+ begin
if Current_Verbosity = High then
- Write_Line ("OK");
+ Write_Str ("checking directory """);
+ Write_Str (Dir_Path);
+ Write_Line ("""");
end if;
- Name_Len := Path_Name'Length;
- Name_Buffer (1 .. Name_Len) := Path_Name.all;
- Path := Name_Find;
+ Open (Dir, Dir_Path);
+
+ loop
+ Read (Dir, Name_Str, Last);
+ exit when Last = 0;
+ Name_Len := Last;
+ Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last);
+ Name := Name_Find;
+ Canonical_Case_File_Name (Name_Str (1 .. Last));
+ Name_Len := Last;
+ Name_Buffer (1 .. Name_Len) := Name_Str (1 .. Last);
+ Canonical_Name := Name_Find;
+ NL := Source_Names.Get (Canonical_Name);
+
+ if NL /= No_Name_Location and then not NL.Found then
+ NL.Found := True;
+ Source_Names.Set (Canonical_Name, NL);
+ Name_Len := Dir_Path'Length;
+ Name_Buffer (1 .. Name_Len) := Dir_Path;
+ Add_Char_To_Name_Buffer (Directory_Separator);
+ Add_Str_To_Name_Buffer (Name_Str (1 .. Last));
+ Path := Name_Find;
- -- Register the source if it is an Ada compilation unit..
+ if Current_Verbosity = High then
+ Write_Str (" found ");
+ Write_Line (Get_Name_String (Name));
+ end if;
- Record_Source
- (File_Name => File,
- Path_Name => Path,
- Project => Project,
- Data => Data,
- Location => Location,
- Current_Source => Current_Source);
- Found := True;
- exit;
+ -- Register the source if it is an Ada compilation unit..
- else
- if Current_Verbosity = High then
- Write_Line ("No");
- end if;
+ Record_Source
+ (File_Name => Name,
+ Path_Name => Path,
+ Project => Project,
+ Data => Data,
+ Location => NL.Location,
+ Current_Source => Current_Source,
+ Source_Recorded => Source_Recorded);
+ end if;
+ end loop;
+
+ Close (Dir);
+ end;
- Source_Dir := Element.Next;
+ if Source_Recorded then
+ String_Elements.Table (Source_Dir).Flag := True;
end if;
+
+ Source_Dir := Element.Next;
end loop;
- -- It is an error if a source file names in a source list or
+ -- It is an error if a source file name in a source list or
-- in a source list file is not found.
- if not Found then
- Errout.Error_Msg_Name_1 := File;
- Error_Msg ("source file { cannot be found", Location);
- end if;
+ NL := Source_Names.Get_First;
+
+ while NL /= No_Name_Location loop
+ if not NL.Found then
+ Err_Vars.Error_Msg_Name_1 := NL.Name;
+
+ if First_Error then
+ Error_Msg
+ (Project,
+ "source file { cannot be found",
+ NL.Location);
+ First_Error := False;
+
+ else
+ Error_Msg
+ (Project,
+ "\source file { cannot be found",
+ NL.Location);
+ end if;
+ end if;
- end Get_Path_Name_And_Record_Source;
+ NL := Source_Names.Get_Next;
+ end loop;
+ end Get_Path_Names_And_Record_Sources;
---------------------------
-- Get_Sources_From_File --
@@ -393,7 +899,7 @@ package body Prj.Nmsc is
File : Prj.Util.Text_File;
Line : String (1 .. 250);
Last : Natural;
- Current_Source : String_List_Id := Nil_String;
+ Source_Name : Name_Id;
begin
if Current_Verbosity = High then
@@ -407,8 +913,10 @@ package body Prj.Nmsc is
Prj.Util.Open (File, Path);
if not Prj.Util.Is_Valid (File) then
- Error_Msg ("file does not exist", Location);
+ Error_Msg (Project, "file does not exist", Location);
else
+ Source_Names.Reset;
+
while not Prj.Util.End_Of_File (File) loop
Prj.Util.Get_Line (File, Line, Last);
@@ -420,10 +928,16 @@ package body Prj.Nmsc is
if Last /= 0
and then (Last = 1 or else Line (1 .. 2) /= "--")
then
- Get_Path_Name_And_Record_Source
- (File_Name => Line (1 .. Last),
- Location => Location,
- Current_Source => Current_Source);
+ Name_Len := Last;
+ Name_Buffer (1 .. Name_Len) := Line (1 .. Last);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Source_Name := Name_Find;
+ Source_Names.Set
+ (K => Source_Name,
+ E =>
+ (Name => Source_Name,
+ Location => Location,
+ Found => False));
end if;
end loop;
@@ -431,23 +945,86 @@ package body Prj.Nmsc is
end if;
+ Get_Path_Names_And_Record_Sources;
+
-- We should have found at least one source.
-- If not, report an error.
- if Current_Source = Nil_String then
- Error_Msg ("this project has no source", Location);
+ if Data.Sources = Nil_String then
+ Error_Msg (Project,
+ "there are no Ada sources in this project",
+ Location);
end if;
end Get_Sources_From_File;
- -- Start of processing for Ada_Check
+ -------------------------
+ -- Warn_If_Not_Sources --
+ -------------------------
+
+ procedure Warn_If_Not_Sources
+ (Conventions : Array_Element_Id;
+ Specs : Boolean)
+ is
+ Conv : Array_Element_Id := Conventions;
+ Unit : Name_Id;
+ The_Unit_Id : Unit_Id;
+ The_Unit_Data : Unit_Data;
+ Location : Source_Ptr;
+
+ begin
+ while Conv /= No_Array_Element loop
+ Unit := Array_Elements.Table (Conv).Index;
+ Error_Msg_Name_1 := Unit;
+ Get_Name_String (Unit);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ Unit := Name_Find;
+ The_Unit_Id := Units_Htable.Get (Unit);
+ Location := Array_Elements.Table (Conv).Value.Location;
+
+ if The_Unit_Id = Prj.Com.No_Unit then
+ Error_Msg
+ (Project,
+ "?unknown unit {",
+ Location);
+
+ else
+ The_Unit_Data := Units.Table (The_Unit_Id);
+
+ if Specs then
+ if The_Unit_Data.File_Names (Specification).Project /=
+ Project
+ then
+ Error_Msg
+ (Project,
+ "?unit{ has no spec in this project",
+ Location);
+ end if;
+
+ else
+ if The_Unit_Data.File_Names (Com.Body_Part).Project /=
+ Project
+ then
+ Error_Msg
+ (Project,
+ "?unit{ has no body in this project",
+ Location);
+ end if;
+ end if;
+ end if;
+
+ Conv := Array_Elements.Table (Conv).Next;
+ end loop;
+ end Warn_If_Not_Sources;
+
+ -- Start of processing for Ada_Check
begin
Language_Independent_Check (Project, Report_Error);
Error_Report := Report_Error;
- Current_Project := Project;
Data := Projects.Table (Project);
+ Extending := Data.Extends /= No_Project;
Languages := Prj.Util.Value_Of (Name_Languages, Data.Decl.Attributes);
Data.Naming.Current_Language := Name_Ada;
@@ -462,7 +1039,7 @@ package body Prj.Nmsc is
begin
Look_For_Ada : while Current /= Nil_String loop
Element := String_Elements.Table (Current);
- String_To_Name_Buffer (Element.Value);
+ Get_Name_String (Element.Value);
To_Lower (Name_Buffer (1 .. Name_Len));
if Name_Buffer (1 .. Name_Len) = "ada" then
@@ -482,383 +1059,704 @@ package body Prj.Nmsc is
end;
end if;
- declare
- Naming_Id : constant Package_Id :=
- Util.Value_Of (Name_Naming, Data.Decl.Packages);
+ Check_Naming_Scheme (Data, Project);
- Naming : Package_Element;
+ Prepare_Naming_Exceptions (Data.Naming.Bodies, Body_Part);
+ Prepare_Naming_Exceptions (Data.Naming.Specs, Specification);
- begin
- -- If there is a package Naming, we will put in Data.Naming
- -- what is in this package Naming.
-
- if Naming_Id /= No_Package then
- Naming := Packages.Table (Naming_Id);
+ -- If we have source directories, then find the sources
- if Current_Verbosity = High then
- Write_Line ("Checking ""Naming"" for Ada.");
- end if;
+ if Data.Sources_Present then
+ if Data.Source_Dirs = Nil_String then
+ Data.Sources_Present := False;
+ else
declare
- Bodies : constant Array_Element_Id :=
- Util.Value_Of
- (Name_Implementation, Naming.Decl.Arrays);
+ Sources : constant Variable_Value :=
+ Util.Value_Of
+ (Name_Source_Files,
+ Data.Decl.Attributes);
- Specifications : constant Array_Element_Id :=
- Util.Value_Of
- (Name_Specification, Naming.Decl.Arrays);
+ Source_List_File : constant Variable_Value :=
+ Util.Value_Of
+ (Name_Source_List_File,
+ Data.Decl.Attributes);
- begin
- if Bodies /= No_Array_Element then
+ Locally_Removed : constant Variable_Value :=
+ Util.Value_Of
+ (Name_Locally_Removed_Files,
+ Data.Decl.Attributes);
- -- We have elements in the array Body_Part
- if Current_Verbosity = High then
- Write_Line ("Found Bodies.");
- end if;
+ begin
+ pragma Assert
+ (Sources.Kind = List,
+ "Source_Files is not a list");
- Data.Naming.Bodies := Bodies;
- Check_Unit_Names (Bodies);
+ pragma Assert
+ (Source_List_File.Kind = Single,
+ "Source_List_File is not a single string");
- else
- if Current_Verbosity = High then
- Write_Line ("No Bodies.");
+ if not Sources.Default then
+ if not Source_List_File.Default then
+ Error_Msg
+ (Project,
+ "?both variables source_files and " &
+ "source_list_file are present",
+ Source_List_File.Location);
end if;
- end if;
- if Specifications /= No_Array_Element then
+ -- Sources is a list of file names
- -- We have elements in the array Specification
+ declare
+ Current : String_List_Id := Sources.Values;
+ Element : String_Element;
+ Location : Source_Ptr;
+ Name : Name_Id;
- if Current_Verbosity = High then
- Write_Line ("Found Specifications.");
- end if;
+ begin
+ Source_Names.Reset;
- Data.Naming.Specifications := Specifications;
- Check_Unit_Names (Specifications);
+ Data.Sources_Present := Current /= Nil_String;
- else
- if Current_Verbosity = High then
- Write_Line ("No Specifications.");
- end if;
- end if;
- end;
+ while Current /= Nil_String loop
+ Element := String_Elements.Table (Current);
+ Get_Name_String (Element.Value);
+ Canonical_Case_File_Name
+ (Name_Buffer (1 .. Name_Len));
+ Name := Name_Find;
- -- We are now checking if variables Dot_Replacement, Casing,
- -- Specification_Append, Body_Append and/or Separate_Append
- -- exist.
+ -- If the element has no location, then use the
+ -- location of Sources to report possible errors.
- -- For each variable, if it does not exist, we do nothing,
- -- because we already have the default.
+ if Element.Location = No_Location then
+ Location := Sources.Location;
- -- Check Dot_Replacement
+ else
+ Location := Element.Location;
+ end if;
- declare
- Dot_Replacement : constant Variable_Value :=
- Util.Value_Of
- (Name_Dot_Replacement,
- Naming.Decl.Attributes);
+ Source_Names.Set
+ (K => Name,
+ E =>
+ (Name => Name,
+ Location => Location,
+ Found => False));
- begin
- pragma Assert (Dot_Replacement.Kind = Single,
- "Dot_Replacement is not a single string");
+ Current := Element.Next;
+ end loop;
- if not Dot_Replacement.Default then
+ Get_Path_Names_And_Record_Sources;
+ end;
- String_To_Name_Buffer (Dot_Replacement.Value);
+ -- No source_files specified.
+ -- We check Source_List_File has been specified.
- if Name_Len = 0 then
- Error_Msg ("Dot_Replacement cannot be empty",
- Dot_Replacement.Location);
+ elsif not Source_List_File.Default then
- else
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Data.Naming.Dot_Replacement := Name_Find;
- Data.Naming.Dot_Repl_Loc := Dot_Replacement.Location;
- end if;
+ -- Source_List_File is the name of the file
+ -- that contains the source file names
- end if;
+ declare
+ Source_File_Path_Name : constant String :=
+ Path_Name_Of
+ (Source_List_File.Value,
+ Data.Directory);
- end;
+ begin
+ if Source_File_Path_Name'Length = 0 then
+ Err_Vars.Error_Msg_Name_1 := Source_List_File.Value;
+ Error_Msg
+ (Project,
+ "file with sources { does not exist",
+ Source_List_File.Location);
- if Current_Verbosity = High then
- Write_Str (" Dot_Replacement = """);
- Write_Str (Get_Name_String (Data.Naming.Dot_Replacement));
- Write_Char ('"');
- Write_Eol;
- end if;
+ else
+ Get_Sources_From_File
+ (Source_File_Path_Name,
+ Source_List_File.Location);
+ end if;
+ end;
+
+ else
+ -- Neither Source_Files nor Source_List_File has been
+ -- specified.
+ -- Find all the files that satisfy
+ -- the naming scheme in all the source directories.
- -- Check Casing
+ Find_Sources;
+ end if;
- declare
- Casing_String : constant Variable_Value :=
- Util.Value_Of (Name_Casing, Naming.Decl.Attributes);
+ -- If there are sources that are locally removed, mark them as
+ -- such in the Units table.
- begin
- pragma Assert (Casing_String.Kind = Single,
- "Casing is not a single string");
+ if not Locally_Removed.Default then
+ -- Sources can be locally removed only in extending
+ -- project files.
- if not Casing_String.Default then
- declare
- Casing_Image : constant String :=
- Get_Name_String (Casing_String.Value);
+ if Data.Extends = No_Project then
+ Error_Msg
+ (Project,
+ "Locally_Removed_Files can only be used " &
+ "in an extending project file",
+ Locally_Removed.Location);
- begin
+ else
declare
- Casing : constant Casing_Type :=
- Value (Casing_Image);
+ Current : String_List_Id :=
+ Locally_Removed.Values;
+ Element : String_Element;
+ Location : Source_Ptr;
+ OK : Boolean;
+ Unit : Unit_Data;
+ Name : Name_Id;
+ Extended : Project_Id;
begin
- Data.Naming.Casing := Casing;
- end;
+ while Current /= Nil_String loop
+ Element := String_Elements.Table (Current);
+ Get_Name_String (Element.Value);
+ Canonical_Case_File_Name
+ (Name_Buffer (1 .. Name_Len));
+ Name := Name_Find;
- exception
- when Constraint_Error =>
- if Casing_Image'Length = 0 then
- Error_Msg ("Casing cannot be an empty string",
- Casing_String.Location);
+ -- If the element has no location, then use the
+ -- location of Locally_Removed to report
+ -- possible errors.
- else
- Name_Len := Casing_Image'Length;
- Name_Buffer (1 .. Name_Len) := Casing_Image;
- Errout.Error_Msg_Name_1 := Name_Find;
- Error_Msg
- ("{ is not a correct Casing",
- Casing_String.Location);
- end if;
- end;
- end if;
- end;
+ if Element.Location = No_Location then
+ Location := Locally_Removed.Location;
- if Current_Verbosity = High then
- Write_Str (" Casing = ");
- Write_Str (Image (Data.Naming.Casing));
- Write_Char ('.');
- Write_Eol;
- end if;
+ else
+ Location := Element.Location;
+ end if;
- -- Check Specification_Suffix
+ OK := False;
+
+ for Index in 1 .. Units.Last loop
+ Unit := Units.Table (Index);
+
+ if
+ Unit.File_Names (Specification).Name = Name
+ then
+ OK := True;
+
+ -- Check that this is from a project that
+ -- the current project extends, but not the
+ -- current project.
+
+ Extended := Unit.File_Names
+ (Specification).Project;
+
+ if Extended = Project then
+ Error_Msg
+ (Project,
+ "cannot remove a source " &
+ "of the same project",
+ Location);
+
+ elsif
+ Project_Extends (Project, Extended)
+ then
+ Unit.File_Names
+ (Specification).Path := Slash;
+ Unit.File_Names
+ (Specification).Needs_Pragma := False;
+ Units.Table (Index) := Unit;
+ Add_Forbidden_File_Name
+ (Unit.File_Names (Specification).Name);
+ exit;
+
+ else
+ Error_Msg
+ (Project,
+ "cannot remove a source from " &
+ "another project",
+ Location);
+ end if;
+
+ elsif
+ Unit.File_Names (Body_Part).Name = Name
+ then
+ OK := True;
+
+ -- Check that this is from a project that
+ -- the current project extends, but not the
+ -- current project.
+
+ Extended := Unit.File_Names
+ (Body_Part).Project;
+
+ if Extended = Project then
+ Error_Msg
+ (Project,
+ "cannot remove a source " &
+ "of the same project",
+ Location);
+
+ elsif
+ Project_Extends (Project, Extended)
+ then
+ Unit.File_Names (Body_Part).Path := Slash;
+ Unit.File_Names (Body_Part).Needs_Pragma
+ := False;
+ Units.Table (Index) := Unit;
+ Add_Forbidden_File_Name
+ (Unit.File_Names (Body_Part).Name);
+ exit;
+ end if;
- declare
- Ada_Spec_Suffix : constant Variable_Value :=
- Prj.Util.Value_Of
- (Index => Name_Ada,
- In_Array => Data.Naming.Specification_Suffix);
+ end if;
+ end loop;
- begin
- if Ada_Spec_Suffix.Kind = Single
- and then String_Length (Ada_Spec_Suffix.Value) /= 0
- then
- String_To_Name_Buffer (Ada_Spec_Suffix.Value);
- Data.Naming.Current_Spec_Suffix := Name_Find;
- Data.Naming.Spec_Suffix_Loc := Ada_Spec_Suffix.Location;
+ if not OK then
+ Err_Vars.Error_Msg_Name_1 := Name;
+ Error_Msg (Project, "unknown file {", Location);
+ end if;
- else
- Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
+ Current := Element.Next;
+ end loop;
+ end;
+ end if;
end if;
end;
+ end if;
+ end if;
- if Current_Verbosity = High then
- Write_Str (" Specification_Suffix = """);
- Write_Str (Get_Name_String (Data.Naming.Current_Spec_Suffix));
- Write_Char ('"');
- Write_Eol;
- end if;
+ if Data.Sources_Present then
- -- Check Implementation_Suffix
+ -- Check that all individual naming conventions apply to
+ -- sources of this project file.
- declare
- Ada_Impl_Suffix : constant Variable_Value :=
- Prj.Util.Value_Of
- (Index => Name_Ada,
- In_Array => Data.Naming.Implementation_Suffix);
+ Warn_If_Not_Sources (Data.Naming.Bodies, Specs => False);
+ Warn_If_Not_Sources (Data.Naming.Specs, Specs => True);
+ end if;
- begin
- if Ada_Impl_Suffix.Kind = Single
- and then String_Length (Ada_Impl_Suffix.Value) /= 0
- then
- String_To_Name_Buffer (Ada_Impl_Suffix.Value);
- Data.Naming.Current_Impl_Suffix := Name_Find;
- Data.Naming.Impl_Suffix_Loc := Ada_Impl_Suffix.Location;
+ -- If it is a library project file, check if it is a standalone library
+
+ if Data.Library then
+ Standalone_Library : declare
+ Lib_Interfaces : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Interface,
+ Data.Decl.Attributes);
+ Lib_Auto_Init : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Auto_Init,
+ Data.Decl.Attributes);
+
+ Lib_Src_Dir : constant Prj.Variable_Value :=
+ Prj.Util.Value_Of
+ (Snames.Name_Library_Src_Dir,
+ Data.Decl.Attributes);
+
+ Auto_Init_Supported
+ : constant Boolean :=
+ MLib.Tgt.
+ Standalone_Library_Auto_Init_Is_Supported;
- else
- Data.Naming.Current_Impl_Suffix := Default_Ada_Impl_Suffix;
- end if;
- end;
+ begin
+ pragma Assert (Lib_Interfaces.Kind = List);
- if Current_Verbosity = High then
- Write_Str (" Implementation_Suffix = """);
- Write_Str (Get_Name_String (Data.Naming.Current_Impl_Suffix));
- Write_Char ('"');
- Write_Eol;
- end if;
+ -- It is a library project file if attribute Library_Interface
+ -- is defined.
- -- Check Separate_Suffix
+ if not Lib_Interfaces.Default then
+ declare
+ Interfaces : String_List_Id := Lib_Interfaces.Values;
+ Interface_ALIs : String_List_Id := Nil_String;
+ Unit : Name_Id;
+ The_Unit_Id : Unit_Id;
+ The_Unit_Data : Unit_Data;
- declare
- Ada_Sep_Suffix : constant Variable_Value :=
- Prj.Util.Value_Of
- (Variable_Name => Name_Separate_Suffix,
- In_Variables => Naming.Decl.Attributes);
- begin
- if Ada_Sep_Suffix.Default then
- Data.Naming.Separate_Suffix :=
- Data.Naming.Current_Impl_Suffix;
+ procedure Add_ALI_For (Source : Name_Id);
+ -- Add an ALI file name to the list of Interface ALIs
- else
- String_To_Name_Buffer (Ada_Sep_Suffix.Value);
+ -----------------
+ -- Add_ALI_For --
+ -----------------
- if Name_Len = 0 then
- Error_Msg ("Separate_Suffix cannot be empty",
- Ada_Sep_Suffix.Location);
+ procedure Add_ALI_For (Source : Name_Id) is
+ begin
+ Get_Name_String (Source);
- else
- Data.Naming.Separate_Suffix := Name_Find;
- Data.Naming.Sep_Suffix_Loc := Ada_Sep_Suffix.Location;
- end if;
+ declare
+ ALI : constant String :=
+ ALI_File_Name (Name_Buffer (1 .. Name_Len));
+ ALI_Name_Id : Name_Id;
+ begin
+ Name_Len := ALI'Length;
+ Name_Buffer (1 .. Name_Len) := ALI;
+ ALI_Name_Id := Name_Find;
+
+ String_Elements.Increment_Last;
+ String_Elements.Table (String_Elements.Last) :=
+ (Value => ALI_Name_Id,
+ Display_Value => No_Name,
+ Location => String_Elements.Table
+ (Interfaces).Location,
+ Flag => False,
+ Next => Interface_ALIs);
+ Interface_ALIs := String_Elements.Last;
+ end;
+ end Add_ALI_For;
- end if;
+ begin
+ Data.Standalone_Library := True;
- end;
+ -- Library_Interface cannot be an empty list
- if Current_Verbosity = High then
- Write_Str (" Separate_Suffix = """);
- Write_Str (Get_Name_String (Data.Naming.Separate_Suffix));
- Write_Char ('"');
- Write_Eol;
- end if;
+ if Interfaces = Nil_String then
+ Error_Msg
+ (Project,
+ "Library_Interface cannot be an empty list",
+ Lib_Interfaces.Location);
+ end if;
- -- Check if Data.Naming is valid
+ -- Process each unit name specified in the attribute
+ -- Library_Interface.
- Check_Ada_Naming_Scheme (Data.Naming);
+ while Interfaces /= Nil_String loop
+ Get_Name_String
+ (String_Elements.Table (Interfaces).Value);
+ To_Lower (Name_Buffer (1 .. Name_Len));
- else
- Data.Naming.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
- Data.Naming.Current_Impl_Suffix := Default_Ada_Impl_Suffix;
- Data.Naming.Separate_Suffix := Default_Ada_Impl_Suffix;
- end if;
- end;
+ if Name_Len = 0 then
+ Error_Msg
+ (Project,
+ "an interface cannot be an empty string",
+ String_Elements.Table (Interfaces).Location);
- -- If we have source directories, then find the sources
+ else
+ Unit := Name_Find;
+ Error_Msg_Name_1 := Unit;
+ The_Unit_Id := Units_Htable.Get (Unit);
- if Data.Sources_Present then
- if Data.Source_Dirs = Nil_String then
- Data.Sources_Present := False;
+ if The_Unit_Id = Prj.Com.No_Unit then
+ Error_Msg
+ (Project,
+ "unknown unit {",
+ String_Elements.Table (Interfaces).Location);
- else
- declare
- Sources : constant Variable_Value :=
- Util.Value_Of
- (Name_Source_Files,
- Data.Decl.Attributes);
+ else
+ -- Check that the unit is part of the project
+
+ The_Unit_Data := Units.Table (The_Unit_Id);
+
+ if The_Unit_Data.File_Names
+ (Com.Body_Part).Name /= No_Name
+ and then The_Unit_Data.File_Names
+ (Com.Body_Part).Path /= Slash
+ then
+ if Check_Project
+ (The_Unit_Data.File_Names (Body_Part).Project)
+ then
+ -- There is a body for this unit.
+ -- If there is no spec, we need to check
+ -- that it is not a subunit.
+
+ if The_Unit_Data.File_Names
+ (Specification).Name = No_Name
+ then
+ declare
+ Src_Ind : Source_File_Index;
+
+ begin
+ Src_Ind := Sinput.P.Load_Project_File
+ (Get_Name_String
+ (The_Unit_Data.File_Names
+ (Body_Part).Path));
+
+ if Sinput.P.Source_File_Is_Subunit
+ (Src_Ind)
+ then
+ Error_Msg
+ (Project,
+ "{ is a subunit; " &
+ "it cannot be an interface",
+ String_Elements.Table
+ (Interfaces).Location);
+ end if;
+ end;
+ end if;
+
+ -- The unit is not a subunit, so we add
+ -- to the Interface ALIs the ALI file
+ -- corresponding to the body.
+
+ Add_ALI_For
+ (The_Unit_Data.File_Names (Body_Part).Name);
+
+ else
+ Error_Msg
+ (Project,
+ "{ is not an unit of this project",
+ String_Elements.Table
+ (Interfaces).Location);
+ end if;
- Source_List_File : constant Variable_Value :=
- Util.Value_Of
- (Name_Source_List_File,
- Data.Decl.Attributes);
+ elsif The_Unit_Data.File_Names
+ (Com.Specification).Name /= No_Name
+ and then The_Unit_Data.File_Names
+ (Com.Specification).Path /= Slash
+ and then Check_Project
+ (The_Unit_Data.File_Names
+ (Specification).Project)
- begin
- pragma Assert
- (Sources.Kind = List,
- "Source_Files is not a list");
- pragma Assert
- (Source_List_File.Kind = Single,
- "Source_List_File is not a single string");
+ then
+ -- The unit is part of the project, it has
+ -- a spec, but no body. We add to the Interface
+ -- ALIs the ALI file corresponding to the spec.
- if not Sources.Default then
- if not Source_List_File.Default then
- Error_Msg
- ("?both variables source_files and " &
- "source_list_file are present",
- Source_List_File.Location);
- end if;
+ Add_ALI_For
+ (The_Unit_Data.File_Names (Specification).Name);
- -- Sources is a list of file names
+ else
+ Error_Msg
+ (Project,
+ "{ is not an unit of this project",
+ String_Elements.Table (Interfaces).Location);
+ end if;
+ end if;
- declare
- Current_Source : String_List_Id := Nil_String;
- Current : String_List_Id := Sources.Values;
- Element : String_Element;
+ end if;
- begin
- Data.Sources_Present := Current /= Nil_String;
+ Interfaces := String_Elements.Table (Interfaces).Next;
+ end loop;
- while Current /= Nil_String loop
- Element := String_Elements.Table (Current);
- String_To_Name_Buffer (Element.Value);
+ -- Put the list of Interface ALIs in the project data
- declare
- File_Name : constant String :=
- Name_Buffer (1 .. Name_Len);
+ Data.Lib_Interface_ALIs := Interface_ALIs;
- begin
- Get_Path_Name_And_Record_Source
- (File_Name => File_Name,
- Location => Element.Location,
- Current_Source => Current_Source);
- Current := Element.Next;
- end;
- end loop;
- end;
+ -- Check value of attribute Library_Auto_Init and set
+ -- Lib_Auto_Init accordingly.
- -- No source_files specified.
- -- We check Source_List_File has been specified.
+ if Lib_Auto_Init.Default then
+ -- If no attribute Library_Auto_Init is declared, then
+ -- set auto init only if it is supported.
- elsif not Source_List_File.Default then
+ Data.Lib_Auto_Init := Auto_Init_Supported;
- -- Source_List_File is the name of the file
- -- that contains the source file names
+ else
+ Get_Name_String (Lib_Auto_Init.Value);
+ To_Lower (Name_Buffer (1 .. Name_Len));
- declare
- Source_File_Path_Name : constant String :=
- Path_Name_Of
- (Source_List_File.Value,
- Data.Directory);
+ if Name_Buffer (1 .. Name_Len) = "false" then
+ Data.Lib_Auto_Init := False;
- begin
- if Source_File_Path_Name'Length = 0 then
- String_To_Name_Buffer (Source_List_File.Value);
- Errout.Error_Msg_Name_1 := Name_Find;
- Error_Msg
- ("file with sources { does not exist",
- Source_List_File.Location);
+ elsif Name_Buffer (1 .. Name_Len) = "true" then
+ if Auto_Init_Supported then
+ Data.Lib_Auto_Init := True;
+
+ else
+ -- Library_Auto_Init cannot be "true" if auto init
+ -- is not supported
+
+ Error_Msg
+ (Project,
+ "library auto init not supported " &
+ "on this platform",
+ Lib_Auto_Init.Location);
+ end if;
else
- Get_Sources_From_File
- (Source_File_Path_Name,
- Source_List_File.Location);
+ Error_Msg
+ (Project,
+ "invalid value for attribute Library_Auto_Init",
+ Lib_Auto_Init.Location);
end if;
- end;
+ end if;
- else
- -- Neither Source_Files nor Source_List_File has been
- -- specified.
- -- Find all the files that satisfy
- -- the naming scheme in all the source directories.
+ if Lib_Src_Dir.Value /= Empty_String then
+ declare
+ Dir_Id : constant Name_Id := Lib_Src_Dir.Value;
- Find_Sources;
- end if;
- end;
- end if;
+ begin
+ Locate_Directory
+ (Dir_Id, Data.Display_Directory,
+ Data.Library_Src_Dir,
+ Data.Display_Library_Src_Dir);
+
+ -- Comment needed here ???
+
+ if Data.Library_Src_Dir = No_Name then
+
+ -- Get the absolute name of the library directory
+ -- that does not exist, to report an error.
+
+ declare
+ Dir_Name : constant String :=
+ Get_Name_String (Dir_Id);
+ begin
+ if Is_Absolute_Path (Dir_Name) then
+ Err_Vars.Error_Msg_Name_1 := Dir_Id;
+
+ else
+ Get_Name_String (Data.Directory);
+
+ if Name_Buffer (Name_Len) /=
+ Directory_Separator
+ then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) :=
+ Directory_Separator;
+ end if;
+
+ Name_Buffer
+ (Name_Len + 1 ..
+ Name_Len + Dir_Name'Length) :=
+ Dir_Name;
+ Name_Len := Name_Len + Dir_Name'Length;
+ Err_Vars.Error_Msg_Name_1 := Name_Find;
+ end if;
+
+ -- Report the error
+
+ Error_Msg
+ (Project,
+ "Directory { does not exist",
+ Lib_Src_Dir.Location);
+ end;
+
+ -- And comment needed here ???
+
+ elsif Data.Library_Src_Dir = Data.Object_Directory then
+ Error_Msg
+ (Project,
+ "directory to copy interfaces cannot be " &
+ "the object directory",
+ Lib_Src_Dir.Location);
+ Data.Library_Src_Dir := No_Name;
+
+ -- And comment needed here ???
+
+ else
+ declare
+ Src_Dirs : String_List_Id := Data.Source_Dirs;
+ Src_Dir : String_Element;
+ begin
+ while Src_Dirs /= Nil_String loop
+ Src_Dir := String_Elements.Table (Src_Dirs);
+ Src_Dirs := Src_Dir.Next;
+
+ if Data.Library_Src_Dir = Src_Dir.Value then
+ Error_Msg
+ (Project,
+ "directory to copy interfaces cannot " &
+ "be one of the source directories",
+ Lib_Src_Dir.Location);
+ Data.Library_Src_Dir := No_Name;
+ exit;
+ end if;
+ end loop;
+ end;
+
+ if Data.Library_Src_Dir /= No_Name
+ and then Current_Verbosity = High
+ then
+ Write_Str ("Directory to copy interfaces =""");
+ Write_Str (Get_Name_String (Data.Library_Dir));
+ Write_Line ("""");
+ end if;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+ end Standalone_Library;
end if;
+ -- Put the list of Mains, if any, in the project data
+
+ declare
+ Mains : constant Variable_Value :=
+ Prj.Util.Value_Of (Name_Main, Data.Decl.Attributes);
+
+ begin
+ Data.Mains := Mains.Values;
+
+ -- If no Mains were specified, and if we are an extending
+ -- project, inherit the Mains from the project we are extending.
+
+ if Mains.Default then
+ if Data.Extends /= No_Project then
+ Data.Mains := Projects.Table (Data.Extends).Mains;
+ end if;
+
+ -- In a library project file, Main cannot be specified
+
+ elsif Data.Library then
+ Error_Msg
+ (Project,
+ "a library project file cannot have Main specified",
+ Mains.Location);
+ end if;
+ end;
+
Projects.Table (Project) := Data;
+
+ Free_Naming_Exceptions;
end Ada_Check;
+ -------------------
+ -- ALI_File_Name --
+ -------------------
+
+ function ALI_File_Name (Source : String) return String is
+ begin
+ -- If the source name has an extension, then replace it with
+ -- the ALI suffix.
+
+ for Index in reverse Source'First + 1 .. Source'Last loop
+ if Source (Index) = '.' then
+ return Source (Source'First .. Index - 1) & ALI_Suffix;
+ end if;
+ end loop;
+
+ -- If there is no dot, or if it is the first character, just add the
+ -- ALI suffix.
+
+ return Source & ALI_Suffix;
+ end ALI_File_Name;
+
--------------------
-- Check_Ada_Name --
--------------------
procedure Check_Ada_Name
- (Name : Name_Id;
+ (Name : String;
Unit : out Name_Id)
is
- The_Name : String := Get_Name_String (Name);
+ The_Name : String := Name;
+ Real_Name : Name_Id;
Need_Letter : Boolean := True;
Last_Underscore : Boolean := False;
OK : Boolean := The_Name'Length > 0;
begin
+ To_Lower (The_Name);
+
+ Name_Len := The_Name'Length;
+ Name_Buffer (1 .. Name_Len) := The_Name;
+ Real_Name := Name_Find;
+
+ -- Check first that the given name is not an Ada reserved word
+
+ if Get_Name_Table_Byte (Real_Name) /= 0
+ and then Real_Name /= Name_Project
+ and then Real_Name /= Name_Extends
+ and then Real_Name /= Name_External
+ then
+ Unit := No_Name;
+
+ if Current_Verbosity = High then
+ Write_Str (The_Name);
+ Write_Line (" is an Ada reserved word.");
+ end if;
+
+ return;
+ end if;
+
for Index in The_Name'Range loop
if Need_Letter then
@@ -932,7 +1830,8 @@ package body Prj.Nmsc is
OK := OK and then not Need_Letter and then not Last_Underscore;
if OK then
- Unit := Name;
+ Unit := Real_Name;
+
else
-- Signal a problem with No_Name
@@ -944,7 +1843,10 @@ package body Prj.Nmsc is
-- Check_Ada_Naming_Scheme --
-----------------------------
- procedure Check_Ada_Naming_Scheme (Naming : Naming_Data) is
+ procedure Check_Ada_Naming_Scheme
+ (Project : Project_Id;
+ Naming : Naming_Data)
+ is
begin
-- Only check if we are not using the standard naming scheme
@@ -954,13 +1856,13 @@ package body Prj.Nmsc is
Get_Name_String
(Naming.Dot_Replacement);
- Specification_Suffix : constant String :=
+ Spec_Suffix : constant String :=
Get_Name_String
(Naming.Current_Spec_Suffix);
- Implementation_Suffix : constant String :=
+ Body_Suffix : constant String :=
Get_Name_String
- (Naming.Current_Impl_Suffix);
+ (Naming.Current_Body_Suffix);
Separate_Suffix : constant String :=
Get_Name_String
@@ -991,89 +1893,96 @@ package body Prj.Nmsc is
Pattern => ".") /= 0)
then
Error_Msg
- ('"' & Dot_Replacement &
+ (Project,
+ '"' & Dot_Replacement &
""" is illegal for Dot_Replacement.",
Naming.Dot_Repl_Loc);
end if;
-- Suffixes cannot
-- - be empty
- -- - start with an alphanumeric
- -- - start with an '_' followed by an alphanumeric
if Is_Illegal_Suffix
- (Specification_Suffix, Dot_Replacement = ".")
+ (Spec_Suffix, Dot_Replacement = ".")
then
- Errout.Error_Msg_Name_1 := Naming.Current_Spec_Suffix;
+ Err_Vars.Error_Msg_Name_1 := Naming.Current_Spec_Suffix;
Error_Msg
- ("{ is illegal for Specification_Suffix",
+ (Project,
+ "{ is illegal for Spec_Suffix",
Naming.Spec_Suffix_Loc);
end if;
if Is_Illegal_Suffix
- (Implementation_Suffix, Dot_Replacement = ".")
+ (Body_Suffix, Dot_Replacement = ".")
then
- Errout.Error_Msg_Name_1 := Naming.Current_Impl_Suffix;
+ Err_Vars.Error_Msg_Name_1 := Naming.Current_Body_Suffix;
Error_Msg
- ("{ is illegal for Implementation_Suffix",
- Naming.Impl_Suffix_Loc);
+ (Project,
+ "{ is illegal for Body_Suffix",
+ Naming.Body_Suffix_Loc);
end if;
- if Implementation_Suffix /= Separate_Suffix then
+ if Body_Suffix /= Separate_Suffix then
if Is_Illegal_Suffix
(Separate_Suffix, Dot_Replacement = ".")
then
- Errout.Error_Msg_Name_1 := Naming.Separate_Suffix;
+ Err_Vars.Error_Msg_Name_1 := Naming.Separate_Suffix;
Error_Msg
- ("{ is illegal for Separate_Suffix",
+ (Project,
+ "{ is illegal for Separate_Suffix",
Naming.Sep_Suffix_Loc);
end if;
end if;
- -- Specification_Suffix cannot have the same termination as
- -- Implementation_Suffix or Separate_Suffix
+ -- Spec_Suffix cannot have the same termination as
+ -- Body_Suffix or Separate_Suffix
- if Specification_Suffix'Length <= Implementation_Suffix'Length
+ if Spec_Suffix'Length <= Body_Suffix'Length
and then
- Implementation_Suffix (Implementation_Suffix'Last -
- Specification_Suffix'Length + 1 ..
- Implementation_Suffix'Last) = Specification_Suffix
+ Body_Suffix (Body_Suffix'Last -
+ Spec_Suffix'Length + 1 ..
+ Body_Suffix'Last) = Spec_Suffix
then
Error_Msg
- ("Implementation_Suffix (""" &
- Implementation_Suffix &
+ (Project,
+ "Body_Suffix (""" &
+ Body_Suffix &
""") cannot end with" &
- "Specification_Suffix (""" &
- Specification_Suffix & """).",
- Naming.Impl_Suffix_Loc);
+ " Spec_Suffix (""" &
+ Spec_Suffix & """).",
+ Naming.Body_Suffix_Loc);
end if;
- if Specification_Suffix'Length <= Separate_Suffix'Length
+ if Body_Suffix /= Separate_Suffix
+ and then Spec_Suffix'Length <= Separate_Suffix'Length
and then
Separate_Suffix
- (Separate_Suffix'Last - Specification_Suffix'Length + 1
+ (Separate_Suffix'Last - Spec_Suffix'Length + 1
..
- Separate_Suffix'Last) = Specification_Suffix
+ Separate_Suffix'Last) = Spec_Suffix
then
Error_Msg
- ("Separate_Suffix (""" &
+ (Project,
+ "Separate_Suffix (""" &
Separate_Suffix &
""") cannot end with" &
- " Specification_Suffix (""" &
- Specification_Suffix & """).",
+ " Spec_Suffix (""" &
+ Spec_Suffix & """).",
Naming.Sep_Suffix_Loc);
end if;
end;
end if;
-
end Check_Ada_Naming_Scheme;
---------------
-- Error_Msg --
---------------
- procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
-
+ procedure Error_Msg
+ (Project : Project_Id;
+ Msg : String;
+ Flag_Location : Source_Ptr)
+ is
Error_Buffer : String (1 .. 5_000);
Error_Last : Natural := 0;
Msg_Name : Natural := 0;
@@ -1114,7 +2023,7 @@ package body Prj.Nmsc is
begin
if Error_Report = null then
- Errout.Error_Msg (Msg, Flag_Location);
+ Prj.Err.Error_Msg (Msg, Flag_Location);
return;
end if;
@@ -1126,8 +2035,7 @@ package body Prj.Nmsc is
elsif Msg (First) = '?' then
- -- Warning character. It is always the first one,
- -- in this package.
+ -- Warning character. It is always the first one in this package
First := First + 1;
Add ("Warning: ");
@@ -1142,9 +2050,9 @@ package body Prj.Nmsc is
Add ('"');
case Msg_Name is
- when 1 => Add (Errout.Error_Msg_Name_1);
- when 2 => Add (Errout.Error_Msg_Name_2);
- when 3 => Add (Errout.Error_Msg_Name_3);
+ when 1 => Add (Err_Vars.Error_Msg_Name_1);
+ when 2 => Add (Err_Vars.Error_Msg_Name_2);
+ when 3 => Add (Err_Vars.Error_Msg_Name_3);
when others => null;
end case;
@@ -1157,125 +2065,80 @@ package body Prj.Nmsc is
end loop;
- Error_Report (Error_Buffer (1 .. Error_Last), Current_Project);
+ Error_Report (Error_Buffer (1 .. Error_Last), Project);
end Error_Msg;
- ---------------------
- -- Get_Name_String --
- ---------------------
-
- function Get_Name_String (S : String_Id) return String is
- begin
- if S = No_String then
- return "";
- else
- String_To_Name_Buffer (S);
- return Name_Buffer (1 .. Name_Len);
- end if;
- end Get_Name_String;
-
--------------
-- Get_Unit --
--------------
procedure Get_Unit
- (File_Name : Name_Id;
- Naming : Naming_Data;
- Unit_Name : out Name_Id;
- Unit_Kind : out Spec_Or_Body;
- Needs_Pragma : out Boolean)
+ (Canonical_File_Name : Name_Id;
+ Naming : Naming_Data;
+ Unit_Name : out Name_Id;
+ Unit_Kind : out Spec_Or_Body;
+ Needs_Pragma : out Boolean)
is
- Canonical_Case_Name : Name_Id;
-
- begin
- Needs_Pragma := False;
- Get_Name_String (File_Name);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Canonical_Case_Name := Name_Find;
-
- if Naming.Bodies /= No_Array_Element then
-
- -- There are some specified file names for some bodies
- -- of this project. Find out if File_Name is one of these bodies.
-
- declare
- Current : Array_Element_Id := Naming.Bodies;
- Element : Array_Element;
-
- begin
- while Current /= No_Array_Element loop
- Element := Array_Elements.Table (Current);
+ function Check_Exception (Canonical : Name_Id) return Boolean;
+ pragma Inline (Check_Exception);
+ -- Check if Canonical is one of the exceptions in List.
+ -- Returns True if Get_Unit should exit
- if Element.Index /= No_Name then
- String_To_Name_Buffer (Element.Value.Value);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
-
- if Canonical_Case_Name = Name_Find then
+ ---------------------
+ -- Check_Exception --
+ ---------------------
- -- File_Name corresponds to one body.
- -- So, we know it is a body, and we know the unit name.
+ function Check_Exception (Canonical : Name_Id) return Boolean is
+ Info : Unit_Info := Naming_Exceptions.Get (Canonical);
+ VMS_Name : Name_Id;
- Unit_Kind := Body_Part;
- Unit_Name := Element.Index;
- Needs_Pragma := True;
- return;
- end if;
+ begin
+ if Info = No_Unit then
+ if Hostparm.OpenVMS then
+ VMS_Name := Canonical;
+ Get_Name_String (VMS_Name);
+
+ if Name_Buffer (Name_Len) = '.' then
+ Name_Len := Name_Len - 1;
+ VMS_Name := Name_Find;
end if;
- Current := Element.Next;
- end loop;
- end;
- end if;
-
- if Naming.Specifications /= No_Array_Element then
-
- -- There are some specified file names for some bodiesspecifications
- -- of this project. Find out if File_Name is one of these
- -- specifications.
-
- declare
- Current : Array_Element_Id := Naming.Specifications;
- Element : Array_Element;
-
- begin
- while Current /= No_Array_Element loop
- Element := Array_Elements.Table (Current);
+ Info := Naming_Exceptions.Get (VMS_Name);
+ end if;
- if Element.Index /= No_Name then
- String_To_Name_Buffer (Element.Value.Value);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ if Info = No_Unit then
+ return False;
+ end if;
+ end if;
- if Canonical_Case_Name = Name_Find then
+ Unit_Kind := Info.Kind;
+ Unit_Name := Info.Unit;
+ Needs_Pragma := True;
+ return True;
+ end Check_Exception;
- -- File_Name corresponds to one specification.
- -- So, we know it is a spec, and we know the unit name.
+ -- Start of processing for Get_Unit
- Unit_Kind := Specification;
- Unit_Name := Element.Index;
- Needs_Pragma := True;
- return;
- end if;
-
- end if;
+ begin
+ Needs_Pragma := False;
- Current := Element.Next;
- end loop;
- end;
+ if Check_Exception (Canonical_File_Name) then
+ return;
end if;
- declare
- File : String := Get_Name_String (Canonical_Case_Name);
- First : Positive := File'First;
- Last : Natural := File'Last;
+ Get_Name_String (Canonical_File_Name);
- Standard_GNAT : Boolean :=
- Naming.Current_Spec_Suffix =
- Default_Ada_Spec_Suffix
- and then
- Naming.Current_Impl_Suffix =
- Default_Ada_Impl_Suffix;
+ declare
+ File : String := Name_Buffer (1 .. Name_Len);
+ First : constant Positive := File'First;
+ Last : Natural := File'Last;
+ Standard_GNAT : Boolean;
begin
+ Standard_GNAT :=
+ Naming.Current_Spec_Suffix = Default_Ada_Spec_Suffix
+ and then Naming.Current_Body_Suffix = Default_Ada_Body_Suffix;
+
-- Check if the end of the file name is Specification_Append
Get_Name_String (Naming.Current_Spec_Suffix);
@@ -1295,7 +2158,7 @@ package body Prj.Nmsc is
end if;
else
- Get_Name_String (Naming.Current_Impl_Suffix);
+ Get_Name_String (Naming.Current_Body_Suffix);
-- Check if the end of the file name is Body_Append
@@ -1474,16 +2337,12 @@ package body Prj.Nmsc is
Write_Line (Src);
end if;
- Name_Len := Src'Length;
- Name_Buffer (1 .. Name_Len) := Src;
-
-- Now, we check if this name is a valid unit name
- Check_Ada_Name (Name => Name_Find, Unit => Unit_Name);
+ Check_Ada_Name (Name => Src, Unit => Unit_Name);
end;
end;
-
end Get_Unit;
-----------------------
@@ -1496,13 +2355,7 @@ package body Prj.Nmsc is
return Boolean
is
begin
- if Suffix'Length = 0
- or else Is_Alphanumeric (Suffix (Suffix'First))
- or else Index (Suffix, ".") = 0
- or else (Suffix'Length >= 2
- and then Suffix (Suffix'First) = '_'
- and then Is_Alphanumeric (Suffix (Suffix'First + 1)))
- then
+ if Suffix'Length = 0 or else Index (Suffix, ".") = 0 then
return True;
end if;
@@ -1538,10 +2391,10 @@ package body Prj.Nmsc is
(Project : Project_Id;
Report_Error : Put_Line_Access)
is
- Last_Source_Dir : String_List_Id := Nil_String;
- Data : Project_Data := Projects.Table (Project);
+ Last_Source_Dir : String_List_Id := Nil_String;
+ Data : Project_Data := Projects.Table (Project);
- procedure Find_Source_Dirs (From : String_Id; Location : Source_Ptr);
+ procedure Find_Source_Dirs (From : Name_Id; Location : Source_Ptr);
-- Find one or several source directories, and add them
-- to the list of source directories of the project.
@@ -1549,13 +2402,12 @@ package body Prj.Nmsc is
-- Find_Source_Dirs --
----------------------
- procedure Find_Source_Dirs (From : String_Id; Location : Source_Ptr) is
-
- Directory : String (1 .. Integer (String_Length (From)));
- Directory_Id : Name_Id;
+ procedure Find_Source_Dirs (From : Name_Id; Location : Source_Ptr) is
+ Directory : constant String := Get_Name_String (From);
+ Canonical_Directory_Id : Name_Id;
Element : String_Element;
- procedure Recursive_Find_Dirs (Path : String_Id);
+ procedure Recursive_Find_Dirs (Path : Name_Id);
-- Find all the subdirectories (recursively) of Path
-- and add them to the list of source directories
-- of the project.
@@ -1564,112 +2416,159 @@ package body Prj.Nmsc is
-- Recursive_Find_Dirs --
-------------------------
- procedure Recursive_Find_Dirs (Path : String_Id) is
+ procedure Recursive_Find_Dirs (Path : Name_Id) is
Dir : Dir_Type;
Name : String (1 .. 250);
Last : Natural;
- The_Path : String := Get_Name_String (Path) & Dir_Sep;
+ List : String_List_Id := Data.Source_Dirs;
+ Element : String_Element;
+ Found : Boolean := False;
- The_Path_Last : Positive := The_Path'Last;
+ Canonical_Path : Name_Id := No_Name;
begin
- if The_Path'Length > 1
- and then
- (The_Path (The_Path_Last - 1) = Dir_Sep
- or else The_Path (The_Path_Last - 1) = '/')
- then
- The_Path_Last := The_Path_Last - 1;
- end if;
+ Get_Name_String (Path);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Canonical_Case_File_Name (The_Path);
+ declare
+ The_Path : String :=
+ Normalize_Pathname
+ (Name => Name_Buffer (1 .. Name_Len)) &
+ Directory_Separator;
+ The_Path_Last : constant Natural :=
+ Compute_Directory_Last (The_Path);
+ begin
+ Name_Len := The_Path_Last - The_Path'First + 1;
+ Name_Buffer (1 .. Name_Len) :=
+ The_Path (The_Path'First .. The_Path_Last);
+ Canonical_Path := Name_Find;
- if Current_Verbosity = High then
- Write_Str (" ");
- Write_Line (The_Path (The_Path'First .. The_Path_Last));
- end if;
+ -- To avoid processing the same directory several times, check
+ -- if the directory is already in Recursive_Dirs. If it is,
+ -- then there is nothing to do, just return. If it is not, put
+ -- it there and continue recursive processing.
- String_Elements.Increment_Last;
- Element :=
- (Value => Path,
- Location => No_Location,
- Next => Nil_String);
+ if Recursive_Dirs.Get (Canonical_Path) then
+ return;
- -- Case of first source directory
+ else
+ Recursive_Dirs.Set (Canonical_Path, True);
+ end if;
- if Last_Source_Dir = Nil_String then
- Data.Source_Dirs := String_Elements.Last;
+ -- Check if directory is already in list
- -- Here we already have source directories.
+ while List /= Nil_String loop
+ Element := String_Elements.Table (List);
- else
- -- Link the previous last to the new one
+ if Element.Value /= No_Name then
+ Get_Name_String (Element.Value);
+ Found :=
+ The_Path (The_Path'First .. The_Path_Last) =
+ Name_Buffer (1 .. Name_Len);
+ exit when Found;
+ end if;
- String_Elements.Table (Last_Source_Dir).Next :=
- String_Elements.Last;
- end if;
+ List := Element.Next;
+ end loop;
- -- And register this source directory as the new last
+ -- If directory is not already in list, put it there
- Last_Source_Dir := String_Elements.Last;
- String_Elements.Table (Last_Source_Dir) := Element;
+ if not Found then
+ if Current_Verbosity = High then
+ Write_Str (" ");
+ Write_Line (The_Path (The_Path'First .. The_Path_Last));
+ end if;
- -- Now look for subdirectories
+ String_Elements.Increment_Last;
+ Element :=
+ (Value => Canonical_Path,
+ Display_Value => No_Name,
+ Location => No_Location,
+ Flag => False,
+ Next => Nil_String);
- Open (Dir, The_Path (The_Path'First .. The_Path_Last));
+ -- Case of first source directory
- loop
- Read (Dir, Name, Last);
- exit when Last = 0;
+ if Last_Source_Dir = Nil_String then
+ Data.Source_Dirs := String_Elements.Last;
- if Current_Verbosity = High then
- Write_Str (" Checking ");
- Write_Line (Name (1 .. Last));
- end if;
+ -- Here we already have source directories.
- if Name (1 .. Last) /= "."
- and then Name (1 .. Last) /= ".."
- then
- -- Avoid . and ..
+ else
+ -- Link the previous last to the new one
- declare
- Path_Name : String :=
- The_Path (The_Path'First .. The_Path_Last) &
- Name (1 .. Last);
+ String_Elements.Table (Last_Source_Dir).Next :=
+ String_Elements.Last;
+ end if;
- begin
- Canonical_Case_File_Name (Path_Name);
+ -- And register this source directory as the new last
+
+ Last_Source_Dir := String_Elements.Last;
+ String_Elements.Table (Last_Source_Dir) := Element;
+ end if;
- if Is_Directory (Path_Name) then
+ -- Now look for subdirectories. We do that even when this
+ -- directory is already in the list, because some of its
+ -- subdirectories may not be in the list yet.
- -- We have found a new subdirectory,
- -- register it and find its own subdirectories.
+ Open (Dir, The_Path (The_Path'First .. The_Path_Last));
- Start_String;
- Store_String_Chars (Path_Name);
- Recursive_Find_Dirs (End_String);
+ loop
+ Read (Dir, Name, Last);
+ exit when Last = 0;
+
+ if Name (1 .. Last) /= "."
+ and then Name (1 .. Last) /= ".."
+ then
+ -- Avoid . and ..
+
+ if Current_Verbosity = High then
+ Write_Str (" Checking ");
+ Write_Line (Name (1 .. Last));
end if;
- end;
- end if;
- end loop;
- Close (Dir);
+ declare
+ Path_Name : String :=
+ Normalize_Pathname
+ (Name => Name (1 .. Last),
+ Directory =>
+ The_Path
+ (The_Path'First .. The_Path_Last));
+
+ begin
+ Canonical_Case_File_Name (Path_Name);
+
+ if Is_Directory (Path_Name) then
+
+ -- We have found a new subdirectory, call self
+
+ Name_Len := Path_Name'Length;
+ Name_Buffer (1 .. Name_Len) := Path_Name;
+ Recursive_Find_Dirs (Name_Find);
+ end if;
+ end;
+ end if;
+ end loop;
+
+ Close (Dir);
+ end;
exception
when Directory_Error =>
null;
end Recursive_Find_Dirs;
- -- Start of processing for Find_Source_Dirs
+ -- Start of processing for Find_Source_Dirs
begin
if Current_Verbosity = High then
Write_Str ("Find_Source_Dirs (""");
end if;
- String_To_Name_Buffer (From);
+ Get_Name_String (From);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Directory := Name_Buffer (1 .. Name_Len);
- Directory_Id := Name_Find;
+ -- Directory := Name_Buffer (1 .. Name_Len);
+ Canonical_Directory_Id := Name_Find;
if Current_Verbosity = High then
Write_Str (Directory);
@@ -1683,11 +2582,14 @@ package body Prj.Nmsc is
and then Directory (Directory'Last - 1 .. Directory'Last) = "**"
and then (Directory (Directory'Last - 2) = '/'
or else
- Directory (Directory'Last - 2) = Dir_Sep)
+ Directory (Directory'Last - 2) = Directory_Separator)
then
+ Data.Known_Order_Of_Source_Dirs := False;
+
Name_Len := Directory'Length - 3;
if Name_Len = 0 then
+
-- This is the case of "/**": all directories
-- in the file system.
@@ -1707,16 +2609,26 @@ package body Prj.Nmsc is
declare
Base_Dir : constant Name_Id := Name_Find;
- Root : constant Name_Id :=
- Locate_Directory (Base_Dir, Data.Directory);
+ Root_Dir : constant String :=
+ Normalize_Pathname
+ (Name => Get_Name_String (Base_Dir),
+ Directory =>
+ Get_Name_String (Data.Display_Directory));
begin
- if Root = No_Name then
- Errout.Error_Msg_Name_1 := Base_Dir;
+ if Root_Dir'Length = 0 then
+ Err_Vars.Error_Msg_Name_1 := Base_Dir;
+
if Location = No_Location then
- Error_Msg ("{ is not a valid directory.", Data.Location);
+ Error_Msg
+ (Project,
+ "{ is not a valid directory.",
+ Data.Location);
else
- Error_Msg ("{ is not a valid directory.", Location);
+ Error_Msg
+ (Project,
+ "{ is not a valid directory.",
+ Location);
end if;
else
@@ -1727,9 +2639,9 @@ package body Prj.Nmsc is
Write_Line ("Looking for source directories:");
end if;
- Start_String;
- Store_String_Chars (Get_Name_String (Root));
- Recursive_Find_Dirs (End_String);
+ Name_Len := Root_Dir'Length;
+ Name_Buffer (1 .. Name_Len) := Root_Dir;
+ Recursive_Find_Dirs (Name_Find);
if Current_Verbosity = High then
Write_Line ("End of looking for source directories.");
@@ -1741,16 +2653,24 @@ package body Prj.Nmsc is
else
declare
- Path_Name : constant Name_Id :=
- Locate_Directory (Directory_Id, Data.Directory);
-
+ Path_Name : Name_Id;
+ Display_Path_Name : Name_Id;
begin
+ Locate_Directory
+ (From, Data.Display_Directory, Path_Name, Display_Path_Name);
if Path_Name = No_Name then
- Errout.Error_Msg_Name_1 := Directory_Id;
+ Err_Vars.Error_Msg_Name_1 := From;
+
if Location = No_Location then
- Error_Msg ("{ is not a valid directory", Data.Location);
+ Error_Msg
+ (Project,
+ "{ is not a valid directory",
+ Data.Location);
else
- Error_Msg ("{ is not a valid directory", Location);
+ Error_Msg
+ (Project,
+ "{ is not a valid directory",
+ Location);
end if;
else
@@ -1758,9 +2678,8 @@ package body Prj.Nmsc is
-- the list of directories.
String_Elements.Increment_Last;
- Start_String;
- Store_String_Chars (Get_Name_String (Path_Name));
- Element.Value := End_String;
+ Element.Value := Path_Name;
+ Element.Display_Value := Display_Path_Name;
if Last_Source_Dir = Nil_String then
@@ -1785,10 +2704,9 @@ package body Prj.Nmsc is
end if;
end Find_Source_Dirs;
- -- Start of processing for Language_Independent_Check
+ -- Start of processing for Language_Independent_Check
begin
-
if Data.Language_Independent_Checked then
return;
end if;
@@ -1797,6 +2715,8 @@ package body Prj.Nmsc is
Error_Report := Report_Error;
+ Recursive_Dirs.Reset;
+
if Current_Verbosity = High then
Write_Line ("Starting to look for directories");
end if;
@@ -1804,7 +2724,7 @@ package body Prj.Nmsc is
-- Check the object directory
declare
- Object_Dir : Variable_Value :=
+ Object_Dir : constant Variable_Value :=
Util.Value_Of (Name_Object_Dir, Data.Decl.Attributes);
begin
@@ -1813,36 +2733,46 @@ package body Prj.Nmsc is
-- We set the object directory to its default
- Data.Object_Directory := Data.Directory;
+ Data.Object_Directory := Data.Directory;
+ Data.Display_Object_Dir := Data.Display_Directory;
- if not String_Equal (Object_Dir.Value, Empty_String) then
+ if Object_Dir.Value /= Empty_String then
- String_To_Name_Buffer (Object_Dir.Value);
+ Get_Name_String (Object_Dir.Value);
if Name_Len = 0 then
- Error_Msg ("Object_Dir cannot be empty",
- Object_Dir.Location);
+ Error_Msg
+ (Project,
+ "Object_Dir cannot be empty",
+ Object_Dir.Location);
else
-- We check that the specified object directory
-- does exist.
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
-
- declare
- Dir_Id : constant Name_Id := Name_Find;
+ Locate_Directory
+ (Object_Dir.Value, Data.Display_Directory,
+ Data.Object_Directory, Data.Display_Object_Dir);
- begin
- Data.Object_Directory :=
- Locate_Directory (Dir_Id, Data.Directory);
-
- if Data.Object_Directory = No_Name then
- Errout.Error_Msg_Name_1 := Dir_Id;
- Error_Msg
- ("the object directory { cannot be found",
- Data.Location);
- end if;
- end;
+ if Data.Object_Directory = No_Name then
+ -- The object directory does not exist, report an error
+ Err_Vars.Error_Msg_Name_1 := Object_Dir.Value;
+ Error_Msg
+ (Project,
+ "the object directory { cannot be found",
+ Data.Location);
+
+ -- Do not keep a nil Object_Directory. Set it to the
+ -- specified (relative or absolute) path.
+ -- This is for the benefit of tools that recover from
+ -- errors; for example, these tools could create the
+ -- non existent directory.
+
+ Data.Display_Object_Dir := Object_Dir.Value;
+ Get_Name_String (Object_Dir.Value);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Data.Object_Directory := Name_Find;
+ end if;
end if;
end if;
end;
@@ -1852,7 +2782,7 @@ package body Prj.Nmsc is
Write_Line ("No object directory");
else
Write_Str ("Object directory: """);
- Write_Str (Get_Name_String (Data.Object_Directory));
+ Write_Str (Get_Name_String (Data.Display_Object_Dir));
Write_Line ("""");
end if;
end if;
@@ -1860,7 +2790,7 @@ package body Prj.Nmsc is
-- Check the exec directory
declare
- Exec_Dir : Variable_Value :=
+ Exec_Dir : constant Variable_Value :=
Util.Value_Of (Name_Exec_Dir, Data.Decl.Attributes);
begin
@@ -1869,36 +2799,34 @@ package body Prj.Nmsc is
-- We set the object directory to its default
- Data.Exec_Directory := Data.Object_Directory;
+ Data.Exec_Directory := Data.Object_Directory;
+ Data.Display_Exec_Dir := Data.Display_Object_Dir;
- if not String_Equal (Exec_Dir.Value, Empty_String) then
+ if Exec_Dir.Value /= Empty_String then
- String_To_Name_Buffer (Exec_Dir.Value);
+ Get_Name_String (Exec_Dir.Value);
if Name_Len = 0 then
- Error_Msg ("Exec_Dir cannot be empty",
- Exec_Dir.Location);
+ Error_Msg
+ (Project,
+ "Exec_Dir cannot be empty",
+ Exec_Dir.Location);
else
-- We check that the specified object directory
-- does exist.
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
-
- declare
- Dir_Id : constant Name_Id := Name_Find;
+ Locate_Directory
+ (Exec_Dir.Value, Data.Directory,
+ Data.Exec_Directory, Data.Display_Exec_Dir);
- begin
- Data.Exec_Directory :=
- Locate_Directory (Dir_Id, Data.Directory);
-
- if Data.Exec_Directory = No_Name then
- Errout.Error_Msg_Name_1 := Dir_Id;
- Error_Msg
- ("the exec directory { cannot be found",
- Data.Location);
- end if;
- end;
+ if Data.Exec_Directory = No_Name then
+ Err_Vars.Error_Msg_Name_1 := Exec_Dir.Value;
+ Error_Msg
+ (Project,
+ "the exec directory { cannot be found",
+ Data.Location);
+ end if;
end if;
end if;
end;
@@ -1908,7 +2836,7 @@ package body Prj.Nmsc is
Write_Line ("No exec directory");
else
Write_Str ("Exec directory: """);
- Write_Str (Get_Name_String (Data.Exec_Directory));
+ Write_Str (Get_Name_String (Data.Display_Exec_Dir));
Write_Line ("""");
end if;
end if;
@@ -1916,11 +2844,11 @@ package body Prj.Nmsc is
-- Look for the source directories
declare
- Source_Dirs : Variable_Value :=
- Util.Value_Of (Name_Source_Dirs, Data.Decl.Attributes);
+ Source_Dirs : constant Variable_Value :=
+ Util.Value_Of
+ (Name_Source_Dirs, Data.Decl.Attributes);
begin
-
if Current_Verbosity = High then
Write_Line ("Starting to look for source directories");
end if;
@@ -1935,26 +2863,30 @@ package body Prj.Nmsc is
String_Elements.Increment_Last;
Data.Source_Dirs := String_Elements.Last;
- Start_String;
- Store_String_Chars (Get_Name_String (Data.Directory));
String_Elements.Table (Data.Source_Dirs) :=
- (Value => End_String,
+ (Value => Data.Directory,
+ Display_Value => Data.Display_Directory,
Location => No_Location,
+ Flag => False,
Next => Nil_String);
if Current_Verbosity = High then
- Write_Line ("(Undefined) Single object directory:");
+ Write_Line ("Single source directory:");
Write_Str (" """);
- Write_Str (Get_Name_String (Data.Directory));
+ Write_Str (Get_Name_String (Data.Display_Directory));
Write_Line ("""");
end if;
elsif Source_Dirs.Values = Nil_String then
-- If Source_Dirs is an empty string list, this means
- -- that this project contains no source.
+ -- that this project contains no source. For projects that
+ -- don't extend other projects, this also means that there is no
+ -- need for an object directory, if not specified.
- if Data.Object_Directory = Data.Directory then
+ if Data.Extends = No_Project
+ and then Data.Object_Directory = Data.Directory
+ then
Data.Object_Directory := No_Name;
end if;
@@ -1979,7 +2911,7 @@ package body Prj.Nmsc is
end if;
if Current_Verbosity = High then
- Write_Line ("Puting source directories in canonical cases");
+ Write_Line ("Putting source directories in canonical cases");
end if;
declare
@@ -1989,12 +2921,11 @@ package body Prj.Nmsc is
begin
while Current /= Nil_String loop
Element := String_Elements.Table (Current);
- if Element.Value /= No_String then
- String_To_Name_Buffer (Element.Value);
+ if Element.Value /= No_Name then
+ Element.Display_Value := Element.Value;
+ Get_Name_String (Element.Value);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Start_String;
- Store_String_Chars (Name_Buffer (1 .. Name_Len));
- Element.Value := End_String;
+ Element.Value := Name_Find;
String_Elements.Table (Current) := Element;
end if;
@@ -2003,26 +2934,57 @@ package body Prj.Nmsc is
end;
end;
- -- Library Dir, Name, Version and Kind
+ -- Library attributes
declare
Attributes : constant Prj.Variable_Id := Data.Decl.Attributes;
- Lib_Dir : Prj.Variable_Value :=
+ Lib_Dir : constant Prj.Variable_Value :=
Prj.Util.Value_Of (Snames.Name_Library_Dir, Attributes);
- Lib_Name : Prj.Variable_Value :=
+ Lib_Name : constant Prj.Variable_Value :=
Prj.Util.Value_Of (Snames.Name_Library_Name, Attributes);
- Lib_Version : Prj.Variable_Value :=
+ Lib_Version : constant Prj.Variable_Value :=
Prj.Util.Value_Of
(Snames.Name_Library_Version, Attributes);
- The_Lib_Kind : Prj.Variable_Value :=
+ The_Lib_Kind : constant Prj.Variable_Value :=
Prj.Util.Value_Of
(Snames.Name_Library_Kind, Attributes);
begin
+ -- Special case of extending project
+
+ if Data.Extends /= No_Project then
+ declare
+ Extended_Data : constant Project_Data :=
+ Projects.Table (Data.Extends);
+
+ begin
+ -- If the project extended is a library project, we inherit
+ -- the library name, if it is not redefined; we check that
+ -- the library directory is specified; and we reset the
+ -- library flag for the extended project.
+
+ if Extended_Data.Library then
+ if Lib_Name.Default then
+ Data.Library_Name := Extended_Data.Library_Name;
+ end if;
+
+ if Lib_Dir.Default then
+ Error_Msg
+ (Project,
+ "a project extending a library project must specify " &
+ "an attribute Library_Dir",
+ Data.Location);
+ end if;
+
+ Projects.Table (Data.Extends).Library := False;
+ end if;
+ end;
+ end if;
+
pragma Assert (Lib_Dir.Kind = Single);
if Lib_Dir.Value = Empty_String then
@@ -2034,69 +2996,83 @@ package body Prj.Nmsc is
else
-- Find path name, check that it is a directory
- Stringt.String_To_Name_Buffer (Lib_Dir.Value);
+ Locate_Directory
+ (Lib_Dir.Value, Data.Display_Directory,
+ Data.Library_Dir, Data.Display_Library_Dir);
- declare
- Dir_Id : constant Name_Id := Name_Find;
+ if Data.Library_Dir = No_Name then
+ -- Get the absolute name of the library directory that
+ -- does not exist, to report an error.
- begin
- Data.Library_Dir :=
- Locate_Directory (Dir_Id, Data.Directory);
+ declare
+ Dir_Name : constant String :=
+ Get_Name_String (Lib_Dir.Value);
+ begin
+ if Is_Absolute_Path (Dir_Name) then
+ Err_Vars.Error_Msg_Name_1 := Lib_Dir.Value;
- if Data.Library_Dir = No_Name then
- Error_Msg ("not an existing directory",
- Lib_Dir.Location);
+ else
+ Get_Name_String (Data.Display_Directory);
+
+ if Name_Buffer (Name_Len) /= Directory_Separator then
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := Directory_Separator;
+ end if;
+
+ Name_Buffer
+ (Name_Len + 1 .. Name_Len + Dir_Name'Length) :=
+ Dir_Name;
+ Name_Len := Name_Len + Dir_Name'Length;
+ Err_Vars.Error_Msg_Name_1 := Name_Find;
+ end if;
+
+ -- Report the error
- elsif Data.Library_Dir = Data.Object_Directory then
Error_Msg
- ("library directory cannot be the same " &
- "as object directory",
+ (Project,
+ "library directory { does not exist",
Lib_Dir.Location);
- Data.Library_Dir := No_Name;
+ end;
- else
- if Current_Verbosity = High then
- Write_Str ("Library directory =""");
- Write_Str (Get_Name_String (Data.Library_Dir));
- Write_Line ("""");
- end if;
+ elsif Data.Library_Dir = Data.Object_Directory then
+ Error_Msg
+ (Project,
+ "library directory cannot be the same " &
+ "as object directory",
+ Lib_Dir.Location);
+ Data.Library_Dir := No_Name;
+ Data.Display_Library_Dir := No_Name;
+
+ else
+ if Current_Verbosity = High then
+ Write_Str ("Library directory =""");
+ Write_Str (Get_Name_String (Data.Display_Library_Dir));
+ Write_Line ("""");
end if;
- end;
+ end if;
end if;
pragma Assert (Lib_Name.Kind = Single);
if Lib_Name.Value = Empty_String then
- if Current_Verbosity = High then
+ if Current_Verbosity = High
+ and then Data.Library_Name = No_Name
+ then
Write_Line ("No library name");
end if;
else
- Stringt.String_To_Name_Buffer (Lib_Name.Value);
-
- if not Is_Letter (Name_Buffer (1)) then
- Error_Msg ("must start with a letter",
- Lib_Name.Location);
+ -- There is no restriction on the syntax of library names
- else
- Data.Library_Name := Name_Find;
-
- for Index in 2 .. Name_Len loop
- if not Is_Alphanumeric (Name_Buffer (Index)) then
- Data.Library_Name := No_Name;
- Error_Msg ("only letters and digits are allowed",
- Lib_Name.Location);
- exit;
- end if;
- end loop;
+ Data.Library_Name := Lib_Name.Value;
+ end if;
- if Data.Library_Name /= No_Name
- and then Current_Verbosity = High then
- Write_Str ("Library name = """);
- Write_Str (Get_Name_String (Data.Library_Name));
- Write_Line ("""");
- end if;
- end if;
+ if Data.Library_Name /= No_Name
+ and then Current_Verbosity = High
+ then
+ Write_Str ("Library name = """);
+ Write_Str (Get_Name_String (Data.Library_Name));
+ Write_Line ("""");
end if;
Data.Library :=
@@ -2105,17 +3081,14 @@ package body Prj.Nmsc is
Data.Library_Name /= No_Name;
if Data.Library then
-
- if not MLib.Tgt.Libraries_Are_Supported then
- Error_Msg ("?libraries are not supported on this platform",
- Lib_Name.Location);
+ if MLib.Tgt.Support_For_Libraries = MLib.Tgt.None then
+ Error_Msg
+ (Project,
+ "?libraries are not supported on this platform",
+ Lib_Name.Location);
Data.Library := False;
else
- if Current_Verbosity = High then
- Write_Line ("This is a library project file");
- end if;
-
pragma Assert (Lib_Version.Kind = Single);
if Lib_Version.Value = Empty_String then
@@ -2124,8 +3097,7 @@ package body Prj.Nmsc is
end if;
else
- Stringt.String_To_Name_Buffer (Lib_Version.Value);
- Data.Lib_Internal_Name := Name_Find;
+ Data.Lib_Internal_Name := Lib_Version.Value;
end if;
pragma Assert (The_Lib_Kind.Kind = Single);
@@ -2136,7 +3108,7 @@ package body Prj.Nmsc is
end if;
else
- Stringt.String_To_Name_Buffer (The_Lib_Kind.Value);
+ Get_Name_String (The_Lib_Kind.Value);
declare
Kind_Name : constant String :=
@@ -2156,7 +3128,8 @@ package body Prj.Nmsc is
else
Error_Msg
- ("illegal value for Library_Kind",
+ (Project,
+ "illegal value for Library_Kind",
The_Lib_Kind.Location);
OK := False;
end if;
@@ -2165,8 +3138,24 @@ package body Prj.Nmsc is
Write_Str ("Library kind = ");
Write_Line (Kind_Name);
end if;
+
+ if Data.Library_Kind /= Static and then
+ MLib.Tgt.Support_For_Libraries = MLib.Tgt.Static_Only
+ then
+ Error_Msg
+ (Project,
+ "only static libraries are supported " &
+ "on this platform",
+ The_Lib_Kind.Location);
+ Data.Library := False;
+ end if;
end;
end if;
+
+ if Data.Library and then Current_Verbosity = High then
+ Write_Line ("This is a library project file");
+ end if;
+
end if;
end if;
end;
@@ -2192,12 +3181,12 @@ package body Prj.Nmsc is
Write_Line ("Checking ""Naming"".");
end if;
- -- Check Specification_Suffix
+ -- Check Spec_Suffix
declare
Spec_Suffixs : Array_Element_Id :=
Util.Value_Of
- (Name_Specification_Suffix,
+ (Name_Spec_Suffix,
Naming.Decl.Arrays);
Suffix : Array_Element_Id;
Element : Array_Element;
@@ -2207,10 +3196,10 @@ package body Prj.Nmsc is
-- If some suffixs have been specified, we make sure that
-- for each language for which a default suffix has been
-- specified, there is a suffix specified, either the one
- -- in the project file or if there were noe, the default.
+ -- in the project file or if there were none, the default.
if Spec_Suffixs /= No_Array_Element then
- Suffix := Data.Naming.Specification_Suffix;
+ Suffix := Data.Naming.Spec_Suffix;
while Suffix /= No_Array_Element loop
Element := Array_Elements.Table (Suffix);
@@ -2230,6 +3219,7 @@ package body Prj.Nmsc is
Array_Elements.Increment_Last;
Array_Elements.Table (Array_Elements.Last) :=
(Index => Element.Index,
+ Index_Case_Sensitive => False,
Value => Element.Value,
Next => Spec_Suffixs);
Spec_Suffixs := Array_Elements.Last;
@@ -2240,22 +3230,23 @@ package body Prj.Nmsc is
-- Put the resulting array as the specification suffixs
- Data.Naming.Specification_Suffix := Spec_Suffixs;
+ Data.Naming.Spec_Suffix := Spec_Suffixs;
end if;
end;
declare
- Current : Array_Element_Id := Data.Naming.Specification_Suffix;
+ Current : Array_Element_Id := Data.Naming.Spec_Suffix;
Element : Array_Element;
begin
while Current /= No_Array_Element loop
Element := Array_Elements.Table (Current);
- String_To_Name_Buffer (Element.Value.Value);
+ Get_Name_String (Element.Value.Value);
if Name_Len = 0 then
Error_Msg
- ("Specification_Suffix cannot be empty",
+ (Project,
+ "Spec_Suffix cannot be empty",
Element.Value.Location);
end if;
@@ -2264,16 +3255,18 @@ package body Prj.Nmsc is
end loop;
end;
- -- Check Implementation_Suffix
+ -- Check Body_Suffix
declare
Impl_Suffixs : Array_Element_Id :=
- Util.Value_Of
- (Name_Implementation_Suffix,
- Naming.Decl.Arrays);
+ Util.Value_Of
+ (Name_Body_Suffix,
+ Naming.Decl.Arrays);
+
Suffix : Array_Element_Id;
Element : Array_Element;
Suffix2 : Array_Element_Id;
+
begin
-- If some suffixs have been specified, we make sure that
-- for each language for which a default suffix has been
@@ -2281,7 +3274,7 @@ package body Prj.Nmsc is
-- in the project file or if there were noe, the default.
if Impl_Suffixs /= No_Array_Element then
- Suffix := Data.Naming.Implementation_Suffix;
+ Suffix := Data.Naming.Body_Suffix;
while Suffix /= No_Array_Element loop
Element := Array_Elements.Table (Suffix);
@@ -2301,6 +3294,7 @@ package body Prj.Nmsc is
Array_Elements.Increment_Last;
Array_Elements.Table (Array_Elements.Last) :=
(Index => Element.Index,
+ Index_Case_Sensitive => False,
Value => Element.Value,
Next => Impl_Suffixs);
Impl_Suffixs := Array_Elements.Last;
@@ -2311,22 +3305,23 @@ package body Prj.Nmsc is
-- Put the resulting array as the implementation suffixs
- Data.Naming.Implementation_Suffix := Impl_Suffixs;
+ Data.Naming.Body_Suffix := Impl_Suffixs;
end if;
end;
declare
- Current : Array_Element_Id := Data.Naming.Implementation_Suffix;
+ Current : Array_Element_Id := Data.Naming.Body_Suffix;
Element : Array_Element;
begin
while Current /= No_Array_Element loop
Element := Array_Elements.Table (Current);
- String_To_Name_Buffer (Element.Value.Value);
+ Get_Name_String (Element.Value.Value);
if Name_Len = 0 then
Error_Msg
- ("Implementation_Suffix cannot be empty",
+ (Project,
+ "Body_Suffix cannot be empty",
Element.Value.Location);
end if;
@@ -2356,25 +3351,19 @@ package body Prj.Nmsc is
-- Locate_Directory --
----------------------
- function Locate_Directory
- (Name : Name_Id;
- Parent : Name_Id)
- return Name_Id
+ procedure Locate_Directory
+ (Name : Name_Id;
+ Parent : Name_Id;
+ Dir : out Name_Id;
+ Display : out Name_Id)
is
The_Name : constant String := Get_Name_String (Name);
The_Parent : constant String :=
- Get_Name_String (Parent) & Dir_Sep;
-
- The_Parent_Last : Positive := The_Parent'Last;
+ Get_Name_String (Parent) & Directory_Separator;
+ The_Parent_Last : constant Natural :=
+ Compute_Directory_Last (The_Parent);
begin
- if The_Parent'Length > 1
- and then (The_Parent (The_Parent_Last - 1) = Dir_Sep
- or else The_Parent (The_Parent_Last - 1) = '/')
- then
- The_Parent_Last := The_Parent_Last - 1;
- end if;
-
if Current_Verbosity = High then
Write_Str ("Locate_Directory (""");
Write_Str (The_Name);
@@ -2383,28 +3372,46 @@ package body Prj.Nmsc is
Write_Line (""")");
end if;
+ Dir := No_Name;
+ Display := No_Name;
+
if Is_Absolute_Path (The_Name) then
if Is_Directory (The_Name) then
- return Name;
+ declare
+ Normed : constant String :=
+ Normalize_Pathname (The_Name);
+
+ begin
+ Name_Len := Normed'Length;
+ Name_Buffer (1 .. Name_Len) := Normed;
+ Display := Name_Find;
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Dir := Name_Find;
+ end;
end if;
else
declare
Full_Path : constant String :=
The_Parent (The_Parent'First .. The_Parent_Last) &
- The_Name;
+ The_Name;
begin
if Is_Directory (Full_Path) then
- Name_Len := Full_Path'Length;
- Name_Buffer (1 .. Name_Len) := Full_Path;
- return Name_Find;
+ declare
+ Normed : constant String :=
+ Normalize_Pathname (Full_Path);
+
+ begin
+ Name_Len := Normed'Length;
+ Name_Buffer (1 .. Name_Len) := Normed;
+ Display := Name_Find;
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Dir := Name_Find;
+ end;
end if;
end;
-
end if;
-
- return No_Name;
end Locate_Directory;
------------------
@@ -2412,7 +3419,7 @@ package body Prj.Nmsc is
------------------
function Path_Name_Of
- (File_Name : String_Id;
+ (File_Name : Name_Id;
Directory : Name_Id)
return String
is
@@ -2420,7 +3427,7 @@ package body Prj.Nmsc is
The_Directory : constant String := Get_Name_String (Directory);
begin
- String_To_Name_Buffer (File_Name);
+ Get_Name_String (File_Name);
Result := Locate_Regular_File
(File_Name => Name_Buffer (1 .. Name_Len),
Path => The_Directory);
@@ -2433,52 +3440,111 @@ package body Prj.Nmsc is
end if;
end Path_Name_Of;
+ ---------------------
+ -- Project_Extends --
+ ---------------------
+
+ function Project_Extends
+ (Extending : Project_Id;
+ Extended : Project_Id)
+ return Boolean
+ is
+ Current : Project_Id := Extending;
+ begin
+ loop
+ if Current = No_Project then
+ return False;
+
+ elsif Current = Extended then
+ return True;
+ end if;
+
+ Current := Projects.Table (Current).Extends;
+ end loop;
+ end Project_Extends;
+
-------------------
-- Record_Source --
-------------------
procedure Record_Source
- (File_Name : Name_Id;
- Path_Name : Name_Id;
- Project : Project_Id;
- Data : in out Project_Data;
- Location : Source_Ptr;
- Current_Source : in out String_List_Id)
+ (File_Name : Name_Id;
+ Path_Name : Name_Id;
+ Project : Project_Id;
+ Data : in out Project_Data;
+ Location : Source_Ptr;
+ Current_Source : in out String_List_Id;
+ Source_Recorded : in out Boolean)
is
+ Canonical_File_Name : Name_Id;
+ Canonical_Path_Name : Name_Id;
Unit_Name : Name_Id;
Unit_Kind : Spec_Or_Body;
Needs_Pragma : Boolean;
- The_Location : Source_Ptr := Location;
+
+ The_Location : Source_Ptr := Location;
+ Previous_Source : constant String_List_Id := Current_Source;
+ Except_Name : Name_Id := No_Name;
begin
+ Get_Name_String (File_Name);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Canonical_File_Name := Name_Find;
+ Get_Name_String (Path_Name);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Canonical_Path_Name := Name_Find;
+
-- Find out the unit name, the unit kind and if it needs
-- a specific SFN pragma.
Get_Unit
- (File_Name => File_Name,
- Naming => Data.Naming,
- Unit_Name => Unit_Name,
- Unit_Kind => Unit_Kind,
- Needs_Pragma => Needs_Pragma);
+ (Canonical_File_Name => Canonical_File_Name,
+ Naming => Data.Naming,
+ Unit_Name => Unit_Name,
+ Unit_Kind => Unit_Kind,
+ Needs_Pragma => Needs_Pragma);
if Unit_Name = No_Name then
if Current_Verbosity = High then
Write_Str (" """);
- Write_Str (Get_Name_String (File_Name));
+ Write_Str (Get_Name_String (Canonical_File_Name));
Write_Line (""" is not a valid source file name (ignored).");
end if;
else
+ -- Check to see if the source has been hidden by an exception,
+ -- but only if it is not an exception.
+
+ if not Needs_Pragma then
+ Except_Name :=
+ Reverse_Naming_Exceptions.Get ((Unit_Kind, Unit_Name));
+
+ if Except_Name /= No_Name then
+ if Current_Verbosity = High then
+ Write_Str (" """);
+ Write_Str (Get_Name_String (Canonical_File_Name));
+ Write_Str (""" contains a unit that is found in """);
+ Write_Str (Get_Name_String (Except_Name));
+ Write_Line (""" (ignored).");
+ end if;
+
+ -- The file is not included in the source of the project,
+ -- because it is hidden by the exception.
+ -- So, there is nothing else to do.
+
+ return;
+ end if;
+ end if;
+
-- Put the file name in the list of sources of the project
String_Elements.Increment_Last;
- Get_Name_String (File_Name);
- Start_String;
- Store_String_Chars (Name_Buffer (1 .. Name_Len));
String_Elements.Table (String_Elements.Last) :=
- (Value => End_String,
- Location => No_Location,
- Next => Nil_String);
+ (Value => Canonical_File_Name,
+ Display_Value => File_Name,
+ Location => No_Location,
+ Flag => False,
+ Next => Nil_String);
if Current_Source = Nil_String then
Data.Sources := String_Elements.Last;
@@ -2511,17 +3577,39 @@ package body Prj.Nmsc is
The_Unit_Data := Units.Table (The_Unit);
if The_Unit_Data.File_Names (Unit_Kind).Name = No_Name
- or else (Data.Modifies /= No_Project
- and then
- The_Unit_Data.File_Names (Unit_Kind).Project =
- Data.Modifies)
+ or else Project_Extends
+ (Data.Extends,
+ The_Unit_Data.File_Names (Unit_Kind).Project)
then
+ if The_Unit_Data.File_Names (Unit_Kind).Path = Slash then
+ Remove_Forbidden_File_Name
+ (The_Unit_Data.File_Names (Unit_Kind).Name);
+ end if;
+
The_Unit_Data.File_Names (Unit_Kind) :=
- (Name => File_Name,
- Path => Path_Name,
+ (Name => Canonical_File_Name,
+ Display_Name => File_Name,
+ Path => Canonical_Path_Name,
+ Display_Path => Path_Name,
Project => Project,
Needs_Pragma => Needs_Pragma);
Units.Table (The_Unit) := The_Unit_Data;
+ Source_Recorded := True;
+
+ elsif The_Unit_Data.File_Names (Unit_Kind).Project = Project
+ and then (Data.Known_Order_Of_Source_Dirs or else
+ The_Unit_Data.File_Names (Unit_Kind).Path =
+ Canonical_Path_Name)
+ then
+ if Previous_Source = Nil_String then
+ Data.Sources := Nil_String;
+ else
+ String_Elements.Table (Previous_Source).Next :=
+ Nil_String;
+ String_Elements.Decrement_Last;
+ end if;
+
+ Current_Source := Previous_Source;
else
-- It is an error to have two units with the same name
@@ -2531,19 +3619,19 @@ package body Prj.Nmsc is
The_Location := Projects.Table (Project).Location;
end if;
- Errout.Error_Msg_Name_1 := Unit_Name;
- Error_Msg ("duplicate source {", The_Location);
+ Err_Vars.Error_Msg_Name_1 := Unit_Name;
+ Error_Msg (Project, "duplicate source {", The_Location);
- Errout.Error_Msg_Name_1 :=
+ Err_Vars.Error_Msg_Name_1 :=
Projects.Table
(The_Unit_Data.File_Names (Unit_Kind).Project).Name;
- Errout.Error_Msg_Name_2 :=
+ Err_Vars.Error_Msg_Name_2 :=
The_Unit_Data.File_Names (Unit_Kind).Path;
- Error_Msg ("\ project file {, {", The_Location);
+ Error_Msg (Project, "\ project file {, {", The_Location);
- Errout.Error_Msg_Name_1 := Projects.Table (Project).Name;
- Errout.Error_Msg_Name_2 := Path_Name;
- Error_Msg ("\ project file {, {", The_Location);
+ Err_Vars.Error_Msg_Name_1 := Projects.Table (Project).Name;
+ Err_Vars.Error_Msg_Name_2 := Canonical_Path_Name;
+ Error_Msg (Project, "\ project file {, {", The_Location);
end if;
@@ -2555,11 +3643,14 @@ package body Prj.Nmsc is
Units_Htable.Set (Unit_Name, The_Unit);
The_Unit_Data.Name := Unit_Name;
The_Unit_Data.File_Names (Unit_Kind) :=
- (Name => File_Name,
- Path => Path_Name,
+ (Name => Canonical_File_Name,
+ Display_Name => File_Name,
+ Path => Canonical_Path_Name,
+ Display_Path => Path_Name,
Project => Project,
Needs_Pragma => Needs_Pragma);
Units.Table (The_Unit) := The_Unit_Data;
+ Source_Recorded := True;
end if;
end;
end if;
diff --git a/gcc/ada/prj-nmsc.ads b/gcc/ada/prj-nmsc.ads
index 33f38094139..63e0f35c707 100644
--- a/gcc/ada/prj-nmsc.ads
+++ b/gcc/ada/prj-nmsc.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- P R J . N M S C --
+-- P R J . N M S C --
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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- --
@@ -23,7 +23,7 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
---
+
-- Check the Naming Scheme of a project file, find the directories
-- and the source files.
diff --git a/gcc/ada/prj-pars.adb b/gcc/ada/prj-pars.adb
index 426be05e6de..19a560d6118 100644
--- a/gcc/ada/prj-pars.adb
+++ b/gcc/ada/prj-pars.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- P R J . P A R S --
+-- P R J . P A R S --
-- --
-- B o d y --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,7 @@
with Ada.Exceptions; use Ada.Exceptions;
-with Errout; use Errout;
+with Prj.Err; use Prj.Err;
with Output; use Output;
with Prj.Com; use Prj.Com;
with Prj.Part;
@@ -41,10 +41,12 @@ package body Prj.Pars is
procedure Parse
(Project : out Project_Id;
- Project_File_Name : String)
+ Project_File_Name : String;
+ Packages_To_Check : String_List_Access := All_Packages)
is
Project_Tree : Project_Node_Id := Empty_Node;
The_Project : Project_Id := No_Project;
+ Success : Boolean := True;
begin
-- Parse the main project file into a tree
@@ -52,16 +54,22 @@ package body Prj.Pars is
Prj.Part.Parse
(Project => Project_Tree,
Project_File_Name => Project_File_Name,
- Always_Errout_Finalize => False);
+ Always_Errout_Finalize => False,
+ Packages_To_Check => Packages_To_Check);
-- If there were no error, process the tree
if Project_Tree /= Empty_Node then
Prj.Proc.Process
(Project => The_Project,
+ Success => Success,
From_Project_Node => Project_Tree,
Report_Error => null);
- Errout.Finalize;
+ Prj.Err.Finalize;
+
+ if not Success then
+ The_Project := No_Project;
+ end if;
end if;
Project := The_Project;
diff --git a/gcc/ada/prj-pars.ads b/gcc/ada/prj-pars.ads
index a928d3a5e29..4f157ef159e 100644
--- a/gcc/ada/prj-pars.ads
+++ b/gcc/ada/prj-pars.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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- --
@@ -23,9 +23,11 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
---
+
-- Implements the parsing of project files.
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
package Prj.Pars is
procedure Set_Verbosity (To : Verbosity);
@@ -33,10 +35,14 @@ package Prj.Pars is
procedure Parse
(Project : out Project_Id;
- Project_File_Name : String);
+ Project_File_Name : String;
+ Packages_To_Check : String_List_Access := All_Packages);
-- Parse a project files and all its imported project files.
-- If parsing is successful, Project_Id is the project ID
-- of the main project file; otherwise, Project_Id is set
-- to No_Project.
+ -- Packages_To_Check indicates the packages where any unknown attribute
+ -- produces an error. For other packages, an unknown attribute produces
+ -- a warning.
end Prj.Pars;
diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb
index 114f18539b1..28e4af9bd44 100644
--- a/gcc/ada/prj-part.adb
+++ b/gcc/ada/prj-part.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -24,24 +24,25 @@
-- --
------------------------------------------------------------------------------
+with Err_Vars; use Err_Vars;
+with Namet; use Namet;
+with Opt;
+with Osint; use Osint;
+with Output; use Output;
+with Prj.Com; use Prj.Com;
+with Prj.Dect;
+with Prj.Err; use Prj.Err;
+with Scans; use Scans;
+with Sinput; use Sinput;
+with Sinput.P; use Sinput.P;
+with Table;
+with Types; use Types;
+
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Exceptions; use Ada.Exceptions;
-with Errout; use Errout;
+
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Namet; use Namet;
-with Osint; use Osint;
-with Output; use Output;
-with Prj.Com; use Prj.Com;
-with Prj.Dect;
-with Scans; use Scans;
-with Scn; use Scn;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Sinput.P; use Sinput.P;
-with Stringt; use Stringt;
-with Table;
-with Types; use Types;
pragma Elaborate_All (GNAT.OS_Lib);
@@ -51,55 +52,97 @@ package body Prj.Part is
Project_Path : String_Access;
-- The project path; initialized during package elaboration.
+ -- Contains at least the current working directory.
Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
+ -- Name of the env. variable that contains path name(s) of directories
+ -- where project files may reside.
+
Prj_Path : constant String_Access := Getenv (Ada_Project_Path);
+ -- The path name(s) of directories where project files may reside.
+ -- May be empty.
------------------------------------
-- Local Packages and Subprograms --
------------------------------------
+ type With_Id is new Nat;
+ No_With : constant With_Id := 0;
+
+ type With_Record is record
+ Path : Name_Id;
+ Location : Source_Ptr;
+ Limited_With : Boolean;
+ Next : With_Id;
+ end record;
+ -- Information about an imported project, to be put in table Withs below
+
+ package Withs is new Table.Table
+ (Table_Component_Type => With_Record,
+ Table_Index_Type => With_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 50,
+ Table_Name => "Prj.Part.Withs");
+ -- Table used to store temporarily paths and locations of imported
+ -- projects. These imported projects will be effectively parsed after the
+ -- name of the current project has been extablished.
+
+ type Name_And_Id is record
+ Name : Name_Id;
+ Id : Project_Node_Id;
+ end record;
+
package Project_Stack is new Table.Table
- (Table_Component_Type => Name_Id,
+ (Table_Component_Type => Name_And_Id,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 10,
- Table_Increment => 10,
+ Table_Increment => 50,
Table_Name => "Prj.Part.Project_Stack");
-- This table is used to detect circular dependencies
- -- for imported and modified projects.
-
- procedure Parse_Context_Clause
- (Context_Clause : out Project_Node_Id;
- Project_Directory : Name_Id);
- -- Parse the context clause of a project
- -- Does nothing if there is b\no context clause (if the current
- -- token is not "with").
+ -- for imported and extended projects and to get the project ids of
+ -- limited imported projects when there is a circularity with at least
+ -- one limited imported project file.
+
+ procedure Pre_Parse_Context_Clause (Context_Clause : out With_Id);
+ -- Parse the context clause of a project.
+ -- Store the paths and locations of the imported projects in table Withs.
+ -- Does nothing if there is no context clause (if the current
+ -- token is not "with" or "limited" followed by "with").
+
+ procedure Post_Parse_Context_Clause
+ (Context_Clause : With_Id;
+ Imported_Projects : out Project_Node_Id;
+ Project_Directory : Name_Id;
+ From_Extended : Boolean);
+ -- Parse the imported projects that have been stored in table Withs,
+ -- if any. From_Extended is used for the call to Parse_Single_Project
+ -- below.
procedure Parse_Single_Project
- (Project : out Project_Node_Id;
- Path_Name : String;
- Modified : Boolean);
+ (Project : out Project_Node_Id;
+ Path_Name : String;
+ Extended : Boolean;
+ From_Extended : Boolean);
-- Parse a project file.
- -- Recursive procedure: it calls itself for imported and
- -- modified projects.
+ -- Recursive procedure: it calls itself for imported and extended
+ -- projects. When From_Extended is True, if the project has already
+ -- been parsed and is an extended project A, return the ultimate
+ -- (not extended) project that extends A.
function Project_Path_Name_Of
(Project_File_Name : String;
Directory : String)
return String;
- -- Returns the path name of a project file.
- -- Returns an empty string if project file cannot be found.
+ -- Returns the path name of a project file. Returns an empty string
+ -- if project file cannot be found.
function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id;
-- Get the directory of the file with the specified path name.
-- This includes the directory separator as the last character.
-- Returns "./" if Path_Name contains no directory separator.
- function Simple_File_Name_Of (Path_Name : Name_Id) return Name_Id;
- -- Returns the name of a file with the specified path name
- -- with no directory information.
-
function Project_Name_From (Path_Name : String) return Name_Id;
-- Returns the name of the project that corresponds to its path name.
-- Returns No_Name if the path name is invalid, because the corresponding
@@ -117,10 +160,15 @@ package body Prj.Part is
if Name_Buffer (Index) = '/'
or else Name_Buffer (Index) = Dir_Sep
then
- -- Remove from name all characters after the last
- -- directory separator.
+ -- Remove all chars after last directory separator from name
+
+ if Index > 1 then
+ Name_Len := Index - 1;
+
+ else
+ Name_Len := Index;
+ end if;
- Name_Len := Index;
return Name_Find;
end if;
end loop;
@@ -140,11 +188,17 @@ package body Prj.Part is
procedure Parse
(Project : out Project_Node_Id;
Project_File_Name : String;
- Always_Errout_Finalize : Boolean)
+ Always_Errout_Finalize : Boolean;
+ Packages_To_Check : String_List_Access := All_Packages)
is
Current_Directory : constant String := Get_Current_Dir;
begin
+ -- Save the Packages_To_Check in Prj, so that it is visible from
+ -- Prj.Dect.
+
+ Current_Packages_To_Check := Packages_To_Check;
+
Project := Empty_Node;
if Current_Verbosity >= Medium then
@@ -159,28 +213,32 @@ package body Prj.Part is
Directory => Current_Directory);
begin
- Errout.Initialize;
+ Prj.Err.Initialize;
-- Parse the main project file
if Path_Name = "" then
- Fail ("project file """ & Project_File_Name & """ not found");
+ Prj.Com.Fail
+ ("project file """, Project_File_Name, """ not found");
+ Project := Empty_Node;
+ return;
end if;
Parse_Single_Project
- (Project => Project,
- Path_Name => Path_Name,
- Modified => False);
+ (Project => Project,
+ Path_Name => Path_Name,
+ Extended => False,
+ From_Extended => False);
-- If there were any kind of error during the parsing, serious
-- or not, then the parsing fails.
- if Errout.Total_Errors_Detected > 0 then
+ if Err_Vars.Total_Errors_Detected > 0 then
Project := Empty_Node;
end if;
if Project = Empty_Node or else Always_Errout_Finalize then
- Errout.Finalize;
+ Prj.Err.Finalize;
end if;
end;
@@ -196,29 +254,34 @@ package body Prj.Part is
Project := Empty_Node;
end Parse;
- --------------------------
- -- Parse_Context_Clause --
- --------------------------
+ ------------------------------
+ -- Pre_Parse_Context_Clause --
+ ------------------------------
- procedure Parse_Context_Clause
- (Context_Clause : out Project_Node_Id;
- Project_Directory : Name_Id)
- is
- Project_Directory_Path : constant String :=
- Get_Name_String (Project_Directory);
- Current_With_Clause : Project_Node_Id := Empty_Node;
- Next_With_Clause : Project_Node_Id := Empty_Node;
+ procedure Pre_Parse_Context_Clause (Context_Clause : out With_Id) is
+ Current_With_Clause : With_Id := No_With;
+ Limited_With : Boolean := False;
+
+ Current_With : With_Record;
begin
-- Assume no context clause
- Context_Clause := Empty_Node;
+ Context_Clause := No_With;
With_Loop :
- -- If Token is not WITH, there is no context clause,
+ -- If Token is not WITH or LIMITED, there is no context clause,
-- or we have exhausted the with clauses.
- while Token = Tok_With loop
+ while Token = Tok_With or else Token = Tok_Limited loop
+ Limited_With := Token = Tok_Limited;
+
+ if Limited_With then
+ Scan; -- scan past LIMITED
+ Expect (Tok_With, "WITH");
+ exit With_Loop when Token /= Tok_With;
+ end if;
+
Comma_Loop :
loop
Scan; -- scan past WITH or ","
@@ -229,143 +292,252 @@ package body Prj.Part is
return;
end if;
- String_To_Name_Buffer (Strval (Token_Node));
+ -- Store path and location in table Withs
- declare
- Original_Path : constant String :=
- Name_Buffer (1 .. Name_Len);
+ Current_With :=
+ (Path => Token_Name,
+ Location => Token_Ptr,
+ Limited_With => Limited_With,
+ Next => No_With);
- Imported_Path_Name : constant String :=
- Project_Path_Name_Of
- (Original_Path,
- Project_Directory_Path);
+ Withs.Increment_Last;
+ Withs.Table (Withs.Last) := Current_With;
- Withed_Project : Project_Node_Id := Empty_Node;
+ if Current_With_Clause = No_With then
+ Context_Clause := Withs.Last;
- begin
- if Imported_Path_Name = "" then
+ else
+ Withs.Table (Current_With_Clause).Next := Withs.Last;
+ end if;
+
+ Current_With_Clause := Withs.Last;
- -- The project file cannot be found
+ Scan;
- Name_Len := Original_Path'Length;
- Name_Buffer (1 .. Name_Len) := Original_Path;
- Error_Msg_Name_1 := Name_Find;
+ if Token = Tok_Semicolon then
- Error_Msg ("unknown project file: {", Token_Ptr);
+ -- End of (possibly multiple) with clause;
- -- If this is not imported by the main project file,
- -- display the import path.
+ Scan; -- scan past the semicolon.
+ exit Comma_Loop;
- if Project_Stack.Last > 1 then
- for Index in reverse 1 .. Project_Stack.Last loop
- Error_Msg_Name_1 := Project_Stack.Table (Index);
- Error_Msg ("\imported by {", Token_Ptr);
- end loop;
- end if;
+ elsif Token /= Tok_Comma then
+ Error_Msg ("expected comma or semi colon", Token_Ptr);
+ exit Comma_Loop;
+ end if;
+ end loop Comma_Loop;
+ end loop With_Loop;
+ end Pre_Parse_Context_Clause;
- else
- -- New with clause
- if Current_With_Clause = Empty_Node then
+ -------------------------------
+ -- Post_Parse_Context_Clause --
+ -------------------------------
- -- First with clause of the context clause
+ procedure Post_Parse_Context_Clause
+ (Context_Clause : With_Id;
+ Imported_Projects : out Project_Node_Id;
+ Project_Directory : Name_Id;
+ From_Extended : Boolean)
+ is
+ Current_With_Clause : With_Id := Context_Clause;
- Current_With_Clause := Default_Project_Node
- (Of_Kind => N_With_Clause);
- Context_Clause := Current_With_Clause;
+ Current_Project : Project_Node_Id := Empty_Node;
+ Previous_Project : Project_Node_Id := Empty_Node;
+ Next_Project : Project_Node_Id := Empty_Node;
- else
- Next_With_Clause := Default_Project_Node
- (Of_Kind => N_With_Clause);
- Set_Next_With_Clause_Of
- (Current_With_Clause, Next_With_Clause);
- Current_With_Clause := Next_With_Clause;
- end if;
+ Project_Directory_Path : constant String :=
+ Get_Name_String (Project_Directory);
- Set_String_Value_Of
- (Current_With_Clause, Strval (Token_Node));
- Set_Location_Of (Current_With_Clause, Token_Ptr);
- String_To_Name_Buffer
- (String_Value_Of (Current_With_Clause));
+ Current_With : With_Record;
+ Limited_With : Boolean := False;
- -- Parse the imported project
+ begin
+ Imported_Projects := Empty_Node;
- Parse_Single_Project
- (Project => Withed_Project,
- Path_Name => Imported_Path_Name,
- Modified => False);
+ while Current_With_Clause /= No_With loop
+ Current_With := Withs.Table (Current_With_Clause);
+ Current_With_Clause := Current_With.Next;
+
+ Limited_With := Current_With.Limited_With;
- if Withed_Project /= Empty_Node then
+ declare
+ Original_Path : constant String :=
+ Get_Name_String (Current_With.Path);
- -- If parsing was successful, record project name
- -- and path name in with clause
+ Imported_Path_Name : constant String :=
+ Project_Path_Name_Of
+ (Original_Path,
+ Project_Directory_Path);
- Set_Project_Node_Of (Current_With_Clause, Withed_Project);
- Set_Name_Of (Current_With_Clause,
- Name_Of (Withed_Project));
- Name_Len := Imported_Path_Name'Length;
- Name_Buffer (1 .. Name_Len) := Imported_Path_Name;
- Set_Path_Name_Of (Current_With_Clause, Name_Find);
- end if;
+ Withed_Project : Project_Node_Id := Empty_Node;
+
+ begin
+ if Imported_Path_Name = "" then
+
+ -- The project file cannot be found
+
+ Error_Msg_Name_1 := Current_With.Path;
+
+ Error_Msg ("unknown project file: {", Current_With.Location);
+
+ -- If this is not imported by the main project file,
+ -- display the import path.
+
+ if Project_Stack.Last > 1 then
+ for Index in reverse 1 .. Project_Stack.Last loop
+ Error_Msg_Name_1 := Project_Stack.Table (Index).Name;
+ Error_Msg ("\imported by {", Current_With.Location);
+ end loop;
end if;
- end;
- Scan;
- if Token = Tok_Semicolon then
+ else
+ -- New with clause
- -- End of (possibly multiple) with clause;
+ Previous_Project := Current_Project;
- Scan; -- scan past the semicolon.
- exit Comma_Loop;
+ if Current_Project = Empty_Node then
- elsif Token /= Tok_Comma then
- Error_Msg ("expected comma or semi colon", Token_Ptr);
- exit Comma_Loop;
- end if;
- end loop Comma_Loop;
- end loop With_Loop;
+ -- First with clause of the context clause
- end Parse_Context_Clause;
+ Current_Project := Default_Project_Node
+ (Of_Kind => N_With_Clause);
+ Imported_Projects := Current_Project;
+
+ else
+ Next_Project := Default_Project_Node
+ (Of_Kind => N_With_Clause);
+ Set_Next_With_Clause_Of (Current_Project, Next_Project);
+ Current_Project := Next_Project;
+ end if;
+
+ Set_String_Value_Of
+ (Current_Project, Current_With.Path);
+ Set_Location_Of (Current_Project, Current_With.Location);
+
+ -- If this is a "limited with", check if we have
+ -- a circularity; if we have one, get the project id
+ -- of the limited imported project file, and don't
+ -- parse it.
+
+ if Limited_With and then Project_Stack.Last > 1 then
+ declare
+ Normed : constant String :=
+ Normalize_Pathname (Imported_Path_Name);
+ Canonical_Path_Name : Name_Id;
+
+ begin
+ Name_Len := Normed'Length;
+ Name_Buffer (1 .. Name_Len) := Normed;
+ Canonical_Path_Name := Name_Find;
+
+ for Index in 1 .. Project_Stack.Last loop
+ if Project_Stack.Table (Index).Name =
+ Canonical_Path_Name
+ then
+ -- We have found the limited imported project,
+ -- get its project id, and don't parse it.
+
+ Withed_Project := Project_Stack.Table (Index).Id;
+ exit;
+ end if;
+ end loop;
+ end;
+ end if;
+
+ -- Parse the imported project, if its project id is unknown
+
+ if Withed_Project = Empty_Node then
+ Parse_Single_Project
+ (Project => Withed_Project,
+ Path_Name => Imported_Path_Name,
+ Extended => False,
+ From_Extended => From_Extended);
+ end if;
+
+ if Withed_Project = Empty_Node then
+ -- If parsing was not successful, remove the
+ -- context clause.
+
+ Current_Project := Previous_Project;
+
+ if Current_Project = Empty_Node then
+ Imported_Projects := Empty_Node;
+
+ else
+ Set_Next_With_Clause_Of
+ (Current_Project, Empty_Node);
+ end if;
+ else
+ -- If parsing was successful, record project name
+ -- and path name in with clause
+
+ Set_Project_Node_Of
+ (Node => Current_Project,
+ To => Withed_Project,
+ Limited_With => Limited_With);
+ Set_Name_Of (Current_Project, Name_Of (Withed_Project));
+ Name_Len := Imported_Path_Name'Length;
+ Name_Buffer (1 .. Name_Len) := Imported_Path_Name;
+ Set_Path_Name_Of (Current_Project, Name_Find);
+ end if;
+ end if;
+ end;
+ end loop;
+ end Post_Parse_Context_Clause;
--------------------------
-- Parse_Single_Project --
--------------------------
procedure Parse_Single_Project
- (Project : out Project_Node_Id;
- Path_Name : String;
- Modified : Boolean)
+ (Project : out Project_Node_Id;
+ Path_Name : String;
+ Extended : Boolean;
+ From_Extended : Boolean)
is
+ Normed_Path_Name : Name_Id;
Canonical_Path_Name : Name_Id;
Project_Directory : Name_Id;
Project_Scan_State : Saved_Project_Scan_State;
Source_Index : Source_File_Index;
- Modified_Project : Project_Node_Id := Empty_Node;
+ Extended_Project : Project_Node_Id := Empty_Node;
A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
- Tree_Private_Part.Projects_Htable.Get_First;
+ Tree_Private_Part.Projects_Htable.Get_First;
Name_From_Path : constant Name_Id := Project_Name_From (Path_Name);
+ Name_Of_Project : Name_Id := No_Name;
+
+ First_With : With_Id;
+
use Tree_Private_Part;
begin
- Name_Len := Path_Name'Length;
- Name_Buffer (1 .. Name_Len) := Path_Name;
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Canonical_Path_Name := Name_Find;
+ declare
+ Normed : String := Normalize_Pathname (Path_Name);
+ begin
+ Name_Len := Normed'Length;
+ Name_Buffer (1 .. Name_Len) := Normed;
+ Normed_Path_Name := Name_Find;
+ Canonical_Case_File_Name (Normed);
+ Name_Len := Normed'Length;
+ Name_Buffer (1 .. Name_Len) := Normed;
+ Canonical_Path_Name := Name_Find;
+ end;
-- Check for a circular dependency
for Index in 1 .. Project_Stack.Last loop
- if Canonical_Path_Name = Project_Stack.Table (Index) then
+ if Canonical_Path_Name = Project_Stack.Table (Index).Name then
Error_Msg ("circular dependency detected", Token_Ptr);
- Error_Msg_Name_1 := Canonical_Path_Name;
+ Error_Msg_Name_1 := Normed_Path_Name;
Error_Msg ("\ { is imported by", Token_Ptr);
for Current in reverse 1 .. Project_Stack.Last loop
- Error_Msg_Name_1 := Project_Stack.Table (Current);
+ Error_Msg_Name_1 := Project_Stack.Table (Current).Name;
if Error_Msg_Name_1 /= Canonical_Path_Name then
Error_Msg
@@ -383,7 +555,7 @@ package body Prj.Part is
end loop;
Project_Stack.Increment_Last;
- Project_Stack.Table (Project_Stack.Last) := Canonical_Path_Name;
+ Project_Stack.Table (Project_Stack.Last).Name := Canonical_Path_Name;
-- Check if the project file has already been parsed.
@@ -393,23 +565,45 @@ package body Prj.Part is
if
Path_Name_Of (A_Project_Name_And_Node.Node) = Canonical_Path_Name
then
- if Modified then
+ if Extended then
- if A_Project_Name_And_Node.Modified then
+ if A_Project_Name_And_Node.Extended then
Error_Msg
- ("cannot modify the same project file several times",
+ ("cannot extend the same project file several times",
Token_Ptr);
else
Error_Msg
- ("cannot modify an imported project file",
+ ("cannot extend an already imported project file",
Token_Ptr);
end if;
- elsif A_Project_Name_And_Node.Modified then
- Error_Msg
- ("cannot imported a modified project file",
- Token_Ptr);
+ elsif A_Project_Name_And_Node.Extended then
+ -- If the imported project is an extended project A, and we are
+ -- in an extended project, replace A with the ultimate project
+ -- extending A.
+
+ if From_Extended then
+ declare
+ Decl : Project_Node_Id :=
+ Project_Declaration_Of
+ (A_Project_Name_And_Node.Node);
+ Prj : Project_Node_Id :=
+ Extending_Project_Of (Decl);
+ begin
+ loop
+ Decl := Project_Declaration_Of (Prj);
+ exit when Extending_Project_Of (Decl) = Empty_Node;
+ Prj := Extending_Project_Of (Decl);
+ end loop;
+
+ A_Project_Name_And_Node.Node := Prj;
+ end;
+ else
+ Error_Msg
+ ("cannot import an already extended project file",
+ Token_Ptr);
+ end if;
end if;
Project := A_Project_Name_And_Node.Node;
@@ -434,7 +628,8 @@ package body Prj.Part is
return;
end if;
- Initialize_Scanner (Types.No_Unit, Source_Index);
+ Prj.Err.Scanner.Initialize_Scanner (Types.No_Unit, Source_Index);
+ Scan;
if Name_From_Path = No_Name then
@@ -453,25 +648,18 @@ package body Prj.Part is
Write_Eol;
end if;
- Project_Directory := Immediate_Directory_Of (Canonical_Path_Name);
+ Project_Directory := Immediate_Directory_Of (Normed_Path_Name);
Project := Default_Project_Node (Of_Kind => N_Project);
+ Project_Stack.Table (Project_Stack.Last).Id := Project;
Set_Directory_Of (Project, Project_Directory);
- Set_Name_Of (Project, Simple_File_Name_Of (Canonical_Path_Name));
- Set_Path_Name_Of (Project, Canonical_Path_Name);
+ Set_Path_Name_Of (Project, Normed_Path_Name);
Set_Location_Of (Project, Token_Ptr);
-- Is there any imported project?
- declare
- First_With_Clause : Project_Node_Id := Empty_Node;
+ Pre_Parse_Context_Clause (First_With);
- begin
- Parse_Context_Clause (Context_Clause => First_With_Clause,
- Project_Directory => Project_Directory);
- Set_First_With_Clause_Of (Project, First_With_Clause);
- end;
-
- Expect (Tok_Project, "project");
+ Expect (Tok_Project, "PROJECT");
-- Mark location of PROJECT token if present
@@ -480,24 +668,74 @@ package body Prj.Part is
Scan; -- scan past project
end if;
- Expect (Tok_Identifier, "identifier");
+ -- Clear the Buffer
+
+ Buffer_Last := 0;
- if Token = Tok_Identifier then
- Set_Name_Of (Project, Token_Name);
+ loop
+ Expect (Tok_Identifier, "identifier");
+
+ -- If the token is not an identifier, clear the buffer before
+ -- exiting to indicate that the name of the project is ill-formed.
+
+ if Token /= Tok_Identifier then
+ Buffer_Last := 0;
+ exit;
+ end if;
+
+ -- Add the identifier name to the buffer
Get_Name_String (Token_Name);
+ Add_To_Buffer (Name_Buffer (1 .. Name_Len));
+
+ -- Scan past the identifier
+
+ Scan;
+
+ -- If we have a dot, add a dot the the Buffer and look for the next
+ -- identifier.
+
+ exit when Token /= Tok_Dot;
+ Add_To_Buffer (".");
+
+ -- Scan past the dot
+
+ Scan;
+ end loop;
+
+ -- If the name is well formed, Buffer_Last is > 0
+
+ if Buffer_Last > 0 then
+
+ -- The Buffer contains the name of the project
+
+ Name_Len := Buffer_Last;
+ Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
+ Name_Of_Project := Name_Find;
+ Set_Name_Of (Project, Name_Of_Project);
+
+ -- To get expected name of the project file, replace dots by dashes
+
+ Name_Len := Buffer_Last;
+ Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
+
+ for Index in 1 .. Name_Len loop
+ if Name_Buffer (Index) = '.' then
+ Name_Buffer (Index) := '-';
+ end if;
+ end loop;
+
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
declare
Expected_Name : constant Name_Id := Name_Find;
begin
+ -- Output a warning if the actual name is not the expected name
+
if Name_From_Path /= No_Name
and then Expected_Name /= Name_From_Path
then
- -- The project name is not the one that was expected from
- -- the file name. Report a warning.
-
Error_Msg_Name_1 := Expected_Name;
Error_Msg ("?file name does not match unit name, " &
"should be `{" & Project_File_Extension & "`",
@@ -506,6 +744,18 @@ package body Prj.Part is
end;
declare
+ Imported_Projects : Project_Node_Id := Empty_Node;
+
+ begin
+ Post_Parse_Context_Clause
+ (Context_Clause => First_With,
+ Imported_Projects => Imported_Projects,
+ Project_Directory => Project_Directory,
+ From_Extended => Extended);
+ Set_First_With_Clause_Of (Project, Imported_Projects);
+ end;
+
+ declare
Project_Name : Name_Id :=
Tree_Private_Part.Projects_Htable.Get_First.Name;
@@ -513,55 +763,61 @@ package body Prj.Part is
-- Check if we already have a project with this name
while Project_Name /= No_Name
- and then Project_Name /= Token_Name
+ and then Project_Name /= Name_Of_Project
loop
Project_Name := Tree_Private_Part.Projects_Htable.Get_Next.Name;
end loop;
+ -- Report an error if we already have a project with this name
+
if Project_Name /= No_Name then
Error_Msg ("duplicate project name", Token_Ptr);
else
+ -- Otherwise, add the name of the project to the hash table, so
+ -- that we can check that no other subsequent project will have
+ -- the same name.
+
Tree_Private_Part.Projects_Htable.Set
- (K => Token_Name,
- E => (Name => Token_Name,
+ (K => Name_Of_Project,
+ E => (Name => Name_Of_Project,
Node => Project,
- Modified => Modified));
+ Extended => Extended));
end if;
end;
- Scan; -- scan past the project name
end if;
if Token = Tok_Extends then
+ -- Make sure that gnatmake will use mapping files
+
+ Opt.Create_Mapping_File := True;
+
-- We are extending another project
Scan; -- scan past EXTENDS
Expect (Tok_String_Literal, "literal string");
if Token = Tok_String_Literal then
- Set_Modified_Project_Path_Of (Project, Strval (Token_Node));
- String_To_Name_Buffer (Modified_Project_Path_Of (Project));
+ Set_Extended_Project_Path_Of (Project, Token_Name);
declare
Original_Path_Name : constant String :=
- Name_Buffer (1 .. Name_Len);
+ Get_Name_String (Token_Name);
- Modified_Project_Path_Name : constant String :=
+ Extended_Project_Path_Name : constant String :=
Project_Path_Name_Of
(Original_Path_Name,
Get_Name_String
(Project_Directory));
begin
- if Modified_Project_Path_Name = "" then
+ if Extended_Project_Path_Name = "" then
- -- We could not find the project file to modify
+ -- We could not find the project file to extend
- Name_Len := Original_Path_Name'Length;
- Name_Buffer (1 .. Name_Len) := Original_Path_Name;
- Error_Msg_Name_1 := Name_Find;
+ Error_Msg_Name_1 := Token_Name;
Error_Msg ("unknown project file: {", Token_Ptr);
@@ -570,75 +826,174 @@ package body Prj.Part is
if Project_Stack.Last > 1 then
Error_Msg_Name_1 :=
- Project_Stack.Table (Project_Stack.Last);
+ Project_Stack.Table (Project_Stack.Last).Name;
Error_Msg ("\extended by {", Token_Ptr);
for Index in reverse 1 .. Project_Stack.Last - 1 loop
- Error_Msg_Name_1 := Project_Stack.Table (Index);
+ Error_Msg_Name_1 := Project_Stack.Table (Index).Name;
Error_Msg ("\imported by {", Token_Ptr);
end loop;
end if;
else
Parse_Single_Project
- (Project => Modified_Project,
- Path_Name => Modified_Project_Path_Name,
- Modified => True);
+ (Project => Extended_Project,
+ Path_Name => Extended_Project_Path_Name,
+ Extended => True,
+ From_Extended => False);
end if;
end;
- Scan; -- scan past the modified project path
+ Scan; -- scan past the extended project path
end if;
end if;
- Expect (Tok_Is, "is");
+ -- Check that a project with a name including a dot either imports
+ -- or extends the project whose name precedes the last dot.
+
+ if Name_Of_Project /= No_Name then
+ Get_Name_String (Name_Of_Project);
+
+ else
+ Name_Len := 0;
+ end if;
+
+ -- Look for the last dot
+
+ while Name_Len > 0 and then Name_Buffer (Name_Len) /= '.' loop
+ Name_Len := Name_Len - 1;
+ end loop;
+
+ -- If a dot was find, check if the parent project is imported
+ -- or extended.
+
+ if Name_Len > 0 then
+ Name_Len := Name_Len - 1;
+
+ declare
+ Parent_Name : constant Name_Id := Name_Find;
+ Parent_Found : Boolean := False;
+ With_Clause : Project_Node_Id := First_With_Clause_Of (Project);
+
+ begin
+ -- If there is an extended project, check its name
+
+ if Extended_Project /= Empty_Node then
+ Parent_Found := Name_Of (Extended_Project) = Parent_Name;
+ end if;
+
+ -- If the parent project is not the extended project,
+ -- check each imported project until we find the parent project.
+
+ while not Parent_Found and then With_Clause /= Empty_Node loop
+ Parent_Found := Name_Of (Project_Node_Of (With_Clause))
+ = Parent_Name;
+ With_Clause := Next_With_Clause_Of (With_Clause);
+ end loop;
+
+ -- If the parent project was not found, report an error
+
+ if not Parent_Found then
+ Error_Msg_Name_1 := Name_Of_Project;
+ Error_Msg_Name_2 := Parent_Name;
+ Error_Msg ("project { does not import or extend project {",
+ Location_Of (Project));
+ end if;
+ end;
+ end if;
+
+ Expect (Tok_Is, "IS");
declare
Project_Declaration : Project_Node_Id := Empty_Node;
begin
- -- No need to Scan past IS, Prj.Dect.Parse will do it.
+ -- No need to Scan past "is", Prj.Dect.Parse will do it.
Prj.Dect.Parse
(Declarations => Project_Declaration,
Current_Project => Project,
- Extends => Modified_Project);
+ Extends => Extended_Project);
Set_Project_Declaration_Of (Project, Project_Declaration);
+
+ if Extended_Project /= Empty_Node then
+ Set_Extending_Project_Of
+ (Project_Declaration_Of (Extended_Project), To => Project);
+ end if;
end;
- Expect (Tok_End, "end");
+ Expect (Tok_End, "END");
- -- Skip END if present
+ -- Skip "end" if present
if Token = Tok_End then
Scan;
end if;
- Expect (Tok_Identifier, "identifier");
+ -- Clear the Buffer
+
+ Buffer_Last := 0;
- if Token = Tok_Identifier then
+ -- Store the name following "end" in the Buffer. The name may be made of
+ -- several simple names.
- -- We check if this is the project name
+ loop
+ Expect (Tok_Identifier, "identifier");
+
+ -- If we don't have an identifier, clear the buffer before exiting to
+ -- avoid checking the name.
+
+ if Token /= Tok_Identifier then
+ Buffer_Last := 0;
+ exit;
+ end if;
+
+ -- Add the identifier to the Buffer
+ Get_Name_String (Token_Name);
+ Add_To_Buffer (Name_Buffer (1 .. Name_Len));
+
+ -- Scan past the identifier
- if To_Lower (Get_Name_String (Token_Name)) /=
+ Scan;
+ exit when Token /= Tok_Dot;
+ Add_To_Buffer (".");
+ Scan;
+ end loop;
+
+ -- If we have a valid name, check if it is the name of the project
+
+ if Name_Of_Project /= No_Name and then Buffer_Last > 0 then
+ if To_Lower (Buffer (1 .. Buffer_Last)) /=
Get_Name_String (Name_Of (Project))
then
+ -- Invalid name: report an error
+
Error_Msg ("Expected """ &
Get_Name_String (Name_Of (Project)) & """",
Token_Ptr);
end if;
end if;
- if Token /= Tok_Semicolon then
+ Expect (Tok_Semicolon, "`;`");
+
+ -- Check that there is no more text following the end of the project
+ -- source.
+
+ if Token = Tok_Semicolon then
Scan;
- end if;
- Expect (Tok_Semicolon, ";");
+ if Token /= Tok_EOF then
+ Error_Msg
+ ("Unexpected text following end of project", Token_Ptr);
+ end if;
+ end if;
-- Restore the scan state, in case we are not the main project
Restore_Project_Scan_State (Project_Scan_State);
+ -- And remove the project from the project stack
+
Project_Stack.Decrement_Last;
end Parse_Single_Project;
@@ -648,16 +1003,27 @@ package body Prj.Part is
function Project_Name_From (Path_Name : String) return Name_Id is
Canonical : String (1 .. Path_Name'Length) := Path_Name;
- First : Natural := Canonical'Last;
- Last : Positive := First;
+ First : Natural := Canonical'Last;
+ Last : Natural := First;
+ Index : Positive;
begin
+ if Current_Verbosity = High then
+ Write_Str ("Project_Name_From (""");
+ Write_Str (Canonical);
+ Write_Line (""")");
+ end if;
+
+ -- If the path name is empty, return No_Name to indicate failure
+
if First = 0 then
return No_Name;
end if;
Canonical_Case_File_Name (Canonical);
+ -- Look for the last dot in the path name
+
while First > 0
and then
Canonical (First) /= '.'
@@ -665,10 +1031,14 @@ package body Prj.Part is
First := First - 1;
end loop;
- if Canonical (First) = '.' then
+ -- If we have a dot, check that it is followed by the correct extension
+
+ if First > 0 and then Canonical (First) = '.' then
if Canonical (First .. Last) = Project_File_Extension
and then First /= 1
then
+ -- Look for the last directory separator, if any
+
First := First - 1;
Last := First;
@@ -680,46 +1050,77 @@ package body Prj.Part is
end loop;
else
+ -- Not the correct extension, return No_Name to indicate failure
+
return No_Name;
end if;
+ -- If no dot in the path name, return No_Name to indicate failure
+
else
return No_Name;
end if;
- if Canonical (First) = '/'
- or else Canonical (First) = Dir_Sep
- then
- First := First + 1;
+ First := First + 1;
+
+ -- If the extension is the file name, return No_Name to indicate failure
+
+ if First > Last then
+ return No_Name;
end if;
+ -- Put the name in lower case into Name_Buffer
+
Name_Len := Last - First + 1;
Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last));
- if not Is_Letter (Name_Buffer (1)) then
- return No_Name;
+ Index := 1;
- else
- for Index in 2 .. Name_Len - 1 loop
- if Name_Buffer (Index) = '_' then
- if Name_Buffer (Index + 1) = '_' then
+ -- Check if it is a well formed project name. Return No_Name if it is
+ -- ill formed.
+
+ loop
+ if not Is_Letter (Name_Buffer (Index)) then
+ return No_Name;
+
+ else
+ loop
+ Index := Index + 1;
+
+ exit when Index >= Name_Len;
+
+ if Name_Buffer (Index) = '_' then
+ if Name_Buffer (Index + 1) = '_' then
+ return No_Name;
+ end if;
+ end if;
+
+ exit when Name_Buffer (Index) = '-';
+
+ if Name_Buffer (Index) /= '_'
+ and then not Is_Alphanumeric (Name_Buffer (Index))
+ then
return No_Name;
end if;
- elsif not Is_Alphanumeric (Name_Buffer (Index)) then
- return No_Name;
- end if;
+ end loop;
+ end if;
- end loop;
+ if Index >= Name_Len then
+ if Is_Alphanumeric (Name_Buffer (Name_Len)) then
- if not Is_Alphanumeric (Name_Buffer (Name_Len)) then
- return No_Name;
+ -- All checks have succeeded. Return name in Name_Buffer
- else
- return Name_Find;
- end if;
+ return Name_Find;
- end if;
+ else
+ return No_Name;
+ end if;
+
+ elsif Name_Buffer (Index) = '-' then
+ Index := Index + 1;
+ end if;
+ end loop;
end Project_Name_From;
--------------------------
@@ -734,68 +1135,78 @@ package body Prj.Part is
Result : String_Access;
begin
- -- First we try <file_name>.<extension>
-
if Current_Verbosity = High then
Write_Str ("Project_Path_Name_Of (""");
Write_Str (Project_File_Name);
Write_Str (""", """);
Write_Str (Directory);
Write_Line (""");");
- Write_Str (" Trying ");
- Write_Str (Project_File_Name);
- Write_Line (Project_File_Extension);
end if;
- Result :=
- Locate_Regular_File
- (File_Name => Project_File_Name & Project_File_Extension,
- Path => Project_Path.all);
+ if not Is_Absolute_Path (Project_File_Name) then
+ -- First we try <directory>/<file_name>.<extension>
- -- Then we try <file_name>
-
- if Result = null then
if Current_Verbosity = High then
Write_Str (" Trying ");
- Write_Line (Project_File_Name);
+ Write_Str (Directory);
+ Write_Char (Directory_Separator);
+ Write_Str (Project_File_Name);
+ Write_Line (Project_File_Extension);
end if;
Result :=
Locate_Regular_File
- (File_Name => Project_File_Name,
+ (File_Name => Directory & Directory_Separator &
+ Project_File_Name & Project_File_Extension,
Path => Project_Path.all);
- -- The we try <directory>/<file_name>.<extension>
+ -- Then we try <directory>/<file_name>
if Result = null then
if Current_Verbosity = High then
Write_Str (" Trying ");
Write_Str (Directory);
- Write_Str (Project_File_Name);
- Write_Line (Project_File_Extension);
+ Write_Char (Directory_Separator);
+ Write_Line (Project_File_Name);
end if;
Result :=
Locate_Regular_File
- (File_Name => Directory & Project_File_Name &
- Project_File_Extension,
+ (File_Name => Directory & Directory_Separator &
+ Project_File_Name,
Path => Project_Path.all);
+ end if;
+ end if;
- -- Then we try <directory>/<file_name>
+ if Result = null then
- if Result = null then
- if Current_Verbosity = High then
- Write_Str (" Trying ");
- Write_Str (Directory);
- Write_Line (Project_File_Name);
- end if;
+ -- Then we try <file_name>.<extension>
- Result :=
- Locate_Regular_File
- (File_Name => Directory & Project_File_Name,
- Path => Project_Path.all);
- end if;
+ if Current_Verbosity = High then
+ Write_Str (" Trying ");
+ Write_Str (Project_File_Name);
+ Write_Line (Project_File_Extension);
end if;
+
+ Result :=
+ Locate_Regular_File
+ (File_Name => Project_File_Name & Project_File_Extension,
+ Path => Project_Path.all);
+ end if;
+
+ if Result = null then
+
+ -- Then we try <file_name>
+
+ if Current_Verbosity = High then
+ Write_Str (" Trying ");
+ Write_Line (Project_File_Name);
+ end if;
+
+ Result :=
+ Locate_Regular_File
+ (File_Name => Project_File_Name,
+ Path => Project_Path.all);
end if;
-- If we cannot find the project file, we return an empty string
@@ -805,48 +1216,22 @@ package body Prj.Part is
else
declare
- Final_Result : String
- := GNAT.OS_Lib.Normalize_Pathname (Result.all);
+ Final_Result : String :=
+ GNAT.OS_Lib.Normalize_Pathname (Result.all);
begin
Free (Result);
Canonical_Case_File_Name (Final_Result);
return Final_Result;
end;
-
end if;
-
end Project_Path_Name_Of;
- -------------------------
- -- Simple_File_Name_Of --
- -------------------------
-
- function Simple_File_Name_Of (Path_Name : Name_Id) return Name_Id is
- begin
- Get_Name_String (Path_Name);
-
- for Index in reverse 1 .. Name_Len loop
- if Name_Buffer (Index) = '/'
- or else Name_Buffer (Index) = Dir_Sep
- then
- exit when Index = Name_Len;
- Name_Buffer (1 .. Name_Len - Index) :=
- Name_Buffer (Index + 1 .. Name_Len);
- Name_Len := Name_Len - Index;
- return Name_Find;
- end if;
- end loop;
-
- return No_Name;
-
- end Simple_File_Name_Of;
-
begin
+ -- Initialize Project_Path during package elaboration
+
if Prj_Path.all = "" then
Project_Path := new String'(".");
-
else
Project_Path := new String'("." & Path_Separator & Prj_Path.all);
end if;
-
end Prj.Part;
diff --git a/gcc/ada/prj-part.ads b/gcc/ada/prj-part.ads
index c84e61275ca..a4d20faef1a 100644
--- a/gcc/ada/prj-part.ads
+++ b/gcc/ada/prj-part.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-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- --
@@ -23,7 +23,7 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
---
+
-- Implements the parsing of project files into a tree.
with Prj.Tree; use Prj.Tree;
@@ -33,12 +33,14 @@ package Prj.Part is
procedure Parse
(Project : out Project_Node_Id;
Project_File_Name : String;
- Always_Errout_Finalize : Boolean);
- -- Parse a project file and all its imported project files
- -- and create a tree.
- -- Return the node for the project (or Empty_Node if parsing failed).
- -- If Always_Errout_Finalize is True, Errout.Finalize is called
- -- in all cases; otherwise, Errout.Finalize is only called if there are
- -- errors (but not if there are only warnings).
+ Always_Errout_Finalize : Boolean;
+ Packages_To_Check : String_List_Access := All_Packages);
+ -- Parse project file and all its imported project files and create a tree.
+ -- Return the node for the project (or Empty_Node if parsing failed). If
+ -- Always_Errout_Finalize is True, Errout.Finalize is called in all cases,
+ -- Otherwise, Errout.Finalize is only called if there are errors (but not
+ -- if there are only warnings). Packages_To_Check indicates the packages
+ -- where any unknown attribute produces an error. For other packages, an
+ -- unknown attribute produces a warning.
end Prj.Part;
diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb
index 91580e4ae84..8bbc265efc8 100644
--- a/gcc/ada/prj-pp.adb
+++ b/gcc/ada/prj-pp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -29,7 +29,7 @@ with Ada.Characters.Handling; use Ada.Characters.Handling;
with Hostparm;
with Namet; use Namet;
with Output; use Output;
-with Stringt; use Stringt;
+with Snames;
package body Prj.PP is
@@ -42,7 +42,7 @@ package body Prj.PP is
Column : Natural := 0;
-- Column number of the last character in the line. Used to avoid
- -- outputting lines longer than Max_Line_Length.
+ -- outputing lines longer than Max_Line_Length.
procedure Indicate_Tested (Kind : Project_Node_Kind);
-- Set the corresponding component of array Not_Tested to False.
@@ -69,14 +69,18 @@ package body Prj.PP is
Minimize_Empty_Lines : Boolean := False;
W_Char : Write_Char_Ap := null;
W_Eol : Write_Eol_Ap := null;
- W_Str : Write_Str_Ap := null) is
-
+ W_Str : Write_Str_Ap := null;
+ Backward_Compatibility : Boolean)
+ is
procedure Print (Node : Project_Node_Id; Indent : Natural);
- -- A recursive procedure that traverses a project file tree
- -- and outputs its source.
- -- Current_Prj is the project that we are printing. This
- -- is used when printing attributes, since in nested packages they need
- -- to use a fully qualified name.
+ -- A recursive procedure that traverses a project file tree and outputs
+ -- its source. Current_Prj is the project that we are printing. This
+ -- is used when printing attributes, since in nested packages they
+ -- need to use a fully qualified name.
+
+ procedure Output_Attribute_Name (Name : Name_Id);
+ -- Outputs an attribute name, taking into account the value of
+ -- Backward_Compatibility.
procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True);
-- Outputs a name
@@ -84,13 +88,12 @@ package body Prj.PP is
procedure Start_Line (Indent : Natural);
-- Outputs the indentation at the beginning of the line.
- procedure Output_String (S : String_Id);
+ procedure Output_String (S : Name_Id);
-- Outputs a string using the default output procedures
procedure Write_Empty_Line (Always : Boolean := False);
- -- Outputs an empty line, only if the previous line was not
- -- empty already and either Always is True or Minimize_Empty_Lines
- -- is False.
+ -- Outputs an empty line, only if the previous line was not empty
+ -- already and either Always is True or Minimize_Empty_Lines is False.
procedure Write_Line (S : String);
-- Outputs S followed by a new line
@@ -102,11 +105,40 @@ package body Prj.PP is
Write_Char : Write_Char_Ap := Output.Write_Char'Access;
Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access;
Write_Str : Write_Str_Ap := Output.Write_Str'Access;
- -- These two access to procedure values are used for the output.
+ -- These three access to procedure values are used for the output.
Last_Line_Is_Empty : Boolean := False;
-- Used to avoid two consecutive empty lines.
+ ---------------------------
+ -- Output_Attribute_Name --
+ ---------------------------
+
+ procedure Output_Attribute_Name (Name : Name_Id) is
+ begin
+ if Backward_Compatibility then
+ case Name is
+ when Snames.Name_Spec =>
+ Output_Name (Snames.Name_Specification);
+
+ when Snames.Name_Spec_Suffix =>
+ Output_Name (Snames.Name_Specification_Suffix);
+
+ when Snames.Name_Body =>
+ Output_Name (Snames.Name_Implementation);
+
+ when Snames.Name_Body_Suffix =>
+ Output_Name (Snames.Name_Implementation_Suffix);
+
+ when others =>
+ Output_Name (Name);
+ end case;
+
+ else
+ Output_Name (Name);
+ end if;
+ end Output_Attribute_Name;
+
-----------------
-- Output_Name --
-----------------
@@ -137,15 +169,17 @@ package body Prj.PP is
or else Is_Digit (Name_Buffer (J));
end if;
end loop;
+
+ Column := Column + Name_Len;
end Output_Name;
-------------------
-- Output_String --
-------------------
- procedure Output_String (S : String_Id) is
+ procedure Output_String (S : Name_Id) is
begin
- String_To_Name_Buffer (S);
+ Get_Name_String (S);
-- If line could become too long, create new line.
-- Note that the number of characters on the line could be
@@ -159,7 +193,7 @@ package body Prj.PP is
Write_Char ('"');
Column := Column + 1;
- String_To_Name_Buffer (S);
+ Get_Name_String (S);
for J in 1 .. Name_Len loop
if Name_Buffer (J) = '"' then
@@ -266,11 +300,11 @@ package body Prj.PP is
Write_String ("project ");
Output_Name (Name_Of (Node));
- -- Check if this project modifies another project
+ -- Check if this project extends another project
- if Modified_Project_Path_Of (Node) /= No_String then
+ if Extended_Project_Path_Of (Node) /= No_Name then
Write_String (" extends ");
- Output_String (Modified_Project_Path_Of (Node));
+ Output_String (Extended_Project_Path_Of (Node));
end if;
Write_Line (" is");
@@ -289,6 +323,11 @@ package body Prj.PP is
if Name_Of (Node) /= No_Name then
Start_Line (Indent);
+
+ if Non_Limited_Project_Node_Of (Node) = Empty_Node then
+ Write_String ("limited ");
+ end if;
+
Write_String ("with ");
Output_String (String_Value_Of (Node));
Write_Line (";");
@@ -375,9 +414,9 @@ package body Prj.PP is
pragma Debug (Indicate_Tested (N_Attribute_Declaration));
Start_Line (Indent);
Write_String ("for ");
- Output_Name (Name_Of (Node));
+ Output_Attribute_Name (Name_Of (Node));
- if Associative_Array_Index_Of (Node) /= No_String then
+ if Associative_Array_Index_Of (Node) /= No_Name then
Write_String (" (");
Output_String (Associative_Array_Index_Of (Node));
Write_String (")");
@@ -494,14 +533,14 @@ package body Prj.PP is
end if;
Write_String ("'");
- Output_Name (Name_Of (Node));
+ Output_Attribute_Name (Name_Of (Node));
declare
- Index : constant String_Id :=
+ Index : constant Name_Id :=
Associative_Array_Index_Of (Node);
begin
- if Index /= No_String then
+ if Index /= No_Name then
Write_String (" (");
Output_String (Index);
Write_String (")");
@@ -582,8 +621,8 @@ package body Prj.PP is
Write_Line (" =>");
declare
- First : Project_Node_Id :=
- First_Declarative_Item_Of (Node);
+ First : constant Project_Node_Id :=
+ First_Declarative_Item_Of (Node);
begin
if First = Empty_Node then
@@ -598,6 +637,8 @@ package body Prj.PP is
end if;
end Print;
+ -- Start of processing for Pretty_Print
+
begin
if W_Char = null then
Write_Char := Output.Write_Char'Access;
diff --git a/gcc/ada/prj-pp.ads b/gcc/ada/prj-pp.ads
index b43c9a3498a..aba19ac88c0 100644
--- a/gcc/ada/prj-pp.ads
+++ b/gcc/ada/prj-pp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -23,7 +23,7 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
---
+
-- This package is the Project File Pretty Printer.
-- It is used to output a project file from a project file tree.
-- It is used by gnatname to update or create project files.
@@ -51,7 +51,8 @@ package Prj.PP is
Minimize_Empty_Lines : Boolean := False;
W_Char : Write_Char_Ap := null;
W_Eol : Write_Eol_Ap := null;
- W_Str : Write_Str_Ap := null);
+ W_Str : Write_Str_Ap := null;
+ Backward_Compatibility : Boolean);
-- Output a project file, using either the default output
-- routines, or the ones specified by W_Char, W_Eol and W_Str.
--
@@ -67,6 +68,11 @@ package Prj.PP is
-- after the last with clause, after the line declaring the project name,
-- after the last declarative item of the project and before each
-- package declaration. Otherwise, more empty lines are output.
+ --
+ -- If Backward_Compatibility is True, then new attributes (Spec,
+ -- Spec_Suffix, Body, Body_Suffix) will be replaced by obsolete ones
+ -- (Specification, Specification_Suffix, Implementation,
+ -- Implementation_Suffix).
private
diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb
index 8ad23289b31..fc0d816d9af 100644
--- a/gcc/ada/prj-proc.adb
+++ b/gcc/ada/prj-proc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -24,15 +24,16 @@
-- --
------------------------------------------------------------------------------
-with Errout; use Errout;
+with Err_Vars; use Err_Vars;
with Namet; use Namet;
with Opt;
+with Osint; use Osint;
with Output; use Output;
with Prj.Attr; use Prj.Attr;
with Prj.Com; use Prj.Com;
+with Prj.Err; use Prj.Err;
with Prj.Ext; use Prj.Ext;
with Prj.Nmsc; use Prj.Nmsc;
-with Stringt; use Stringt;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.HTable;
@@ -50,7 +51,7 @@ package body Prj.Proc is
Equal => "=");
-- This hash table contains all processed projects
- procedure Add (To_Exp : in out String_Id; Str : String_Id);
+ procedure Add (To_Exp : in out Name_Id; Str : Name_Id);
-- Concatenate two strings and returns another string if both
-- arguments are not null string.
@@ -70,11 +71,11 @@ package body Prj.Proc is
-- From N_Expression project node From_Project_Node, compute the value
-- of an expression and return it as a Variable_Value.
- function Imported_Or_Modified_Project_From
+ function Imported_Or_Extended_Project_From
(Project : Project_Id;
With_Name : Name_Id)
return Project_Id;
- -- Find an imported or modified project of Project whose name is With_Name
+ -- Find an imported or extended project of Project whose name is With_Name
function Package_From
(Project : Project_Id;
@@ -94,12 +95,12 @@ package body Prj.Proc is
procedure Recursive_Process
(Project : out Project_Id;
From_Project_Node : Project_Node_Id;
- Modified_By : Project_Id);
+ Extended_By : Project_Id);
-- Process project with node From_Project_Node in the tree.
-- Do nothing if From_Project_Node is Empty_Node.
-- If project has already been processed, simply return its project id.
-- Otherwise create a new project id, mark it as processed, call itself
- -- recursively for all imported projects and a modified project, if any.
+ -- recursively for all imported projects and a extended project, if any.
-- Then process the declarative items of the project.
procedure Check (Project : in out Project_Id);
@@ -107,17 +108,17 @@ package body Prj.Proc is
-- main project Project. Project is set to No_Project if errors occurred.
procedure Recursive_Check (Project : Project_Id);
- -- If Project is marked as not checked, mark it as checked, call
+ -- If Project is not marked as checked, mark it as checked, call
-- Check_Naming_Scheme for the project, then call itself for a
- -- possible modified project and all the imported projects of Project.
+ -- possible extended project and all the imported projects of Project.
---------
-- Add --
---------
- procedure Add (To_Exp : in out String_Id; Str : String_Id) is
+ procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is
begin
- if To_Exp = Types.No_String or else String_Length (To_Exp) = 0 then
+ if To_Exp = Types.No_Name or else To_Exp = Empty_String then
-- To_Exp is nil or empty. The result is Str.
@@ -125,10 +126,15 @@ package body Prj.Proc is
-- If Str is nil, then do not change To_Ext
- elsif Str /= No_String then
- Start_String (To_Exp);
- Store_String_Chars (Str);
- To_Exp := End_String;
+ elsif Str /= No_Name and then Str /= Empty_String then
+ declare
+ S : constant String := Get_Name_String (Str);
+
+ begin
+ Get_Name_String (To_Exp);
+ Add_Str_To_Name_Buffer (S);
+ To_Exp := Name_Find;
+ end;
end if;
end Add;
@@ -138,7 +144,8 @@ package body Prj.Proc is
procedure Add_Attributes
(Decl : in out Declarations;
- First : Attribute_Node_Id) is
+ First : Attribute_Node_Id)
+ is
The_Attribute : Attribute_Node_Id := First;
Attribute_Data : Attribute_Record;
@@ -146,7 +153,7 @@ package body Prj.Proc is
while The_Attribute /= Empty_Attribute loop
Attribute_Data := Attributes.Table (The_Attribute);
- if Attribute_Data.Kind_2 /= Associative_Array then
+ if Attribute_Data.Kind_2 = Single then
declare
New_Attribute : Variable_Value;
@@ -191,7 +198,6 @@ package body Prj.Proc is
The_Attribute := Attributes.Table (The_Attribute).Next;
end loop;
-
end Add_Attributes;
-----------
@@ -208,10 +214,6 @@ package body Prj.Proc is
Recursive_Check (Project);
- if Errout.Total_Errors_Detected > 0 then
- Project := No_Project;
- end if;
-
end Check;
----------------
@@ -232,9 +234,6 @@ package body Prj.Proc is
The_Current_Term : Project_Node_Id := Empty_Node;
-- The current term node id
- Term_Kind : Variable_Kind;
- -- The kind of the current term
-
Result : Variable_Value (Kind => Kind);
-- The returned result
@@ -247,11 +246,6 @@ package body Prj.Proc is
-- Process each term of the expression, starting with First_Term
while The_Term /= Empty_Node loop
-
- -- We get the term data and kind ...
-
- Term_Kind := Expression_Kind_Of (The_Term);
-
The_Current_Term := Current_Term (The_Term);
case Kind_Of (The_Current_Term) is
@@ -289,7 +283,9 @@ package body Prj.Proc is
Last := String_Elements.Last;
String_Elements.Table (Last) :=
(Value => String_Value_Of (The_Current_Term),
+ Display_Value => No_Name,
Location => Location_Of (The_Current_Term),
+ Flag => False,
Next => Nil_String);
end case;
@@ -331,7 +327,9 @@ package body Prj.Proc is
Last := String_Elements.Last;
String_Elements.Table (Last) :=
(Value => Value.Value,
+ Display_Value => No_Name,
Location => Value.Location,
+ Flag => False,
Next => Nil_String);
loop
@@ -357,7 +355,9 @@ package body Prj.Proc is
Last := String_Elements.Last;
String_Elements.Table (Last) :=
(Value => Value.Value,
+ Display_Value => No_Name,
Location => Value.Location,
+ Flag => False,
Next => Nil_String);
end loop;
@@ -377,7 +377,7 @@ package body Prj.Proc is
Project_Node_Of (The_Current_Term);
Term_Package : constant Project_Node_Id :=
Package_Node_Of (The_Current_Term);
- Index : String_Id := No_String;
+ Index : Name_Id := No_Name;
begin
if Term_Project /= Empty_Node and then
@@ -386,8 +386,9 @@ package body Prj.Proc is
-- This variable or attribute comes from another project
The_Name := Name_Of (Term_Project);
- The_Project := Imported_Or_Modified_Project_From
- (Project => Project, With_Name => The_Name);
+ The_Project := Imported_Or_Extended_Project_From
+ (Project => Project,
+ With_Name => The_Name);
end if;
if Term_Package /= Empty_Node then
@@ -419,7 +420,7 @@ package body Prj.Proc is
-- If it is not an associative array attribute
- if Index = No_String then
+ if Index = No_Name then
-- It is not an associative array attribute
@@ -508,7 +509,7 @@ package body Prj.Proc is
if The_Array /= No_Array then
The_Element := Arrays.Table (The_Array).Value;
- String_To_Name_Buffer (Index);
+ Get_Name_String (Index);
if Case_Insensitive (The_Current_Term) then
To_Lower (Name_Buffer (1 .. Name_Len));
@@ -547,11 +548,8 @@ package body Prj.Proc is
Default => True,
Value => Empty_String);
end if;
-
end if;
-
end;
-
end if;
case Kind is
@@ -582,7 +580,6 @@ package body Prj.Proc is
"list cannot appear in single " &
"string expression");
null;
-
end case;
when List =>
@@ -609,7 +606,9 @@ package body Prj.Proc is
Last := String_Elements.Last;
String_Elements.Table (Last) :=
(Value => The_Variable.Value,
+ Display_Value => No_Name,
Location => Location_Of (The_Current_Term),
+ Flag => False,
Next => Nil_String);
when List =>
@@ -636,12 +635,13 @@ package body Prj.Proc is
(Value =>
String_Elements.Table
(The_List).Value,
+ Display_Value => No_Name,
Location => Location_Of
(The_Current_Term),
+ Flag => False,
Next => Nil_String);
The_List :=
String_Elements.Table (The_List).Next;
-
end loop;
end;
end case;
@@ -649,13 +649,13 @@ package body Prj.Proc is
end;
when N_External_Value =>
- String_To_Name_Buffer
+ Get_Name_String
(String_Value_Of (External_Reference_Of (The_Current_Term)));
declare
Name : constant Name_Id := Name_Find;
- Default : String_Id := No_String;
- Value : String_Id := No_String;
+ Default : Name_Id := No_Name;
+ Value : Name_Id := No_Name;
Default_Node : constant Project_Node_Id :=
External_Default_Of (The_Current_Term);
@@ -667,17 +667,19 @@ package body Prj.Proc is
Value := Prj.Ext.Value_Of (Name, Default);
- if Value = No_String then
- if Error_Report = null then
- Error_Msg
- ("undefined external reference",
- Location_Of (The_Current_Term));
+ if Value = No_Name then
+ if not Opt.Quiet_Output then
+ if Error_Report = null then
+ Error_Msg
+ ("?undefined external reference",
+ Location_Of (The_Current_Term));
- else
- Error_Report
- ("""" & Get_Name_String (Name) &
- """ is an undefined external reference",
- Project);
+ else
+ Error_Report
+ ("warning: """ & Get_Name_String (Name) &
+ """ is an undefined external reference",
+ Project);
+ end if;
end if;
Value := Empty_String;
@@ -706,11 +708,12 @@ package body Prj.Proc is
Last := String_Elements.Last;
String_Elements.Table (Last) :=
(Value => Value,
+ Display_Value => No_Name,
Location => Location_Of (The_Current_Term),
+ Flag => False,
Next => Nil_String);
end case;
-
end;
when others =>
@@ -731,10 +734,10 @@ package body Prj.Proc is
end Expression;
---------------------------------------
- -- Imported_Or_Modified_Project_From --
+ -- Imported_Or_Extended_Project_From --
---------------------------------------
- function Imported_Or_Modified_Project_From
+ function Imported_Or_Extended_Project_From
(Project : Project_Id;
With_Name : Name_Id)
return Project_Id
@@ -743,12 +746,12 @@ package body Prj.Proc is
List : Project_List := Data.Imported_Projects;
begin
- -- First check if it is the name of a modified project
+ -- First check if it is the name of a extended project
- if Data.Modifies /= No_Project
- and then Projects.Table (Data.Modifies).Name = With_Name
+ if Data.Extends /= No_Project
+ and then Projects.Table (Data.Extends).Name = With_Name
then
- return Data.Modifies;
+ return Data.Extends;
else
-- Then check the name of each imported project
@@ -768,7 +771,7 @@ package body Prj.Proc is
return Project_Lists.Table (List).Project;
end if;
- end Imported_Or_Modified_Project_From;
+ end Imported_Or_Extended_Project_From;
------------------
-- Package_From --
@@ -809,11 +812,16 @@ package body Prj.Proc is
procedure Process
(Project : out Project_Id;
+ Success : out Boolean;
From_Project_Node : Project_Node_Id;
Report_Error : Put_Line_Access)
is
+ Obj_Dir : Name_Id;
+ Extending : Project_Id;
+
begin
Error_Report := Report_Error;
+ Success := True;
-- Make sure there is no projects in the data structure
@@ -826,15 +834,70 @@ package body Prj.Proc is
Recursive_Process
(Project => Project,
From_Project_Node => From_Project_Node,
- Modified_By => No_Project);
+ Extended_By => No_Project);
- if Errout.Total_Errors_Detected > 0 then
- Project := No_Project;
+ if Project /= No_Project then
+ Check (Project);
end if;
+ -- Check that no extended project shares its object directory with
+ -- another project.
+
if Project /= No_Project then
- Check (Project);
+ for Extended in 1 .. Projects.Last loop
+ Extending := Projects.Table (Extended).Extended_By;
+
+ if Extending /= No_Project then
+ Obj_Dir := Projects.Table (Extended).Object_Directory;
+
+ for Prj in 1 .. Projects.Last loop
+ if Prj /= Extended
+ and then Projects.Table (Prj).Sources_Present
+ and then Projects.Table (Prj).Object_Directory = Obj_Dir
+ then
+ Error_Msg_Name_1 := Projects.Table (Extending).Name;
+ Error_Msg_Name_2 := Projects.Table (Extended).Name;
+
+ if Error_Report = null then
+ Error_Msg ("project % cannot extend project %",
+ Projects.Table (Extending).Location);
+
+ else
+ Error_Report
+ ("project """ &
+ Get_Name_String (Error_Msg_Name_1) &
+ """ cannot extend project """ &
+ Get_Name_String (Error_Msg_Name_2) & '"',
+ Project);
+ end if;
+
+ Error_Msg_Name_1 := Projects.Table (Extended).Name;
+ Error_Msg_Name_2 := Projects.Table (Prj).Name;
+
+ if Error_Report = null then
+ Error_Msg
+ ("\project % has the same object directory " &
+ "as project %",
+ Projects.Table (Extending).Location);
+
+ else
+ Error_Report
+ ("project """ &
+ Get_Name_String (Error_Msg_Name_1) &
+ """ has the same object directory as project """ &
+ Get_Name_String (Error_Msg_Name_2) & '"',
+ Project);
+ end if;
+
+ Project := No_Project;
+ exit;
+ end if;
+ end loop;
+ end if;
+ end loop;
end if;
+
+ Success := Total_Errors_Detected <= 0;
end Process;
-------------------------------
@@ -845,11 +908,10 @@ package body Prj.Proc is
(Project : Project_Id;
From_Project_Node : Project_Node_Id;
Pkg : Package_Id;
- Item : Project_Node_Id) is
-
+ Item : Project_Node_Id)
+ is
Current_Declarative_Item : Project_Node_Id := Item;
-
- Current_Item : Project_Node_Id := Empty_Node;
+ Current_Item : Project_Node_Id := Empty_Node;
begin
-- For each declarative item
@@ -861,7 +923,7 @@ package body Prj.Proc is
Current_Item := Current_Item_Node (Current_Declarative_Item);
-- And set Current_Declarative_Item to the next declarative item
- -- ready for the next iteration
+ -- ready for the next iteration.
Current_Declarative_Item := Next_Declarative_Item
(Current_Declarative_Item);
@@ -869,71 +931,87 @@ package body Prj.Proc is
case Kind_Of (Current_Item) is
when N_Package_Declaration =>
- Packages.Increment_Last;
+ -- Do not process a package declaration that should be ignored
- declare
- New_Pkg : constant Package_Id := Packages.Last;
- The_New_Package : Package_Element;
+ if Expression_Kind_Of (Current_Item) /= Ignored then
+ -- Create the new package
- Project_Of_Renamed_Package : constant Project_Node_Id :=
- Project_Of_Renamed_Package_Of
- (Current_Item);
+ Packages.Increment_Last;
- begin
- The_New_Package.Name := Name_Of (Current_Item);
+ declare
+ New_Pkg : constant Package_Id := Packages.Last;
+ The_New_Package : Package_Element;
- if Pkg /= No_Package then
- The_New_Package.Next :=
- Packages.Table (Pkg).Decl.Packages;
- Packages.Table (Pkg).Decl.Packages := New_Pkg;
- else
- The_New_Package.Next :=
- Projects.Table (Project).Decl.Packages;
- Projects.Table (Project).Decl.Packages := New_Pkg;
- end if;
+ Project_Of_Renamed_Package : constant Project_Node_Id :=
+ Project_Of_Renamed_Package_Of
+ (Current_Item);
- Packages.Table (New_Pkg) := The_New_Package;
+ begin
+ -- Set the name of the new package
- if Project_Of_Renamed_Package /= Empty_Node then
+ The_New_Package.Name := Name_Of (Current_Item);
- -- Renamed package
+ -- Insert the new package in the appropriate list
- declare
- Project_Name : constant Name_Id :=
- Name_Of
- (Project_Of_Renamed_Package);
+ if Pkg /= No_Package then
+ The_New_Package.Next :=
+ Packages.Table (Pkg).Decl.Packages;
+ Packages.Table (Pkg).Decl.Packages := New_Pkg;
+ else
+ The_New_Package.Next :=
+ Projects.Table (Project).Decl.Packages;
+ Projects.Table (Project).Decl.Packages := New_Pkg;
+ end if;
- Renamed_Project : constant Project_Id :=
- Imported_Or_Modified_Project_From
- (Project, Project_Name);
+ Packages.Table (New_Pkg) := The_New_Package;
- Renamed_Package : constant Package_Id :=
- Package_From
- (Renamed_Project,
- Name_Of (Current_Item));
+ if Project_Of_Renamed_Package /= Empty_Node then
- begin
- Packages.Table (New_Pkg).Decl :=
- Packages.Table (Renamed_Package).Decl;
- end;
+ -- Renamed package
- else
- -- Set the default values of the attributes
+ declare
+ Project_Name : constant Name_Id :=
+ Name_Of
+ (Project_Of_Renamed_Package);
- Add_Attributes
- (Packages.Table (New_Pkg).Decl,
- Package_Attributes.Table
- (Package_Id_Of (Current_Item)).First_Attribute);
+ Renamed_Project : constant Project_Id :=
+ Imported_Or_Extended_Project_From
+ (Project, Project_Name);
- Process_Declarative_Items
- (Project => Project,
- From_Project_Node => From_Project_Node,
- Pkg => New_Pkg,
- Item => First_Declarative_Item_Of
- (Current_Item));
- end if;
+ Renamed_Package : constant Package_Id :=
+ Package_From
+ (Renamed_Project,
+ Name_Of (Current_Item));
- end;
+ begin
+ -- For a renamed package, set declarations to
+ -- the declarations of the renamed package.
+
+ Packages.Table (New_Pkg).Decl :=
+ Packages.Table (Renamed_Package).Decl;
+ end;
+
+ -- Standard package declaration, not renaming
+
+ else
+ -- Set the default values of the attributes
+
+ Add_Attributes
+ (Packages.Table (New_Pkg).Decl,
+ Package_Attributes.Table
+ (Package_Id_Of (Current_Item)).First_Attribute);
+
+ -- And process declarative items of the new package
+
+ Process_Declarative_Items
+ (Project => Project,
+ From_Project_Node => From_Project_Node,
+ Pkg => New_Pkg,
+ Item => First_Declarative_Item_Of
+ (Current_Item));
+ end if;
+ end;
+ end if;
when N_String_Type_Declaration =>
@@ -945,249 +1023,542 @@ package body Prj.Proc is
N_Typed_Variable_Declaration |
N_Variable_Declaration =>
- pragma Assert (Expression_Of (Current_Item) /= Empty_Node,
- "no expression for an object declaration");
+ if Expression_Of (Current_Item) = Empty_Node then
- declare
- New_Value : constant Variable_Value :=
- Expression
- (Project => Project,
- From_Project_Node => From_Project_Node,
- Pkg => Pkg,
- First_Term =>
- Tree.First_Term (Expression_Of
- (Current_Item)),
- Kind =>
- Expression_Kind_Of (Current_Item));
-
- The_Variable : Variable_Id := No_Variable;
-
- Current_Item_Name : constant Name_Id :=
- Name_Of (Current_Item);
+ -- It must be a full associative array attribute declaration
- begin
- if Kind_Of (Current_Item) = N_Typed_Variable_Declaration then
+ declare
+ Current_Item_Name : constant Name_Id :=
+ Name_Of (Current_Item);
+ -- The name of the attribute
- if String_Equal (New_Value.Value, Empty_String) then
- Error_Msg_Name_1 := Name_Of (Current_Item);
+ New_Array : Array_Id;
+ -- The new associative array created
- if Error_Report = null then
- Error_Msg
- ("no value defined for %",
- Location_Of (Current_Item));
+ Orig_Array : Array_Id;
+ -- The associative array value
- else
- Error_Report
- ("no value defined for " &
- Get_Name_String (Error_Msg_Name_1),
- Project);
- end if;
+ Orig_Project_Name : Name_Id := No_Name;
+ -- The name of the project where the associative array
+ -- value is.
- else
- declare
- Current_String : Project_Node_Id :=
- First_Literal_String
- (String_Type_Of
- (Current_Item));
+ Orig_Project : Project_Id := No_Project;
+ -- The id of the project where the associative array
+ -- value is.
- begin
- while Current_String /= Empty_Node
- and then not String_Equal
- (String_Value_Of (Current_String),
- New_Value.Value)
- loop
- Current_String :=
- Next_Literal_String (Current_String);
- end loop;
+ Orig_Package_Name : Name_Id := No_Name;
+ -- The name of the package, if any, where the associative
+ -- array value is.
- if Current_String = Empty_Node then
- String_To_Name_Buffer (New_Value.Value);
- Error_Msg_Name_1 := Name_Find;
- Error_Msg_Name_2 := Name_Of (Current_Item);
+ Orig_Package : Package_Id := No_Package;
+ -- The id of the package, if any, where the associative
+ -- array value is.
- if Error_Report = null then
- Error_Msg
- ("value { is illegal for typed string %",
- Location_Of (Current_Item));
+ New_Element : Array_Element_Id := No_Array_Element;
+ -- Id of a new array element created
- else
- Error_Report
- ("value """ &
- Get_Name_String (Error_Msg_Name_1) &
- """ is illegal for typed string """ &
- Get_Name_String (Error_Msg_Name_2) &
- """",
- Project);
- end if;
- end if;
- end;
+ Prev_Element : Array_Element_Id := No_Array_Element;
+ -- Last new element id created
+
+ Orig_Element : Array_Element_Id := No_Array_Element;
+ -- Current array element in the original associative
+ -- array.
+
+ Next_Element : Array_Element_Id := No_Array_Element;
+ -- Id of the array element that follows the new element.
+ -- This is not always nil, because values for the
+ -- associative array attribute may already have been
+ -- declared, and the array elements declared are reused.
+
+ begin
+ -- First, find if the associative array attribute already
+ -- has elements declared.
+
+ if Pkg /= No_Package then
+ New_Array := Packages.Table (Pkg).Decl.Arrays;
+
+ else
+ New_Array := Projects.Table (Project).Decl.Arrays;
end if;
- end if;
- if Kind_Of (Current_Item) /= N_Attribute_Declaration
- or else
- Associative_Array_Index_Of (Current_Item) = No_String
- then
- -- Usual case
+ while New_Array /= No_Array and then
+ Arrays.Table (New_Array).Name /= Current_Item_Name
+ loop
+ New_Array := Arrays.Table (New_Array).Next;
+ end loop;
+
+ -- If the attribute has never been declared add new entry
+ -- in the arrays of the project/package and link it.
- -- Code below really needs more comments ???
+ if New_Array = No_Array then
+ Arrays.Increment_Last;
+ New_Array := Arrays.Last;
- if Kind_Of (Current_Item) = N_Attribute_Declaration then
if Pkg /= No_Package then
- The_Variable :=
- Packages.Table (Pkg).Decl.Attributes;
+ Arrays.Table (New_Array) :=
+ (Name => Current_Item_Name,
+ Value => No_Array_Element,
+ Next => Packages.Table (Pkg).Decl.Arrays);
+ Packages.Table (Pkg).Decl.Arrays := New_Array;
else
- The_Variable :=
- Projects.Table (Project).Decl.Attributes;
+ Arrays.Table (New_Array) :=
+ (Name => Current_Item_Name,
+ Value => No_Array_Element,
+ Next => Projects.Table (Project).Decl.Arrays);
+ Projects.Table (Project).Decl.Arrays := New_Array;
end if;
+ end if;
- else
- if Pkg /= No_Package then
- The_Variable :=
- Packages.Table (Pkg).Decl.Variables;
+ -- Find the project where the value is declared
- else
- The_Variable :=
- Projects.Table (Project).Decl.Variables;
+ Orig_Project_Name :=
+ Name_Of (Associative_Project_Of (Current_Item));
+
+ for Index in Projects.First .. Projects.Last loop
+ if Projects.Table (Index).Name = Orig_Project_Name then
+ Orig_Project := Index;
+ exit;
end if;
+ end loop;
+
+ pragma Assert (Orig_Project /= No_Project,
+ "original project not found");
+
+ if Associative_Package_Of (Current_Item) = Empty_Node then
+ Orig_Array :=
+ Projects.Table (Orig_Project).Decl.Arrays;
+
+ else
+ -- If in a package, find the package where the
+ -- value is declared.
+
+ Orig_Package_Name :=
+ Name_Of (Associative_Package_Of (Current_Item));
+ Orig_Package :=
+ Projects.Table (Orig_Project).Decl.Packages;
+ pragma Assert (Orig_Package /= No_Package,
+ "original package not found");
+
+ while Packages.Table (Orig_Package).Name /=
+ Orig_Package_Name
+ loop
+ Orig_Package := Packages.Table (Orig_Package).Next;
+ pragma Assert (Orig_Package /= No_Package,
+ "original package not found");
+ end loop;
+ Orig_Array :=
+ Packages.Table (Orig_Package).Decl.Arrays;
end if;
- while
- The_Variable /= No_Variable
- and then
- Variable_Elements.Table (The_Variable).Name /=
- Current_Item_Name
+ -- Now look for the array
+
+ while Orig_Array /= No_Array and then
+ Arrays.Table (Orig_Array).Name /= Current_Item_Name
loop
- The_Variable :=
- Variable_Elements.Table (The_Variable).Next;
+ Orig_Array := Arrays.Table (Orig_Array).Next;
end loop;
- if The_Variable = No_Variable then
- pragma Assert
- (Kind_Of (Current_Item) /= N_Attribute_Declaration,
- "illegal attribute declaration");
-
- Variable_Elements.Increment_Last;
- The_Variable := Variable_Elements.Last;
-
- if Pkg /= No_Package then
- Variable_Elements.Table (The_Variable) :=
- (Next =>
- Packages.Table (Pkg).Decl.Variables,
- Name => Current_Item_Name,
- Value => New_Value);
- Packages.Table (Pkg).Decl.Variables := The_Variable;
+ if Orig_Array = No_Array then
+ if Error_Report = null then
+ Error_Msg
+ ("associative array value cannot be found",
+ Location_Of (Current_Item));
else
- Variable_Elements.Table (The_Variable) :=
- (Next =>
- Projects.Table (Project).Decl.Variables,
- Name => Current_Item_Name,
- Value => New_Value);
- Projects.Table (Project).Decl.Variables :=
- The_Variable;
+ Error_Report
+ ("associative array value cannot be found",
+ Project);
end if;
else
- Variable_Elements.Table (The_Variable).Value :=
- New_Value;
+ Orig_Element := Arrays.Table (Orig_Array).Value;
- end if;
+ -- Copy each array element
- else
- -- Associative array attribute
+ while Orig_Element /= No_Array_Element loop
+ -- If it is the first element ...
+
+ if Prev_Element = No_Array_Element then
+ -- And there is no array element declared yet,
+ -- create a new first array element.
- String_To_Name_Buffer
- (Associative_Array_Index_Of (Current_Item));
+ if Arrays.Table (New_Array).Value =
+ No_Array_Element
+ then
+ Array_Elements.Increment_Last;
+ New_Element := Array_Elements.Last;
+ Arrays.Table (New_Array).Value := New_Element;
+ Next_Element := No_Array_Element;
+
+ -- Otherwise, the new element is the first
+
+ else
+ New_Element := Arrays.Table (New_Array).Value;
+ Next_Element :=
+ Array_Elements.Table (New_Element).Next;
+ end if;
+
+ -- Otherwise, reuse an existing element, or create
+ -- one if necessary.
+
+ else
+ Next_Element :=
+ Array_Elements.Table (Prev_Element).Next;
+
+ if Next_Element = No_Array_Element then
+ Array_Elements.Increment_Last;
+ New_Element := Array_Elements.Last;
+
+ else
+ New_Element := Next_Element;
+ Next_Element :=
+ Array_Elements.Table (New_Element).Next;
+ end if;
+ end if;
+
+ -- Copy the value of the element
+
+ Array_Elements.Table (New_Element) :=
+ Array_Elements.Table (Orig_Element);
- if Case_Insensitive (Current_Item) then
- GNAT.Case_Util.To_Lower (Name_Buffer (1 .. Name_Len));
+ -- Adjust the Next link
+
+ Array_Elements.Table (New_Element).Next :=
+ Next_Element;
+
+ -- Adjust the previous id for the next element
+
+ Prev_Element := New_Element;
+
+ -- Go to the next element in the original array
+ Orig_Element :=
+ Array_Elements.Table (Orig_Element).Next;
+ end loop;
+
+ -- Make sure that the array ends here, in case there
+ -- previously a greater number of elements.
+
+ Array_Elements.Table (New_Element).Next :=
+ No_Array_Element;
end if;
+ end;
- declare
- The_Array : Array_Id;
+ -- Declarations other that full associative arrays
+
+ else
+ declare
+ New_Value : constant Variable_Value :=
+ Expression
+ (Project => Project,
+ From_Project_Node => From_Project_Node,
+ Pkg => Pkg,
+ First_Term =>
+ Tree.First_Term (Expression_Of
+ (Current_Item)),
+ Kind =>
+ Expression_Kind_Of (Current_Item));
+ -- The expression value
+
+ The_Variable : Variable_Id := No_Variable;
+
+ Current_Item_Name : constant Name_Id :=
+ Name_Of (Current_Item);
- The_Array_Element : Array_Element_Id :=
- No_Array_Element;
+ begin
+ -- Process a typed variable declaration
- Index_Name : constant Name_Id := Name_Find;
+ if
+ Kind_Of (Current_Item) = N_Typed_Variable_Declaration
+ then
+ -- Report an error for an empty string
- begin
+ if New_Value.Value = Empty_String then
+ Error_Msg_Name_1 := Name_Of (Current_Item);
- if Pkg /= No_Package then
- The_Array := Packages.Table (Pkg).Decl.Arrays;
+ if Error_Report = null then
+ Error_Msg
+ ("no value defined for %",
+ Location_Of (Current_Item));
+
+ else
+ Error_Report
+ ("no value defined for " &
+ Get_Name_String (Error_Msg_Name_1),
+ Project);
+ end if;
else
- The_Array := Projects.Table (Project).Decl.Arrays;
+ declare
+ Current_String : Project_Node_Id :=
+ First_Literal_String
+ (String_Type_Of
+ (Current_Item));
+
+ begin
+ -- Loop through all the valid strings for
+ -- the string type and compare to the string
+ -- value.
+
+ while Current_String /= Empty_Node
+ and then String_Value_Of (Current_String) /=
+ New_Value.Value
+ loop
+ Current_String :=
+ Next_Literal_String (Current_String);
+ end loop;
+
+ -- Report an error if the string value is not
+ -- one for the string type.
+
+ if Current_String = Empty_Node then
+ Error_Msg_Name_1 := New_Value.Value;
+ Error_Msg_Name_2 := Name_Of (Current_Item);
+
+ if Error_Report = null then
+ Error_Msg
+ ("value { is illegal for typed string %",
+ Location_Of (Current_Item));
+
+ else
+ Error_Report
+ ("value """ &
+ Get_Name_String (Error_Msg_Name_1) &
+ """ is illegal for typed string """ &
+ Get_Name_String (Error_Msg_Name_2) &
+ """",
+ Project);
+ end if;
+ end if;
+ end;
end if;
+ end if;
- while
- The_Array /= No_Array
- and then Arrays.Table (The_Array).Name /=
- Current_Item_Name
- loop
- The_Array := Arrays.Table (The_Array).Next;
- end loop;
+ if Kind_Of (Current_Item) /= N_Attribute_Declaration
+ or else
+ Associative_Array_Index_Of (Current_Item) = No_Name
+ then
+ -- Case of a variable declaration or of a not
+ -- associative array attribute.
- if The_Array = No_Array then
- Arrays.Increment_Last;
- The_Array := Arrays.Last;
+ -- First, find the list where to find the variable
+ -- or attribute.
+ if
+ Kind_Of (Current_Item) = N_Attribute_Declaration
+ then
if Pkg /= No_Package then
- Arrays.Table (The_Array) :=
- (Name => Current_Item_Name,
- Value => No_Array_Element,
- Next => Packages.Table (Pkg).Decl.Arrays);
- Packages.Table (Pkg).Decl.Arrays := The_Array;
+ The_Variable :=
+ Packages.Table (Pkg).Decl.Attributes;
else
- Arrays.Table (The_Array) :=
- (Name => Current_Item_Name,
- Value => No_Array_Element,
- Next =>
- Projects.Table (Project).Decl.Arrays);
- Projects.Table (Project).Decl.Arrays :=
- The_Array;
+ The_Variable :=
+ Projects.Table (Project).Decl.Attributes;
end if;
else
- The_Array_Element := Arrays.Table (The_Array).Value;
+ if Pkg /= No_Package then
+ The_Variable :=
+ Packages.Table (Pkg).Decl.Variables;
+
+ else
+ The_Variable :=
+ Projects.Table (Project).Decl.Variables;
+ end if;
+
end if;
- while The_Array_Element /= No_Array_Element
+ -- Loop through the list, to find if it has already
+ -- been declared.
+
+ while
+ The_Variable /= No_Variable
and then
- Array_Elements.Table (The_Array_Element).Index /=
- Index_Name
+ Variable_Elements.Table (The_Variable).Name /=
+ Current_Item_Name
loop
- The_Array_Element :=
- Array_Elements.Table (The_Array_Element).Next;
+ The_Variable :=
+ Variable_Elements.Table (The_Variable).Next;
end loop;
- if The_Array_Element = No_Array_Element then
- Array_Elements.Increment_Last;
- The_Array_Element := Array_Elements.Last;
- Array_Elements.Table (The_Array_Element) :=
- (Index => Index_Name,
- Value => New_Value,
- Next => Arrays.Table (The_Array).Value);
- Arrays.Table (The_Array).Value := The_Array_Element;
+ -- If it has not been declared, create a new entry
+ -- in the list.
+
+ if The_Variable = No_Variable then
+ -- All single string attribute should already have
+ -- been declared with a default empty string value.
+
+ pragma Assert
+ (Kind_Of (Current_Item) /=
+ N_Attribute_Declaration,
+ "illegal attribute declaration");
+
+ Variable_Elements.Increment_Last;
+ The_Variable := Variable_Elements.Last;
+
+ -- Put the new variable in the appropriate list
+
+ if Pkg /= No_Package then
+ Variable_Elements.Table (The_Variable) :=
+ (Next =>
+ Packages.Table (Pkg).Decl.Variables,
+ Name => Current_Item_Name,
+ Value => New_Value);
+ Packages.Table (Pkg).Decl.Variables :=
+ The_Variable;
+
+ else
+ Variable_Elements.Table (The_Variable) :=
+ (Next =>
+ Projects.Table (Project).Decl.Variables,
+ Name => Current_Item_Name,
+ Value => New_Value);
+ Projects.Table (Project).Decl.Variables :=
+ The_Variable;
+ end if;
+
+ -- If the variable/attribute has already been
+ -- declared, just change the value.
else
- Array_Elements.Table (The_Array_Element).Value :=
+ Variable_Elements.Table (The_Variable).Value :=
New_Value;
+
end if;
- end;
- end if;
- end;
+
+ else
+ -- Associative array attribute
+
+ -- Get the string index
+
+ Get_Name_String
+ (Associative_Array_Index_Of (Current_Item));
+
+ -- Put in lower case, if necessary
+
+ if Case_Insensitive (Current_Item) then
+ GNAT.Case_Util.To_Lower
+ (Name_Buffer (1 .. Name_Len));
+ end if;
+
+ declare
+ The_Array : Array_Id;
+
+ The_Array_Element : Array_Element_Id :=
+ No_Array_Element;
+
+ Index_Name : constant Name_Id := Name_Find;
+ -- The name id of the index
+
+ begin
+ -- Look for the array in the appropriate list
+
+ if Pkg /= No_Package then
+ The_Array := Packages.Table (Pkg).Decl.Arrays;
+
+ else
+ The_Array := Projects.Table
+ (Project).Decl.Arrays;
+ end if;
+
+ while
+ The_Array /= No_Array
+ and then Arrays.Table (The_Array).Name /=
+ Current_Item_Name
+ loop
+ The_Array := Arrays.Table (The_Array).Next;
+ end loop;
+
+ -- If the array cannot be found, create a new
+ -- entry in the list. As The_Array_Element is
+ -- initialized to No_Array_Element, a new element
+ -- will be created automatically later.
+
+ if The_Array = No_Array then
+ Arrays.Increment_Last;
+ The_Array := Arrays.Last;
+
+ if Pkg /= No_Package then
+ Arrays.Table (The_Array) :=
+ (Name => Current_Item_Name,
+ Value => No_Array_Element,
+ Next => Packages.Table (Pkg).Decl.Arrays);
+ Packages.Table (Pkg).Decl.Arrays := The_Array;
+
+ else
+ Arrays.Table (The_Array) :=
+ (Name => Current_Item_Name,
+ Value => No_Array_Element,
+ Next =>
+ Projects.Table (Project).Decl.Arrays);
+ Projects.Table (Project).Decl.Arrays :=
+ The_Array;
+ end if;
+
+ -- Otherwise, initialize The_Array_Element as the
+ -- head of the element list.
+
+ else
+ The_Array_Element :=
+ Arrays.Table (The_Array).Value;
+ end if;
+
+ -- Look in the list, if any, to find an element
+ -- with the same index.
+
+ while The_Array_Element /= No_Array_Element
+ and then
+ Array_Elements.Table (The_Array_Element).Index /=
+ Index_Name
+ loop
+ The_Array_Element :=
+ Array_Elements.Table (The_Array_Element).Next;
+ end loop;
+
+ -- If no such element were found, create a new
+ -- one and insert it in the element list, with
+ -- the propoer value.
+
+ if The_Array_Element = No_Array_Element then
+ Array_Elements.Increment_Last;
+ The_Array_Element := Array_Elements.Last;
+
+ Array_Elements.Table (The_Array_Element) :=
+ (Index => Index_Name,
+ Index_Case_Sensitive =>
+ not Case_Insensitive (Current_Item),
+ Value => New_Value,
+ Next => Arrays.Table (The_Array).Value);
+ Arrays.Table (The_Array).Value :=
+ The_Array_Element;
+
+ -- An element with the same index already exists,
+ -- just replace its value with the new one.
+
+ else
+ Array_Elements.Table (The_Array_Element).Value :=
+ New_Value;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
when N_Case_Construction =>
declare
The_Project : Project_Id := Project;
+ -- The id of the project of the case variable
+
The_Package : Package_Id := Pkg;
+ -- The id of the package, if any, of the case variable
+
The_Variable : Variable_Value := Nil_Variable_Value;
- Case_Value : String_Id := No_String;
+ -- The case variable
+
+ Case_Value : Name_Id := No_Name;
+ -- The case variable value
+
Case_Item : Project_Node_Id := Empty_Node;
Choice_String : Project_Node_Id := Empty_Node;
Decl_Item : Project_Node_Id := Empty_Node;
@@ -1202,12 +1573,18 @@ package body Prj.Proc is
Name : Name_Id := No_Name;
begin
+ -- If a project were specified for the case variable,
+ -- get its id.
+
if Project_Node_Of (Variable_Node) /= Empty_Node then
Name := Name_Of (Project_Node_Of (Variable_Node));
The_Project :=
- Imported_Or_Modified_Project_From (Project, Name);
+ Imported_Or_Extended_Project_From (Project, Name);
end if;
+ -- If a package were specified for the case variable,
+ -- get its id.
+
if Package_Node_Of (Variable_Node) /= Empty_Node then
Name := Name_Of (Package_Node_Of (Variable_Node));
The_Package := Package_From (The_Project, Name);
@@ -1215,6 +1592,9 @@ package body Prj.Proc is
Name := Name_Of (Variable_Node);
+ -- First, look for the case variable into the package,
+ -- if any.
+
if The_Package /= No_Package then
Var_Id := Packages.Table (The_Package).Decl.Variables;
Name := Name_Of (Variable_Node);
@@ -1226,6 +1606,9 @@ package body Prj.Proc is
end loop;
end if;
+ -- If not found in the package, or if there is no
+ -- package, look at the project level.
+
if Var_Id = No_Variable
and then Package_Node_Of (Variable_Node) = Empty_Node
then
@@ -1240,7 +1623,8 @@ package body Prj.Proc is
if Var_Id = No_Variable then
- -- Should never happen
+ -- Should never happen, because this has already been
+ -- checked during parsing.
Write_Line ("variable """ &
Get_Name_String (Name) &
@@ -1248,11 +1632,14 @@ package body Prj.Proc is
raise Program_Error;
end if;
+ -- Get the case variable
+
The_Variable := Variable_Elements.Table (Var_Id).Value;
if The_Variable.Kind /= Single then
- -- Should never happen
+ -- Should never happen, because this has already been
+ -- checked during parsing.
Write_Line ("variable""" &
Get_Name_String (Name) &
@@ -1260,23 +1647,31 @@ package body Prj.Proc is
raise Program_Error;
end if;
+ -- Get the case variable value
Case_Value := The_Variable.Value;
end;
+ -- Now look into all the case items of the case construction
+
Case_Item := First_Case_Item_Of (Current_Item);
Case_Item_Loop :
while Case_Item /= Empty_Node loop
Choice_String := First_Choice_Of (Case_Item);
+ -- When Choice_String is nil, it means that it is
+ -- the "when others =>" alternative.
+
if Choice_String = Empty_Node then
Decl_Item := First_Declarative_Item_Of (Case_Item);
exit Case_Item_Loop;
end if;
+ -- Look into all the alternative of this case item
+
Choice_Loop :
while Choice_String /= Empty_Node loop
- if String_Equal (Case_Value,
- String_Value_Of (Choice_String))
+ if
+ Case_Value = String_Value_Of (Choice_String)
then
Decl_Item :=
First_Declarative_Item_Of (Case_Item);
@@ -1289,6 +1684,8 @@ package body Prj.Proc is
Case_Item := Next_Case_Item (Case_Item);
end loop Case_Item_Loop;
+ -- If there is an alternative, then we process it
+
if Decl_Item /= Empty_Node then
Process_Declarative_Items
(Project => Project,
@@ -1324,12 +1721,17 @@ package body Prj.Proc is
if Project /= No_Project
and then not Projects.Table (Project).Checked
then
+ -- Mark project as checked, to avoid infinite recursion in
+ -- ill-formed trees, where a project imports itself.
+
+ Projects.Table (Project).Checked := True;
+
Data := Projects.Table (Project);
- -- Call itself for a possible modified project.
- -- (if there is no modified project, then nothing happens).
+ -- Call itself for a possible extended project.
+ -- (if there is no extended project, then nothing happens).
- Recursive_Check (Data.Modifies);
+ Recursive_Check (Data.Extends);
-- Call itself for all imported projects
@@ -1341,10 +1743,6 @@ package body Prj.Proc is
Project_Lists.Table (Imported_Project_List).Next;
end loop;
- -- Mark project as checked
-
- Projects.Table (Project).Checked := True;
-
if Opt.Verbose_Mode then
Write_Str ("Checking project file """);
Write_Str (Get_Name_String (Data.Name));
@@ -1362,7 +1760,7 @@ package body Prj.Proc is
procedure Recursive_Process
(Project : out Project_Id;
From_Project_Node : Project_Node_Id;
- Modified_By : Project_Id)
+ Extended_By : Project_Id)
is
With_Clause : Project_Node_Id;
@@ -1389,11 +1787,23 @@ package body Prj.Proc is
Project := Projects.Last;
Processed_Projects.Set (Name, Project);
- Processed_Data.Name := Name;
- Processed_Data.Path_Name := Path_Name_Of (From_Project_Node);
- Processed_Data.Location := Location_Of (From_Project_Node);
- Processed_Data.Directory := Directory_Of (From_Project_Node);
- Processed_Data.Modified_By := Modified_By;
+ Processed_Data.Name := Name;
+
+ Processed_Data.Display_Path_Name :=
+ Path_Name_Of (From_Project_Node);
+ Get_Name_String (Processed_Data.Display_Path_Name);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Processed_Data.Path_Name := Name_Find;
+
+ Processed_Data.Location := Location_Of (From_Project_Node);
+
+ Processed_Data.Display_Directory :=
+ Directory_Of (From_Project_Node);
+ Get_Name_String (Processed_Data.Display_Directory);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ Processed_Data.Directory := Name_Find;
+
+ Processed_Data.Extended_By := Extended_By;
Processed_Data.Naming := Standard_Naming_Data;
Add_Attributes (Processed_Data.Decl, Attribute_First);
@@ -1408,7 +1818,7 @@ package body Prj.Proc is
Recursive_Process
(Project => New_Project,
From_Project_Node => Project_Node_Of (With_Clause),
- Modified_By => No_Project);
+ Extended_By => No_Project);
New_Data := Projects.Table (New_Project);
-- If we were the first project to import it,
@@ -1444,9 +1854,9 @@ package body Prj.Proc is
Declaration_Node := Project_Declaration_Of (From_Project_Node);
Recursive_Process
- (Project => Processed_Data.Modifies,
- From_Project_Node => Modified_Project_Of (Declaration_Node),
- Modified_By => Project);
+ (Project => Processed_Data.Extends,
+ From_Project_Node => Extended_Project_Of (Declaration_Node),
+ Extended_By => Project);
Projects.Table (Project) := Processed_Data;
@@ -1457,6 +1867,52 @@ package body Prj.Proc is
Item => First_Declarative_Item_Of
(Declaration_Node));
+ -- If it is an extending project, inherit all packages
+ -- from the extended project that are not explicitely defined
+ -- or renamed.
+
+ if Processed_Data.Extends /= No_Project then
+ Processed_Data := Projects.Table (Project);
+
+ declare
+ Extended_Pkg : Package_Id :=
+ Projects.Table
+ (Processed_Data.Extends).Decl.Packages;
+ Current_Pkg : Package_Id;
+ Element : Package_Element;
+ First : constant Package_Id :=
+ Processed_Data.Decl.Packages;
+
+ begin
+ while Extended_Pkg /= No_Package loop
+ Element := Packages.Table (Extended_Pkg);
+
+ Current_Pkg := First;
+
+ loop
+ exit when Current_Pkg = No_Package
+ or else Packages.Table (Current_Pkg).Name
+ = Element.Name;
+ Current_Pkg := Packages.Table (Current_Pkg).Next;
+ end loop;
+
+ if Current_Pkg = No_Package then
+ Packages.Increment_Last;
+ Current_Pkg := Packages.Last;
+ Packages.Table (Current_Pkg) :=
+ (Name => Element.Name,
+ Decl => Element.Decl,
+ Parent => No_Package,
+ Next => Processed_Data.Decl.Packages);
+ Processed_Data.Decl.Packages := Current_Pkg;
+ end if;
+
+ Extended_Pkg := Element.Next;
+ end loop;
+ end;
+
+ Projects.Table (Project) := Processed_Data;
+ end if;
end;
end if;
end Recursive_Process;
diff --git a/gcc/ada/prj-proc.ads b/gcc/ada/prj-proc.ads
index 74845c3fe5a..0f8ae66446e 100644
--- a/gcc/ada/prj-proc.ads
+++ b/gcc/ada/prj-proc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -23,7 +23,7 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
---
+
-- This package is used to convert a project file tree (see prj-tree.ads) to
-- project file data structures (see prj.ads), taking into account
-- the environment (external references).
@@ -34,10 +34,11 @@ package Prj.Proc is
procedure Process
(Project : out Project_Id;
+ Success : out Boolean;
From_Project_Node : Project_Node_Id;
Report_Error : Put_Line_Access);
-- Process a project file tree into project file data structures.
- -- If Report_Error is null, use the standard error reporting mechanism
- -- (Errout). Otherwise, report errors using Report_Error.
+ -- If Report_Error is null, use the error reporting mechanism.
+ -- Otherwise, report errors using Report_Error.
end Prj.Proc;
diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb
index 0fda16feceb..1d1d1a8cb5d 100644
--- a/gcc/ada/prj-strt.adb
+++ b/gcc/ada/prj-strt.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -24,45 +24,31 @@
-- --
------------------------------------------------------------------------------
-with Errout; use Errout;
+with Err_Vars; use Err_Vars;
with Namet; use Namet;
with Prj.Attr; use Prj.Attr;
+with Prj.Err; use Prj.Err;
with Prj.Tree; use Prj.Tree;
with Scans; use Scans;
-with Sinfo; use Sinfo;
-with Stringt; use Stringt;
+with Snames;
with Table;
with Types; use Types;
package body Prj.Strt is
- type Name_Location is record
- Name : Name_Id := No_Name;
- Location : Source_Ptr := No_Location;
- end record;
- -- Store the identifier and the location of a simple name
-
- type Name_Range is range 0 .. 3;
- subtype Name_Index is Name_Range range 1 .. Name_Range'Last;
- -- A Name may contain up to 3 simple names
-
- type Names is array (Name_Index) of Name_Location;
- -- Used to store 1 to 3 simple_names. 2 simple names are for
- -- <project>.<package>, <project>.<variable> or <package>.<variable>.
- -- 3 simple names are for <project>.<package>.<variable>.
-
type Choice_String is record
- The_String : String_Id;
+ The_String : Name_Id;
Already_Used : Boolean := False;
end record;
-- The string of a case label, and an indication that it has already
-- been used (to avoid duplicate case labels).
Choices_Initial : constant := 10;
- Choices_Increment : constant := 10;
+ Choices_Increment : constant := 50;
Choice_Node_Low_Bound : constant := 0;
- Choice_Node_High_Bound : constant := 099_999_999; -- In practice, infinite
+ Choice_Node_High_Bound : constant := 099_999_999;
+ -- In practice, infinite
type Choice_Node_Id is
range Choice_Node_Low_Bound .. Choice_Node_High_Bound;
@@ -83,21 +69,38 @@ package body Prj.Strt is
new Table.Table (Table_Component_Type => Choice_Node_Id,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
- Table_Initial => 3,
- Table_Increment => 3,
+ Table_Initial => 10,
+ Table_Increment => 100,
Table_Name => "Prj.Strt.Choice_Lasts");
-- Used to store the indices of the choices in table Choices,
-- to distinguish nested case constructions.
Choice_First : Choice_Node_Id := 0;
-- Index in table Choices of the first case label of the current
- -- case construction.
- -- 0 means no current case construction.
+ -- case construction. Zero means no current case construction.
+
+ type Name_Location is record
+ Name : Name_Id := No_Name;
+ Location : Source_Ptr := No_Location;
+ end record;
+ -- Store the identifier and the location of a simple name
+
+ package Names is
+ new Table.Table (Table_Component_Type => Name_Location,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Prj.Strt.Names");
+ -- Used to accumulate the single names of a name
- procedure Add (This_String : String_Id);
+ procedure Add (This_String : Name_Id);
-- Add a string to the case label list, indicating that it has not
-- yet been used.
+ procedure Add_To_Names (NL : Name_Location);
+ -- Add one single names to table Names
+
procedure External_Reference (External_Value : out Project_Node_Id);
-- Parse an external reference. Current token is "external".
@@ -120,7 +123,7 @@ package body Prj.Strt is
-- Add --
---------
- procedure Add (This_String : String_Id) is
+ procedure Add (This_String : Name_Id) is
begin
Choices.Increment_Last;
Choices.Table (Choices.Last) :=
@@ -128,6 +131,16 @@ package body Prj.Strt is
Already_Used => False);
end Add;
+ ------------------
+ -- Add_To_Names --
+ ------------------
+
+ procedure Add_To_Names (NL : Name_Location) is
+ begin
+ Names.Increment_Last;
+ Names.Table (Names.Last) := NL;
+ end Add_To_Names;
+
-------------------------
-- Attribute_Reference --
-------------------------
@@ -141,14 +154,27 @@ package body Prj.Strt is
Current_Attribute : Attribute_Node_Id := First_Attribute;
begin
+ -- Declare the node of the attribute reference
+
Reference := Default_Project_Node (Of_Kind => N_Attribute_Reference);
Set_Location_Of (Reference, To => Token_Ptr);
Scan; -- past apostrophe
- Expect (Tok_Identifier, "Identifier");
+
+ -- Body may be an attribute name
+
+ if Token = Tok_Body then
+ Token := Tok_Identifier;
+ Token_Name := Snames.Name_Body;
+ end if;
+
+ Expect (Tok_Identifier, "identifier");
if Token = Tok_Identifier then
Set_Name_Of (Reference, To => Token_Name);
+ -- Check if the identifier is one of the attribute identifiers in the
+ -- context (package or project level attributes).
+
while Current_Attribute /= Empty_Attribute
and then
Attributes.Table (Current_Attribute).Name /= Token_Name
@@ -156,12 +182,20 @@ package body Prj.Strt is
Current_Attribute := Attributes.Table (Current_Attribute).Next;
end loop;
+ -- If the identifier is not allowed, report an error
+
if Current_Attribute = Empty_Attribute then
Error_Msg_Name_1 := Token_Name;
Error_Msg ("unknown attribute %", Token_Ptr);
Reference := Empty_Node;
+ -- Scan past the attribute name
+
+ Scan;
+
else
+ -- Give its characteristics to this attribute reference
+
Set_Project_Node_Of (Reference, To => Current_Project);
Set_Package_Node_Of (Reference, To => Current_Package);
Set_Expression_Kind_Of
@@ -169,10 +203,15 @@ package body Prj.Strt is
Set_Case_Insensitive
(Reference, To => Attributes.Table (Current_Attribute).Kind_2 =
Case_Insensitive_Associative_Array);
+
+ -- Scan past the attribute name
+
Scan;
+ -- If the attribute is an associative array, get the index
+
if Attributes.Table (Current_Attribute).Kind_2 /= Single then
- Expect (Tok_Left_Paren, "(");
+ Expect (Tok_Left_Paren, "`(`");
if Token = Tok_Left_Paren then
Scan;
@@ -180,9 +219,9 @@ package body Prj.Strt is
if Token = Tok_String_Literal then
Set_Associative_Array_Index_Of
- (Reference, To => Strval (Token_Node));
+ (Reference, To => Token_Name);
Scan;
- Expect (Tok_Right_Paren, ")");
+ Expect (Tok_Right_Paren, "`)`");
if Token = Tok_Right_Paren then
Scan;
@@ -191,6 +230,27 @@ package body Prj.Strt is
end if;
end if;
end if;
+
+ -- Change name of obsolete attributes
+
+ if Reference /= Empty_Node then
+ case Name_Of (Reference) is
+ when Snames.Name_Specification =>
+ Set_Name_Of (Reference, To => Snames.Name_Spec);
+
+ when Snames.Name_Specification_Suffix =>
+ Set_Name_Of (Reference, To => Snames.Name_Spec_Suffix);
+
+ when Snames.Name_Implementation =>
+ Set_Name_Of (Reference, To => Snames.Name_Body);
+
+ when Snames.Name_Implementation_Suffix =>
+ Set_Name_Of (Reference, To => Snames.Name_Body_Suffix);
+
+ when others =>
+ null;
+ end case;
+ end if;
end if;
end Attribute_Reference;
@@ -200,17 +260,24 @@ package body Prj.Strt is
procedure End_Case_Construction is
begin
+ -- If this is the only case construction, empty the tables
+
if Choice_Lasts.Last = 1 then
Choice_Lasts.Set_Last (0);
Choices.Set_Last (First_Choice_Node_Id);
Choice_First := 0;
elsif Choice_Lasts.Last = 2 then
+ -- This is the second case onstruction, set the tables to the first
+
Choice_Lasts.Set_Last (1);
Choices.Set_Last (Choice_Lasts.Table (1));
Choice_First := 1;
else
+ -- This is the 3rd or more case construction, set the tables to the
+ -- previous one.
+
Choice_Lasts.Decrement_Last;
Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last));
Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1;
@@ -235,7 +302,7 @@ package body Prj.Strt is
-- Get the left parenthesis
Scan;
- Expect (Tok_Left_Paren, "(");
+ Expect (Tok_Left_Paren, "`(`");
-- Scan past the left parenthesis
@@ -251,7 +318,7 @@ package body Prj.Strt is
Field_Id :=
Default_Project_Node (Of_Kind => N_Literal_String,
And_Expr_Kind => Single);
- Set_String_Value_Of (Field_Id, To => Strval (Token_Node));
+ Set_String_Value_Of (Field_Id, To => Token_Name);
Set_External_Reference_Of (External_Value, To => Field_Id);
-- Scan past the first argument
@@ -279,10 +346,10 @@ package body Prj.Strt is
Field_Id :=
Default_Project_Node (Of_Kind => N_Literal_String,
And_Expr_Kind => Single);
- Set_String_Value_Of (Field_Id, To => Strval (Token_Node));
+ Set_String_Value_Of (Field_Id, To => Token_Name);
Set_External_Default_Of (External_Value, To => Field_Id);
Scan;
- Expect (Tok_Right_Paren, ")");
+ Expect (Tok_Right_Paren, "`)`");
end if;
-- Scan past the right parenthesis
@@ -291,7 +358,7 @@ package body Prj.Strt is
end if;
when others =>
- Error_Msg ("',' or ')' expected", Token_Ptr);
+ Error_Msg ("`,` or `)` expected", Token_Ptr);
end case;
end if;
end External_Reference;
@@ -303,32 +370,45 @@ package body Prj.Strt is
procedure Parse_Choice_List (First_Choice : out Project_Node_Id) is
Current_Choice : Project_Node_Id := Empty_Node;
Next_Choice : Project_Node_Id := Empty_Node;
- Choice_String : String_Id := No_String;
+ Choice_String : Name_Id := No_Name;
Found : Boolean := False;
begin
+ -- Declare the node of the first choice
+
First_Choice :=
Default_Project_Node (Of_Kind => N_Literal_String,
And_Expr_Kind => Single);
+
+ -- Initially Current_Choice is the same as First_Choice
+
Current_Choice := First_Choice;
loop
Expect (Tok_String_Literal, "literal string");
exit when Token /= Tok_String_Literal;
Set_Location_Of (Current_Choice, To => Token_Ptr);
- Choice_String := Strval (Token_Node);
+ Choice_String := Token_Name;
+
+ -- Give the string value to the current choice
+
Set_String_Value_Of (Current_Choice, To => Choice_String);
+ -- Check if the label is part of the string type and if it has not
+ -- been already used.
+
Found := False;
for Choice in Choice_First .. Choices.Last loop
- if String_Equal (Choices.Table (Choice).The_String,
- Choice_String)
- then
+ if Choices.Table (Choice).The_String = Choice_String then
+ -- This label is part of the string type
+
Found := True;
if Choices.Table (Choice).Already_Used then
- String_To_Name_Buffer (Choice_String);
- Error_Msg_Name_1 := Name_Find;
+ -- But it has already appeared in a choice list for this
+ -- case construction; report an error.
+
+ Error_Msg_Name_1 := Choice_String;
Error_Msg ("duplicate case label {", Token_Ptr);
else
Choices.Table (Choice).Already_Used := True;
@@ -338,15 +418,23 @@ package body Prj.Strt is
end if;
end loop;
+ -- If the label is not part of the string list, report an error
+
if not Found then
- String_To_Name_Buffer (Choice_String);
- Error_Msg_Name_1 := Name_Find;
+ Error_Msg_Name_1 := Choice_String;
Error_Msg ("illegal case label {", Token_Ptr);
end if;
+ -- Scan past the label
+
Scan;
+ -- If there is no '|', we are done
+
if Token = Tok_Vertical_Bar then
+ -- Otherwise, declare the node of the next choice, link it to
+ -- Current_Choice and set Current_Choice to this new node.
+
Next_Choice :=
Default_Project_Node (Of_Kind => N_Literal_String,
And_Expr_Kind => Single);
@@ -372,12 +460,20 @@ package body Prj.Strt is
Expression_Kind : Variable_Kind := Undefined;
begin
+ -- Declare the node of the expression
+
Expression := Default_Project_Node (Of_Kind => N_Expression);
Set_Location_Of (Expression, To => Token_Ptr);
+
+ -- Parse the term or terms of the expression
+
Terms (Term => First_Term,
Expr_Kind => Expression_Kind,
Current_Project => Current_Project,
Current_Package => Current_Package);
+
+ -- Set the first term and the expression kind
+
Set_First_Term (Expression, To => First_Term);
Set_Expression_Kind_Of (Expression, To => Expression_Kind);
end Parse_Expression;
@@ -389,29 +485,40 @@ package body Prj.Strt is
procedure Parse_String_Type_List (First_String : out Project_Node_Id) is
Last_String : Project_Node_Id := Empty_Node;
Next_String : Project_Node_Id := Empty_Node;
- String_Value : String_Id := No_String;
+ String_Value : Name_Id := No_Name;
begin
+ -- Declare the node of the first string
+
First_String :=
Default_Project_Node (Of_Kind => N_Literal_String,
And_Expr_Kind => Single);
+
+ -- Initially, Last_String is the same as First_String
+
Last_String := First_String;
loop
Expect (Tok_String_Literal, "literal string");
exit when Token /= Tok_String_Literal;
- String_Value := Strval (Token_Node);
+ String_Value := Token_Name;
+
+ -- Give its string value to Last_String
+
Set_String_Value_Of (Last_String, To => String_Value);
Set_Location_Of (Last_String, To => Token_Ptr);
+ -- Now, check if the string is already part of the string type
+
declare
Current : Project_Node_Id := First_String;
begin
while Current /= Last_String loop
- if String_Equal (String_Value_Of (Current), String_Value) then
- String_To_Name_Buffer (String_Value);
- Error_Msg_Name_1 := Name_Find;
+ if String_Value_Of (Current) = String_Value then
+ -- This is a repetition, report an error
+
+ Error_Msg_Name_1 := String_Value;
Error_Msg ("duplicate value { in type", Token_Ptr);
exit;
end if;
@@ -420,12 +527,19 @@ package body Prj.Strt is
end loop;
end;
+ -- Scan past the literal string
+
Scan;
+ -- If there is no comma following the literal string, we are done
+
if Token /= Tok_Comma then
exit;
else
+ -- Declare the next string, link it to Last_String and set
+ -- Last_String to its node.
+
Next_String :=
Default_Project_Node (Of_Kind => N_Literal_String,
And_Expr_Kind => Single);
@@ -445,8 +559,6 @@ package body Prj.Strt is
Current_Project : Project_Node_Id;
Current_Package : Project_Node_Id)
is
- The_Names : Names;
- Last_Name : Name_Range := 0;
Current_Variable : Project_Node_Id := Empty_Node;
The_Package : Project_Node_Id := Current_Package;
@@ -459,7 +571,9 @@ package body Prj.Strt is
Variable_Name : Name_Id;
begin
- for Index in The_Names'Range loop
+ Names.Init;
+
+ loop
Expect (Tok_Identifier, "identifier");
if Token /= Tok_Identifier then
@@ -467,21 +581,19 @@ package body Prj.Strt is
exit;
end if;
- Last_Name := Last_Name + 1;
- The_Names (Last_Name) :=
- (Name => Token_Name,
- Location => Token_Ptr);
+ Add_To_Names (NL => (Name => Token_Name, Location => Token_Ptr));
Scan;
exit when Token /= Tok_Dot;
Scan;
end loop;
if Look_For_Variable then
+
if Token = Tok_Apostrophe then
-- Attribute reference
- case Last_Name is
+ case Names.Last is
when 0 =>
-- Cannot happen
@@ -489,9 +601,14 @@ package body Prj.Strt is
null;
when 1 =>
+ -- This may be a project name or a package name.
+ -- Project name have precedence.
+
+ -- First, look if it can be a package name
+
for Index in Package_First .. Package_Attributes.Last loop
if Package_Attributes.Table (Index).Name =
- The_Names (1).Name
+ Names.Table (1).Name
then
First_Attribute :=
Package_Attributes.Table (Index).First_Attribute;
@@ -499,96 +616,159 @@ package body Prj.Strt is
end if;
end loop;
- if First_Attribute /= Empty_Attribute then
- The_Package := First_Package_Of (Current_Project);
- while The_Package /= Empty_Node
- and then Name_Of (The_Package) /= The_Names (1).Name
- loop
- The_Package := Next_Package_In_Project (The_Package);
- end loop;
+ -- Now, look if it can be a project name
- if The_Package = Empty_Node then
- Error_Msg_Name_1 := The_Names (1).Name;
- Error_Msg ("package % not yet defined",
- The_Names (1).Location);
+ The_Project := Imported_Or_Extended_Project_Of
+ (Current_Project, Names.Table (1).Name);
+
+ if The_Project = Empty_Node then
+ -- If it is neither a project name nor a package name,
+ -- report an error
+
+ if First_Attribute = Empty_Attribute then
+ Error_Msg_Name_1 := Names.Table (1).Name;
+ Error_Msg ("unknown project %",
+ Names.Table (1).Location);
+ First_Attribute := Attribute_First;
+
+ else
+ -- If it is a package name, check if the package
+ -- has already been declared in the current project.
+
+ The_Package := First_Package_Of (Current_Project);
+
+ while The_Package /= Empty_Node
+ and then Name_Of (The_Package) /=
+ Names.Table (1).Name
+ loop
+ The_Package :=
+ Next_Package_In_Project (The_Package);
+ end loop;
+
+ -- If it has not been already declared, report an
+ -- error.
+
+ if The_Package = Empty_Node then
+ Error_Msg_Name_1 := Names.Table (1).Name;
+ Error_Msg ("package % not yet defined",
+ Names.Table (1).Location);
+ end if;
end if;
else
+ -- It is a project name
+
First_Attribute := Attribute_First;
The_Package := Empty_Node;
-
- declare
- The_Project_Name_And_Node :
- constant Tree_Private_Part.Project_Name_And_Node :=
- Tree_Private_Part.Projects_Htable.Get
- (The_Names (1).Name);
-
- use Tree_Private_Part;
-
- begin
- if The_Project_Name_And_Node =
- Tree_Private_Part.No_Project_Name_And_Node
- then
- Error_Msg_Name_1 := The_Names (1).Name;
- Error_Msg ("unknown project %",
- The_Names (1).Location);
- else
- The_Project := The_Project_Name_And_Node.Node;
- end if;
- end;
end if;
- when 2 =>
+ when others =>
+
+ -- We have either a project name made of several simple
+ -- names (long project), or a project name (short project)
+ -- followed by a package name. The long project name has
+ -- precedence.
+
declare
- With_Clause : Project_Node_Id :=
- First_With_Clause_Of (Current_Project);
+ Short_Project : Name_Id;
+ Long_Project : Name_Id;
begin
- while With_Clause /= Empty_Node loop
- The_Project := Project_Node_Of (With_Clause);
- exit when Name_Of (The_Project) = The_Names (1).Name;
- With_Clause := Next_With_Clause_Of (With_Clause);
+ -- Clear the Buffer
+
+ Buffer_Last := 0;
+
+ -- Get the name of the short project
+
+ for Index in 1 .. Names.Last - 1 loop
+ Add_To_Buffer
+ (Get_Name_String (Names.Table (Index).Name));
+
+ if Index /= Names.Last - 1 then
+ Add_To_Buffer (".");
+ end if;
end loop;
- if With_Clause = Empty_Node then
- Error_Msg_Name_1 := The_Names (1).Name;
- Error_Msg ("unknown project %",
- The_Names (1).Location);
- The_Project := Empty_Node;
- The_Package := Empty_Node;
+ Name_Len := Buffer_Last;
+ Name_Buffer (1 .. Buffer_Last) :=
+ Buffer (1 .. Buffer_Last);
+ Short_Project := Name_Find;
+
+ -- Now, add the last simple name to get the name of the
+ -- long project.
+
+ Add_To_Buffer (".");
+ Add_To_Buffer
+ (Get_Name_String (Names.Table (Names.Last).Name));
+ Name_Len := Buffer_Last;
+ Name_Buffer (1 .. Buffer_Last) :=
+ Buffer (1 .. Buffer_Last);
+ Long_Project := Name_Find;
+
+ -- Check if the long project is imported or extended
+
+ The_Project := Imported_Or_Extended_Project_Of
+ (Current_Project, Long_Project);
+
+ -- If the long project exists, then this is the prefix
+ -- of the attribute.
+
+ if The_Project /= Empty_Node then
First_Attribute := Attribute_First;
+ The_Package := Empty_Node;
else
- The_Package := First_Package_Of (The_Project);
- while The_Package /= Empty_Node
- and then Name_Of (The_Package) /= The_Names (2).Name
- loop
- The_Package :=
- Next_Package_In_Project (The_Package);
- end loop;
+ -- Otherwise, check if the short project is imported
+ -- or extended.
- if The_Package = Empty_Node then
- Error_Msg_Name_1 := The_Names (2).Name;
- Error_Msg_Name_2 := The_Names (1).Name;
- Error_Msg ("package % not declared in project %",
- The_Names (2).Location);
+ The_Project := Imported_Or_Extended_Project_Of
+ (Current_Project, Short_Project);
+
+ -- If the short project does not exist, we report an
+ -- error.
+
+ if The_Project = Empty_Node then
+ Error_Msg_Name_1 := Long_Project;
+ Error_Msg_Name_2 := Short_Project;
+ Error_Msg ("unknown projects % or %",
+ Names.Table (1).Location);
+ The_Package := Empty_Node;
First_Attribute := Attribute_First;
else
- First_Attribute :=
- Package_Attributes.Table
- (Package_Id_Of (The_Package)).First_Attribute;
+ -- Now, we check if the package has been declared
+ -- in this project.
+
+ The_Package := First_Package_Of (The_Project);
+ while The_Package /= Empty_Node
+ and then Name_Of (The_Package) /=
+ Names.Table (Names.Last).Name
+ loop
+ The_Package :=
+ Next_Package_In_Project (The_Package);
+ end loop;
+
+ -- If it has not, then we report an error
+
+ if The_Package = Empty_Node then
+ Error_Msg_Name_1 :=
+ Names.Table (Names.Last).Name;
+ Error_Msg_Name_2 := Short_Project;
+ Error_Msg ("package % not declared in project %",
+ Names.Table (Names.Last).Location);
+ First_Attribute := Attribute_First;
+
+ else
+ -- Otherwise, we have the correct project and
+ -- package.
+
+ First_Attribute :=
+ Package_Attributes.Table
+ (Package_Id_Of (The_Package)).First_Attribute;
+ end if;
end if;
end if;
end;
-
- when 3 =>
- Error_Msg
- ("too many single names for an attribute reference",
- The_Names (1).Location);
- Scan;
- Variable := Empty_Node;
- return;
end case;
Attribute_Reference
@@ -604,7 +784,7 @@ package body Prj.Strt is
Default_Project_Node (Of_Kind => N_Variable_Reference);
if Look_For_Variable then
- case Last_Name is
+ case Names.Last is
when 0 =>
-- Cannot happen
@@ -612,117 +792,146 @@ package body Prj.Strt is
null;
when 1 =>
- Set_Name_Of (Variable, To => The_Names (1).Name);
- -- Header comment needed ???
+ -- Simple variable name
+
+ Set_Name_Of (Variable, To => Names.Table (1).Name);
when 2 =>
- Set_Name_Of (Variable, To => The_Names (2).Name);
+
+ -- Variable name with a simple name prefix that can be
+ -- a project name or a package name. Project names have
+ -- priority over package names.
+
+ Set_Name_Of (Variable, To => Names.Table (2).Name);
+
+ -- Check if it can be a package name
+
The_Package := First_Package_Of (Current_Project);
while The_Package /= Empty_Node
- and then Name_Of (The_Package) /= The_Names (1).Name
+ and then Name_Of (The_Package) /= Names.Table (1).Name
loop
The_Package := Next_Package_In_Project (The_Package);
end loop;
- if The_Package /= Empty_Node then
- Specified_Package := The_Package;
- The_Project := Empty_Node;
+ -- Now look for a possible project name
- else
- declare
- With_Clause : Project_Node_Id :=
- First_With_Clause_Of (Current_Project);
+ The_Project := Imported_Or_Extended_Project_Of
+ (Current_Project, Names.Table (1).Name);
- begin
- while With_Clause /= Empty_Node loop
- The_Project := Project_Node_Of (With_Clause);
- exit when Name_Of (The_Project) = The_Names (1).Name;
- With_Clause := Next_With_Clause_Of (With_Clause);
- end loop;
+ if The_Project /= Empty_Node then
+ Specified_Project := The_Project;
- if With_Clause = Empty_Node then
- The_Project :=
- Modified_Project_Of
- (Project_Declaration_Of (Current_Project));
+ elsif The_Package = Empty_Node then
+ Error_Msg_Name_1 := Names.Table (1).Name;
+ Error_Msg ("unknown package or project %",
+ Names.Table (1).Location);
+ Look_For_Variable := False;
- if The_Project /= Empty_Node
- and then
- Name_Of (The_Project) /= The_Names (1).Name
- then
- The_Project := Empty_Node;
- end if;
- end if;
-
- if The_Project = Empty_Node then
- Error_Msg_Name_1 := The_Names (1).Name;
- Error_Msg ("unknown package or project %",
- The_Names (1).Location);
- Look_For_Variable := False;
- else
- Specified_Project := The_Project;
- end if;
- end;
+ else
+ Specified_Package := The_Package;
end if;
- -- Header comment needed ???
+ when others =>
+
+ -- Variable name with a prefix that is either a project name
+ -- made of several simple names, or a project name followed
+ -- by a package name.
- when 3 =>
- Set_Name_Of (Variable, To => The_Names (3).Name);
+ Set_Name_Of (Variable, To => Names.Table (Names.Last).Name);
declare
- With_Clause : Project_Node_Id :=
- First_With_Clause_Of (Current_Project);
+ Short_Project : Name_Id;
+ Long_Project : Name_Id;
begin
- while With_Clause /= Empty_Node loop
- The_Project := Project_Node_Of (With_Clause);
- exit when Name_Of (The_Project) = The_Names (1).Name;
- With_Clause := Next_With_Clause_Of (With_Clause);
- end loop;
+ -- First, we get the two possible project names
- if With_Clause = Empty_Node then
- The_Project :=
- Modified_Project_Of
- (Project_Declaration_Of (Current_Project));
+ -- Clear the buffer
- if The_Project /= Empty_Node
- and then Name_Of (The_Project) /= The_Names (1).Name
- then
- The_Project := Empty_Node;
+ Buffer_Last := 0;
+
+ -- Add all the simple names, except the last two
+
+ for Index in 1 .. Names.Last - 2 loop
+ Add_To_Buffer
+ (Get_Name_String (Names.Table (Index).Name));
+
+ if Index /= Names.Last - 2 then
+ Add_To_Buffer (".");
end if;
- end if;
+ end loop;
- if The_Project = Empty_Node then
- Error_Msg_Name_1 := The_Names (1).Name;
- Error_Msg ("unknown package or project %",
- The_Names (1).Location);
- Look_For_Variable := False;
+ Name_Len := Buffer_Last;
+ Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
+ Short_Project := Name_Find;
- else
+ -- Add the simple name before the name of the variable
+
+ Add_To_Buffer (".");
+ Add_To_Buffer
+ (Get_Name_String (Names.Table (Names.Last - 1).Name));
+ Name_Len := Buffer_Last;
+ Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
+ Long_Project := Name_Find;
+
+ -- Check if the prefix is the name of an imported or
+ -- extended project.
+
+ The_Project := Imported_Or_Extended_Project_Of
+ (Current_Project, Long_Project);
+
+ if The_Project /= Empty_Node then
Specified_Project := The_Project;
- The_Package := First_Package_Of (The_Project);
- while The_Package /= Empty_Node
- and then Name_Of (The_Package) /= The_Names (2).Name
- loop
- The_Package := Next_Package_In_Project (The_Package);
- end loop;
+ else
+ -- Now check if the prefix may be a project name followed
+ -- by a package name.
+
+ -- First check for a possible project name
- if The_Package = Empty_Node then
- Error_Msg_Name_1 := The_Names (2).Name;
- Error_Msg ("unknown package %",
- The_Names (2).Location);
+ The_Project := Imported_Or_Extended_Project_Of
+ (Current_Project, Short_Project);
+
+ if The_Project = Empty_Node then
+ -- Unknown prefix, report an error
+
+ Error_Msg_Name_1 := Long_Project;
+ Error_Msg_Name_2 := Short_Project;
+ Error_Msg ("unknown projects % or %",
+ Names.Table (1).Location);
Look_For_Variable := False;
else
- Specified_Package := The_Package;
- The_Project := Empty_Node;
+ Specified_Project := The_Project;
+
+ -- Now look for the package in this project
+
+ The_Package := First_Package_Of (The_Project);
+
+ while The_Package /= Empty_Node
+ and then Name_Of (The_Package) /=
+ Names.Table (Names.Last - 1).Name
+ loop
+ The_Package :=
+ Next_Package_In_Project (The_Package);
+ end loop;
+
+ if The_Package = Empty_Node then
+ -- The package does not vexist, report an error
+
+ Error_Msg_Name_1 := Names.Table (2).Name;
+ Error_Msg ("unknown package %",
+ Names.Table (Names.Last - 1).Location);
+ Look_For_Variable := False;
+
+ else
+ Specified_Package := The_Package;
+ end if;
end if;
end if;
end;
-
end case;
end if;
@@ -731,8 +940,22 @@ package body Prj.Strt is
Set_Project_Node_Of (Variable, To => Specified_Project);
Set_Package_Node_Of (Variable, To => Specified_Package);
- if The_Package /= Empty_Node then
- Current_Variable := First_Variable_Of (The_Package);
+ if Specified_Project /= Empty_Node then
+ The_Project := Specified_Project;
+
+ else
+ The_Project := Current_Project;
+ end if;
+
+ Current_Variable := Empty_Node;
+
+ -- Look for this variable
+
+ -- If a package was specified, check if the variable has been
+ -- declared in this package.
+
+ if Specified_Package /= Empty_Node then
+ Current_Variable := First_Variable_Of (Specified_Package);
while Current_Variable /= Empty_Node
and then
@@ -740,22 +963,44 @@ package body Prj.Strt is
loop
Current_Variable := Next_Variable (Current_Variable);
end loop;
- end if;
- if Current_Variable = Empty_Node
- and then The_Project /= Empty_Node
- then
- Current_Variable := First_Variable_Of (The_Project);
- while Current_Variable /= Empty_Node
- and then Name_Of (Current_Variable) /= Variable_Name
- loop
- Current_Variable := Next_Variable (Current_Variable);
- end loop;
+ else
+ -- Otherwise, if no project has been specified and we are in
+ -- a package, first check if the variable has been declared in
+ -- the package.
+
+ if Specified_Project = Empty_Node
+ and then Current_Package /= Empty_Node
+ then
+ Current_Variable := First_Variable_Of (Current_Package);
+
+ while Current_Variable /= Empty_Node
+ and then Name_Of (Current_Variable) /= Variable_Name
+ loop
+ Current_Variable := Next_Variable (Current_Variable);
+ end loop;
+ end if;
+
+ -- If we have not found the variable in the package, check if the
+ -- variable has been declared in the project.
+
+ if Current_Variable = Empty_Node then
+ Current_Variable := First_Variable_Of (The_Project);
+
+ while Current_Variable /= Empty_Node
+ and then Name_Of (Current_Variable) /= Variable_Name
+ loop
+ Current_Variable := Next_Variable (Current_Variable);
+ end loop;
+ end if;
end if;
+ -- If the variable was not found, report an error
+
if Current_Variable = Empty_Node then
Error_Msg_Name_1 := Variable_Name;
- Error_Msg ("unknown variable %", The_Names (Last_Name).Location);
+ Error_Msg
+ ("unknown variable %", Names.Table (Names.Last).Location);
end if;
end if;
@@ -769,6 +1014,9 @@ package body Prj.Strt is
end if;
end if;
+ -- If the variable is followed by a left parenthesis, report an error
+ -- but attempt to scan the index.
+
if Token = Tok_Left_Paren then
Error_Msg ("\variables cannot be associative arrays", Token_Ptr);
Scan;
@@ -776,7 +1024,7 @@ package body Prj.Strt is
if Token = Tok_String_Literal then
Scan;
- Expect (Tok_Right_Paren, ")");
+ Expect (Tok_Right_Paren, "`)`");
if Token = Tok_Right_Paren then
Scan;
@@ -793,6 +1041,9 @@ package body Prj.Strt is
Current_String : Project_Node_Id;
begin
+ -- Set Choice_First, depending on whether is the first case
+ -- construction or not.
+
if Choice_First = 0 then
Choice_First := 1;
Choices.Set_Last (First_Choice_Node_Id);
@@ -800,6 +1051,8 @@ package body Prj.Strt is
Choice_First := Choices.Last + 1;
end if;
+ -- Add to table Choices the literal of the string type
+
if String_Type /= Empty_Node then
Current_String := First_Literal_String (String_Type);
@@ -809,6 +1062,8 @@ package body Prj.Strt is
end loop;
end if;
+ -- Set the value of the last choice in table Choice_Lasts
+
Choice_Lasts.Increment_Last;
Choice_Lasts.Table (Choice_Lasts.Last) := Choices.Last;
@@ -818,10 +1073,11 @@ package body Prj.Strt is
-- Terms --
-----------
- procedure Terms (Term : out Project_Node_Id;
- Expr_Kind : in out Variable_Kind;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id)
+ procedure Terms
+ (Term : out Project_Node_Id;
+ Expr_Kind : in out Variable_Kind;
+ Current_Project : Project_Node_Id;
+ Current_Package : Project_Node_Id)
is
Next_Term : Project_Node_Id := Empty_Node;
Term_Id : Project_Node_Id := Empty_Node;
@@ -831,46 +1087,74 @@ package body Prj.Strt is
Reference : Project_Node_Id := Empty_Node;
begin
+ -- Declare a new node for the term
+
Term := Default_Project_Node (Of_Kind => N_Term);
Set_Location_Of (Term, To => Token_Ptr);
case Token is
-
when Tok_Left_Paren =>
+
+ -- If we have a left parenthesis and we don't know the expression
+ -- kind, then this is a string list.
+
case Expr_Kind is
when Undefined =>
Expr_Kind := List;
+
when List =>
null;
+
when Single =>
+
+ -- If we already know that this is a single string, report
+ -- an error, but set the expression kind to string list to
+ -- avoid several errors.
+
Expr_Kind := List;
Error_Msg
("literal string list cannot appear in a string",
Token_Ptr);
end case;
+ -- Declare a new node for this literal string list
+
Term_Id := Default_Project_Node
(Of_Kind => N_Literal_String_List,
And_Expr_Kind => List);
Set_Current_Term (Term, To => Term_Id);
Set_Location_Of (Term, To => Token_Ptr);
+ -- Scan past the left parenthesis
+
Scan;
+
+ -- If the left parenthesis is immediately followed by a right
+ -- parenthesis, the literal string list is empty.
+
if Token = Tok_Right_Paren then
Scan;
else
+ -- Otherwise, we parse the expression(s) in the literal string
+ -- list.
+
loop
Current_Location := Token_Ptr;
Parse_Expression (Expression => Next_Expression,
Current_Project => Current_Project,
Current_Package => Current_Package);
+ -- The expression kind is String list, report an error
+
if Expression_Kind_Of (Next_Expression) = List then
Error_Msg ("single expression expected",
Current_Location);
end if;
+ -- If Current_Expression is empty, it means that the
+ -- expression is the first in the string list.
+
if Current_Expression = Empty_Node then
Set_First_Expression_In_List
(Term_Id, To => Next_Expression);
@@ -880,11 +1164,16 @@ package body Prj.Strt is
end if;
Current_Expression := Next_Expression;
+
+ -- If there is a comma, continue with the next expression
+
exit when Token /= Tok_Comma;
Scan; -- past the comma
end loop;
- Expect (Tok_Right_Paren, "(");
+ -- We expect a closing right parenthesis
+
+ Expect (Tok_Right_Paren, "`)`");
if Token = Tok_Right_Paren then
Scan;
@@ -892,18 +1181,29 @@ package body Prj.Strt is
end if;
when Tok_String_Literal =>
+
+ -- If we don't know the expression kind (first term), then it is
+ -- a simple string.
+
if Expr_Kind = Undefined then
Expr_Kind := Single;
end if;
+ -- Declare a new node for the string literal
+
Term_Id := Default_Project_Node (Of_Kind => N_Literal_String);
Set_Current_Term (Term, To => Term_Id);
- Set_String_Value_Of (Term_Id, To => Strval (Token_Node));
+ Set_String_Value_Of (Term_Id, To => Token_Name);
+
+ -- Scan past the string literal
Scan;
when Tok_Identifier =>
Current_Location := Token_Ptr;
+
+ -- Get the variable or attribute reference
+
Parse_Variable_Reference
(Variable => Reference,
Current_Project => Current_Project,
@@ -911,12 +1211,20 @@ package body Prj.Strt is
Set_Current_Term (Term, To => Reference);
if Reference /= Empty_Node then
+
+ -- If we don't know the expression kind (first term), then it
+ -- has the kind of the variable or attribute reference.
+
if Expr_Kind = Undefined then
Expr_Kind := Expression_Kind_Of (Reference);
elsif Expr_Kind = Single
and then Expression_Kind_Of (Reference) = List
then
+ -- If the expression is a single list, and the reference is
+ -- a string list, report an error, and set the expression
+ -- kind to string list to avoid multiple errors.
+
Expr_Kind := List;
Error_Msg
("list variable cannot appear in single string expression",
@@ -925,9 +1233,13 @@ package body Prj.Strt is
end if;
when Tok_Project =>
+
+ -- project can appear in an expression as the prefix of an
+ -- attribute reference of the current project.
+
Current_Location := Token_Ptr;
Scan;
- Expect (Tok_Apostrophe, "'");
+ Expect (Tok_Apostrophe, "`'`");
if Token = Tok_Apostrophe then
Attribute_Reference
@@ -938,6 +1250,8 @@ package body Prj.Strt is
Set_Current_Term (Term, To => Reference);
end if;
+ -- Same checks as above for the expression kind
+
if Reference /= Empty_Node then
if Expr_Kind = Undefined then
Expr_Kind := Expression_Kind_Of (Reference);
@@ -952,6 +1266,8 @@ package body Prj.Strt is
end if;
when Tok_External =>
+ -- An external reference is always a single string
+
if Expr_Kind = Undefined then
Expr_Kind := Single;
end if;
@@ -965,17 +1281,23 @@ package body Prj.Strt is
return;
end case;
+ -- If there is an '&', call Terms recursively
+
if Token = Tok_Ampersand then
+
+ -- Scan past the '&'
+
Scan;
Terms (Term => Next_Term,
Expr_Kind => Expr_Kind,
Current_Project => Current_Project,
Current_Package => Current_Package);
- Set_Next_Term (Term, To => Next_Term);
- end if;
+ -- And link the next term to this term
+ Set_Next_Term (Term, To => Next_Term);
+ end if;
end Terms;
end Prj.Strt;
diff --git a/gcc/ada/prj-strt.ads b/gcc/ada/prj-strt.ads
index 17b267c24a6..69105690b51 100644
--- a/gcc/ada/prj-strt.ads
+++ b/gcc/ada/prj-strt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -23,7 +23,7 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
---
+
-- This package implements parsing of string expressions in project files.
with Prj.Tree; use Prj.Tree;
diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb
index a7cff09c236..6587d35300b 100644
--- a/gcc/ada/prj-tree.adb
+++ b/gcc/ada/prj-tree.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -24,8 +24,6 @@
-- --
------------------------------------------------------------------------------
-with Stringt; use Stringt;
-
package body Prj.Tree is
use Tree_Private_Part;
@@ -36,7 +34,7 @@ package body Prj.Tree is
function Associative_Array_Index_Of
(Node : Project_Node_Id)
- return String_Id
+ return Name_Id
is
begin
pragma Assert
@@ -48,6 +46,38 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Value;
end Associative_Array_Index_Of;
+ ----------------------------
+ -- Associative_Package_Of --
+ ----------------------------
+
+ function Associative_Package_Of
+ (Node : Project_Node_Id)
+ return Project_Node_Id
+ is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration));
+ return Project_Nodes.Table (Node).Field3;
+ end Associative_Package_Of;
+
+ ----------------------------
+ -- Associative_Project_Of --
+ ----------------------------
+
+ function Associative_Project_Of
+ (Node : Project_Node_Id)
+ return Project_Node_Id
+ is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration));
+ return Project_Nodes.Table (Node).Field2;
+ end Associative_Project_Of;
+
----------------------
-- Case_Insensitive --
----------------------
@@ -132,7 +162,7 @@ package body Prj.Tree is
Pkg_Id => Empty_Package,
Name => No_Name,
Path_Name => No_Name,
- Value => No_String,
+ Value => No_Name,
Field1 => Empty_Node,
Field2 => Empty_Node,
Field3 => Empty_Node,
@@ -170,6 +200,8 @@ package body Prj.Tree is
or else
Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration
or else
+ Project_Nodes.Table (Node).Kind = N_Package_Declaration
+ or else
Project_Nodes.Table (Node).Kind = N_Expression
or else
Project_Nodes.Table (Node).Kind = N_Term
@@ -202,6 +234,53 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field1;
end Expression_Of;
+ -------------------------
+ -- Extended_Project_Of --
+ -------------------------
+
+ function Extended_Project_Of
+ (Node : Project_Node_Id)
+ return Project_Node_Id
+ is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Project_Declaration);
+ return Project_Nodes.Table (Node).Field2;
+ end Extended_Project_Of;
+
+ ------------------------------
+ -- Extended_Project_Path_Of --
+ ------------------------------
+
+ function Extended_Project_Path_Of
+ (Node : Project_Node_Id)
+ return Name_Id
+ is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Project);
+ return Project_Nodes.Table (Node).Value;
+ end Extended_Project_Path_Of;
+
+ --------------------------
+ -- Extending_Project_Of --
+ --------------------------
+ function Extending_Project_Of
+ (Node : Project_Node_Id)
+ return Project_Node_Id
+ is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Project_Declaration);
+ return Project_Nodes.Table (Node).Field3;
+ end Extending_Project_Of;
+
---------------------------
-- External_Reference_Of --
---------------------------
@@ -406,6 +485,55 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field1;
end First_With_Clause_Of;
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (N : Project_Node_Id) return Header_Num is
+ begin
+ return Header_Num (N mod Project_Node_Id (Header_Num'Last));
+ end Hash;
+
+ -------------------------------------
+ -- Imported_Or_Extended_Project_Of --
+ -------------------------------------
+
+ function Imported_Or_Extended_Project_Of
+ (Project : Project_Node_Id;
+ With_Name : Name_Id)
+ return Project_Node_Id
+ is
+ With_Clause : Project_Node_Id := First_With_Clause_Of (Project);
+ Result : Project_Node_Id := Empty_Node;
+
+ begin
+ -- First check all the imported projects
+
+ while With_Clause /= Empty_Node loop
+
+ -- Only non limited imported project may be used as prefix
+ -- of variable or attributes.
+
+ Result := Non_Limited_Project_Node_Of (With_Clause);
+ exit when Result /= Empty_Node and then Name_Of (Result) = With_Name;
+ With_Clause := Next_With_Clause_Of (With_Clause);
+ end loop;
+
+ -- If it is not an imported project, it might be the imported project
+
+ if With_Clause = Empty_Node then
+ Result := Extended_Project_Of (Project_Declaration_Of (Project));
+
+ if Result /= Empty_Node
+ and then Name_Of (Result) /= With_Name
+ then
+ Result := Empty_Node;
+ end if;
+ end if;
+
+ return Result;
+ end Imported_Or_Extended_Project_Of;
+
----------------
-- Initialize --
----------------
@@ -436,38 +564,6 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Location;
end Location_Of;
- -------------------------
- -- Modified_Project_Of --
- -------------------------
-
- function Modified_Project_Of
- (Node : Project_Node_Id)
- return Project_Node_Id
- is
- begin
- pragma Assert
- (Node /= Empty_Node
- and then
- Project_Nodes.Table (Node).Kind = N_Project_Declaration);
- return Project_Nodes.Table (Node).Field2;
- end Modified_Project_Of;
-
- ------------------------------
- -- Modified_Project_Path_Of --
- ------------------------------
-
- function Modified_Project_Path_Of
- (Node : Project_Node_Id)
- return String_Id
- is
- begin
- pragma Assert
- (Node /= Empty_Node
- and then
- Project_Nodes.Table (Node).Kind = N_Project);
- return Project_Nodes.Table (Node).Value;
- end Modified_Project_Path_Of;
-
-------------
-- Name_Of --
-------------
@@ -625,6 +721,21 @@ package body Prj.Tree is
return Project_Nodes.Table (Node).Field2;
end Next_With_Clause_Of;
+ ---------------------------------
+ -- Non_Limited_Project_Node_Of --
+ ---------------------------------
+
+ function Non_Limited_Project_Node_Of
+ (Node : Project_Node_Id)
+ return Project_Node_Id
+ is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ (Project_Nodes.Table (Node).Kind = N_With_Clause));
+ return Project_Nodes.Table (Node).Field3;
+ end Non_Limited_Project_Node_Of;
-------------------
-- Package_Id_Of --
-------------------
@@ -729,7 +840,7 @@ package body Prj.Tree is
procedure Set_Associative_Array_Index_Of
(Node : Project_Node_Id;
- To : String_Id)
+ To : Name_Id)
is
begin
pragma Assert
@@ -741,6 +852,38 @@ package body Prj.Tree is
Project_Nodes.Table (Node).Value := To;
end Set_Associative_Array_Index_Of;
+ --------------------------------
+ -- Set_Associative_Package_Of --
+ --------------------------------
+
+ procedure Set_Associative_Package_Of
+ (Node : Project_Node_Id;
+ To : Project_Node_Id)
+ is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Attribute_Declaration);
+ Project_Nodes.Table (Node).Field3 := To;
+ end Set_Associative_Package_Of;
+
+ --------------------------------
+ -- Set_Associative_Project_Of --
+ --------------------------------
+
+ procedure Set_Associative_Project_Of
+ (Node : Project_Node_Id;
+ To : Project_Node_Id)
+ is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ (Project_Nodes.Table (Node).Kind = N_Attribute_Declaration));
+ Project_Nodes.Table (Node).Field2 := To;
+ end Set_Associative_Project_Of;
+
--------------------------
-- Set_Case_Insensitive --
--------------------------
@@ -843,6 +986,8 @@ package body Prj.Tree is
or else
Project_Nodes.Table (Node).Kind = N_Typed_Variable_Declaration
or else
+ Project_Nodes.Table (Node).Kind = N_Package_Declaration
+ or else
Project_Nodes.Table (Node).Kind = N_Expression
or else
Project_Nodes.Table (Node).Kind = N_Term
@@ -1119,10 +1264,10 @@ package body Prj.Tree is
end Set_Location_Of;
-----------------------------
- -- Set_Modified_Project_Of --
+ -- Set_Extended_Project_Of --
-----------------------------
- procedure Set_Modified_Project_Of
+ procedure Set_Extended_Project_Of
(Node : Project_Node_Id;
To : Project_Node_Id)
is
@@ -1132,15 +1277,15 @@ package body Prj.Tree is
and then
Project_Nodes.Table (Node).Kind = N_Project_Declaration);
Project_Nodes.Table (Node).Field2 := To;
- end Set_Modified_Project_Of;
+ end Set_Extended_Project_Of;
----------------------------------
- -- Set_Modified_Project_Path_Of --
+ -- Set_Extended_Project_Path_Of --
----------------------------------
- procedure Set_Modified_Project_Path_Of
+ procedure Set_Extended_Project_Path_Of
(Node : Project_Node_Id;
- To : String_Id)
+ To : Name_Id)
is
begin
pragma Assert
@@ -1148,7 +1293,23 @@ package body Prj.Tree is
and then
Project_Nodes.Table (Node).Kind = N_Project);
Project_Nodes.Table (Node).Value := To;
- end Set_Modified_Project_Path_Of;
+ end Set_Extended_Project_Path_Of;
+
+ ------------------------------
+ -- Set_Extending_Project_Of --
+ ------------------------------
+
+ procedure Set_Extending_Project_Of
+ (Node : Project_Node_Id;
+ To : Project_Node_Id)
+ is
+ begin
+ pragma Assert
+ (Node /= Empty_Node
+ and then
+ Project_Nodes.Table (Node).Kind = N_Project_Declaration);
+ Project_Nodes.Table (Node).Field3 := To;
+ end Set_Extending_Project_Of;
-----------------
-- Set_Name_Of --
@@ -1366,8 +1527,9 @@ package body Prj.Tree is
-------------------------
procedure Set_Project_Node_Of
- (Node : Project_Node_Id;
- To : Project_Node_Id)
+ (Node : Project_Node_Id;
+ To : Project_Node_Id;
+ Limited_With : Boolean := False)
is
begin
pragma Assert
@@ -1379,6 +1541,12 @@ package body Prj.Tree is
or else
Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
Project_Nodes.Table (Node).Field1 := To;
+
+ if Project_Nodes.Table (Node).Kind = N_With_Clause
+ and then not Limited_With
+ then
+ Project_Nodes.Table (Node).Field3 := To;
+ end if;
end Set_Project_Node_Of;
---------------------------------------
@@ -1428,7 +1596,7 @@ package body Prj.Tree is
procedure Set_String_Value_Of
(Node : Project_Node_Id;
- To : String_Id)
+ To : Name_Id)
is
begin
pragma Assert
@@ -1465,7 +1633,7 @@ package body Prj.Tree is
-- String_Value_Of --
---------------------
- function String_Value_Of (Node : Project_Node_Id) return String_Id is
+ function String_Value_Of (Node : Project_Node_Id) return Name_Id is
begin
pragma Assert
(Node /= Empty_Node
@@ -1482,7 +1650,7 @@ package body Prj.Tree is
function Value_Is_Valid
(For_Typed_Variable : Project_Node_Id;
- Value : String_Id)
+ Value : Name_Id)
return Boolean
is
begin
@@ -1500,7 +1668,7 @@ package body Prj.Tree is
begin
while Current_String /= Empty_Node
and then
- not String_Equal (String_Value_Of (Current_String), Value)
+ String_Value_Of (Current_String) /= Value
loop
Current_String :=
Next_Literal_String (Current_String);
diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads
index e4c76fd9158..4ddebb35763 100644
--- a/gcc/ada/prj-tree.ads
+++ b/gcc/ada/prj-tree.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -95,6 +95,16 @@ package Prj.Tree is
-- Returns a Project_Node_Record with the specified Kind and
-- Expr_Kind; all the other components have default nil values.
+ function Hash (N : Project_Node_Id) return Header_Num;
+ -- Used for hash tables where the key is a Project_Node_Id
+
+ function Imported_Or_Extended_Project_Of
+ (Project : Project_Node_Id;
+ With_Name : Name_Id)
+ return Project_Node_Id;
+ -- Return the node of a project imported or extended by project Project and
+ -- whose name is With_Name. Return Empty_Node if there is no such project.
+
----------------------
-- Access Functions --
----------------------
@@ -103,19 +113,24 @@ package Prj.Tree is
-- of the Project File tree
function Name_Of (Node : Project_Node_Id) return Name_Id;
+ pragma Inline (Name_Of);
-- Valid for all non empty nodes. May return No_Name for nodes that have
-- no names.
function Kind_Of (Node : Project_Node_Id) return Project_Node_Kind;
+ pragma Inline (Kind_Of);
-- Valid for all non empty nodes
function Location_Of (Node : Project_Node_Id) return Source_Ptr;
+ pragma Inline (Location_Of);
-- Valid for all non empty nodes
function Directory_Of (Node : Project_Node_Id) return Name_Id;
+ pragma Inline (Directory_Of);
-- Only valid for N_Project nodes.
function Expression_Kind_Of (Node : Project_Node_Id) return Variable_Kind;
+ pragma Inline (Expression_Kind_Of);
-- Only valid for N_Literal_String, N_Attribute_Declaration,
-- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression,
-- N_Term, N_Variable_Reference or N_Attribute_Reference nodes.
@@ -123,189 +138,253 @@ package Prj.Tree is
function First_Variable_Of
(Node : Project_Node_Id)
return Variable_Node_Id;
+ pragma Inline (First_Variable_Of);
-- Only valid for N_Project or N_Package_Declaration nodes
function First_Package_Of
(Node : Project_Node_Id)
return Package_Declaration_Id;
+ pragma Inline (First_Package_Of);
-- Only valid for N_Project nodes
function Package_Id_Of (Node : Project_Node_Id) return Package_Node_Id;
+ pragma Inline (Package_Id_Of);
-- Only valid for N_Package_Declaration nodes
function Path_Name_Of (Node : Project_Node_Id) return Name_Id;
+ pragma Inline (Path_Name_Of);
-- Only valid for N_Project and N_With_Clause nodes.
- function String_Value_Of (Node : Project_Node_Id) return String_Id;
+ function String_Value_Of (Node : Project_Node_Id) return Name_Id;
+ pragma Inline (String_Value_Of);
-- Only valid for N_With_Clause or N_Literal_String nodes.
function First_With_Clause_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (First_With_Clause_Of);
-- Only valid for N_Project nodes
function Project_Declaration_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Project_Declaration_Of);
-- Only valid for N_Project nodes
+ function Extending_Project_Of
+ (Node : Project_Node_Id)
+ return Project_Node_Id;
+ pragma Inline (Extending_Project_Of);
+ -- Only valid for N_Project_Declaration nodes
+
function First_String_Type_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (First_String_Type_Of);
-- Only valid for N_Project nodes
- function Modified_Project_Path_Of
+ function Extended_Project_Path_Of
(Node : Project_Node_Id)
- return String_Id;
+ return Name_Id;
+ pragma Inline (Extended_Project_Path_Of);
-- Only valid for N_With_Clause nodes
function Project_Node_Of
(Node : Project_Node_Id)
return Project_Node_Id;
- -- Only valid for N_Project nodes
+ pragma Inline (Project_Node_Of);
+ -- Only valid for N_With_Clause, N_Variable_Reference and
+ -- N_Attribute_Reference nodes.
+
+ function Non_Limited_Project_Node_Of
+ (Node : Project_Node_Id)
+ return Project_Node_Id;
+ pragma Inline (Non_Limited_Project_Node_Of);
+ -- Only valid for N_With_Clause nodes. Returns Empty_Node for limited
+ -- imported project files, otherwise returns the same result as
+ -- Project_Node_Of.
function Next_With_Clause_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Next_With_Clause_Of);
-- Only valid for N_With_Clause nodes
function First_Declarative_Item_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (First_Declarative_Item_Of);
-- Only valid for N_With_Clause nodes
- function Modified_Project_Of
+ function Extended_Project_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Extended_Project_Of);
-- Only valid for N_With_Clause nodes
function Current_Item_Node
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Current_Item_Node);
-- Only valid for N_Declarative_Item nodes
function Next_Declarative_Item
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Next_Declarative_Item);
-- Only valid for N_Declarative_Item node
function Project_Of_Renamed_Package_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Project_Of_Renamed_Package_Of);
-- Only valid for N_Package_Declaration nodes.
-- May return Empty_Node.
function Next_Package_In_Project
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Next_Package_In_Project);
-- Only valid for N_Package_Declaration nodes
function First_Literal_String
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (First_Literal_String);
-- Only valid for N_String_Type_Declaration nodes
function Next_String_Type
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Next_String_Type);
-- Only valid for N_String_Type_Declaration nodes
function Next_Literal_String
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Next_Literal_String);
-- Only valid for N_Literal_String nodes
function Expression_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Expression_Of);
-- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration
-- or N_Variable_Declaration nodes
+ function Associative_Project_Of
+ (Node : Project_Node_Id)
+ return Project_Node_Id;
+ pragma Inline (Associative_Project_Of);
+ -- Only valid for N_Attribute_Declaration nodes
+
+ function Associative_Package_Of
+ (Node : Project_Node_Id)
+ return Project_Node_Id;
+ pragma Inline (Associative_Package_Of);
+ -- Only valid for N_Attribute_Declaration nodes
+
function Value_Is_Valid
(For_Typed_Variable : Project_Node_Id;
- Value : String_Id)
+ Value : Name_Id)
return Boolean;
+ pragma Inline (Value_Is_Valid);
-- Only valid for N_Typed_Variable_Declaration. Returns True if Value is
-- in the list of allowed strings for For_Typed_Variable. False otherwise.
function Associative_Array_Index_Of
(Node : Project_Node_Id)
- return String_Id;
+ return Name_Id;
+ pragma Inline (Associative_Array_Index_Of);
-- Only valid for N_Attribute_Declaration and N_Attribute_Reference.
-- Returns No_String for non associative array attributes.
function Next_Variable
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Next_Variable);
-- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration
-- nodes.
function First_Term
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (First_Term);
-- Only valid for N_Expression nodes
function Next_Expression_In_List
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Next_Expression_In_List);
-- Only valid for N_Expression nodes
function Current_Term
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Current_Term);
-- Only valid for N_Term nodes
function Next_Term
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Next_Term);
-- Only valid for N_Term nodes
function First_Expression_In_List
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (First_Expression_In_List);
-- Only valid for N_Literal_String_List nodes
function Package_Node_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Package_Node_Of);
-- Only valid for N_Variable_Reference or N_Attribute_Reference nodes.
-- May return Empty_Node.
function String_Type_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (String_Type_Of);
-- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration
-- nodes.
function External_Reference_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (External_Reference_Of);
-- Only valid for N_External_Value nodes
function External_Default_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (External_Default_Of);
-- Only valid for N_External_Value nodes
function Case_Variable_Reference_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Case_Variable_Reference_Of);
-- Only valid for N_Case_Construction nodes
function First_Case_Item_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (First_Case_Item_Of);
-- Only valid for N_Case_Construction nodes
function First_Choice_Of
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (First_Choice_Of);
-- Return the first choice in a N_Case_Item, or Empty_Node if
-- this is when others.
function Next_Case_Item
(Node : Project_Node_Id)
return Project_Node_Id;
+ pragma Inline (Next_Case_Item);
-- Only valid for N_Case_Item nodes
function Case_Insensitive (Node : Project_Node_Id) return Boolean;
@@ -324,166 +403,223 @@ package Prj.Tree is
procedure Set_Name_Of
(Node : Project_Node_Id;
To : Name_Id);
+ pragma Inline (Set_Name_Of);
procedure Set_Kind_Of
(Node : Project_Node_Id;
To : Project_Node_Kind);
+ pragma Inline (Set_Kind_Of);
procedure Set_Location_Of
(Node : Project_Node_Id;
To : Source_Ptr);
+ pragma Inline (Set_Location_Of);
procedure Set_Directory_Of
(Node : Project_Node_Id;
To : Name_Id);
+ pragma Inline (Set_Directory_Of);
procedure Set_Expression_Kind_Of
(Node : Project_Node_Id;
To : Variable_Kind);
+ pragma Inline (Set_Expression_Kind_Of);
procedure Set_First_Variable_Of
(Node : Project_Node_Id;
To : Variable_Node_Id);
+ pragma Inline (Set_First_Variable_Of);
procedure Set_First_Package_Of
(Node : Project_Node_Id;
To : Package_Declaration_Id);
+ pragma Inline (Set_First_Package_Of);
procedure Set_Package_Id_Of
(Node : Project_Node_Id;
To : Package_Node_Id);
+ pragma Inline (Set_Package_Id_Of);
procedure Set_Path_Name_Of
(Node : Project_Node_Id;
To : Name_Id);
+ pragma Inline (Set_Path_Name_Of);
procedure Set_String_Value_Of
(Node : Project_Node_Id;
- To : String_Id);
+ To : Name_Id);
+ pragma Inline (Set_String_Value_Of);
procedure Set_First_With_Clause_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_First_With_Clause_Of);
procedure Set_Project_Declaration_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Project_Declaration_Of);
+
+ procedure Set_Extending_Project_Of
+ (Node : Project_Node_Id;
+ To : Project_Node_Id);
+ pragma Inline (Set_Extending_Project_Of);
procedure Set_First_String_Type_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_First_String_Type_Of);
- procedure Set_Modified_Project_Path_Of
+ procedure Set_Extended_Project_Path_Of
(Node : Project_Node_Id;
- To : String_Id);
+ To : Name_Id);
+ pragma Inline (Set_Extended_Project_Path_Of);
procedure Set_Project_Node_Of
- (Node : Project_Node_Id;
- To : Project_Node_Id);
+ (Node : Project_Node_Id;
+ To : Project_Node_Id;
+ Limited_With : Boolean := False);
+ pragma Inline (Set_Project_Node_Of);
procedure Set_Next_With_Clause_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Next_With_Clause_Of);
procedure Set_First_Declarative_Item_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_First_Declarative_Item_Of);
- procedure Set_Modified_Project_Of
+ procedure Set_Extended_Project_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Extended_Project_Of);
procedure Set_Current_Item_Node
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Current_Item_Node);
procedure Set_Next_Declarative_Item
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Next_Declarative_Item);
procedure Set_Project_Of_Renamed_Package_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Project_Of_Renamed_Package_Of);
procedure Set_Next_Package_In_Project
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Next_Package_In_Project);
procedure Set_First_Literal_String
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_First_Literal_String);
procedure Set_Next_String_Type
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Next_String_Type);
procedure Set_Next_Literal_String
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Next_Literal_String);
procedure Set_Expression_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Expression_Of);
+
+ procedure Set_Associative_Project_Of
+ (Node : Project_Node_Id;
+ To : Project_Node_Id);
+ pragma Inline (Set_Associative_Project_Of);
+
+ procedure Set_Associative_Package_Of
+ (Node : Project_Node_Id;
+ To : Project_Node_Id);
+ pragma Inline (Set_Associative_Package_Of);
procedure Set_Associative_Array_Index_Of
(Node : Project_Node_Id;
- To : String_Id);
+ To : Name_Id);
+ pragma Inline (Set_Associative_Array_Index_Of);
procedure Set_Next_Variable
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Next_Variable);
procedure Set_First_Term
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_First_Term);
procedure Set_Next_Expression_In_List
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Next_Expression_In_List);
procedure Set_Current_Term
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Current_Term);
procedure Set_Next_Term
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Next_Term);
procedure Set_First_Expression_In_List
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_First_Expression_In_List);
procedure Set_Package_Node_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Package_Node_Of);
procedure Set_String_Type_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_String_Type_Of);
procedure Set_External_Reference_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_External_Reference_Of);
procedure Set_External_Default_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_External_Default_Of);
procedure Set_Case_Variable_Reference_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Case_Variable_Reference_Of);
procedure Set_First_Case_Item_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_First_Case_Item_Of);
procedure Set_First_Choice_Of
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_First_Choice_Of);
procedure Set_Next_Case_Item
(Node : Project_Node_Id;
To : Project_Node_Id);
+ pragma Inline (Set_Next_Case_Item);
procedure Set_Case_Insensitive
(Node : Project_Node_Id;
@@ -532,7 +668,7 @@ package Prj.Tree is
Path_Name : Name_Id := No_Name;
-- See below for what Project_Node_Kind it is used
- Value : String_Id := No_String;
+ Value : Name_Id := No_Name;
-- See below for what Project_Node_Kind it is used
Field1 : Project_Node_Id := Empty_Node;
@@ -560,7 +696,7 @@ package Prj.Tree is
-- -- Field1: first with clause
-- -- Field2: project declaration
-- -- Field3: first string type
- -- -- Value: modified project path name (if any)
+ -- -- Value: extended project path name (if any)
-- N_With_Clause,
-- -- Name: imported project name
@@ -568,7 +704,7 @@ package Prj.Tree is
-- -- Expr_Kind: Undefined
-- -- Field1: project node
-- -- Field2: next with clause
- -- -- Field3: not used
+ -- -- Field3: project node or empty if "limited with"
-- -- Value: literal string withed
-- N_Project_Declaration,
@@ -576,8 +712,8 @@ package Prj.Tree is
-- -- Path_Name: not used
-- -- Expr_Kind: Undefined
-- -- Field1: first declarative item
- -- -- Field2: modified project
- -- -- Field3: not used
+ -- -- Field2: extended project
+ -- -- Field3: extending project
-- -- Value: not used
-- N_Declarative_Item,
@@ -621,8 +757,8 @@ package Prj.Tree is
-- -- Path_Name: not used
-- -- Expr_Kind: attribute kind
-- -- Field1: expression
- -- -- Field2: not used
- -- -- Field3: not used
+ -- -- Field2: project of full associative array
+ -- -- Field3: package of full associative array
-- -- Value: associative array index
-- -- (if an associative array element)
@@ -742,12 +878,12 @@ package Prj.Tree is
Node : Project_Node_Id;
-- Node of the project in table Project_Nodes
- Modified : Boolean;
- -- True when the project is being modified by another project
+ Extended : Boolean;
+ -- True when the project is being extended by another project
end record;
No_Project_Name_And_Node : constant Project_Name_And_Node :=
- (Name => No_Name, Node => Empty_Node, Modified => True);
+ (Name => No_Name, Node => Empty_Node, Extended => True);
package Projects_Htable is new GNAT.HTable.Simple_HTable
(Header_Num => Header_Num,
diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb
index 15d7360c2a4..e11200026f8 100644
--- a/gcc/ada/prj-util.adb
+++ b/gcc/ada/prj-util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -26,10 +26,13 @@
with Ada.Unchecked_Deallocation;
+with GNAT.Case_Util; use GNAT.Case_Util;
+
with Namet; use Namet;
-with Osint;
+with Osint; use Osint;
with Output; use Output;
-with Stringt; use Stringt;
+with Prj.Com;
+with Snames; use Snames;
package body Prj.Util is
@@ -43,9 +46,12 @@ package body Prj.Util is
procedure Close (File : in out Text_File) is
begin
if File = null then
- Osint.Fail ("Close attempted on an invalid Text_File");
+ Prj.Com.Fail ("Close attempted on an invalid Text_File");
end if;
+ -- Close file, no need to test status, since this is a file that we
+ -- read, and the file was read successfully before we closed it.
+
Close (File.FD);
Free (File);
end Close;
@@ -57,12 +63,197 @@ package body Prj.Util is
function End_Of_File (File : Text_File) return Boolean is
begin
if File = null then
- Osint.Fail ("End_Of_File attempted on an invalid Text_File");
+ Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File");
end if;
return File.End_Of_File_Reached;
end End_Of_File;
+ -------------------
+ -- Executable_Of --
+ -------------------
+
+ function Executable_Of
+ (Project : Project_Id; Main : Name_Id) return Name_Id
+ is
+ pragma Assert (Project /= No_Project);
+
+ The_Packages : constant Package_Id :=
+ Projects.Table (Project).Decl.Packages;
+
+ Builder_Package : constant Prj.Package_Id :=
+ Prj.Util.Value_Of
+ (Name => Name_Builder,
+ In_Packages => The_Packages);
+
+ Executable : Variable_Value :=
+ Prj.Util.Value_Of
+ (Name => Main,
+ Attribute_Or_Array_Name => Name_Executable,
+ In_Package => Builder_Package);
+
+ Executable_Suffix : Variable_Value :=
+ Prj.Util.Value_Of
+ (Name => Main,
+ Attribute_Or_Array_Name =>
+ Name_Executable_Suffix,
+ In_Package => Builder_Package);
+
+ Body_Append : constant String := Get_Name_String
+ (Projects.Table
+ (Project).
+ Naming.Current_Body_Suffix);
+
+ Spec_Append : constant String := Get_Name_String
+ (Projects.Table
+ (Project).
+ Naming.Current_Spec_Suffix);
+
+ begin
+ if Builder_Package /= No_Package then
+ if Executable = Nil_Variable_Value then
+ Get_Name_String (Main);
+
+ -- Try as index the name minus the implementation suffix or minus
+ -- the specification suffix.
+
+ declare
+ Name : String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
+ Last : Positive := Name_Len;
+
+ Naming : constant Naming_Data :=
+ Projects.Table (Project).Naming;
+
+ Spec_Suffix : constant String :=
+ Get_Name_String (Naming.Current_Spec_Suffix);
+ Body_Suffix : constant String :=
+ Get_Name_String (Naming.Current_Body_Suffix);
+
+ Truncated : Boolean := False;
+
+ begin
+ if Last > Body_Suffix'Length
+ and then Name (Last - Body_Suffix'Length + 1 .. Last) =
+ Body_Suffix
+ then
+ Truncated := True;
+ Last := Last - Body_Suffix'Length;
+ end if;
+
+ if not Truncated
+ and then Last > Spec_Suffix'Length
+ and then Name (Last - Spec_Suffix'Length + 1 .. Last) =
+ Spec_Suffix
+ then
+ Truncated := True;
+ Last := Last - Spec_Suffix'Length;
+ end if;
+
+ if Truncated then
+ Name_Len := Last;
+ Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
+ Executable :=
+ Prj.Util.Value_Of
+ (Name => Name_Find,
+ Attribute_Or_Array_Name => Name_Executable,
+ In_Package => Builder_Package);
+ end if;
+ end;
+ end if;
+
+ -- If we have found an Executable attribute, return its value,
+ -- possibly suffixed by the executable suffix.
+
+ if Executable /= Nil_Variable_Value
+ and then Executable.Value /= Empty_Name
+ then
+ declare
+ Exec_Suffix : String_Access := Get_Executable_Suffix;
+ Result : Name_Id := Executable.Value;
+
+ begin
+ if Exec_Suffix'Length /= 0 then
+ Get_Name_String (Executable.Value);
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+
+ -- If the Executable does not end with the executable
+ -- suffix, add it.
+
+ if Name_Len <= Exec_Suffix'Length
+ or else
+ Name_Buffer
+ (Name_Len - Exec_Suffix'Length + 1 .. Name_Len) /=
+ Exec_Suffix.all
+ then
+ -- Get the original Executable to keep the correct
+ -- case for systems where file names are case
+ -- insensitive (Windows).
+
+ Get_Name_String (Executable.Value);
+ Name_Buffer
+ (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
+ Exec_Suffix.all;
+ Name_Len := Name_Len + Exec_Suffix'Length;
+ Result := Name_Find;
+ end if;
+
+ Free (Exec_Suffix);
+ end if;
+
+ return Result;
+ end;
+ end if;
+ end if;
+
+ Get_Name_String (Main);
+
+ -- If there is a body suffix or a spec suffix, remove this suffix,
+ -- otherwise remove any suffix ('.' followed by other characters), if
+ -- there is one.
+
+ if Name_Len > Body_Append'Length
+ and then Name_Buffer (Name_Len - Body_Append'Length + 1 .. Name_Len) =
+ Body_Append
+ then
+ -- Found the body termination, remove it
+
+ Name_Len := Name_Len - Body_Append'Length;
+
+ elsif Name_Len > Spec_Append'Length
+ and then Name_Buffer (Name_Len - Spec_Append'Length + 1 .. Name_Len) =
+ Spec_Append
+ then
+ -- Found the spec termination, remove it
+
+ Name_Len := Name_Len - Spec_Append'Length;
+
+ else
+ -- Remove any suffix, if there is one
+
+ Get_Name_String (Strip_Suffix (Main));
+ end if;
+
+ if Executable_Suffix /= Nil_Variable_Value
+ and then not Executable_Suffix.Default
+ then
+ -- If attribute Executable_Suffix is specified, add this suffix
+
+ declare
+ Suffix : constant String :=
+ Get_Name_String (Executable_Suffix.Value);
+ begin
+ Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
+ Name_Len := Name_Len + Suffix'Length;
+ return Name_Find;
+ end;
+
+ else
+ -- Otherwise, add the standard suffix for the platform, if any
+
+ return Executable_Name (Name_Find);
+ end if;
+ end Executable_Of;
+
--------------
-- Get_Line --
--------------
@@ -105,7 +296,7 @@ package body Prj.Util is
begin
if File = null then
- Osint.Fail ("Get_Line attempted on an invalid Text_File");
+ Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
end if;
Last := Line'First - 1;
@@ -193,12 +384,11 @@ package body Prj.Util is
begin
if Variable.Kind /= Single
or else Variable.Default
- or else Variable.Value = No_String then
+ or else Variable.Value = No_Name
+ then
return Default;
-
else
- String_To_Name_Buffer (Variable.Value);
- return Name_Buffer (1 .. Name_Len);
+ return Get_Name_String (Variable.Value);
end if;
end Value_Of;
@@ -207,18 +397,30 @@ package body Prj.Util is
In_Array : Array_Element_Id)
return Name_Id
is
- Current : Array_Element_Id := In_Array;
- Element : Array_Element;
+ Current : Array_Element_Id := In_Array;
+ Element : Array_Element;
+ Real_Index : Name_Id := Index;
begin
+ if Current = No_Array_Element then
+ return No_Name;
+ end if;
+
+ Element := Array_Elements.Table (Current);
+
+ if not Element.Index_Case_Sensitive then
+ Get_Name_String (Index);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ Real_Index := Name_Find;
+ end if;
+
while Current /= No_Array_Element loop
Element := Array_Elements.Table (Current);
- if Index = Element.Index then
+ if Real_Index = Element.Index then
exit when Element.Value.Kind /= Single;
- exit when String_Length (Element.Value.Value) = 0;
- String_To_Name_Buffer (Element.Value.Value);
- return Name_Find;
+ exit when Element.Value.Value = Empty_String;
+ return Element.Value.Value;
else
Current := Element.Next;
end if;
@@ -234,12 +436,25 @@ package body Prj.Util is
is
Current : Array_Element_Id := In_Array;
Element : Array_Element;
+ Real_Index : Name_Id := Index;
begin
+ if Current = No_Array_Element then
+ return Nil_Variable_Value;
+ end if;
+
+ Element := Array_Elements.Table (Current);
+
+ if not Element.Index_Case_Sensitive then
+ Get_Name_String (Index);
+ To_Lower (Name_Buffer (1 .. Name_Len));
+ Real_Index := Name_Find;
+ end if;
+
while Current /= No_Array_Element loop
Element := Array_Elements.Table (Current);
- if Index = Element.Index then
+ if Real_Index = Element.Index then
return Element.Value;
else
Current := Element.Next;
@@ -312,8 +527,8 @@ package body Prj.Util is
In_Arrays : Array_Id)
return Array_Element_Id
is
- Current : Array_Id := In_Arrays;
- The_Array : Array_Data;
+ Current : Array_Id := In_Arrays;
+ The_Array : Array_Data;
begin
while Current /= No_Array loop
@@ -353,7 +568,7 @@ package body Prj.Util is
In_Variables : Variable_Id)
return Variable_Value
is
- Current : Variable_Id := In_Variables;
+ Current : Variable_Id := In_Variables;
The_Variable : Variable;
begin
@@ -428,5 +643,4 @@ package body Prj.Util is
Write_Str (S (First .. S'Last));
end if;
end Write_Str;
-
end Prj.Util;
diff --git a/gcc/ada/prj-util.ads b/gcc/ada/prj-util.ads
index 4f1f64d7ad7..57067e225f2 100644
--- a/gcc/ada/prj-util.ads
+++ b/gcc/ada/prj-util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -23,14 +23,23 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
---
--- Utilities when using project files.
+
+-- Utilities for use in processing project files
+
+with Types; use Types;
with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Types; use Types;
package Prj.Util is
+ function Executable_Of
+ (Project : Project_Id; Main : Name_Id) return Name_Id;
+ -- Return the value of the attribute Builder'Executable for file Main in
+ -- the project Project, if it exists. If there is no attribute Executable
+ -- for Main, remove the suffix from Main; then, if the attribute
+ -- Executable_Suffix is specified, add this suffix, otherwise add the
+ -- standard executable suffix for the platform.
+
function Value_Of
(Variable : Variable_Value;
Default : String)
@@ -42,9 +51,12 @@ package Prj.Util is
(Index : Name_Id;
In_Array : Array_Element_Id)
return Name_Id;
- -- Get a single string array component.
- -- Returns No_Name if there is no component Index (case sensitive),
- -- if In_Array is null, or if the component is a String list.
+ -- Get a single string array component. Returns No_Name if there is no
+ -- component Index, if In_Array is null, or if the component is a String
+ -- list. Depending on the attribute (only attributes may be associative
+ -- arrays) the index may or may not be case sensitive. If the index is not
+ -- case sensitive, it is first set to lower case before the search in the
+ -- associative array.
function Value_Of
(Index : Name_Id;
@@ -52,7 +64,12 @@ package Prj.Util is
return Variable_Value;
-- Get a string array component (single String or String list).
-- Returns Nil_Variable_Value if there is no component Index
- -- (case sensitive), or if In_Array is null.
+ -- or if In_Array is null.
+ --
+ -- Depending on the attribute (only attributes may be associative arrays)
+ -- the index may or may not be case sensitive. If the index is not
+ -- case sensitive, it is first set to lower case before the search
+ -- in the associative array.
function Value_Of
(Name : Name_Id;
@@ -60,9 +77,11 @@ package Prj.Util is
In_Package : Package_Id)
return Variable_Value;
-- In a specific package,
- -- - if there exists an array Variable_Or_Array_Name with an index
- -- Name, returns the corresponding component,
- -- - otherwise if there is a attribute Attribute_Or_Array_Name,
+ -- - if there exists an array Attribute_Or_Array_Name with an index
+ -- Name, returns the corresponding component (depending on the
+ -- attribute, the index may or may not be case sensitive, see previous
+ -- function),
+ -- - otherwise if there is a single attribute Attribute_Or_Array_Name,
-- returns this attribute,
-- - otherwise, returns Nil_Variable_Value.
-- If In_Package is null, returns Nil_Variable_Value.
@@ -73,9 +92,8 @@ package Prj.Util is
In_Arrays : Array_Id)
return Name_Id;
-- Get a string array component in an array of an array list.
- -- Returns No_Name if there is no component Index (case sensitive),
- -- if In_Arrays is null, if In_Array is not found in In_Arrays,
- -- or if the component is a String list.
+ -- Returns No_Name if there is no component Index, if In_Arrays is null, if
+ -- In_Array is not found in In_Arrays or if the component is a String list.
function Value_Of
(Name : Name_Id;
diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb
index 6a2c553bd27..f03f5559622 100644
--- a/gcc/ada/prj.adb
+++ b/gcc/ada/prj.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -25,28 +25,27 @@
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Errout; use Errout;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Namet; use Namet;
-with Osint; use Osint;
+
+with Namet; use Namet;
+with Osint; use Osint;
with Prj.Attr;
with Prj.Com;
with Prj.Env;
-with Scans; use Scans;
-with Scn;
-with Stringt; use Stringt;
-with Sinfo.CN;
-with Snames; use Snames;
+with Prj.Err; use Prj.Err;
+with Scans; use Scans;
+with Snames; use Snames;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
package body Prj is
- The_Empty_String : String_Id;
+ The_Empty_String : Name_Id;
Ada_Language : constant Name_Id := Name_Ada;
subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
- The_Casing_Images : array (Known_Casing) of String_Access :=
+ The_Casing_Images : constant array (Known_Casing) of String_Access :=
(All_Lower_Case => new String'("lowercase"),
All_Upper_Case => new String'("UPPERCASE"),
Mixed_Case => new String'("MixedCase"));
@@ -61,51 +60,92 @@ package body Prj is
Dot_Replacement => Standard_Dot_Replacement,
Dot_Repl_Loc => No_Location,
Casing => All_Lower_Case,
- Specification_Suffix => No_Array_Element,
+ Spec_Suffix => No_Array_Element,
Current_Spec_Suffix => No_Name,
Spec_Suffix_Loc => No_Location,
- Implementation_Suffix => No_Array_Element,
- Current_Impl_Suffix => No_Name,
- Impl_Suffix_Loc => No_Location,
+ Body_Suffix => No_Array_Element,
+ Current_Body_Suffix => No_Name,
+ Body_Suffix_Loc => No_Location,
Separate_Suffix => No_Name,
Sep_Suffix_Loc => No_Location,
- Specifications => No_Array_Element,
+ Specs => No_Array_Element,
Bodies => No_Array_Element,
Specification_Exceptions => No_Array_Element,
Implementation_Exceptions => No_Array_Element);
Project_Empty : constant Project_Data :=
- (First_Referred_By => No_Project,
- Name => No_Name,
- Path_Name => No_Name,
- Location => No_Location,
- Directory => No_Name,
- Library => False,
- Library_Dir => No_Name,
- Library_Name => No_Name,
- Library_Kind => Static,
- Lib_Internal_Name => No_Name,
- Lib_Elaboration => False,
- Sources_Present => True,
- Sources => Nil_String,
- Source_Dirs => Nil_String,
- Object_Directory => No_Name,
- Exec_Directory => No_Name,
- Modifies => No_Project,
- Modified_By => No_Project,
- Naming => Std_Naming_Data,
- Decl => No_Declarations,
- Imported_Projects => Empty_Project_List,
- Include_Path => null,
- Objects_Path => null,
- Config_File_Name => No_Name,
- Config_File_Temp => False,
- Config_Checked => False,
- Language_Independent_Checked => False,
- Checked => False,
- Seen => False,
- Flag1 => False,
- Flag2 => False);
+ (First_Referred_By => No_Project,
+ Name => No_Name,
+ Path_Name => No_Name,
+ Display_Path_Name => No_Name,
+ Location => No_Location,
+ Mains => Nil_String,
+ Directory => No_Name,
+ Display_Directory => No_Name,
+ Dir_Path => null,
+ Library => False,
+ Library_Dir => No_Name,
+ Display_Library_Dir => No_Name,
+ Library_Src_Dir => No_Name,
+ Display_Library_Src_Dir => No_Name,
+ Library_Name => No_Name,
+ Library_Kind => Static,
+ Lib_Internal_Name => No_Name,
+ Lib_Elaboration => False,
+ Standalone_Library => False,
+ Lib_Interface_ALIs => Nil_String,
+ Lib_Auto_Init => False,
+ Sources_Present => True,
+ Sources => Nil_String,
+ Source_Dirs => Nil_String,
+ Known_Order_Of_Source_Dirs => True,
+ Object_Directory => No_Name,
+ Display_Object_Dir => No_Name,
+ Exec_Directory => No_Name,
+ Display_Exec_Dir => No_Name,
+ Extends => No_Project,
+ Extended_By => No_Project,
+ Naming => Std_Naming_Data,
+ Decl => No_Declarations,
+ Imported_Projects => Empty_Project_List,
+ Ada_Include_Path => null,
+ Ada_Objects_Path => null,
+ Include_Path_File => No_Name,
+ Objects_Path_File_With_Libs => No_Name,
+ Objects_Path_File_Without_Libs => No_Name,
+ Config_File_Name => No_Name,
+ Config_File_Temp => False,
+ Config_Checked => False,
+ Language_Independent_Checked => False,
+ Checked => False,
+ Seen => False,
+ Flag1 => False,
+ Flag2 => False,
+ Depth => 0);
+
+ -------------------
+ -- Add_To_Buffer --
+ -------------------
+
+ procedure Add_To_Buffer (S : String) is
+ begin
+ -- If Buffer is too small, double its size
+
+ if Buffer_Last + S'Length > Buffer'Last then
+ declare
+ New_Buffer : constant String_Access :=
+ new String (1 .. 2 * Buffer'Last);
+
+ begin
+ New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
+ Free (Buffer);
+ Buffer := New_Buffer;
+ end;
+ end if;
+
+ Buffer (Buffer_Last + 1 .. Buffer_Last + S'Length) := S;
+ Buffer_Last := Buffer_Last + S'Length;
+ end Add_To_Buffer;
-------------------
-- Empty_Project --
@@ -121,7 +161,7 @@ package body Prj is
-- Empty_String --
------------------
- function Empty_String return String_Id is
+ function Empty_String return Name_Id is
begin
return The_Empty_String;
end Empty_String;
@@ -133,7 +173,7 @@ package body Prj is
procedure Expect (The_Token : Token_Type; Token_Image : String) is
begin
if Token /= The_Token then
- Error_Msg ("""" & Token_Image & """ expected", Token_Ptr);
+ Error_Msg (Token_Image & " expected", Token_Ptr);
end if;
end Expect;
@@ -192,22 +232,25 @@ package body Prj is
begin
if not Initialized then
Initialized := True;
- Stringt.Initialize;
- Start_String;
- The_Empty_String := End_String;
+ Name_Len := 0;
+ The_Empty_String := Name_Find;
+ Empty_Name := The_Empty_String;
Name_Len := 4;
Name_Buffer (1 .. 4) := ".ads";
Default_Ada_Spec_Suffix := Name_Find;
Name_Len := 4;
Name_Buffer (1 .. 4) := ".adb";
- Default_Ada_Impl_Suffix := Name_Find;
+ Default_Ada_Body_Suffix := Name_Find;
+ Name_Len := 1;
+ Name_Buffer (1) := '/';
+ Slash := Name_Find;
Std_Naming_Data.Current_Spec_Suffix := Default_Ada_Spec_Suffix;
- Std_Naming_Data.Current_Impl_Suffix := Default_Ada_Impl_Suffix;
- Std_Naming_Data.Separate_Suffix := Default_Ada_Impl_Suffix;
+ Std_Naming_Data.Current_Body_Suffix := Default_Ada_Body_Suffix;
+ Std_Naming_Data.Separate_Suffix := Default_Ada_Body_Suffix;
Register_Default_Naming_Scheme
(Language => Ada_Language,
Default_Spec_Suffix => Default_Ada_Spec_Suffix,
- Default_Impl_Suffix => Default_Ada_Impl_Suffix);
+ Default_Body_Suffix => Default_Ada_Body_Suffix);
Prj.Env.Initialize;
Prj.Attr.Initialize;
Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
@@ -223,42 +266,32 @@ package body Prj is
procedure Register_Default_Naming_Scheme
(Language : Name_Id;
Default_Spec_Suffix : Name_Id;
- Default_Impl_Suffix : Name_Id)
+ Default_Body_Suffix : Name_Id)
is
Lang : Name_Id;
Suffix : Array_Element_Id;
Found : Boolean := False;
Element : Array_Element;
- Spec_Str : String_Id;
- Impl_Str : String_Id;
-
begin
- -- The following code is completely uncommented ???
+ -- Get the language name in small letters
Get_Name_String (Language);
Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
Lang := Name_Find;
- Get_Name_String (Default_Spec_Suffix);
- Start_String;
- Store_String_Chars (Name_Buffer (1 .. Name_Len));
- Spec_Str := End_String;
-
- Get_Name_String (Default_Impl_Suffix);
- Start_String;
- Store_String_Chars (Name_Buffer (1 .. Name_Len));
- Impl_Str := End_String;
-
- Suffix := Std_Naming_Data.Specification_Suffix;
+ Suffix := Std_Naming_Data.Spec_Suffix;
Found := False;
+ -- Look for an element of the spec sufix array indexed by the language
+ -- name. If one is found, put the default value.
+
while Suffix /= No_Array_Element and then not Found loop
Element := Array_Elements.Table (Suffix);
if Element.Index = Lang then
Found := True;
- Element.Value.Value := Spec_Str;
+ Element.Value.Value := Default_Spec_Suffix;
Array_Elements.Table (Suffix) := Element;
else
@@ -266,28 +299,34 @@ package body Prj is
end if;
end loop;
+ -- If none can be found, create a new one.
+
if not Found then
Element :=
(Index => Lang,
+ Index_Case_Sensitive => False,
Value => (Kind => Single,
Location => No_Location,
Default => False,
- Value => Spec_Str),
- Next => Std_Naming_Data.Specification_Suffix);
+ Value => Default_Spec_Suffix),
+ Next => Std_Naming_Data.Spec_Suffix);
Array_Elements.Increment_Last;
Array_Elements.Table (Array_Elements.Last) := Element;
- Std_Naming_Data.Specification_Suffix := Array_Elements.Last;
+ Std_Naming_Data.Spec_Suffix := Array_Elements.Last;
end if;
- Suffix := Std_Naming_Data.Implementation_Suffix;
+ Suffix := Std_Naming_Data.Body_Suffix;
Found := False;
+ -- Look for an element of the body sufix array indexed by the language
+ -- name. If one is found, put the default value.
+
while Suffix /= No_Array_Element and then not Found loop
Element := Array_Elements.Table (Suffix);
if Element.Index = Lang then
Found := True;
- Element.Value.Value := Impl_Str;
+ Element.Value.Value := Default_Body_Suffix;
Array_Elements.Table (Suffix) := Element;
else
@@ -295,17 +334,20 @@ package body Prj is
end if;
end loop;
+ -- If none can be found, create a new one.
+
if not Found then
Element :=
(Index => Lang,
+ Index_Case_Sensitive => False,
Value => (Kind => Single,
Location => No_Location,
Default => False,
- Value => Impl_Str),
- Next => Std_Naming_Data.Implementation_Suffix);
+ Value => Default_Body_Suffix),
+ Next => Std_Naming_Data.Body_Suffix);
Array_Elements.Increment_Last;
Array_Elements.Table (Array_Elements.Last) := Element;
- Std_Naming_Data.Implementation_Suffix := Array_Elements.Last;
+ Std_Naming_Data.Body_Suffix := Array_Elements.Last;
end if;
end Register_Default_Naming_Scheme;
@@ -337,7 +379,7 @@ package body Prj is
return Left.Dot_Replacement = Right.Dot_Replacement
and then Left.Casing = Right.Casing
and then Left.Current_Spec_Suffix = Right.Current_Spec_Suffix
- and then Left.Current_Impl_Suffix = Right.Current_Impl_Suffix
+ and then Left.Current_Body_Suffix = Right.Current_Body_Suffix
and then Left.Separate_Suffix = Right.Separate_Suffix;
end Same_Naming_Scheme;
@@ -347,15 +389,7 @@ package body Prj is
procedure Scan is
begin
- Scn.Scan;
-
- -- Change operator symbol to literal strings, since that's the way
- -- we treat all strings in a project file.
-
- if Token = Tok_Operator_Symbol then
- Sinfo.CN.Change_Operator_Symbol_To_String_Literal (Token_Node);
- Token := Tok_String_Literal;
- end if;
+ Scanner.Scan;
end Scan;
--------------------------
diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads
index 3ac425fface..b9dff5988b8 100644
--- a/gcc/ada/prj.ads
+++ b/gcc/ada/prj.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -30,14 +30,23 @@
-- Children of these package implements various services on these data types.
-- See in particular Prj.Pars and Prj.Env.
-with Casing; use Casing;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Scans; use Scans;
+with Casing; use Casing;
+with Scans; use Scans;
with Table;
-with Types; use Types;
+with Types; use Types;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
package Prj is
+ Empty_Name : Name_Id;
+ -- Name_Id for an empty name (no characters).
+ -- Initialized by procedure Initialize.
+
+ All_Packages : constant String_List_Access := null;
+ -- Default value of parameter Packages of procedures Parse, in Prj.Pars and
+ -- Prj.Part, indicating that all packages should be checked.
+
Project_File_Extension : String := ".gpr";
-- The standard project file name extension.
-- It is not a constant, because Canonical_Case_File_Name is called
@@ -47,10 +56,13 @@ package Prj is
-- The Name_Id for the standard GNAT suffix for Ada spec source file
-- name ".ads". Initialized by Prj.Initialize.
- Default_Ada_Impl_Suffix : Name_Id;
+ Default_Ada_Body_Suffix : Name_Id;
-- The Name_Id for the standard GNAT suffix for Ada body source file
-- name ".adb". Initialized by Prj.Initialize.
+ Slash : Name_Id;
+ -- "/", used as the path of locally removed files
+
type Verbosity is (Default, Medium, High);
-- Verbosity when parsing GNAT Project Files
-- Default is default (very quiet, if no errors).
@@ -59,16 +71,20 @@ package Prj is
type Lib_Kind is (Static, Dynamic, Relocatable);
- function Empty_String return String_Id;
+ function Empty_String return Name_Id;
type String_List_Id is new Nat;
Nil_String : constant String_List_Id := 0;
type String_Element is record
- Value : String_Id := No_String;
+ Value : Name_Id := No_Name;
+ Display_Value : Name_Id := No_Name;
Location : Source_Ptr := No_Location;
+ Flag : Boolean := False;
Next : String_List_Id := Nil_String;
end record;
- -- To hold values for string list variables and array elements
+ -- To hold values for string list variables and array elements.
+ -- Component Flag may be used for various purposes. For source
+ -- directories, it indicates if the directory contains Ada source(s).
package String_Elements is new Table.Table
(Table_Component_Type => String_Element,
@@ -82,6 +98,10 @@ package Prj is
type Variable_Kind is (Undefined, List, Single);
-- Different kinds of variables
+ Ignored : constant Variable_Kind := Single;
+ -- Used to indicate that a package declaration must be ignored
+ -- while processing the project tree (unknown package name).
+
type Variable_Value (Kind : Variable_Kind := Undefined) is record
Location : Source_Ptr := No_Location;
Default : Boolean := False;
@@ -91,7 +111,7 @@ package Prj is
when List =>
Values : String_List_Id := Nil_String;
when Single =>
- Value : String_Id := No_String;
+ Value : Name_Id := No_Name;
end case;
end record;
-- Values for variables and array elements.
@@ -124,9 +144,10 @@ package Prj is
type Array_Element_Id is new Nat;
No_Array_Element : constant Array_Element_Id := 0;
type Array_Element is record
- Index : Name_Id;
- Value : Variable_Value;
- Next : Array_Element_Id := No_Array_Element;
+ Index : Name_Id;
+ Index_Case_Sensitive : Boolean := True;
+ Value : Variable_Value;
+ Next : Array_Element_Id := No_Array_Element;
end record;
-- Each Array_Element represents an array element and is linked (Next)
-- to the next array element, if any, in the array.
@@ -200,6 +221,8 @@ package Prj is
-- Similar to 'Value (but avoid use of this attribute in compiler)
-- Raises Constraint_Error if not a Casing_Type image.
+ -- The following record contains data for a naming scheme
+
type Naming_Data is record
Current_Language : Name_Id := No_Name;
-- The programming language being currently considered
@@ -214,29 +237,29 @@ package Prj is
Casing : Casing_Type := All_Lower_Case;
-- The casing of the source file name (for Ada).
- Specification_Suffix : Array_Element_Id := No_Array_Element;
+ Spec_Suffix : Array_Element_Id := No_Array_Element;
-- The string to append to the unit name for the
- -- source file name of a specification.
+ -- source file name of a spec.
-- Indexed by the programming language.
Current_Spec_Suffix : Name_Id := No_Name;
- -- The specification suffix of the current programming language
+ -- The "spec" suffix of the current programming language
Spec_Suffix_Loc : Source_Ptr := No_Location;
-- The position in the project file source where
-- Current_Spec_Suffix is defined.
- Implementation_Suffix : Array_Element_Id := No_Array_Element;
+ Body_Suffix : Array_Element_Id := No_Array_Element;
-- The string to append to the unit name for the
-- source file name of a body.
-- Indexed by the programming language.
- Current_Impl_Suffix : Name_Id := No_Name;
- -- The implementation suffix of the current programming language
+ Current_Body_Suffix : Name_Id := No_Name;
+ -- The "body" suffix of the current programming language
- Impl_Suffix_Loc : Source_Ptr := No_Location;
+ Body_Suffix_Loc : Source_Ptr := No_Location;
-- The position in the project file source where
- -- Current_Impl_Suffix is defined.
+ -- Current_Body_Suffix is defined.
Separate_Suffix : Name_Id := No_Name;
-- The string to append to the unit name for the
@@ -246,8 +269,8 @@ package Prj is
-- The position in the project file source where
-- Separate_Suffix is defined.
- Specifications : Array_Element_Id := No_Array_Element;
- -- An associative array mapping individual specifications
+ Specs : Array_Element_Id := No_Array_Element;
+ -- An associative array mapping individual specs
-- to source file names. Specific to Ada.
Bodies : Array_Element_Id := No_Array_Element;
@@ -255,15 +278,16 @@ package Prj is
-- to source file names. Specific to Ada.
Specification_Exceptions : Array_Element_Id := No_Array_Element;
- -- An associative array mapping individual specifications
- -- to source file names. Indexed by the programming language name.
+ -- An associative array listing spec file names that don't have the
+ -- spec suffix. Not used by Ada. Indexed by the programming language
+ -- name.
Implementation_Exceptions : Array_Element_Id := No_Array_Element;
- -- An associative array mapping individual bodies
- -- to source file names. Indexed by the programming language name.
+ -- An associative array listing body file names that don't have the
+ -- body suffix. Not used by Ada. Indexed by the programming language
+ -- name.
end record;
- -- A naming scheme.
function Standard_Naming_Data return Naming_Data;
pragma Inline (Standard_Naming_Data);
@@ -273,7 +297,7 @@ package Prj is
(Left, Right : Naming_Data)
return Boolean;
-- Returns True if Left and Right are the same naming scheme
- -- not considering Specifications and Bodies.
+ -- not considering Specs and Bodies.
type Project_Id is new Nat;
No_Project : constant Project_Id := 0;
@@ -299,6 +323,8 @@ package Prj is
Table_Name => "Prj.Project_Lists");
-- The table that contains the lists of project files.
+ -- The following record describes a project file representation
+
type Project_Data is record
First_Referred_By : Project_Id := No_Project;
-- The project, if any, that was the first to be known
@@ -313,39 +339,75 @@ package Prj is
-- The path name of the project file.
-- Set by Prj.Proc.Process.
+ Display_Path_Name : Name_Id := No_Name;
+
Location : Source_Ptr := No_Location;
-- The location in the project file source of the
-- reserved word project.
-- Set by Prj.Proc.Process.
+ Mains : String_List_Id := Nil_String;
+ -- The list of mains as specified by attribute Main.
+ -- Set by Prj.Nmsc.Ada_Check.
+
Directory : Name_Id := No_Name;
-- The directory where the project file resides.
-- Set by Prj.Proc.Process.
+ Display_Directory : Name_Id := No_Name;
+
+ Dir_Path : String_Access;
+ -- Same as Directory, but as an access to String.
+ -- Set by Make.Compile_Sources.Collect_Arguments_And_Compile.
+
Library : Boolean := False;
-- True if this is a library project.
- -- Set by Prj.Nmsc.Check_Naming_Scheme.
+ -- Set by Prj.Nmsc.Language_Independent_Check.
Library_Dir : Name_Id := No_Name;
-- If a library project, directory where resides the library
- -- Set by Prj.Nmsc.Check_Naming_Scheme.
+ -- Set by Prj.Nmsc.Language_Independent_Check.
+
+ Display_Library_Dir : Name_Id := No_Name;
+
+ Library_Src_Dir : Name_Id := No_Name;
+ -- If a library project, directory where the sources and the ALI files
+ -- of the library are copied. By default, if attribute Library_Src_Dir
+ -- is not specified, sources are not copied anywhere and ALI files are
+ -- copied in the Library Directory.
+ -- Set by Prj.Nmsc.Language_Independent_Check.
+
+ Display_Library_Src_Dir : Name_Id := No_Name;
Library_Name : Name_Id := No_Name;
-- If a library project, name of the library
- -- Set by Prj.Nmsc.Check_Naming_Scheme.
+ -- Set by Prj.Nmsc.Language_Independent_Check.
Library_Kind : Lib_Kind := Static;
-- If a library project, kind of library
- -- Set by Prj.Nmsc.Check_Naming_Scheme.
+ -- Set by Prj.Nmsc.Language_Independent_Check.
Lib_Internal_Name : Name_Id := No_Name;
-- If a library project, internal name store inside the library
- -- Set by Prj.Nmsc.Check_Naming_Scheme.
+ -- Set by Prj.Nmsc.Language_Independent_Check.
Lib_Elaboration : Boolean := False;
-- If a library project, indicate if <lib>init and <lib>final
-- procedures need to be defined.
- -- Set by Prj.Nmsc.Check_Naming_Scheme.
+ -- Set by Prj.Nmsc.Language_Independent_Check.
+
+ Standalone_Library : Boolean := False;
+ -- Indicate that this is a Standalone Library Project File.
+ -- Set by Prj.Nmsc.Ada_Check.
+
+ Lib_Interface_ALIs : String_List_Id := Nil_String;
+ -- For Standalone Library Project Files, indicate the list
+ -- of Interface ALI files.
+ -- Set by Prj.Nmsc.Ada_Check.
+
+ Lib_Auto_Init : Boolean := False;
+ -- For non static Standalone Library Project Files, indicate if
+ -- the library initialisation should be automatic.
Sources_Present : Boolean := True;
-- A flag that indicates if there are sources in this project file.
@@ -362,23 +424,32 @@ package Prj is
-- The list of all the source directories.
-- Set by Prj.Nmsc.Check_Naming_Scheme.
+ Known_Order_Of_Source_Dirs : Boolean := True;
+ -- False, if there is any /** in the Source_Dirs, because in this case
+ -- the ordering of the source subdirs depend on the OS. If True,
+ -- duplicate file names in the same project file are allowed.
+
Object_Directory : Name_Id := No_Name;
-- The object directory of this project file.
-- Set by Prj.Nmsc.Check_Naming_Scheme.
+ Display_Object_Dir : Name_Id := No_Name;
+
Exec_Directory : Name_Id := No_Name;
-- The exec directory of this project file.
-- Default is equal to Object_Directory.
-- Set by Prj.Nmsc.Check_Naming_Scheme.
- Modifies : Project_Id := No_Project;
+ Display_Exec_Dir : Name_Id := No_Name;
+
+ Extends : Project_Id := No_Project;
-- The reference of the project file, if any, that this
- -- project file modifies.
+ -- project file extends.
-- Set by Prj.Proc.Process.
- Modified_By : Project_Id := No_Project;
+ Extended_By : Project_Id := No_Project;
-- The reference of the project file, if any, that
- -- modifies this project file.
+ -- extends this project file.
-- Set by Prj.Proc.Process.
Naming : Naming_Data := Standard_Naming_Data;
@@ -394,17 +465,31 @@ package Prj is
-- The list of all directly imported projects, if any.
-- Set by Prj.Proc.Process.
- Include_Path : String_Access := null;
+ Ada_Include_Path : String_Access := null;
-- The cached value of ADA_INCLUDE_PATH for this project file.
- -- Set by gnatmake (Prj.Env.Set_Ada_Paths).
-- Do not use this field directly outside of the compiler, use
- -- Prj.Env.Ada_Source_Path instead.
+ -- Prj.Env.Ada_Include_Path instead.
+ -- Set by Prj.Env.Ada_Include_Path.
- Objects_Path : String_Access := null;
+ Ada_Objects_Path : String_Access := null;
-- The cached value of ADA_OBJECTS_PATH for this project file.
- -- Set by gnatmake (Prj.Env.Set_Ada_Paths).
-- Do not use this field directly outside of the compiler, use
-- Prj.Env.Ada_Objects_Path instead.
+ -- Set by Prj.Env.Ada_Objects_Path
+
+ Include_Path_File : Name_Id := No_Name;
+ -- The cached value of the source path temp file for this project file.
+ -- Set by gnatmake (Prj.Env.Set_Ada_Paths).
+
+ Objects_Path_File_With_Libs : Name_Id := No_Name;
+ -- The cached value of the object path temp file (including library
+ -- dirs) for this project file.
+ -- Set by gnatmake (Prj.Env.Set_Ada_Paths).
+
+ Objects_Path_File_Without_Libs : Name_Id := No_Name;
+ -- The cached value of the object path temp file (excluding library
+ -- dirs) for this project file.
+ -- Set by gnatmake (Prj.Env.Set_Ada_Paths).
Config_File_Name : Name_Id := No_Name;
-- The name of the configuration pragmas file, if any.
@@ -438,8 +523,11 @@ package Prj is
-- and Flag2 have multiple uses, then either we use multiple fields
-- or a renaming scheme.
+ Depth : Natural := 0;
+ -- The maximum depth of a project in the project graph.
+ -- Depth of main project is 0.
+
end record;
- -- Project File representation.
function Empty_Project return Project_Data;
-- Return the representation of an empty project.
@@ -473,13 +561,13 @@ package Prj is
procedure Register_Default_Naming_Scheme
(Language : Name_Id;
Default_Spec_Suffix : Name_Id;
- Default_Impl_Suffix : Name_Id);
+ Default_Body_Suffix : Name_Id);
-- Register the default suffixs for a given language. These extensions
-- will be ignored if the user has specified a new naming scheme in a
-- project file.
+ --
-- Otherwise, this information will be automatically added to Naming_Data
- -- when a project is processed, in the lists Specification_Suffix and
- -- Implementation_Suffix.
+ -- when a project is processed, in the lists Spec_Suffix and Body_Suffix.
generic
type State is limited private;
@@ -495,9 +583,25 @@ package Prj is
-- it is called for B. With_State may be used by Action to choose a
-- behavior or to report some global result.
+ procedure Scan;
+ pragma Inline (Scan);
+ -- Scan a token. Change all operator symbols to literal strings.
+
private
- procedure Scan;
- -- Calls Scn.Scan and change any Operator_Symbol to String_Literal
+ Initial_Buffer_Size : constant := 100;
+
+ Buffer : String_Access := new String (1 .. Initial_Buffer_Size);
+ -- An extensible character buffer to store names. Used in Prj.Part and
+ -- Prj.Strt.
+
+ Buffer_Last : Natural := 0;
+ -- The index of the last character in the Buffer
+
+ Current_Packages_To_Check : String_List_Access := All_Packages;
+ -- Global variable, set by Prj.Part.Parse, used by Prj.Dect.
+
+ procedure Add_To_Buffer (S : String);
+ -- Append a String to the Buffer
end Prj;
diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c
index a9841740d88..751c01d70ca 100644
--- a/gcc/ada/raise.c
+++ b/gcc/ada/raise.c
@@ -6,8 +6,7 @@
* *
* C Implementation File *
* *
- * *
- * 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,6 +34,14 @@
#ifdef IN_RTS
#include "tconfig.h"
+/* In the top-of-tree GCC, tconfig does not include tm.h, but in GCC 3.2
+ it does. To avoid branching raise.c just for that purpose, we kludge by
+ looking for a symbol always defined by tm.h and if it's not defined,
+ we include it. */
+#ifndef FIRST_PSEUDO_REGISTER
+#include "coretypes.h"
+#include "tm.h"
+#endif
#include "tsystem.h"
#include <sys/stat.h>
typedef char bool;
@@ -88,565 +95,1052 @@ __gnat_unhandled_terminate ()
}
/* Below is the code related to the integration of the GCC mechanism for
- exception handling. Still work in progress. */
+ exception handling. */
#include "unwind.h"
-/* If the underlying GCC scheme for exception handling is SJLJ, the standard
- propagation routine (_Unwind_RaiseException) is actually renamed using a
- #define directive (see unwing-sjlj.c). We need a consistently named
- interface to import from a-except, so stubs are defined here, at the end
- of this file. */
+/* The names of a couple of "standard" routines for unwinding/propagation
+ actually vary depending on the underlying GCC scheme for exception handling
+ (SJLJ or DWARF). We need a consistently named interface to import from
+ a-except, so stubs are defined here. */
-_Unwind_Reason_Code
-__gnat_Unwind_RaiseException PARAMS ((struct _Unwind_Exception *));
+typedef struct _Unwind_Context _Unwind_Context;
+typedef struct _Unwind_Exception _Unwind_Exception;
+_Unwind_Reason_Code
+__gnat_Unwind_RaiseException PARAMS ((_Unwind_Exception *));
-/* Exception Handling personality routine for Ada.
+_Unwind_Reason_Code
+__gnat_Unwind_ForcedUnwind PARAMS ((_Unwind_Exception *, void *, void *));
- ??? It is currently inspired from the one for C++, needs cleanups and
- additional comments. It also contains a big bunch of debugging code that
- we shall get rid of at some point. */
#ifdef IN_RTS /* For eh personality routine */
-/* ??? Does it make any sense to leave this for the compiler ? */
-
#include "dwarf2.h"
#include "unwind-dw2-fde.h"
#include "unwind-pe.h"
-/* First define a set of useful structures and helper routines. */
-typedef struct _Unwind_Context _Unwind_Context;
+/* --------------------------------------------------------------
+ -- The DB stuff below is there for debugging purposes only. --
+ -------------------------------------------------------------- */
-struct lsda_header_info
+#define DB_PHASES 0x1
+#define DB_CSITE 0x2
+#define DB_ACTIONS 0x4
+#define DB_REGIONS 0x8
+
+#define DB_ERR 0x1000
+
+/* The "action" stuff below is also there for debugging purposes only. */
+
+typedef struct
{
- _Unwind_Ptr Start;
- _Unwind_Ptr LPStart;
- _Unwind_Ptr ttype_base;
- const unsigned char *TType;
- const unsigned char *action_table;
- unsigned char ttype_encoding;
- unsigned char call_site_encoding;
-};
+ _Unwind_Action phase;
+ char * description;
+} phase_descriptor;
-typedef struct lsda_header_info lsda_header_info;
+static phase_descriptor phase_descriptors[]
+ = {{ _UA_SEARCH_PHASE, "SEARCH_PHASE" },
+ { _UA_CLEANUP_PHASE, "CLEANUP_PHASE" },
+ { _UA_HANDLER_FRAME, "HANDLER_FRAME" },
+ { _UA_FORCE_UNWIND, "FORCE_UNWIND" },
+ { -1, 0}};
-static const unsigned char *
-parse_lsda_header (context, p, info)
- _Unwind_Context *context;
- const unsigned char *p;
- lsda_header_info *info;
+static int
+db_accepted_codes (void)
{
- _Unwind_Ptr tmp;
- unsigned char lpstart_encoding;
+ static int accepted_codes = -1;
- info->Start = (context ? _Unwind_GetRegionStart (context) : 0);
+ if (accepted_codes == -1)
+ {
+ char * db_env = getenv ("EH_DEBUG");
- /* Find @LPStart, the base to which landing pad offsets are relative. */
- lpstart_encoding = *p++;
- if (lpstart_encoding != DW_EH_PE_omit)
- p = read_encoded_value (context, lpstart_encoding, p, &info->LPStart);
- else
- info->LPStart = info->Start;
+ accepted_codes = db_env ? (atoi (db_env) | DB_ERR) : 0;
+ /* Arranged for ERR stuff to always be visible when the variable
+ is defined. One may just set the variable to 0 to see the ERR
+ stuff only. */
+ }
- /* Find @TType, the base of the handler and exception spec type data. */
- info->ttype_encoding = *p++;
- if (info->ttype_encoding != DW_EH_PE_omit)
+ return accepted_codes;
+}
+
+#define DB_INDENT_INCREASE 0x01
+#define DB_INDENT_DECREASE 0x02
+#define DB_INDENT_OUTPUT 0x04
+#define DB_INDENT_NEWLINE 0x08
+#define DB_INDENT_RESET 0x10
+
+#define DB_INDENT_UNIT 8
+
+static void
+db_indent (int requests)
+{
+ static int current_indentation_level = 0;
+
+ if (requests & DB_INDENT_RESET)
{
- p = read_uleb128 (p, &tmp);
- info->TType = p + tmp;
+ current_indentation_level = 0;
}
- else
- info->TType = 0;
- /* The encoding and length of the call-site table; the action table
- immediately follows. */
- info->call_site_encoding = *p++;
- p = read_uleb128 (p, &tmp);
- info->action_table = p + tmp;
+ if (requests & DB_INDENT_INCREASE)
+ {
+ current_indentation_level ++;
+ }
+
+ if (requests & DB_INDENT_DECREASE)
+ {
+ current_indentation_level --;
+ }
+
+ if (requests & DB_INDENT_NEWLINE)
+ {
+ fprintf (stderr, "\n");
+ }
+
+ if (requests & DB_INDENT_OUTPUT)
+ {
+ fprintf (stderr, "%*s",
+ current_indentation_level * DB_INDENT_UNIT, " ");
+ }
- return p;
}
-static const _Unwind_Ptr
-get_ttype_entry (context, info, i)
- _Unwind_Context *context;
- lsda_header_info *info;
- long i;
+static void
+db (int db_code, char * msg_format, ...)
+{
+ if (db_accepted_codes () & db_code)
+ {
+ va_list msg_args;
+
+ db_indent (DB_INDENT_OUTPUT);
+
+ va_start (msg_args, msg_format);
+ vfprintf (stderr, msg_format, msg_args);
+ va_end (msg_args);
+ }
+}
+
+static void
+db_phases (int phases)
{
- _Unwind_Ptr ptr;
+ phase_descriptor *a = phase_descriptors;
+
+ if (! (db_accepted_codes() & DB_PHASES))
+ return;
- i *= size_of_encoded_value (info->ttype_encoding);
- read_encoded_value (context, info->ttype_encoding, info->TType - i, &ptr);
+ db (DB_PHASES, "\n");
+
+ for (; a->description != 0; a++)
+ if (phases & a->phase)
+ db (DB_PHASES, "%s ", a->description);
- return ptr;
+ db (DB_PHASES, " :\n");
}
+
+/* ---------------------------------------------------------------
+ -- Now come a set of useful structures and helper routines. --
+ --------------------------------------------------------------- */
+
+/* There are three major runtime tables involved, generated by the
+ GCC back-end. Contents slightly vary depending on the underlying
+ implementation scheme (dwarf zero cost / sjlj).
+
+ =======================================
+ * Tables for the dwarf zero cost case *
+ =======================================
+
+ call_site []
+ -------------------------------------------------------------------
+ * region-start | region-length | landing-pad | first-action-index *
+ -------------------------------------------------------------------
+
+ Identify possible actions to be taken and where to resume control
+ for that when an exception propagates through a pc inside the region
+ delimited by start and length.
+
+ A null landing-pad indicates that nothing is to be done.
+
+ Otherwise, first-action-index provides an entry into the action[]
+ table which heads a list of possible actions to be taken (see below).
+
+ If it is determined that indeed an action should be taken, that
+ is, if one action filter matches the exception beeing propagated,
+ then control should be transfered to landing-pad.
+
+ A null first-action-index indicates that there are only cleanups
+ to run there.
+
+ action []
+ -------------------------------
+ * action-filter | next-action *
+ -------------------------------
+
+ This table contains lists (called action chains) of possible actions
+ associated with call-site entries described in the call-site [] table.
+ There is at most one action list per call-site entry.
+
+ A null action-filter indicates a cleanup.
+
+ Non null action-filters provide an index into the ttypes [] table
+ (see below), from which information may be retrieved to check if it
+ matches the exception beeing propagated.
+
+ action-filter > 0 means there is a regular handler to be run,
+
+ action-filter < 0 means there is a some "exception_specification"
+ data to retrieve, which is only relevant for C++
+ and should never show up for Ada.
+
+ next-action indexes the next entry in the list. 0 indicates there is
+ no other entry.
+
+ ttypes []
+ ---------------
+ * ttype-value *
+ ---------------
+
+ A null value indicates a catch-all handler in C++, and an "others"
+ handler in Ada.
+
+ Non null values are used to match the exception beeing propagated:
+ In C++ this is a pointer to some rtti data, while in Ada this is an
+ exception id.
+
+ The special id value 1 indicates an "all_others" handler.
+
+ For C++, this table is actually also used to store "exception
+ specification" data. The differentiation between the two kinds
+ of entries is made by the sign of the associated action filter,
+ which translates into positive or negative offsets from the
+ so called base of the table:
+
+ Exception Specification data is stored at positive offsets from
+ the ttypes table base, which Exception Type data is stored at
+ negative offsets:
+
+ ---------------------------------------------------------------------------
+
+ Here is a quick summary of the tables organization:
+
+ +-- Unwind_Context (pc, ...)
+ |
+ |(pc)
+ |
+ | CALL-SITE[]
+ |
+ | +=============================================================+
+ | | region-start + length | landing-pad | first-action-index |
+ | +=============================================================+
+ +-> | pc range 0 => no-action 0 => cleanups only |
+ | !0 => jump @ N --+ |
+ +====================================================== | ====+
+ |
+ |
+ ACTION [] |
+ |
+ +==========================================================+ |
+ | action-filter | next-action | |
+ +==========================================================+ |
+ | 0 => cleanup | |
+ | >0 => ttype index for handler ------+ 0 => end of chain | <-+
+ | <0 => ttype index for spec data | |
+ +==================================== | ===================+
+ |
+ |
+ TTYPES [] |
+ | Offset negated from
+ +=====================+ | the actual base.
+ | ttype-value | |
+ +============+=====================+ |
+ | | 0 => "others" | |
+ | ... | 1 => "all others" | <---+
+ | | X => exception id |
+ | handlers +---------------------+
+ | | ... |
+ | ... | ... |
+ | | ... |
+ +============+=====================+ <<------ Table base
+ | ... | ... |
+ | specs | ... | (should not see negative filter
+ | ... | ... | values for Ada).
+ +============+=====================+
+
+
+ ============================
+ * Tables for the sjlj case *
+ ============================
+
+ So called "function contexts" are pushed on a context stack by calls to
+ _Unwind_SjLj_Register on function entry, and popped off at exit points by
+ calls to _Unwind_SjLj_Unregister. The current call_site for a function is
+ updated in the function context as the function's code runs along.
+
+ The generic unwinding engine in _Unwind_RaiseException walks the function
+ context stack and not the actual call chain.
+
+ The ACTION and TTYPES tables remain unchanged, which allows to search them
+ during the propagation phase to determine wether or not the propagated
+ exception is handled somewhere. When it is, we only "jump" up once directly
+ to the context where the handler will be found. Besides, this allows "break
+ exception unhandled" to work also
+
+ The CALL-SITE table is setup differently, though: the pc attached to the
+ unwind context is a direct index into the table, so the entries in this
+ table do not hold region bounds any more.
+
+ A special index (-1) is used to indicate that no action is possibly
+ connected with the context at hand, so null landing pads cannot appear
+ in the table.
+
+ Additionally, landing pad values in the table do not represent code address
+ to jump at, but so called "dispatch" indices used by a common landing pad
+ for the function to switch to the appropriate post-landing-pad.
+
+ +-- Unwind_Context (pc, ...)
+ |
+ | pc = call-site index
+ | 0 => terminate (should not see this for Ada)
+ | -1 => no-action
+ |
+ | CALL-SITE[]
+ |
+ | +=====================================+
+ | | landing-pad | first-action-index |
+ | +=====================================+
+ +-> | 0 => cleanups only |
+ | dispatch index N |
+ +=====================================+
+
+
+ ===================================
+ * Basic organization of this unit *
+ ===================================
+
+ The major point of this unit is to provide an exception propagation
+ personality routine for Ada. This is __gnat_eh_personality.
+
+ It is provided with a pointer to the propagated exception, an unwind
+ context describing a location the propagation is going through, and a
+ couple of other arguments including a description of the current
+ propagation phase.
+
+ It shall return to the generic propagation engine what is to be performed
+ next, after possible context adjustments, depending on what it finds in the
+ traversed context (a handler for the exception, a cleanup, nothing, ...),
+ and on the propagation phase.
+
+ A number of structures and subroutines are used for this purpose, as
+ sketched below:
+
+ o region_descriptor: General data associated with the context (base pc,
+ call-site table, action table, ttypes table, ...)
+
+ o action_descriptor: Data describing the action to be taken for the
+ propagated exception in the provided context (kind of action: nothing,
+ handler, cleanup; pointer to the action table entry, ...).
+
+ raise
+ |
+ ... (a-except.adb)
+ |
+ Propagate_Exception (a-exexpr.adb)
+ |
+ |
+ _Unwind_RaiseException (libgcc)
+ |
+ | (Ada frame)
+ |
+ +--> __gnat_eh_personality (context, exception)
+ |
+ +--> get_region_descriptor_for (context)
+ |
+ +--> get_action_descriptor_for (context, exception, region)
+ | |
+ | +--> get_call_site_action_for (context, region)
+ | (one version for each underlying scheme)
+ |
+ +--> setup_to_install (context)
+
+ This unit is inspired from the C++ version found in eh_personality.cc,
+ part of libstdc++-v3.
+
+*/
+
+
/* This is the structure of exception objects as built by the GNAT runtime
- library (a-except.adb). The layouts should exactly match, and the "common"
+ library (a-exexpr.adb). The layouts should exactly match, and the "common"
header is mandated by the exception handling ABI. */
-struct _GNAT_Exception
+typedef struct
{
- struct _Unwind_Exception common;
+ _Unwind_Exception common;
+ /* ABI header, maximally aligned. */
+
_Unwind_Ptr id;
- char handled_by_others;
- char has_cleanup;
- char select_cleanups;
-};
+ /* Id of the exception beeing propagated, filled by Propagate_Exception.
+
+ This is compared against the ttype entries associated with actions in the
+ examined context to see if one of these actions matches. */
+
+ bool handled_by_others;
+ /* Indicates wether a "when others" may catch this exception, also filled by
+ Propagate_Exception.
+
+ This is used to decide if a GNAT_OTHERS ttype entry matches. */
+ int n_cleanups_to_trigger;
+ /* Number of cleanups on the propagation way for the occurrence. This is
+ initialized to 0 by Propagate_Exception and computed by the personality
+ routine during the first phase of the propagation (incremented for each
+ context in which only cleanup actions match).
+
+ This is used by Propagate_Exception when the occurrence is not handled,
+ to control a forced unwinding phase aimed at triggering all the cleanups
+ before calling Unhandled_Exception_Terminate.
+
+ This is also used by __gnat_eh_personality to identify the point at which
+ the notification routine shall be called for a handled occurrence. */
+} _GNAT_Exception;
/* The two constants below are specific ttype identifiers for special
exception ids. Their value is currently hardcoded at the gigi level
(see N_Exception_Handler). */
-#define GNAT_OTHERS_ID ((_Unwind_Ptr) 0x0)
-#define GNAT_ALL_OTHERS_ID ((_Unwind_Ptr) 0x1)
+#define GNAT_OTHERS ((_Unwind_Ptr) 0x0)
+#define GNAT_ALL_OTHERS ((_Unwind_Ptr) 0x1)
+/* Describe the useful region data associated with an unwind context. */
-/* The DB stuff below is there for debugging purposes only. */
+typedef struct
+{
+ /* The base pc of the region. */
+ _Unwind_Ptr base;
-#define DB_PHASES 0x1
-#define DB_SEARCH 0x2
-#define DB_ECLASS 0x4
-#define DB_MATCH 0x8
-#define DB_SAW 0x10
-#define DB_FOUND 0x20
-#define DB_INSTALL 0x40
-#define DB_CALLS 0x80
+ /* Pointer to the Language Specific Data for the region. */
+ _Unwind_Ptr lsda;
-#define AEHP_DB_SPECS \
-(DB_PHASES | DB_SEARCH | DB_SAW | DB_FOUND | DB_INSTALL | DB_CALLS | DB_MATCH)
+ /* Call-Site data associated with this region. */
+ unsigned char call_site_encoding;
+ const unsigned char *call_site_table;
-#undef AEHP_DB_SPECS
+ /* The base to which are relative landing pad offsets inside the call-site
+ entries . */
+ _Unwind_Ptr lp_base;
-#ifdef AEHP_DB_SPECS
-static int db_specs = AEHP_DB_SPECS;
-#else
-static int db_specs = 0;
-#endif
+ /* Action-Table associated with this region. */
+ const unsigned char *action_table;
-#define START_DB(what) do { if (what & db_specs) {
-#define END_DB(what) } \
- } while (0);
+ /* Ttype data associated with this region. */
+ unsigned char ttype_encoding;
+ const unsigned char *ttype_table;
+ _Unwind_Ptr ttype_base;
+
+} region_descriptor;
+
+static void
+db_region_for (region, uw_context)
+ region_descriptor *region;
+ _Unwind_Context *uw_context;
+{
+ _Unwind_Ptr ip = _Unwind_GetIP (uw_context) - 1;
+
+ if (! (db_accepted_codes () & DB_REGIONS))
+ return;
+
+ db (DB_REGIONS, "For ip @ 0x%08x => ", ip);
+
+ if (region->lsda)
+ db (DB_REGIONS, "lsda @ 0x%x", region->lsda);
+ else
+ db (DB_REGIONS, "no lsda");
+
+ db (DB_REGIONS, "\n");
+}
+
+/* Retrieve the ttype entry associated with FILTER in the REGION's
+ ttype table. */
+
+static const _Unwind_Ptr
+get_ttype_entry_for (region, filter)
+ region_descriptor *region;
+ long filter;
+{
+ _Unwind_Ptr ttype_entry;
+
+ filter *= size_of_encoded_value (region->ttype_encoding);
+ read_encoded_value_with_base
+ (region->ttype_encoding, region->ttype_base,
+ region->ttype_table - filter, &ttype_entry);
+
+ return ttype_entry;
+}
+
+/* Fill out the REGION descriptor for the provided UW_CONTEXT. */
+
+static void
+get_region_description_for (uw_context, region)
+ _Unwind_Context *uw_context;
+ region_descriptor *region;
+{
+ const unsigned char * p;
+ _Unwind_Word tmp;
+ unsigned char lpbase_encoding;
+
+ /* Get the base address of the lsda information. If the provided context
+ is null or if there is no associated language specific data, there's
+ nothing we can/should do. */
+ region->lsda
+ = (_Unwind_Ptr) (uw_context
+ ? _Unwind_GetLanguageSpecificData (uw_context) : 0);
+
+ if (! region->lsda)
+ return;
+
+ /* Parse the lsda and fill the region descriptor. */
+ p = (char *)region->lsda;
+
+ region->base = _Unwind_GetRegionStart (uw_context);
+
+ /* Find @LPStart, the base to which landing pad offsets are relative. */
+ lpbase_encoding = *p++;
+ if (lpbase_encoding != DW_EH_PE_omit)
+ p = read_encoded_value
+ (uw_context, lpbase_encoding, p, &region->lp_base);
+ else
+ region->lp_base = region->base;
+
+ /* Find @TType, the base of the handler and exception spec type data. */
+ region->ttype_encoding = *p++;
+ if (region->ttype_encoding != DW_EH_PE_omit)
+ {
+ p = read_uleb128 (p, &tmp);
+ region->ttype_table = p + tmp;
+ }
+ else
+ region->ttype_table = 0;
+
+ region->ttype_base
+ = base_of_encoded_value (region->ttype_encoding, uw_context);
+
+ /* Get the encoding and length of the call-site table; the action table
+ immediately follows. */
+ region->call_site_encoding = *p++;
+ region->call_site_table = read_uleb128 (p, &tmp);
+
+ region->action_table = region->call_site_table + tmp;
+}
+
+
+/* Describe an action to be taken when propagating an exception up to
+ some context. */
+
+typedef enum
+{
+ /* Found some call site base data, but need to analyze further
+ before beeing able to decide. */
+ unknown,
+
+ /* There is nothing relevant in the context at hand. */
+ nothing,
+
+ /* There are only cleanups to run in this context. */
+ cleanup,
+
+ /* There is a handler for the exception in this context. */
+ handler
+} action_kind;
-/* The "action" stuff below is also there for debugging purposes only. */
typedef struct
{
- _Unwind_Action action;
- char * description;
-} action_description_t;
+ /* The kind of action to be taken. */
+ action_kind kind;
+
+ /* A pointer to the action record entry. */
+ const unsigned char *table_entry;
+
+ /* Where we should jump to actually take an action (trigger a cleanup or an
+ exception handler). */
+ _Unwind_Ptr landing_pad;
+
+ /* If we have a handler matching our exception, these are the filter to
+ trigger it and the corresponding id. */
+ _Unwind_Sword ttype_filter;
+ _Unwind_Ptr ttype_entry;
+
+} action_descriptor;
-static action_description_t action_descriptions[]
- = {{ _UA_SEARCH_PHASE, "SEARCH_PHASE" },
- { _UA_CLEANUP_PHASE, "CLEANUP_PHASE" },
- { _UA_HANDLER_FRAME, "HANDLER_FRAME" },
- { _UA_FORCE_UNWIND, "FORCE_UNWIND" },
- { -1, 0}};
static void
-decode_actions (actions)
- _Unwind_Action actions;
+db_action_for (action, uw_context)
+ action_descriptor *action;
+ _Unwind_Context *uw_context;
{
- int i;
+ _Unwind_Ptr ip = _Unwind_GetIP (uw_context) - 1;
- action_description_t *a = action_descriptions;
+ db (DB_ACTIONS, "For ip @ 0x%08x => ", ip);
- printf ("\n");
- for (; a->description != 0; a++)
- if (actions & a->action)
- printf ("%s ", a->description);
+ switch (action->kind)
+ {
+ case unknown:
+ db (DB_ACTIONS, "lpad @ 0x%x, record @ 0x%x\n",
+ ip, action->landing_pad, action->table_entry);
+ break;
+
+ case nothing:
+ db (DB_ACTIONS, "Nothing\n");
+ break;
+
+ case cleanup:
+ db (DB_ACTIONS, "Cleanup\n");
+ break;
+
+ case handler:
+ db (DB_ACTIONS, "Handler, filter = %d\n", action->ttype_filter);
+ break;
+
+ default:
+ db (DB_ACTIONS, "Err? Unexpected action kind !\n");
+ break;
+ }
- printf (" : ");
+ return;
}
-/* The following is defined from a-except.adb. Its purpose is to enable
- automatic backtraces upon exception raise, as provided through the
- GNAT.Traceback facilities. */
-extern void __gnat_notify_handled_exception PARAMS ((void *, bool, bool));
-/* Below is the eh personality routine per se. */
+/* Search the call_site_table of REGION for an entry appropriate for the
+ UW_CONTEXT's ip. If one is found, store the associated landing_pad and
+ action_table entry, and set the ACTION kind to unknown for further
+ analysis. Otherwise, set the ACTION kind to nothing.
-_Unwind_Reason_Code
-__gnat_eh_personality (version, actions, exception_class, ue_header, context)
- int version;
- _Unwind_Action actions;
- _Unwind_Exception_Class exception_class;
- struct _Unwind_Exception *ue_header;
- struct _Unwind_Context *context;
+ There are two variants of this routine, depending on the underlying
+ mechanism (dwarf/sjlj), which account for differences in the tables
+ organization.
+*/
+
+#ifdef __USING_SJLJ_EXCEPTIONS__
+
+#define __builtin_eh_return_data_regno(x) x
+
+static void
+get_call_site_action_for (uw_context, region, action)
+ _Unwind_Context *uw_context;
+ region_descriptor *region;
+ action_descriptor *action;
{
- enum found_handler_type
- {
- found_nothing,
- found_terminate,
- found_cleanup,
- found_handler
- } found_type;
- lsda_header_info info;
- const unsigned char *language_specific_data;
- const unsigned char *action_record;
- const unsigned char *p;
- _Unwind_Ptr landing_pad, ip;
- int handler_switch_value;
- bool hit_others_handler;
- struct _GNAT_Exception *gnat_exception;
-
- if (version != 1)
- return _URC_FATAL_PHASE1_ERROR;
+ _Unwind_Ptr call_site
+ = _Unwind_GetIP (uw_context) - 1;
+ /* Subtract 1 because GetIP returns the actual call_site value + 1. */
- START_DB (DB_PHASES);
- decode_actions (actions);
- END_DB (DB_PHASES);
+ /* call_site is a direct index into the call-site table, with two special
+ values : -1 for no-action and 0 for "terminate". The latter should never
+ show up for Ada. To test for the former, beware that _Unwind_Ptr might be
+ unsigned. */
- if (strcmp ((char *) &exception_class, "GNU") != 0
- || strcmp (((char *) &exception_class) + 4, "Ada") != 0)
+ if ((int)call_site < 0)
{
- START_DB (DB_SEARCH);
- printf (" Exception Class doesn't match for ip = %p\n", ip);
- END_DB (DB_SEARCH);
- START_DB (DB_FOUND);
- printf (" => FOUND nothing\n");
- END_DB (DB_FOUND);
- return _URC_CONTINUE_UNWIND;
+ action->kind = nothing;
+ return;
}
+ else if (call_site == 0)
+ {
+ db (DB_ERR, "========> Err, null call_site for Ada/sjlj\n");
+ action->kind = nothing;
+ return;
+ }
+ else
+ {
+ _Unwind_Word cs_lp, cs_action;
- gnat_exception = (struct _GNAT_Exception *) ue_header;
+ /* Let the caller know there may be an action to take, but let it
+ determine the kind. */
+ action->kind = unknown;
- START_DB (DB_PHASES);
- if (gnat_exception->select_cleanups)
- printf ("(select_cleanups) :\n");
- else
- printf (" :\n");
- END_DB (DB_PHASES);
+ /* We have a direct index into the call-site table, but this table is
+ made of leb128 values, the encoding length of which is variable. We
+ can't merely compute an offset from the index, then, but have to read
+ all the entries before the one of interest. */
- language_specific_data
- = (const unsigned char *) _Unwind_GetLanguageSpecificData (context);
+ const unsigned char * p = region->call_site_table;
- /* If no LSDA, then there are no handlers or cleanups. */
- if (! language_specific_data)
- {
- ip = _Unwind_GetIP (context) - 1;
-
- START_DB (DB_SEARCH);
- printf (" No Language Specific Data for ip = %p\n", ip);
- END_DB (DB_SEARCH);
- START_DB (DB_FOUND);
- printf (" => FOUND nothing\n");
- END_DB (DB_FOUND);
- return _URC_CONTINUE_UNWIND;
+ do {
+ p = read_uleb128 (p, &cs_lp);
+ p = read_uleb128 (p, &cs_action);
+ } while (--call_site);
+
+
+ action->landing_pad = cs_lp + 1;
+
+ if (cs_action)
+ action->table_entry = region->action_table + cs_action - 1;
+ else
+ action->table_entry = 0;
+
+ return;
}
+}
+
+#else
+/* ! __USING_SJLJ_EXCEPTIONS__ */
+
+static void
+get_call_site_action_for (uw_context, region, action)
+ _Unwind_Context *uw_context;
+ region_descriptor *region;
+ action_descriptor *action;
+{
+ _Unwind_Ptr ip
+ = _Unwind_GetIP (uw_context) - 1;
+ /* Substract 1 because GetIP yields a call return address while we are
+ interested in information for the call point. This does not always yield
+ the exact call instruction address but always brings the ip back within
+ the corresponding region.
+
+ ??? When unwinding up from a signal handler triggered by a trap on some
+ instruction, we usually have the faulting instruction address here and
+ subtracting 1 might get us into the wrong region. */
- /* Parse the LSDA header. */
- p = parse_lsda_header (context, language_specific_data, &info);
- info.ttype_base = base_of_encoded_value (info.ttype_encoding, context);
- ip = _Unwind_GetIP (context) - 1;
- landing_pad = 0;
- action_record = 0;
- handler_switch_value = 0;
+ const unsigned char * p
+ = region->call_site_table;
- /* Search the call-site table for the action associated with this IP. */
- while (p < info.action_table)
+ /* Unless we are able to determine otherwise ... */
+ action->kind = nothing;
+
+ db (DB_CSITE, "\n");
+
+ while (p < region->action_table)
{
_Unwind_Ptr cs_start, cs_len, cs_lp;
_Unwind_Word cs_action;
/* Note that all call-site encodings are "absolute" displacements. */
- p = read_encoded_value (0, info.call_site_encoding, p, &cs_start);
- p = read_encoded_value (0, info.call_site_encoding, p, &cs_len);
- p = read_encoded_value (0, info.call_site_encoding, p, &cs_lp);
+ p = read_encoded_value (0, region->call_site_encoding, p, &cs_start);
+ p = read_encoded_value (0, region->call_site_encoding, p, &cs_len);
+ p = read_encoded_value (0, region->call_site_encoding, p, &cs_lp);
p = read_uleb128 (p, &cs_action);
+ db (DB_CSITE,
+ "c_site @ 0x%08x (+0x%03x), len = %3d, lpad @ 0x%08x (+0x%03x)\n",
+ region->base+cs_start, cs_start, cs_len,
+ region->lp_base+cs_lp, cs_lp);
+
/* The table is sorted, so if we've passed the ip, stop. */
- if (ip < info.Start + cs_start)
- p = info.action_table;
- else if (ip < info.Start + cs_start + cs_len)
+ if (ip < region->base + cs_start)
+ break;
+
+ /* If we have a match, fill the ACTION fields accordingly. */
+ else if (ip < region->base + cs_start + cs_len)
{
+ /* Let the caller know there may be an action to take, but let it
+ determine the kind. */
+ action->kind = unknown;
+
if (cs_lp)
- landing_pad = info.LPStart + cs_lp;
+ action->landing_pad = region->lp_base + cs_lp;
+ else
+ action->landing_pad = 0;
+
if (cs_action)
- action_record = info.action_table + cs_action - 1;
- goto found_something;
+ action->table_entry = region->action_table + cs_action - 1;
+ else
+ action->table_entry = 0;
+
+ db (DB_CSITE, "+++\n");
+ return;
}
}
- START_DB (DB_SEARCH);
- printf (" No Action entry for ip = %p\n", ip);
- END_DB (DB_SEARCH);
+ db (DB_CSITE, "---\n");
+}
- /* If ip is not present in the table, call terminate. This is for
- a destructor inside a cleanup, or a library routine the compiler
- was not expecting to throw.
+#endif
- found_type =
- (actions & _UA_FORCE_UNWIND ? found_nothing : found_terminate);
+/* Fill out the ACTION to be taken from propagating UW_EXCEPTION up to
+ UW_CONTEXT in REGION. */
- ??? Does this have a mapping in Ada semantics ? */
+static void
+get_action_description_for (uw_context, uw_exception, region, action)
+ _Unwind_Context *uw_context;
+ _Unwind_Exception *uw_exception;
+ region_descriptor *region;
+ action_descriptor *action;
+{
+ _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception;
- found_type = found_nothing;
- goto do_something;
+ /* Search the call site table first, which may get us a landing pad as well
+ as the head of an action record list. */
+ get_call_site_action_for (uw_context, region, action);
+ db_action_for (action, uw_context);
- found_something:
+ /* If there is not even a call_site entry, we are done. */
+ if (action->kind == nothing)
+ return;
- found_type = found_nothing;
+ /* Otherwise, check what we have at the place of the call site */
- if (landing_pad == 0)
+ /* No landing pad => no cleanups or handlers. */
+ if (action->landing_pad == 0)
{
- /* If ip is present, and has a null landing pad, there are
- no cleanups or handlers to be run. */
- START_DB (DB_SEARCH);
- printf (" No Landing Pad for ip = %p\n", ip);
- END_DB (DB_SEARCH);
+ action->kind = nothing;
+ return;
}
- else if (action_record == 0)
+
+ /* Landing pad + null table entry => only cleanups. */
+ else if (action->table_entry == 0)
{
- START_DB (DB_SEARCH);
- printf (" Null Action Record for ip = %p <===\n", ip);
- END_DB (DB_SEARCH);
+ action->kind = cleanup;
+ return;
}
+
+ /* Landing pad + Table entry => handlers + possible cleanups. */
else
{
- signed long ar_filter, ar_disp;
- signed long cleanup_filter = 0;
- signed long handler_filter = 0;
+ const unsigned char * p = action->table_entry;
- START_DB (DB_SEARCH);
- printf (" Landing Pad + Action Record for ip = %p\n", ip);
- END_DB (DB_SEARCH);
+ _Unwind_Sword ar_filter, ar_disp;
- START_DB (DB_MATCH);
- printf (" => Search for exception matching id %p\n",
- gnat_exception->id);
- END_DB (DB_MATCH);
-
- /* Otherwise we have a catch handler or exception specification. */
+ action->kind = nothing;
while (1)
{
- _Unwind_Word tmp;
-
- p = action_record;
- p = read_sleb128 (p, &tmp); ar_filter = tmp;
- read_sleb128 (p, &tmp); ar_disp = tmp;
-
- START_DB (DB_MATCH);
- printf ("ar_filter %d\n", ar_filter);
- END_DB (DB_MATCH);
+ p = read_sleb128 (p, &ar_filter);
+ read_sleb128 (p, &ar_disp);
+ /* Don't assign p here, as it will be incremented by ar_disp
+ below. */
+ /* Null filters are for cleanups. */
if (ar_filter == 0)
- {
- /* Zero filter values are cleanups. We should not be seeing
- this for GNU-Ada though
- saw_cleanup = true; */
- START_DB (DB_SEARCH);
- printf (" Null Filter for ip = %p <===\n", ip);
- END_DB (DB_SEARCH);
- }
+ action->kind = cleanup;
+
+ /* Positive filters are for regular handlers. */
else if (ar_filter > 0)
{
- _Unwind_Ptr lp_id = get_ttype_entry (context, &info, ar_filter);
-
- START_DB (DB_MATCH);
- printf ("catch_type ");
-
- switch (lp_id)
- {
- case GNAT_ALL_OTHERS_ID:
- printf ("GNAT_ALL_OTHERS_ID\n");
- break;
-
- case GNAT_OTHERS_ID:
- printf ("GNAT_OTHERS_ID\n");
- break;
-
- default:
- printf ("%p\n", lp_id);
- break;
- }
-
- END_DB (DB_MATCH);
-
- if (lp_id == GNAT_ALL_OTHERS_ID)
- {
- START_DB (DB_SAW);
- printf (" => SAW cleanup\n");
- END_DB (DB_SAW);
-
- cleanup_filter = ar_filter;
- gnat_exception->has_cleanup = true;
- }
-
- hit_others_handler
- = (lp_id == GNAT_OTHERS_ID
- && gnat_exception->handled_by_others);
+ /* See if the filter we have is for an exception which matches
+ the one we are propagating. */
+ _Unwind_Ptr eid = get_ttype_entry_for (region, ar_filter);
- if (hit_others_handler || lp_id == gnat_exception->id)
+ if (eid == gnat_exception->id
+ || eid == GNAT_ALL_OTHERS
+ || (eid == GNAT_OTHERS && gnat_exception->handled_by_others))
{
- START_DB (DB_SAW);
- printf (" => SAW handler\n");
- END_DB (DB_SAW);
-
- handler_filter = ar_filter;
+ action->ttype_filter = ar_filter;
+ action->ttype_entry = eid;
+ action->kind = handler;
+ return;
}
}
+
+ /* Negative filter values are for C++ exception specifications.
+ Should not be there for Ada :/ */
else
- /* Negative filter values are for C++ exception specifications.
- Should not be there for Ada :/ */
- ;
+ db (DB_ERR, "========> Err, filter < 0 for Ada/dwarf\n");
- if (actions & _UA_SEARCH_PHASE)
- {
- if (handler_filter)
- {
- found_type = found_handler;
- handler_switch_value = handler_filter;
- break;
- }
+ if (ar_disp == 0)
+ return;
- if (cleanup_filter)
- found_type = found_cleanup;
- }
+ p += ar_disp;
+ }
+ }
+}
- if (actions & _UA_CLEANUP_PHASE)
- {
- if (handler_filter)
- {
- found_type = found_handler;
- handler_switch_value = handler_filter;
- break;
- }
+/* Setup in UW_CONTEXT the eh return target IP and data registers, which will
+ be restored with the others and retrieved by the landing pad once the jump
+ occured. */
- if (cleanup_filter)
- {
- found_type = found_cleanup;
- handler_switch_value = cleanup_filter;
- break;
- }
- }
+static void
+setup_to_install (uw_context, uw_exception, uw_landing_pad, uw_filter)
+ _Unwind_Context *uw_context;
+ _Unwind_Exception *uw_exception;
+ int uw_filter;
+ _Unwind_Ptr uw_landing_pad;
+{
+#ifndef EH_RETURN_DATA_REGNO
+ /* We should not be called if the appropriate underlying support is not
+ there. */
+ abort ();
+#else
+ /* 1/ exception object pointer, which might be provided back to
+ _Unwind_Resume (and thus to this personality routine) if we are jumping
+ to a cleanup. */
+ _Unwind_SetGR (uw_context, __builtin_eh_return_data_regno (0),
+ (_Unwind_Word)uw_exception);
+
+ /* 2/ handler switch value register, which will also be used by the target
+ landing pad to decide what action it shall take. */
+ _Unwind_SetGR (uw_context, __builtin_eh_return_data_regno (1),
+ (_Unwind_Word)uw_filter);
+
+ /* Setup the address we should jump at to reach the code where there is the
+ "something" we found. */
+ _Unwind_SetIP (uw_context, uw_landing_pad);
+#endif
+}
- if (ar_disp == 0)
- break;
+/* The following is defined from a-except.adb. Its purpose is to enable
+ automatic backtraces upon exception raise, as provided through the
+ GNAT.Traceback facilities. */
+extern void __gnat_notify_handled_exception PARAMS ((void));
+extern void __gnat_notify_unhandled_exception PARAMS ((void));
- action_record = p + ar_disp;
- }
- }
+/* Below is the eh personality routine per se. We currently assume that only
+ GNU-Ada exceptions are met. */
- do_something:
- if (found_type == found_nothing)
- {
- START_DB (DB_FOUND);
- printf (" => FOUND nothing\n");
- END_DB (DB_FOUND);
+_Unwind_Reason_Code
+__gnat_eh_personality (uw_version, uw_phases,
+ uw_exception_class, uw_exception, uw_context)
+ int uw_version;
+ _Unwind_Action uw_phases;
+ _Unwind_Exception_Class uw_exception_class;
+ _Unwind_Exception *uw_exception;
+ _Unwind_Context *uw_context;
+{
+ _GNAT_Exception * gnat_exception = (_GNAT_Exception *) uw_exception;
- return _URC_CONTINUE_UNWIND;
- }
+ region_descriptor region;
+ action_descriptor action;
- if (actions & _UA_SEARCH_PHASE)
- {
- START_DB (DB_FOUND);
- printf (" => Computing return for SEARCH\n");
- END_DB (DB_FOUND);
+ if (uw_version != 1)
+ return _URC_FATAL_PHASE1_ERROR;
- if (found_type == found_cleanup
- && !gnat_exception->select_cleanups)
+ db_indent (DB_INDENT_RESET);
+ db_phases (uw_phases);
+ db_indent (DB_INDENT_INCREASE);
+
+ /* Get the region description for the context we were provided with. This
+ will tell us if there is some lsda, call_site, action and/or ttype data
+ for the associated ip. */
+ get_region_description_for (uw_context, &region);
+ db_region_for (&region, uw_context);
+
+ /* No LSDA => no handlers or cleanups => we shall unwind further up. */
+ if (! region.lsda)
+ return _URC_CONTINUE_UNWIND;
+
+ /* Search the call-site and action-record tables for the action associated
+ with this IP. */
+ get_action_description_for (uw_context, uw_exception, &region, &action);
+ db_action_for (&action, uw_context);
+
+ /* Whatever the phase, if there is nothing relevant in this frame,
+ unwinding should just go on. */
+ if (action.kind == nothing)
+ return _URC_CONTINUE_UNWIND;
+
+ /* If we found something in search phase, we should return a code indicating
+ what to do next depending on what we found. If we only have cleanups
+ around, we shall try to unwind further up to find a handler, otherwise,
+ tell we have a handler, which will trigger the second phase. */
+ if (uw_phases & _UA_SEARCH_PHASE)
+ {
+ if (action.kind == cleanup)
{
- START_DB (DB_FOUND);
- printf (" => FOUND cleanup\n");
- END_DB (DB_FOUND);
-
+ gnat_exception->n_cleanups_to_trigger ++;
return _URC_CONTINUE_UNWIND;
}
+ else
+ {
+ /* Trigger the appropriate notification routines before the second
+ phase starts, which ensures the stack is still intact. */
+ __gnat_notify_handled_exception ();
- START_DB (DB_FOUND);
- printf (" => FOUND handler\n");
- END_DB (DB_FOUND);
-
- return _URC_HANDLER_FOUND;
+ return _URC_HANDLER_FOUND;
+ }
}
- install_context:
+ /* We found something in cleanup/handler phase, which might be the handler
+ or a cleanup for a handled occurrence, or a cleanup for an unhandled
+ occurrence (we are in a FORCED_UNWIND phase in this case). Install the
+ context to get there. */
- START_DB (DB_INSTALL);
- printf (" => INSTALLING context for filter %d\n",
- handler_switch_value);
- END_DB (DB_INSTALL);
+ /* If we are going to install a cleanup context, decrement the cleanup
+ count. This is required in a FORCED_UNWINDing phase (for an unhandled
+ exception), as this is used from the forced unwinding handler in
+ Ada.Exceptions.Exception_Propagation to decide wether unwinding should
+ proceed further or Unhandled_Exception_Terminate should be called. */
+ if (action.kind == cleanup)
+ gnat_exception->n_cleanups_to_trigger --;
- if (found_type == found_terminate)
- {
- /* Should not have this for Ada ? */
- START_DB (DB_INSTALL);
- printf (" => FOUND terminate <===\n");
- END_DB (DB_INSTALL);
- }
+ setup_to_install
+ (uw_context, uw_exception, action.landing_pad, action.ttype_filter);
+ return _URC_INSTALL_CONTEXT;
+}
- /* Signal that we are going to enter a handler, which will typically
- enable the debugger to take control and possibly output an automatic
- backtrace. Note that we are supposed to provide the handler's entry
- point here but we don't have it. */
- __gnat_notify_handled_exception ((void *)landing_pad, hit_others_handler,
- true);
+/* Define the consistently named stubs imported by Propagate_Exception. */
- /* The GNU-Ada exception handlers know how to find the exception
- occurrence without having to pass it as an argument so there
- is no need to feed any specific register with this information.
+#ifdef __USING_SJLJ_EXCEPTIONS__
- This is why the two following lines are commented out. */
+#undef _Unwind_RaiseException
- /* _Unwind_SetGR (context, __builtin_eh_return_data_regno (0),
- (_Unwind_Ptr) &xh->unwindHeader); */
+_Unwind_Reason_Code
+__gnat_Unwind_RaiseException (e)
+ _Unwind_Exception *e;
+{
+ return _Unwind_SjLj_RaiseException (e);
+}
- _Unwind_SetGR (context, __builtin_eh_return_data_regno (1),
- handler_switch_value);
- _Unwind_SetIP (context, landing_pad);
+#undef _Unwind_ForcedUnwind
- return _URC_INSTALL_CONTEXT;
+_Unwind_Reason_Code
+__gnat_Unwind_ForcedUnwind (e, handler, argument)
+ _Unwind_Exception *e;
+ void * handler;
+ void * argument;
+{
+ return _Unwind_SjLj_ForcedUnwind (e, handler, argument);
}
-/* Stubs for the libgcc unwinding interface, to be imported by a-except. */
-
-#ifdef __USING_SJLJ_EXCEPTIONS__
+#else /* __USING_SJLJ_EXCEPTIONS__ */
_Unwind_Reason_Code
__gnat_Unwind_RaiseException (e)
- struct _Unwind_Exception *e;
+ _Unwind_Exception *e;
{
- return _Unwind_SjLj_RaiseException (e);
+ return _Unwind_RaiseException (e);
}
-#else
-/* __USING_SJLJ_EXCEPTIONS__ not defined */
-
_Unwind_Reason_Code
-__gnat_Unwind_RaiseException (e)
- struct _Unwind_Exception *e;
+__gnat_Unwind_ForcedUnwind (e, handler, argument)
+ _Unwind_Exception *e;
+ void * handler;
+ void * argument;
{
- return _Unwind_RaiseException (e);
+ return _Unwind_ForcedUnwind (e, handler, argument);
}
-
-#endif
+
+#endif /* __USING_SJLJ_EXCEPTIONS__ */
#else
-/* IN_RTS not defined */
+/* ! IN_RTS */
/* The calls to the GCC runtime interface for exception raising are currently
- issued from a-except.adb, which is used by both the runtime library and
- the compiler. As the compiler binary is not linked against the GCC runtime
- library, we need a stub for this interface in the compiler case. */
+ issued from a-exexpr.adb, which is used by both the runtime library and the
+ compiler.
-/* Since we don't link the compiler with a host libgcc, we should not be
- using the GCC eh mechanism for the compiler and so expect this function
- never to be called. */
+ As the compiler binary is not linked against the GCC runtime library, we
+ need also need stubs for this interface in the compiler case. We should not
+ be using the GCC eh mechanism for the compiler, however, so expect these
+ functions never to be called. */
_Unwind_Reason_Code
__gnat_Unwind_RaiseException (e)
- struct _Unwind_Exception *e ATTRIBUTE_UNUSED;
+ _Unwind_Exception *e ATTRIBUTE_UNUSED;
{
abort ();
}
-#endif
+
+_Unwind_Reason_Code
+__gnat_Unwind_ForcedUnwind (e, handler, argument)
+ _Unwind_Exception *e ATTRIBUTE_UNUSED;
+ void * handler ATTRIBUTE_UNUSED;
+ void * argument ATTRIBUTE_UNUSED;
+{
+ abort ();
+}
+
+#endif /* IN_RTS */
diff --git a/gcc/ada/raise.h b/gcc/ada/raise.h
index 9e088c90199..8628ecbee0f 100644
--- a/gcc/ada/raise.h
+++ b/gcc/ada/raise.h
@@ -6,8 +6,7 @@
* *
* C Header File *
* *
- * *
- * Copyright (C) 1992-2001, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2002, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -32,7 +31,7 @@
****************************************************************************/
struct Exception_Data
-{
+{
char Handled_By_Others;
char Lang;
int Name_Length;
@@ -59,9 +58,10 @@ extern void __gnat_free PARAMS ((void *));
extern void *__gnat_realloc PARAMS ((void *, __SIZE_TYPE__));
extern void __gnat_finalize PARAMS ((void));
extern void set_gnat_exit_status PARAMS ((int));
-extern void __gnat_set_globals PARAMS ((int, int,
+extern void __gnat_set_globals PARAMS ((int, int,
char, char, char, char,
- char *, int, int, int));
+ char *, char *,
+ int, int, int, int));
extern void __gnat_initialize PARAMS ((void));
extern void __gnat_init_float PARAMS ((void));
extern void __gnat_install_handler PARAMS ((void));
diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb
index f7315dbf242..cd4e9db6a71 100644
--- a/gcc/ada/repinfo.adb
+++ b/gcc/ada/repinfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,6 +42,8 @@ with Opt; use Opt;
with Output; use Output;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
with Table; use Table;
with Uname; use Uname;
with Urealp; use Urealp;
@@ -52,6 +54,7 @@ package body Repinfo is
-- Value for Storage_Unit, we do not want to get this from TTypes, since
-- this introduces problematic dependencies in ASIS, and in any case this
-- value is assumed to be 8 for the implementation of the DDA.
+
-- This is wrong for AAMP???
---------------------------------------
@@ -97,21 +100,27 @@ package body Repinfo is
Table_Increment => Alloc.Rep_Table_Increment,
Table_Name => "FE_Rep_Table");
- -----------------------
- -- Local Subprograms --
- -----------------------
-
Unit_Casing : Casing_Type;
-- Identifier casing for current unit
- procedure Spaces (N : Natural);
- -- Output given number of spaces
+ Need_Blank_Line : Boolean;
+ -- Set True if a blank line is needed before outputting any
+ -- information for the current entity. Set True when a new
+ -- entity is processed, and false when the blank line is output.
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
function Back_End_Layout return Boolean;
-- Test for layout mode, True = back end, False = front end. This
-- function is used rather than checking the configuration parameter
-- because we do not want Repinfo to depend on Targparm (for ASIS)
+ procedure Blank_Line;
+ -- Called before outputting anything for an entity. Ensures that
+ -- a blank line precedes the output for a particular entity.
+
procedure List_Entities (Ent : Entity_Id);
-- This procedure lists the entities associated with the entity E,
-- starting with the First_Entity and using the Next_Entity link.
@@ -125,6 +134,10 @@ package body Repinfo is
procedure List_Array_Info (Ent : Entity_Id);
-- List representation info for array type Ent
+ procedure List_Mechanisms (Ent : Entity_Id);
+ -- List mechanism information for parameters of Ent, which is a
+ -- subprogram, subprogram type, or an entry or entry family.
+
procedure List_Object_Info (Ent : Entity_Id);
-- List representation info for object Ent
@@ -138,6 +151,9 @@ package body Repinfo is
-- Returns True if Val represents a variable value, and False if it
-- represents a value that is fixed at compile time.
+ procedure Spaces (N : Natural);
+ -- Output given number of spaces
+
procedure Write_Info_Line (S : String);
-- Routine to write a line to Repinfo output file. This routine is
-- passed as a special output procedure to Output.Set_Special_Output.
@@ -146,6 +162,9 @@ package body Repinfo is
-- to the appropriate routine in Osint requires that the end of line
-- sequence be stripped off.
+ procedure Write_Mechanism (M : Mechanism_Type);
+ -- Writes symbolic string for mechanism represented by M
+
procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
-- Given a representation value, write it out. No_Uint values or values
-- dependent on discriminants are written as two question marks. If the
@@ -164,6 +183,18 @@ package body Repinfo is
return Rep_Table.Last > 0;
end Back_End_Layout;
+ ----------------
+ -- Blank_Line --
+ ----------------
+
+ procedure Blank_Line is
+ begin
+ if Need_Blank_Line then
+ Write_Eol;
+ Need_Blank_Line := False;
+ end if;
+ end Blank_Line;
+
------------------------
-- Create_Discrim_Ref --
------------------------
@@ -286,40 +317,104 @@ package body Repinfo is
-------------------
procedure List_Entities (Ent : Entity_Id) is
- E : Entity_Id;
+ Body_E : Entity_Id;
+ E : Entity_Id;
+
+ function Find_Declaration (E : Entity_Id) return Node_Id;
+ -- Utility to retrieve declaration node for entity in the
+ -- case of package bodies and subprograms.
+
+ ----------------------
+ -- Find_Declaration --
+ ----------------------
+
+ function Find_Declaration (E : Entity_Id) return Node_Id is
+ Decl : Node_Id;
+ begin
+ Decl := Parent (E);
+
+ while Present (Decl)
+ and then Nkind (Decl) /= N_Package_Body
+ and then Nkind (Decl) /= N_Subprogram_Declaration
+ and then Nkind (Decl) /= N_Subprogram_Body
+ loop
+ Decl := Parent (Decl);
+ end loop;
+
+ return Decl;
+ end Find_Declaration;
+
+ -- Start of processing for List_Entities
begin
if Present (Ent) then
+
+ -- If entity is a subprogram and we are listing mechanisms,
+ -- then we need to list mechanisms for this entity.
+
+ if List_Representation_Info_Mechanisms
+ and then (Is_Subprogram (Ent)
+ or else Ekind (Ent) = E_Entry
+ or else Ekind (Ent) = E_Entry_Family)
+ then
+ Need_Blank_Line := True;
+ List_Mechanisms (Ent);
+ end if;
+
E := First_Entity (Ent);
while Present (E) loop
+ Need_Blank_Line := True;
-- We list entities that come from source (excluding private
- -- types, where we will list the info for the full view). If
- -- debug flag A is set, all entities are listed
-
- if (Comes_From_Source (E) and then not Is_Private_Type (E))
+ -- or incomplete types or deferred constants, where we will
+ -- list the info for the full view). If debug flag A is set,
+ -- then all entities are listed
+
+ if (Comes_From_Source (E)
+ and then not Is_Incomplete_Or_Private_Type (E)
+ and then not (Ekind (E) = E_Constant
+ and then Present (Full_View (E))))
or else Debug_Flag_AA
then
- if Is_Record_Type (E) then
- List_Record_Info (E);
+ if Is_Subprogram (E)
+ or else
+ Ekind (E) = E_Entry
+ or else
+ Ekind (E) = E_Entry_Family
+ or else
+ Ekind (E) = E_Subprogram_Type
+ then
+ if List_Representation_Info_Mechanisms then
+ List_Mechanisms (E);
+ end if;
+
+ elsif Is_Record_Type (E) then
+ if List_Representation_Info >= 1 then
+ List_Record_Info (E);
+ end if;
elsif Is_Array_Type (E) then
- List_Array_Info (E);
+ if List_Representation_Info >= 1 then
+ List_Array_Info (E);
+ end if;
- elsif List_Representation_Info >= 2 then
- if Is_Type (E) then
+ elsif Is_Type (E) then
+ if List_Representation_Info >= 2 then
List_Type_Info (E);
+ end if;
- elsif Ekind (E) = E_Variable
- or else
- Ekind (E) = E_Constant
- or else
- Ekind (E) = E_Loop_Parameter
- or else
- Is_Formal (E)
- then
+ elsif Ekind (E) = E_Variable
+ or else
+ Ekind (E) = E_Constant
+ or else
+ Ekind (E) = E_Loop_Parameter
+ or else
+ Is_Formal (E)
+ then
+ if List_Representation_Info >= 2 then
List_Object_Info (E);
end if;
+
end if;
-- Recurse into nested package, but not if they are
@@ -357,6 +452,35 @@ package body Repinfo is
E := Next_Entity (E);
end loop;
+
+ -- For a package body, the entities of the visible subprograms
+ -- are declared in the corresponding spec. Iterate over its
+ -- entities in order to handle properly the subprogram bodies.
+ -- Skip bodies in subunits, which are listed independently.
+
+ if Ekind (Ent) = E_Package_Body
+ and then Present (Corresponding_Spec (Find_Declaration (Ent)))
+ then
+ E := First_Entity (Corresponding_Spec (Find_Declaration (Ent)));
+
+ while Present (E) loop
+ if Is_Subprogram (E)
+ and then
+ Nkind (Find_Declaration (E)) = N_Subprogram_Declaration
+ then
+ Body_E := Corresponding_Body (Find_Declaration (E));
+
+ if Present (Body_E)
+ and then
+ Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit
+ then
+ List_Entities (Body_E);
+ end if;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
end if;
end List_Entities;
@@ -366,10 +490,14 @@ package body Repinfo is
procedure List_GCC_Expression (U : Node_Ref_Or_Val) is
- procedure P (Val : Node_Ref_Or_Val);
+ procedure Print_Expr (Val : Node_Ref_Or_Val);
-- Internal recursive procedure to print expression
- procedure P (Val : Node_Ref_Or_Val) is
+ ----------------
+ -- Print_Expr --
+ ----------------
+
+ procedure Print_Expr (Val : Node_Ref_Or_Val) is
begin
if Val >= 0 then
UI_Write (Val, Decimal);
@@ -381,26 +509,30 @@ package body Repinfo is
procedure Binop (S : String);
-- Output text for binary operator with S being operator name
+ -----------
+ -- Binop --
+ -----------
+
procedure Binop (S : String) is
begin
Write_Char ('(');
- P (Node.Op1);
+ Print_Expr (Node.Op1);
Write_Str (S);
- P (Node.Op2);
+ Print_Expr (Node.Op2);
Write_Char (')');
end Binop;
- -- Start of processing for P
+ -- Start of processing for Print_Expr
begin
case Node.Expr is
when Cond_Expr =>
Write_Str ("(if ");
- P (Node.Op1);
+ Print_Expr (Node.Op1);
Write_Str (" then ");
- P (Node.Op2);
+ Print_Expr (Node.Op2);
Write_Str (" else ");
- P (Node.Op3);
+ Print_Expr (Node.Op3);
Write_Str (" end)");
when Plus_Expr =>
@@ -435,7 +567,7 @@ package body Repinfo is
when Negate_Expr =>
Write_Char ('-');
- P (Node.Op1);
+ Print_Expr (Node.Op1);
when Min_Expr =>
Binop (" min ");
@@ -445,7 +577,7 @@ package body Repinfo is
when Abs_Expr =>
Write_Str ("abs ");
- P (Node.Op1);
+ Print_Expr (Node.Op1);
when Truth_Andif_Expr =>
Binop (" and if ");
@@ -464,7 +596,7 @@ package body Repinfo is
when Truth_Not_Expr =>
Write_Str ("not ");
- P (Node.Op1);
+ Print_Expr (Node.Op1);
when Lt_Expr =>
Binop (" < ");
@@ -491,7 +623,7 @@ package body Repinfo is
end case;
end;
end if;
- end P;
+ end Print_Expr;
-- Start of processing for List_GCC_Expression
@@ -499,10 +631,105 @@ package body Repinfo is
if U = No_Uint then
Write_Str ("??");
else
- P (U);
+ Print_Expr (U);
end if;
end List_GCC_Expression;
+ ---------------------
+ -- List_Mechanisms --
+ ---------------------
+
+ procedure List_Mechanisms (Ent : Entity_Id) is
+ Plen : Natural;
+ Form : Entity_Id;
+
+ begin
+ Blank_Line;
+
+ case Ekind (Ent) is
+ when E_Function =>
+ Write_Str ("function ");
+
+ when E_Operator =>
+ Write_Str ("operator ");
+
+ when E_Procedure =>
+ Write_Str ("procedure ");
+
+ when E_Subprogram_Type =>
+ Write_Str ("type ");
+
+ when E_Entry | E_Entry_Family =>
+ Write_Str ("entry ");
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ Get_Unqualified_Decoded_Name_String (Chars (Ent));
+ Write_Str (Name_Buffer (1 .. Name_Len));
+ Write_Str (" declared at ");
+ Write_Location (Sloc (Ent));
+ Write_Eol;
+
+ Write_Str (" convention : ");
+
+ case Convention (Ent) is
+ when Convention_Ada => Write_Line ("Ada");
+ when Convention_Intrinsic => Write_Line ("InLineinsic");
+ when Convention_Entry => Write_Line ("Entry");
+ when Convention_Protected => Write_Line ("Protected");
+ when Convention_Assembler => Write_Line ("Assembler");
+ when Convention_C => Write_Line ("C");
+ when Convention_COBOL => Write_Line ("COBOL");
+ when Convention_CPP => Write_Line ("C++");
+ when Convention_Fortran => Write_Line ("Fortran");
+ when Convention_Java => Write_Line ("Java");
+ when Convention_Stdcall => Write_Line ("Stdcall");
+ when Convention_Stubbed => Write_Line ("Stubbed");
+ end case;
+
+ -- Find max length of formal name
+
+ Plen := 0;
+ Form := First_Formal (Ent);
+ while Present (Form) loop
+ Get_Unqualified_Decoded_Name_String (Chars (Form));
+
+ if Name_Len > Plen then
+ Plen := Name_Len;
+ end if;
+
+ Next_Formal (Form);
+ end loop;
+
+ -- Output formals and mechanisms
+
+ Form := First_Formal (Ent);
+ while Present (Form) loop
+ Get_Unqualified_Decoded_Name_String (Chars (Form));
+
+ while Name_Len <= Plen loop
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := ' ';
+ end loop;
+
+ Write_Str (" ");
+ Write_Str (Name_Buffer (1 .. Plen + 1));
+ Write_Str (": passed by ");
+
+ Write_Mechanism (Mechanism (Form));
+ Write_Eol;
+ Next_Formal (Form);
+ end loop;
+
+ if Etype (Ent) /= Standard_Void_Type then
+ Write_Str (" returns by ");
+ Write_Mechanism (Mechanism (Ent));
+ Write_Eol;
+ end if;
+ end List_Mechanisms;
+
---------------
-- List_Name --
---------------
@@ -525,7 +752,7 @@ package body Repinfo is
procedure List_Object_Info (Ent : Entity_Id) is
begin
- Write_Eol;
+ Blank_Line;
Write_Str ("for ");
List_Name (Ent);
@@ -546,7 +773,6 @@ package body Repinfo is
procedure List_Record_Info (Ent : Entity_Id) is
Comp : Entity_Id;
- Esiz : Uint;
Cfbit : Uint;
Sunit : Uint;
@@ -554,6 +780,7 @@ package body Repinfo is
Max_Suni_Length : Natural;
begin
+ Blank_Line;
List_Type_Info (Ent);
Write_Str ("for ");
@@ -585,7 +812,6 @@ package body Repinfo is
Set_Normalized_Position (Comp, Cfbit / SSU);
Set_Normalized_First_Bit (Comp, Cfbit mod SSU);
- Esiz := Esize (Comp);
Sunit := Cfbit / SSU;
UI_Image (Sunit);
end if;
@@ -746,55 +972,55 @@ package body Repinfo is
Col : Nat;
begin
- for U in Main_Unit .. Last_Unit loop
- if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
+ if Debug_Flag_AA then
+ List_Representation_Info := 3;
+ List_Representation_Info_Mechanisms := True;
+ end if;
- -- Normal case, list to standard output
+ if List_Representation_Info /= 0
+ or else List_Representation_Info_Mechanisms
+ then
+ for U in Main_Unit .. Last_Unit loop
+ if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
- if not List_Representation_Info_To_File then
- Unit_Casing := Identifier_Casing (Source_Index (U));
- Write_Eol;
- Write_Str ("Representation information for unit ");
- Write_Unit_Name (Unit_Name (U));
- Col := Column;
- Write_Eol;
+ -- Normal case, list to standard output
- for J in 1 .. Col - 1 loop
- Write_Char ('-');
- end loop;
+ if not List_Representation_Info_To_File then
+ Unit_Casing := Identifier_Casing (Source_Index (U));
+ Write_Eol;
+ Write_Str ("Representation information for unit ");
+ Write_Unit_Name (Unit_Name (U));
+ Col := Column;
+ Write_Eol;
+
+ for J in 1 .. Col - 1 loop
+ Write_Char ('-');
+ end loop;
- Write_Eol;
- List_Entities (Cunit_Entity (U));
+ Write_Eol;
+ List_Entities (Cunit_Entity (U));
- -- List representation information to file
+ -- List representation information to file
- else
- Creat_Repinfo_File_Access.all (File_Name (Source_Index (U)));
- Set_Special_Output (Write_Info_Line'Access);
- List_Entities (Cunit_Entity (U));
- Set_Special_Output (null);
- Close_Repinfo_File_Access.all;
+ else
+ Creat_Repinfo_File_Access.all (File_Name (Source_Index (U)));
+ Set_Special_Output (Write_Info_Line'Access);
+ List_Entities (Cunit_Entity (U));
+ Set_Special_Output (null);
+ Close_Repinfo_File_Access.all;
+ end if;
end if;
- end if;
- end loop;
+ end loop;
+ end if;
end List_Rep_Info;
- ---------------------
- -- Write_Info_Line --
- ---------------------
-
- procedure Write_Info_Line (S : String) is
- begin
- Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1));
- end Write_Info_Line;
-
--------------------
-- List_Type_Info --
--------------------
procedure List_Type_Info (Ent : Entity_Id) is
begin
- Write_Eol;
+ Blank_Line;
-- Do not list size info for unconstrained arrays, not meaningful
@@ -1070,6 +1296,60 @@ package body Repinfo is
Rep_Table.Tree_Write;
end Tree_Write;
+ ---------------------
+ -- Write_Info_Line --
+ ---------------------
+
+ procedure Write_Info_Line (S : String) is
+ begin
+ Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1));
+ end Write_Info_Line;
+
+ ---------------------
+ -- Write_Mechanism --
+ ---------------------
+
+ procedure Write_Mechanism (M : Mechanism_Type) is
+ begin
+ case M is
+ when 0 =>
+ Write_Str ("default");
+
+ when -1 =>
+ Write_Str ("copy");
+
+ when -2 =>
+ Write_Str ("reference");
+
+ when -3 =>
+ Write_Str ("descriptor");
+
+ when -4 =>
+ Write_Str ("descriptor (UBS)");
+
+ when -5 =>
+ Write_Str ("descriptor (UBSB)");
+
+ when -6 =>
+ Write_Str ("descriptor (UBA)");
+
+ when -7 =>
+ Write_Str ("descriptor (S)");
+
+ when -8 =>
+ Write_Str ("descriptor (SB)");
+
+ when -9 =>
+ Write_Str ("descriptor (A)");
+
+ when -10 =>
+ Write_Str ("descriptor (NCA)");
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end Write_Mechanism;
+
---------------
-- Write_Val --
---------------
diff --git a/gcc/ada/repinfo.h b/gcc/ada/repinfo.h
index aa885fd20d8..b8a0cc98f75 100644
--- a/gcc/ada/repinfo.h
+++ b/gcc/ada/repinfo.h
@@ -6,8 +6,7 @@
* *
* C Header File *
* *
- * *
- * Copyright (C) 1999-2001 Free Software Foundation, Inc. *
+ * Copyright (C) 1999-2002 Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -74,5 +73,5 @@ typedef char TCode;
that this call can be used to create a discriminant reference by
using (Expr => Discrim_Val, Op1 => discriminant_number). */
#define Create_Node repinfo__create_node
-extern Node_Ref Create_Node PARAMS((TCode, Node_Ref_Or_Val,
- Node_Ref_Or_Val, Node_Ref_Or_Val));
+extern Node_Ref Create_Node (TCode, Node_Ref_Or_Val,
+ Node_Ref_Or_Val, Node_Ref_Or_Val);
diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb
index 06f0f9b3d9c..2740fc67d22 100644
--- a/gcc/ada/restrict.adb
+++ b/gcc/ada/restrict.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- --
@@ -27,19 +27,27 @@
with Atree; use Atree;
with Casing; use Casing;
with Errout; use Errout;
-with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Lib; use Lib;
with Namet; use Namet;
-with Opt; use Opt;
-with Stand; use Stand;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
+with Sinput; use Sinput;
with Uname; use Uname;
package body Restrict is
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Restriction_Msg (Msg : String; R : String; N : Node_Id);
+ -- Output error message at node N with given text, replacing the
+ -- '%' in the message with the name of the restriction given as R,
+ -- cased according to the current identifier casing. We do not use
+ -- the normal insertion mechanism, since this requires an entry
+ -- in the Names table, and this table will be locked if we are
+ -- generating a message from gigi.
+
function Suppress_Restriction_Message (N : Node_Id) return Boolean;
-- N is the node for a possible restriction violation message, but
-- the message is to be suppressed if this is an internal file and
@@ -51,10 +59,14 @@ package body Restrict is
function Abort_Allowed return Boolean is
begin
- return
- Restrictions (No_Abort_Statements) = False
- or else
- Restriction_Parameters (Max_Asynchronous_Select_Nesting) /= 0;
+ if Restrictions (No_Abort_Statements)
+ and then Restriction_Parameters (Max_Asynchronous_Select_Nesting) = 0
+ then
+ return False;
+
+ else
+ return True;
+ end if;
end Abort_Allowed;
------------------------------------
@@ -71,11 +83,20 @@ package body Restrict is
and then not Suppress_Restriction_Message (N)
then
Namet.Unlock;
- Check_Restriction (No_Elaboration_Code, N);
+ Check_Restriction (Restriction_Id'(No_Elaboration_Code), N);
Namet.Lock;
end if;
end Check_Elaboration_Code_Allowed;
+ ----------------------------------
+ -- Check_No_Implicit_Heap_Alloc --
+ ----------------------------------
+
+ procedure Check_No_Implicit_Heap_Alloc (N : Node_Id) is
+ begin
+ Check_Restriction (Restriction_Id'(No_Implicit_Heap_Allocations), N);
+ end Check_No_Implicit_Heap_Alloc;
+
---------------------------
-- Check_Restricted_Unit --
---------------------------
@@ -150,73 +171,82 @@ package body Restrict is
-- Case of simple identifier (no parameter)
procedure Check_Restriction (R : Restriction_Id; N : Node_Id) is
+ Rimage : constant String := Restriction_Id'Image (R);
+
begin
Violations (R) := True;
- if Restrictions (R)
+ if (Restrictions (R) or Restriction_Warnings (R))
and then not Suppress_Restriction_Message (N)
then
- declare
- S : constant String := Restriction_Id'Image (R);
+ -- Output proper message. If this is just a case of
+ -- a restriction warning, then we output a warning msg
- begin
- Name_Buffer (1 .. S'Last) := S;
- Name_Len := S'Length;
- Set_Casing (All_Lower_Case);
- Error_Msg_Name_1 := Name_Enter;
+ if not Restrictions (R) then
+ Restriction_Msg
+ ("?violation of restriction %", Rimage, N);
+
+ -- If this is a real restriction violation, then generate
+ -- a non-serious message with appropriate location.
+
+ else
Error_Msg_Sloc := Restrictions_Loc (R);
- Error_Msg_N ("|violation of restriction %#", N);
- end;
+
+ -- If we have a location for the Restrictions pragma, output it
+
+ if Error_Msg_Sloc > No_Location
+ or else Error_Msg_Sloc = System_Location
+ then
+ Restriction_Msg
+ ("|violation of restriction %#", Rimage, N);
+
+ -- Otherwise restriction was implicit (e.g. set by another pragma)
+
+ else
+ Restriction_Msg
+ ("|violation of implicit restriction %", Rimage, N);
+ end if;
+ end if;
end if;
end Check_Restriction;
- -- Case where a parameter is present (but no count)
+ -- Case where a parameter is present, with a count
procedure Check_Restriction
(R : Restriction_Parameter_Id;
+ V : Uint;
N : Node_Id)
is
begin
- if Restriction_Parameters (R) = Uint_0
+ if Restriction_Parameters (R) /= No_Uint
+ and then V > Restriction_Parameters (R)
and then not Suppress_Restriction_Message (N)
then
declare
- Loc : constant Source_Ptr := Sloc (N);
- S : constant String :=
- Restriction_Parameter_Id'Image (R);
-
+ S : constant String := Restriction_Parameter_Id'Image (R);
begin
- Error_Msg_NE
- ("& will be raised at run time?!", N, Standard_Storage_Error);
Name_Buffer (1 .. S'Last) := S;
Name_Len := S'Length;
Set_Casing (All_Lower_Case);
Error_Msg_Name_1 := Name_Enter;
Error_Msg_Sloc := Restriction_Parameters_Loc (R);
- Error_Msg_N ("violation of restriction %?#!", N);
-
- Insert_Action (N,
- Make_Raise_Storage_Error (Loc,
- Reason => SE_Restriction_Violation));
+ Error_Msg_N ("|maximum value exceeded for restriction %#", N);
end;
end if;
end Check_Restriction;
- -- Case where a parameter is present, with a count
+ -- Case where a parameter is present, no count given
procedure Check_Restriction
(R : Restriction_Parameter_Id;
- V : Uint;
N : Node_Id)
is
begin
- if Restriction_Parameters (R) /= No_Uint
- and then V > Restriction_Parameters (R)
+ if Restriction_Parameters (R) = Uint_0
and then not Suppress_Restriction_Message (N)
then
declare
S : constant String := Restriction_Parameter_Id'Image (R);
-
begin
Name_Buffer (1 .. S'Last) := S;
Name_Len := S'Length;
@@ -259,23 +289,6 @@ package body Restrict is
return R;
end Compilation_Unit_Restrictions_Save;
- ----------------------------------
- -- Disallow_In_No_Run_Time_Mode --
- ----------------------------------
-
- procedure Disallow_In_No_Run_Time_Mode (Enode : Node_Id) is
- begin
- if No_Run_Time then
- if High_Integrity_Mode_On_Target then
- Error_Msg_N
- ("|this construct not allowed in high integrity mode", Enode);
- else
- Error_Msg_N
- ("|this construct not allowed in No_Run_Time mode", Enode);
- end if;
- end if;
- end Disallow_In_No_Run_Time_Mode;
-
------------------------
-- Get_Restriction_Id --
------------------------
@@ -369,33 +382,73 @@ package body Restrict is
and then Restriction_Parameters (Max_Select_Alternatives) = 0;
end Restricted_Profile;
- --------------------------
- -- Set_No_Run_Time_Mode --
- --------------------------
+ ---------------------
+ -- Restriction_Msg --
+ ---------------------
+
+ procedure Restriction_Msg (Msg : String; R : String; N : Node_Id) is
+ B : String (1 .. Msg'Length + 2 * R'Length + 1);
+ P : Natural := 1;
- procedure Set_No_Run_Time_Mode is
begin
- No_Run_Time := True;
- Restrictions (No_Exception_Handlers) := True;
- Restrictions (No_Implicit_Dynamic_Code) := True;
- Opt.Global_Discard_Names := True;
- end Set_No_Run_Time_Mode;
+ Name_Buffer (1 .. R'Last) := R;
+ Name_Len := R'Length;
+ Set_Casing (Identifier_Casing (Get_Source_File_Index (Sloc (N))));
+
+ P := 0;
+ for J in Msg'Range loop
+ if Msg (J) = '%' then
+ P := P + 1;
+ B (P) := '`';
+
+ -- Put characters of image in message, quoting upper case letters
+
+ for J in 1 .. Name_Len loop
+ if Name_Buffer (J) in 'A' .. 'Z' then
+ P := P + 1;
+ B (P) := ''';
+ end if;
+
+ P := P + 1;
+ B (P) := Name_Buffer (J);
+ end loop;
+
+ P := P + 1;
+ B (P) := '`';
+
+ else
+ P := P + 1;
+ B (P) := Msg (J);
+ end if;
+ end loop;
+
+ Error_Msg_N (B (1 .. P), N);
+ end Restriction_Msg;
-------------------
-- Set_Ravenscar --
-------------------
- procedure Set_Ravenscar is
+ procedure Set_Ravenscar (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+
begin
- Set_Restricted_Profile;
+ Set_Restricted_Profile (N);
Restrictions (Boolean_Entry_Barriers) := True;
Restrictions (No_Select_Statements) := True;
Restrictions (No_Calendar) := True;
- Restrictions (Static_Storage_Size) := True;
Restrictions (No_Entry_Queue) := True;
Restrictions (No_Relative_Delay) := True;
Restrictions (No_Task_Termination) := True;
Restrictions (No_Implicit_Heap_Allocations) := True;
+
+ Restrictions_Loc (Boolean_Entry_Barriers) := Loc;
+ Restrictions_Loc (No_Select_Statements) := Loc;
+ Restrictions_Loc (No_Calendar) := Loc;
+ Restrictions_Loc (No_Entry_Queue) := Loc;
+ Restrictions_Loc (No_Relative_Delay) := Loc;
+ Restrictions_Loc (No_Task_Termination) := Loc;
+ Restrictions_Loc (No_Implicit_Heap_Allocations) := Loc;
end Set_Ravenscar;
----------------------------
@@ -404,7 +457,9 @@ package body Restrict is
-- This must be coordinated with Restricted_Profile
- procedure Set_Restricted_Profile is
+ procedure Set_Restricted_Profile (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+
begin
Restrictions (No_Abort_Statements) := True;
Restrictions (No_Asynchronous_Control) := True;
@@ -419,9 +474,22 @@ package body Restrict is
Restrictions (No_Requeue) := True;
Restrictions (No_Task_Attributes) := True;
- Restriction_Parameters (Max_Asynchronous_Select_Nesting) := Uint_0;
- Restriction_Parameters (Max_Task_Entries) := Uint_0;
- Restriction_Parameters (Max_Select_Alternatives) := Uint_0;
+ Restrictions_Loc (No_Abort_Statements) := Loc;
+ Restrictions_Loc (No_Asynchronous_Control) := Loc;
+ Restrictions_Loc (No_Entry_Queue) := Loc;
+ Restrictions_Loc (No_Task_Hierarchy) := Loc;
+ Restrictions_Loc (No_Task_Allocators) := Loc;
+ Restrictions_Loc (No_Dynamic_Priorities) := Loc;
+ Restrictions_Loc (No_Terminate_Alternatives) := Loc;
+ Restrictions_Loc (No_Dynamic_Interrupts) := Loc;
+ Restrictions_Loc (No_Protected_Type_Allocators) := Loc;
+ Restrictions_Loc (No_Local_Protected_Objects) := Loc;
+ Restrictions_Loc (No_Requeue) := Loc;
+ Restrictions_Loc (No_Task_Attributes) := Loc;
+
+ Restriction_Parameters (Max_Asynchronous_Select_Nesting) := Uint_0;
+ Restriction_Parameters (Max_Task_Entries) := Uint_0;
+ Restriction_Parameters (Max_Select_Alternatives) := Uint_0;
if Restriction_Parameters (Max_Protected_Entries) /= Uint_0 then
Restriction_Parameters (Max_Protected_Entries) := Uint_1;
@@ -457,7 +525,8 @@ package body Restrict is
function Tasking_Allowed return Boolean is
begin
- return Restriction_Parameters (Max_Tasks) /= 0;
+ return Restriction_Parameters (Max_Tasks) /= 0
+ and then not Restrictions (No_Tasking);
end Tasking_Allowed;
end Restrict;
diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads
index 6cbdb17790d..0c1f7b8eae4 100644
--- a/gcc/ada/restrict.ads
+++ b/gcc/ada/restrict.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -36,8 +36,8 @@ package Restrict is
-- The type Restriction_Id defines the set of restriction identifiers,
-- which take no parameter (i.e. they are either present or not present).
-- The actual definition is in the separate package Rident, so that
- -- it can easily be accessed by the binder without dragging in lots of
- -- stuff.
+ -- it can easily be accessed by the binder without dragging in lots
+ -- of stuff.
subtype All_Restrictions is
Restriction_Id range
@@ -59,9 +59,8 @@ package Restrict is
type Restriction_Parameter_Id is new Rident.Restriction_Parameter_Id;
-- The type Restriction_Parameter_Id records cases where a parameter is
- -- present in the corresponding pragma. These cases are not checked for
- -- consistency by the binder. The actual definition is in the separate
- -- package Rident for consistency.
+ -- present in the corresponding pragma. The actual definition is in the
+ -- separate package Rident for consistency.
type Restrictions_Flags is array (Restriction_Id) of Boolean;
-- Type used for arrays indexed by Restriction_Id.
@@ -78,9 +77,13 @@ package Restrict is
-- legitimate direct use of this array is when the code is modified
-- as a result of the restriction in some way.
- Restrictions_Loc : array (Restriction_Id) of Source_Ptr;
+ Restrictions_Loc : array (Restriction_Id) of Source_Ptr :=
+ (others => No_Location);
-- Locations of Restrictions pragmas for error message purposes.
- -- Valid only if corresponding entry in Restrictions is set.
+ -- Valid only if corresponding entry in Restrictions is set. A value
+ -- of No_Location is used for implicit restrictions set by another
+ -- pragma, and a value of System_Location is used for restrictions
+ -- set from package Standard by the processing in Targparm.
Main_Restrictions : Restrictions_Flags := (others => False);
-- This variable saves the cumulative restrictions in effect compiling
@@ -95,6 +98,11 @@ package Restrict is
-- Corresponding entry is False if the restriction has not been
-- violated in the current main unit, and True if it has been violated.
+ Restriction_Warnings : Restrictions_Flags := (others => False);
+ -- If one of these flags is set, then it means that violation of the
+ -- corresponding restriction results only in a warning message, not
+ -- in an error message, and the restriction is not otherwise enforced.
+
Restriction_Parameters :
array (Restriction_Parameter_Id) of Uint := (others => No_Uint);
-- This array indicates the setting of restriction parameter identifier
@@ -123,6 +131,7 @@ package Restrict is
(No_Delay, "a-calend"),
(No_Delay, "calendar"),
(No_Dynamic_Priorities, "a-dynpri"),
+ (No_Finalization, "a-finali"),
(No_IO, "a-direio"),
(No_IO, "directio"),
(No_IO, "a-sequio"),
@@ -157,6 +166,7 @@ package Restrict is
No_Entry_Calls_In_Elaboration_Code => True,
No_Entry_Queue => True,
No_Exception_Handlers => True,
+ No_Exception_Registration => True,
No_Implicit_Conditionals => True,
No_Implicit_Dynamic_Code => True,
No_Implicit_Loops => True,
@@ -170,7 +180,6 @@ package Restrict is
No_Streams => True,
No_Task_Attributes => True,
No_Task_Termination => True,
- No_Tasking => True,
No_Wide_Characters => True,
Static_Priorities => True,
Static_Storage_Size => True,
@@ -183,6 +192,12 @@ package Restrict is
-- Subprograms --
-----------------
+ function Abort_Allowed return Boolean;
+ pragma Inline (Abort_Allowed);
+ -- Tests to see if abort is allowed by the current restrictions settings.
+ -- For abort to be allowed, either No_Abort_Statements must be False,
+ -- or Max_Asynchronous_Select_Nesting must be non-zero.
+
procedure Check_Restricted_Unit (U : Unit_Name_Type; N : Node_Id);
-- Checks if loading of unit U is prohibited by the setting of some
-- restriction (e.g. No_IO restricts the loading of unit Ada.Text_IO).
@@ -198,19 +213,23 @@ package Restrict is
procedure Check_Restriction
(R : Restriction_Parameter_Id;
- N : Node_Id);
- -- Checks that the given restriction parameter identifier is not set to
- -- zero. If it is set to zero, then the node N is replaced by a node
- -- that raises Storage_Error, and a warning is issued.
-
- procedure Check_Restriction
- (R : Restriction_Parameter_Id;
V : Uint;
N : Node_Id);
-- Checks that the count in V does not exceed the maximum value of the
-- restriction parameter value corresponding to the given restriction
-- parameter identifier (if it has been set). If the count in V exceeds
- -- the maximum, then post an error message on node N.
+ -- the maximum, then post an error message on node N. We use this call
+ -- when we can tell the maximum usage at compile time. In other words,
+ -- we guarantee that if a call is made to this routine, then the front
+ -- end will make all necessary calls for the restriction parameter R
+ -- to ensure that we really know the maximum value used anywhere.
+
+ procedure Check_Restriction (R : Restriction_Parameter_Id; N : Node_Id);
+ -- Check that the maximum value of the restriction parameter corresponding
+ -- to the given restriction parameter identifier is not set to zero. If
+ -- it has been set to zero, post an error message on node N. We use this
+ -- call in cases where we can tell at compile time that the count must be
+ -- at least one, but we can't tell anything more.
procedure Check_Elaboration_Code_Allowed (N : Node_Id);
-- Tests to see if elaboration code is allowed by the current restrictions
@@ -218,10 +237,9 @@ package Restrict is
-- an elaboration routine. If elaboration code is not allowed, an error
-- message is posted on the node given as argument.
- function No_Exception_Handlers_Set return Boolean;
- -- Test to see if current restrictions settings specify that no exception
- -- handlers are present. This function is called by Gigi when it needs to
- -- expand an AT END clean up identifier with no exception handler.
+ procedure Check_No_Implicit_Heap_Alloc (N : Node_Id);
+ -- Equivalent to Check_Restriction (No_Implicit_Heap_Allocations, N).
+ -- Provided for easy use by back end, which has to check this restriction.
function Compilation_Unit_Restrictions_Save
return Save_Compilation_Unit_Restrictions;
@@ -239,13 +257,6 @@ package Restrict is
-- This is the corresponding restore procedure to restore restrictions
-- previously saved by Compilation_Unit_Restrictions_Save.
- procedure Disallow_In_No_Run_Time_Mode (Enode : Node_Id);
- -- If in No_Run_Time mode, then the construct represented by Enode is
- -- not permitted, and will be appropriately flagged.
-
- procedure Set_No_Run_Time_Mode;
- -- Set the no run time mode, and associated restriction pragmas.
-
function Get_Restriction_Id
(N : Name_Id)
return Restriction_Id;
@@ -261,21 +272,24 @@ package Restrict is
-- Restriction_Parameter_Id value, otherwise returns
-- Not_A_Restriction_Parameter_Id.
- function Abort_Allowed return Boolean;
- pragma Inline (Abort_Allowed);
- -- Tests to see if abort is allowed by the current restrictions settings.
- -- For abort to be allowed, either No_Abort_Statements must be False,
- -- or Max_Asynchronous_Select_Nesting must be non-zero.
+ function No_Exception_Handlers_Set return Boolean;
+ -- Test to see if current restrictions settings specify that no exception
+ -- handlers are present. This function is called by Gigi when it needs to
+ -- expand an AT END clean up identifier with no exception handler.
function Restricted_Profile return Boolean;
-- Tests to see if tasking operations follow the GNAT restricted run time
-- profile.
- procedure Set_Ravenscar;
- -- Sets the set of rerstrictions fro Ravenscar
+ procedure Set_Ravenscar (N : Node_Id);
+ -- Enables the set of restrictions for Ravenscar. N is the corresponding
+ -- pragma node, which is used for error messages on any constructs that
+ -- violate the profile.
- procedure Set_Restricted_Profile;
- -- Sets the set of restrictions for pragma Restricted_Run_Time
+ procedure Set_Restricted_Profile (N : Node_Id);
+ -- Enables the set of restrictions for pragma Restricted_Run_Time. N is
+ -- the corresponding pragma node, which is used for error messages on
+ -- constructs that violate the profile.
function Tasking_Allowed return Boolean;
pragma Inline (Tasking_Allowed);
diff --git a/gcc/ada/rident.ads b/gcc/ada/rident.ads
index c82c0fb8d4b..1ee636e8453 100644
--- a/gcc/ada/rident.ads
+++ b/gcc/ada/rident.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -24,121 +24,21 @@
-- --
------------------------------------------------------------------------------
--- This package defines the set of restriction identifiers. It is in a
--- separate package from Restrict so that it can be easily used by the
--- binder without dragging in a lot of stuff.
+-- This package defines the set of restriction identifiers for use by the
+-- compiler and binder. It is in a separate package from Restrict so that
+-- it can be used by the binder without dragging in unneeded compiler
+-- packages.
-package Rident is
+-- Note: the actual definitions of the types are in package System.Rident,
+-- and this package is merely an instantiation of that package. The point
+-- of this level of generic indirection is to allow the compile time use
+-- to have the image tables available (this package is not compiled with
+-- Discard_Names), while at run-time we do not want those image tables.
- -- The following enumeration type defines the set of restriction
- -- identifiers not taking a parameter that are implemented in GNAT.
- -- To add a new restriction identifier, add an entry with the name
- -- to be used in the pragma, and add appropriate calls to the
- -- Restrict.Check_Restriction routine.
+-- Rather than have clients instantiate System.Rident directly, we have the
+-- single instantiation here at the library level, which means that we only
+-- have one copy of the image tables
- type Restriction_Id is (
+with System.Rident;
- -- The following cases are checked for consistency in the binder
-
- Boolean_Entry_Barriers, -- GNAT (Ravenscar)
- No_Abort_Statements, -- (RM D.7(5), H.4(3))
- No_Access_Subprograms, -- (RM H.4(17))
- No_Allocators, -- (RM H.4(7))
- No_Asynchronous_Control, -- (RM D.7(10))
- No_Calendar, -- GNAT
- No_Delay, -- (RM H.4(21))
- No_Dispatch, -- (RM H.4(19))
- No_Dynamic_Interrupts, -- GNAT
- No_Dynamic_Priorities, -- (RM D.9(9))
- No_Enumeration_Maps, -- GNAT
- No_Entry_Calls_In_Elaboration_Code, -- GNAT
- No_Entry_Queue, -- GNAT
- No_Exception_Handlers, -- GNAT
- No_Exceptions, -- (RM H.4(12))
- No_Fixed_Point, -- (RM H.4(15))
- No_Floating_Point, -- (RM H.4(14))
- No_IO, -- (RM H.4(20))
- No_Implicit_Conditionals, -- GNAT
- No_Implicit_Dynamic_Code, -- GNAT
- No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3))
- No_Implicit_Loops, -- GNAT
- No_Local_Allocators, -- (RM H.4(8))
- No_Local_Protected_Objects, -- GNAT
- No_Nested_Finalization, -- (RM D.7(4))
- No_Protected_Type_Allocators, -- GNAT
- No_Protected_Types, -- (RM H.4(5))
- No_Recursion, -- (RM H.4(22))
- No_Reentrancy, -- (RM H.4(23))
- No_Relative_Delay, -- GNAT
- No_Requeue, -- GNAT
- No_Secondary_Stack, -- GNAT
- No_Select_Statements, -- GNAT (Ravenscar)
- No_Standard_Storage_Pools, -- GNAT
- No_Streams, -- GNAT
- No_Task_Allocators, -- (RM D.7(7))
- No_Task_Attributes, -- GNAT
- No_Task_Hierarchy, -- (RM D.7(3), H.4(3))
- No_Task_Termination, -- GNAT
- No_Tasking, -- GNAT
- No_Terminate_Alternatives, -- (RM D.7(6))
- No_Unchecked_Access, -- (RM H.4(18))
- No_Unchecked_Conversion, -- (RM H.4(16))
- No_Unchecked_Deallocation, -- (RM H.4(9))
- No_Wide_Characters, -- GNAT
- Static_Priorities, -- GNAT
- Static_Storage_Size, -- GNAT
-
- -- The following cases do not require partition-wide checks
-
- Immediate_Reclamation, -- (RM H.4(10))
- No_Implementation_Attributes, -- GNAT
- No_Implementation_Pragmas, -- GNAT
- No_Implementation_Restrictions, -- GNAT
- No_Elaboration_Code, -- GNAT
-
- Not_A_Restriction_Id);
-
- subtype All_Restrictions is
- Restriction_Id range Boolean_Entry_Barriers .. No_Elaboration_Code;
- -- All restrictions except Not_A_Restriction_Id
-
- -- The following range of Restriction identifiers is checked for
- -- consistency across a partition. The generated ali file is marked
- -- for each entry to show one of three possibilities:
- --
- -- Corresponding restriction is set (so unit does not violate it)
- -- Corresponding restriction is not violated
- -- Corresponding restriction is violated
-
- subtype Partition_Restrictions is
- Restriction_Id range Boolean_Entry_Barriers .. Static_Storage_Size;
-
- -- The following set of Restriction identifiers is not checked for
- -- consistency across a partition. The generated ali file still
- -- contains indications of the above three possibilities for the
- -- purposes of listing applicable restrictions.
-
- subtype Compilation_Unit_Restrictions is
- Restriction_Id range Immediate_Reclamation .. No_Elaboration_Code;
-
- -- The following enumeration type defines the set of restriction
- -- parameter identifiers taking a parameter that are implemented in
- -- GNAT. To add a new restriction parameter identifier, add an entry
- -- with the name to be used in the pragma, and add appropriate
- -- calls to Restrict.Check_Restriction.
-
- -- Note: the GNAT implementation currently only accomodates restriction
- -- parameter identifiers whose expression value is a non-negative
- -- integer. This is true for all language defined parameters.
-
- type Restriction_Parameter_Id is (
- Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3))
- Max_Entry_Queue_Depth, -- GNAT
- Max_Protected_Entries, -- (RM D.7(14))
- Max_Select_Alternatives, -- (RM D.7(12))
- Max_Storage_At_Blocking, -- (RM D.7(17))
- Max_Task_Entries, -- (RM D.7(13), H.4(3))
- Max_Tasks, -- (RM D.7(19), H.4(3))
- Not_A_Restriction_Parameter_Id);
-
-end Rident;
+package Rident is new System.Rident;
diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb
index b4876838eb1..5759855b9b9 100644
--- a/gcc/ada/rtsfind.adb
+++ b/gcc/ada/rtsfind.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- --
@@ -24,33 +24,41 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Casing; use Casing;
-with Csets; use Csets;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-with Fname; use Fname;
-with Fname.UF; use Fname.UF;
-with Lib; use Lib;
-with Lib.Load; use Lib.Load;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Output; use Output;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Sem; use Sem;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
-with Snames; use Snames;
-with Tbuild; use Tbuild;
-with Uname; use Uname;
+with Atree; use Atree;
+with Casing; use Casing;
+with Csets; use Csets;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Elists; use Elists;
+with Errout; use Errout;
+with Fname; use Fname;
+with Fname.UF; use Fname.UF;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Output; use Output;
+with Opt; use Opt;
+with Sem; use Sem;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Stand; use Stand;
+with Snames; use Snames;
+with Tbuild; use Tbuild;
+with Uname; use Uname;
package body Rtsfind is
+ RTE_Available_Call : Boolean := False;
+ -- Set True during call to RTE from RTE_Available. Tells RTE to set
+ -- RTE_Is_Available to False rather than generating an error message.
+
+ RTE_Is_Available : Boolean;
+ -- Set True by RTE_Available on entry. When RTE_Available_Call is set
+ -- True, set False if RTE would otherwise generate an error message.
+
----------------
-- Unit table --
----------------
@@ -89,38 +97,56 @@ package body Rtsfind is
--------------------------
-- When a unit is implicitly loaded as a result of a call to RTE, it
- -- is necessary to create an implicit with to ensure that the object
- -- is correctly loaded by the binder. Such with statements are only
+ -- is necessary to create an implicit WITH to ensure that the object
+ -- is correctly loaded by the binder. Such WITH statements are only
-- required when the request is from the extended main unit (if a
- -- client needs a with, that will be taken care of when the client
- -- is compiled.
+ -- client needs a WITH, that will be taken care of when the client
+ -- is compiled).
- -- We always attach the with to the main unit. This is not perfectly
+ -- We always attach the WITH to the main unit. This is not perfectly
-- accurate in terms of elaboration requirements, but it is close
-- enough, since the units that are accessed using rtsfind do not
-- have delicate elaboration requirements.
-- The flag Withed in the unit table record is initially set to False.
- -- It is set True if a with has been generated for the main unit for
+ -- It is set True if a WITH has been generated for the main unit for
-- the corresponding unit.
-----------------------
-- Local Subprograms --
-----------------------
- procedure Load_Fail (S : String; U_Id : RTU_Id; Ent_Name : String := "");
- -- Internal procedure called if we can't find the entity or unit.
- -- The parameter is a detailed error message that is to be given.
- -- S is a reason for failing to compile the file. U_Id is the unit
- -- id, and Ent_Name, if non-null, is the associated entity name.
+ procedure Entity_Not_Defined (Id : RE_Id);
+ -- Outputs error messages for an entity that is not defined in the
+ -- run-time library (the form of the error message is tailored for
+ -- no run time/configurable run time mode as required).
+
+ procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id);
+ -- Internal procedure called if we can't sucessfully locate or
+ -- process a run-time unit. The parameters give information about
+ -- the error message to be given. S is a reason for failing to
+ -- compile the file and U_Id is the unit id. RE_Id is the RE_Id
+ -- originally passed to RTE. The message in S is one of the
+ -- following:
+ --
+ -- "not found"
+ -- "had parser errors"
+ -- "had semantic errors"
+ --
+ -- The "not found" case is treated specially in that it is considered
+ -- a normal situation in configurable run-time mode (and the message in
+ -- this case is suppressed unless we are operating in All_Errors_Mode).
function Get_Unit_Name (U_Id : RTU_Id) return Unit_Name_Type;
-- Retrieves the Unit Name given a unit id represented by its
-- enumaration value in RTU_Id.
- procedure Load_RTU (U_Id : RTU_Id; Use_Setting : Boolean := False);
+ procedure Load_RTU
+ (U_Id : RTU_Id;
+ Id : RE_Id := RE_Null;
+ Use_Setting : Boolean := False);
-- Load the unit whose Id is given if not already loaded. The unit is
- -- loaded, analyzed, and added to the with list, and the entry in
+ -- loaded, analyzed, and added to the WITH list, and the entry in
-- RT_Unit_Table is updated to reflect the load. The second parameter
-- indicates the initial setting for the Is_Potentially_Use_Visible
-- flag of the entity for the loaded unit (if it is indeed loaded).
@@ -128,10 +154,26 @@ package body Rtsfind is
-- True indicates that this flag must be set to True. It is needed
-- only in the Text_IO_Kludge procedure, which may materialize an
-- entity of Text_IO (or Wide_Text_IO) that was previously unknown.
+ -- Id is the RE_Id value of the entity which was originally requested.
+ -- Id is used only for error message detail, and if it is RE_Null, then
+ -- the attempt to output the entity name is ignored.
+
+ procedure Output_Entity_Name (Id : RE_Id; Msg : String);
+ -- Output continuation error message giving qualified name of entity
+ -- corresponding to Id, appending the string given by Msg. This call
+ -- is only effective in All_Errors mode.
function RE_Chars (E : RE_Id) return Name_Id;
-- Given a RE_Id value returns the Chars of the corresponding entity.
+ procedure RTE_Error_Msg (Msg : String);
+ -- Generates a message by calling Error_Msg_N specifying Current_Error_Node
+ -- as the node location using the given Msg text. Special processing in the
+ -- case where RTE_Available_Call is set. In this case, no message is output
+ -- and instead RTE_Is_Available is set to False. Note that this can only be
+ -- used if you are sure that the message comes directly or indirectly from
+ -- a call to the RTE function.
+
-------------------
-- Get_Unit_Name --
-------------------
@@ -153,6 +195,9 @@ package body Rtsfind is
elsif U_Id in Ada_Finalization_Child then
Name_Buffer (17) := '.';
+ elsif U_Id in Ada_Interrupts_Child then
+ Name_Buffer (15) := '.';
+
elsif U_Id in Ada_Real_Time_Child then
Name_Buffer (14) := '.';
@@ -310,6 +355,16 @@ package body Rtsfind is
end if;
end Is_RTE;
+ ------------
+ -- Is_RTU --
+ ------------
+
+ function Is_RTU (Ent : Entity_Id; U : RTU_Id) return Boolean is
+ E : constant Entity_Id := RT_Unit_Table (U).Entity;
+ begin
+ return Present (E) and then E = Ent;
+ end Is_RTU;
+
----------------------------
-- Is_Text_IO_Kludge_Unit --
----------------------------
@@ -344,62 +399,82 @@ package body Rtsfind is
Nkind (Sel) = N_Identifier
and then
Chars (Sel) in Text_IO_Package_Name;
-
end Is_Text_IO_Kludge_Unit;
+ ------------------------
+ -- Entity_Not_Defined --
+ ------------------------
+
+ procedure Entity_Not_Defined (Id : RE_Id) is
+ begin
+ if No_Run_Time_Mode then
+ RTE_Error_Msg ("|construct not allowed in no run time mode");
+ elsif Configurable_Run_Time_Mode then
+ RTE_Error_Msg ("|construct not allowed in this configuration>");
+ else
+ RTE_Error_Msg ("run-time configuration error");
+ end if;
+
+ Output_Entity_Name (Id, "not defined");
+ end Entity_Not_Defined;
+
---------------
-- Load_Fail --
---------------
- procedure Load_Fail (S : String; U_Id : RTU_Id; Ent_Name : String := "") is
+ procedure Load_Fail (S : String; U_Id : RTU_Id; Id : RE_Id) is
+ M : String (1 .. 100);
+ P : Natural := 0;
+
begin
- Set_Standard_Error;
+ -- Output header message
- Write_Str ("fatal error: run-time library configuration error");
- Write_Eol;
+ if Configurable_Run_Time_Mode then
+ RTE_Error_Msg ("construct not allowed in configurable run-time mode");
+ else
+ RTE_Error_Msg ("run-time library configuration error");
+ end if;
- if Ent_Name /= "" then
- Write_Str ("cannot locate """);
+ -- Output file name and reason string
- -- Copy name skipping initial RE_ or RO_XX characters
+ if S /= "not found"
+ or else not Configurable_Run_Time_Mode
+ then
+ M (1 .. 6) := "\file ";
+ P := 6;
- if Ent_Name (1 .. 2) = "RE" then
- for J in 4 .. Ent_Name'Length loop
- Name_Buffer (J - 3) := Ent_Name (J);
- end loop;
- else
- for J in 7 .. Ent_Name'Length loop
- Name_Buffer (J - 6) := Ent_Name (J);
- end loop;
- end if;
+ Get_Name_String
+ (Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False));
+ M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len);
+ P := P + Name_Len;
- Name_Len := Ent_Name'Length - 3;
- Set_Casing (Mixed_Case);
- Write_Str (Name_Buffer (1 .. Name_Len));
- Write_Str (""" in file """);
+ M (P + 1) := ' ';
+ P := P + 1;
- else
- Write_Str ("cannot load file """);
+ M (P + 1 .. P + S'Length) := S;
+ P := P + S'Length;
+
+ RTE_Error_Msg (M (1 .. P));
+
+ -- Output entity name
+
+ Output_Entity_Name (Id, "not available");
end if;
- Write_Name
- (Get_File_Name (RT_Unit_Table (U_Id).Uname, Subunit => False));
- Write_Str (""" (");
- Write_Str (S);
- Write_Char (')');
- Write_Eol;
- Set_Standard_Output;
- raise Unrecoverable_Error;
+ raise RE_Not_Available;
end Load_Fail;
--------------
-- Load_RTU --
--------------
- procedure Load_RTU (U_Id : RTU_Id; Use_Setting : Boolean := False) is
- Loaded : Boolean;
+ procedure Load_RTU
+ (U_Id : RTU_Id;
+ Id : RE_Id := RE_Null;
+ Use_Setting : Boolean := False)
+ is
U : RT_Unit_Table_Record renames RT_Unit_Table (U_Id);
- Priv_Par : Elist_Id := New_Elmt_List;
+ Priv_Par : constant Elist_Id := New_Elmt_List;
Lib_Unit : Node_Id;
procedure Save_Private_Visibility;
@@ -469,7 +544,14 @@ package body Rtsfind is
U.Uname := Get_Unit_Name (U_Id);
U.Withed := False;
- Loaded := Is_Loaded (U.Uname);
+
+ declare
+ Loaded : Boolean;
+ pragma Warnings (Off, Loaded);
+
+ begin
+ Loaded := Is_Loaded (U.Uname);
+ end;
-- Now do the load call, note that setting Error_Node to Empty is
-- a signal to Load_Unit that we will regard a failure to find the
@@ -484,22 +566,23 @@ package body Rtsfind is
Error_Node => Empty);
if U.Unum = No_Unit then
- Load_Fail ("unit not found", U_Id);
+ Load_Fail ("not found", U_Id, Id);
elsif Fatal_Error (U.Unum) then
- Load_Fail ("parser errors", U_Id);
+ Load_Fail ("had parser errors", U_Id, Id);
end if;
-- Make sure that the unit is analyzed
declare
- Was_Analyzed : Boolean := Analyzed (Cunit (Current_Sem_Unit));
+ Was_Analyzed : constant Boolean :=
+ Analyzed (Cunit (Current_Sem_Unit));
begin
- -- Pretend that the current unit is analysed, in case it is
- -- System or some such. This allows us to put some declarations,
- -- such as exceptions and packed arrays of Boolean, into System
- -- even though expanding them requires System...
+ -- Pretend that the current unit is analyzed, in case it is System
+ -- or some such. This allows us to put some declarations, such as
+ -- exceptions and packed arrays of Boolean, into System even though
+ -- expanding them requires System...
-- This is a bit odd but works fine. If the RTS unit does not depend
-- in any way on the current unit, then it never gets back into the
@@ -509,7 +592,7 @@ package body Rtsfind is
-- If the RTS Unit *does* depend on the current unit, for instance,
-- when you are compiling System, then you had better have finished
- -- Analyzing the part of System that is depended on before you try
+ -- analyzing the part of System that is depended on before you try
-- to load the RTS Unit. This means having the System ordered in an
-- appropriate manner.
@@ -522,7 +605,7 @@ package body Rtsfind is
Restore_Private_Visibility;
if Fatal_Error (U.Unum) then
- Load_Fail ("semantic errors", U_Id);
+ Load_Fail ("had semantic errors", U_Id, Id);
end if;
end if;
@@ -539,6 +622,60 @@ package body Rtsfind is
end if;
end Load_RTU;
+ -----------------------
+ -- Output_Entity_Name --
+ ------------------------
+
+ procedure Output_Entity_Name (Id : RE_Id; Msg : String) is
+ M : String (1 .. 2048);
+ P : Natural := 0;
+ -- M (1 .. P) is current message to be output
+
+ RE_Image : constant String := RE_Id'Image (Id);
+
+ begin
+ if Id = RE_Null or else not All_Errors_Mode then
+ return;
+ end if;
+
+ M (1 .. 9) := "\entity """;
+ P := 9;
+
+ -- Add unit name to message, excluding %s or %b at end
+
+ Get_Name_String (Get_Unit_Name (RE_Unit_Table (Id)));
+ Name_Len := Name_Len - 2;
+ Set_Casing (Mixed_Case);
+ M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len);
+ P := P + Name_Len;
+
+ -- Add a qualifying period
+
+ M (P + 1) := '.';
+ P := P + 1;
+
+ -- Add entity name and closing quote to message
+
+ Name_Len := RE_Image'Length - 3;
+ Name_Buffer (1 .. Name_Len) := RE_Image (4 .. RE_Image'Length);
+ Set_Casing (Mixed_Case);
+ M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len);
+ P := P + Name_Len;
+ M (P + 1) := '"';
+ P := P + 1;
+
+ -- Add message
+
+ M (P + 1) := ' ';
+ P := P + 1;
+ M (P + 1 .. P + Msg'Length) := Msg;
+ P := P + Msg'Length;
+
+ -- Output message at current error node location
+
+ RTE_Error_Msg (M (1 .. P));
+ end Output_Entity_Name;
+
--------------
-- RE_Chars --
--------------
@@ -579,19 +716,22 @@ package body Rtsfind is
Pkg_Ent : Entity_Id;
Ename : Name_Id;
- Ravenscar : constant Boolean := Restricted_Profile;
-
-- The following flag is used to disable front-end inlining when RTE
-- is invoked. This prevents the analysis of other runtime bodies when
-- a particular spec is loaded through Rtsfind. This is both efficient,
-- and it prevents spurious visibility conflicts between use-visible
-- user entities, and entities in run-time packages.
- -- In No_Run_Time mode, subprograms marked Inlined_Always must be
- -- inlined, so in the case we retain the Front_End_Inlining mode.
+ -- In configurable run-time mode, subprograms marked Inlined_Always must
+ -- be inlined, so in the case we retain the Front_End_Inlining mode.
Save_Front_End_Inlining : Boolean;
+ function Check_CRT (Eid : Entity_Id) return Entity_Id;
+ -- Check entity Eid to ensure that configurable run-time restrictions
+ -- are met. May generate an error message and raise RE_Not_Available
+ -- if the entity E does not exist (i.e. Eid is Empty)
+
procedure Check_RPC;
-- Reject programs that make use of distribution features not supported
-- on the current target. On such targets (VMS, Vxworks, others?) we
@@ -604,7 +744,36 @@ package body Rtsfind is
function Make_Unit_Name (N : Node_Id) return Node_Id;
-- If the unit is a child unit, build fully qualified name for use
- -- in with_clause.
+ -- in With_Clause.
+
+ ---------------
+ -- Check_CRT --
+ ---------------
+
+ function Check_CRT (Eid : Entity_Id) return Entity_Id is
+ begin
+ if No (Eid) then
+ Entity_Not_Defined (E);
+ raise RE_Not_Available;
+
+ -- Entity is available
+
+ else
+ -- If in No_Run_Time mode and entity is not in one of the
+ -- specially permitted units, raise the exception.
+
+ if No_Run_Time_Mode
+ and then not OK_No_Run_Time_Unit (U_Id)
+ then
+ Entity_Not_Defined (E);
+ raise RE_Not_Available;
+ end if;
+
+ -- Otherwise entity is accessible
+
+ return Eid;
+ end if;
+ end Check_CRT;
---------------
-- Check_RPC --
@@ -649,7 +818,8 @@ package body Rtsfind is
if Unum /= No_Unit then
declare
- Decls : List_Id := Declarations (Unit (Cunit (Unum)));
+ Decls : constant List_Id :=
+ Declarations (Unit (Cunit (Unum)));
begin
if Present (Decls)
@@ -722,20 +892,6 @@ package body Rtsfind is
-- Start of processing for RTE
begin
-
- -- Check violation of no run time and ravenscar mode
-
- if No_Run_Time
- and then not OK_To_Use_In_No_Run_Time_Mode (U_Id)
- then
- if not Ravenscar
- or else not OK_To_Use_In_Ravenscar_Mode (U_Id)
- then
- Disallow_In_No_Run_Time_Mode (Current_Error_Node);
- return Empty;
- end if;
- end if;
-
-- Doing a rtsfind in system.ads is special, as we cannot do this
-- when compiling System itself. So if we are compiling system then
-- we should already have acquired and processed the declaration
@@ -751,16 +907,16 @@ package body Rtsfind is
and then Analyzed (Main_Unit_Entity)
and then not Is_Child_Unit (Main_Unit_Entity)
then
- return Find_Local_Entity (E);
+ return Check_CRT (Find_Local_Entity (E));
end if;
Save_Front_End_Inlining := Front_End_Inlining;
- Front_End_Inlining := No_Run_Time;
+ Front_End_Inlining := Configurable_Run_Time_Mode;
-- Load unit if unit not previously loaded
if No (RE_Table (E)) then
- Load_RTU (U_Id);
+ Load_RTU (U_Id, Id => E);
Lib_Unit := Unit (Cunit (U.Unum));
-- In the subprogram case, we are all done, the entity we want
@@ -772,55 +928,54 @@ package body Rtsfind is
if Nkind (Lib_Unit) = N_Subprogram_Declaration then
RE_Table (E) := U.Entity;
- -- Otherwise we must have the package case, and here we have to
- -- search the package entity chain for the entity we want. The
- -- entity we want must be present in this chain, or we have a
- -- misconfigured runtime.
+ -- Otherwise we must have the package case. First check package
+ -- entity itself (e.g. RTE_Name for System.Interrupts.Name)
else
pragma Assert (Nkind (Lib_Unit) = N_Package_Declaration);
Ename := RE_Chars (E);
- Pkg_Ent := First_Entity (U.Entity);
+ -- First we search the package entity chain
- while Present (Pkg_Ent) loop
- if Ename = Chars (Pkg_Ent) then
- RE_Table (E) := Pkg_Ent;
- Check_RPC;
- goto Found;
- end if;
-
- Next_Entity (Pkg_Ent);
- end loop;
+ Pkg_Ent := First_Entity (U.Entity);
+ while Present (Pkg_Ent) loop
+ if Ename = Chars (Pkg_Ent) then
+ RE_Table (E) := Pkg_Ent;
+ Check_RPC;
+ goto Found;
+ end if;
- -- If we didn't find the unit we want, something is wrong
- -- although in no run time mode, we already gave a suitable
- -- message, and so we simply return Empty, and the caller must
- -- be prepared to handle this if the RTE call is otherwise
- -- possible in high integrity mode.
+ Next_Entity (Pkg_Ent);
+ end loop;
- if No_Run_Time
- and then not OK_To_Use_In_No_Run_Time_Mode (U_Id)
- then
- Front_End_Inlining := Save_Front_End_Inlining;
- return Empty;
+ -- If we did not find the entity in the package entity chain,
+ -- then check if the package entity itself matches. Note that
+ -- we do this check after searching the entity chain, since
+ -- the rule is that in case of ambiguity, we prefer the entity
+ -- defined within the package, rather than the package itself.
- else
- Load_Fail ("entity not in package", U_Id, RE_Id'Image (E));
- raise Program_Error;
+ if Ename = Chars (U.Entity) then
+ RE_Table (E) := U.Entity;
end if;
+
+ -- If we didn't find the entity we want, something is wrong.
+ -- We just leave RE_Table (E) set to Empty and the appropriate
+ -- action will be taken by Check_CRT when we exit.
+
end if;
end if;
- -- See if we have to generate a with for this entity. We generate
- -- a with if the current unit is part of the extended main code
- -- unit, and if we have not already added the with. The with is
- -- added to the appropriate unit (the current one).
+ -- See if we have to generate a WITH for this entity. We generate
+ -- a WITH if the current unit is part of the extended main code
+ -- unit, and if we have not already added the with. The WITH is
+ -- added to the appropriate unit (the current one). We do not need
+ -- to generate a WITH for an
<<Found>>
if (not U.Withed)
and then
In_Extended_Main_Code_Unit (Cunit_Entity (Current_Sem_Unit))
+ and then not RTE_Available_Call
then
U.Withed := True;
@@ -846,9 +1001,62 @@ package body Rtsfind is
end if;
Front_End_Inlining := Save_Front_End_Inlining;
- return RE_Table (E);
+ return Check_CRT (RE_Table (E));
end RTE;
+ -------------------
+ -- RTE_Available --
+ -------------------
+
+ function RTE_Available (E : RE_Id) return Boolean is
+ Dummy : Entity_Id;
+ pragma Warnings (Off, Dummy);
+
+ Result : Boolean;
+
+ Save_RTE_Available_Call : constant Boolean := RTE_Available_Call;
+ Save_RTE_Is_Available : constant Boolean := RTE_Is_Available;
+ -- These are saved recursively because the call to load a unit
+ -- caused by an upper level call may perform a recursive call
+ -- to this routine during analysis of the corresponding unit.
+
+ begin
+ RTE_Available_Call := True;
+ RTE_Is_Available := True;
+ Dummy := RTE (E);
+ Result := RTE_Is_Available;
+ RTE_Available_Call := Save_RTE_Available_Call;
+ RTE_Is_Available := Save_RTE_Is_Available;
+ return Result;
+
+ exception
+ when RE_Not_Available =>
+ RTE_Available_Call := Save_RTE_Available_Call;
+ RTE_Is_Available := Save_RTE_Is_Available;
+ return False;
+ end RTE_Available;
+
+ -------------------
+ -- RTE_Error_Msg --
+ -------------------
+
+ procedure RTE_Error_Msg (Msg : String) is
+ begin
+ if RTE_Available_Call then
+ RTE_Is_Available := False;
+ else
+ Error_Msg_N (Msg, Current_Error_Node);
+
+ -- Bump count of violations if we are in configurable run-time
+ -- mode and this is not a continuation message.
+
+ if Configurable_Run_Time_Mode and then Msg (1) /= '\' then
+ Configurable_Run_Time_Violations :=
+ Configurable_Run_Time_Violations + 1;
+ end if;
+ end if;
+ end RTE_Error_Msg;
+
--------------------
-- Text_IO_Kludge --
--------------------
@@ -858,7 +1066,7 @@ package body Rtsfind is
type Name_Map_Type is array (Text_IO_Package_Name) of RTU_Id;
- Name_Map : Name_Map_Type := Name_Map_Type'(
+ Name_Map : constant Name_Map_Type := Name_Map_Type'(
Name_Decimal_IO => Ada_Text_IO_Decimal_IO,
Name_Enumeration_IO => Ada_Text_IO_Enumeration_IO,
Name_Fixed_IO => Ada_Text_IO_Fixed_IO,
@@ -866,7 +1074,7 @@ package body Rtsfind is
Name_Integer_IO => Ada_Text_IO_Integer_IO,
Name_Modular_IO => Ada_Text_IO_Modular_IO);
- Wide_Name_Map : Name_Map_Type := Name_Map_Type'(
+ Wide_Name_Map : constant Name_Map_Type := Name_Map_Type'(
Name_Decimal_IO => Ada_Wide_Text_IO_Decimal_IO,
Name_Enumeration_IO => Ada_Wide_Text_IO_Enumeration_IO,
Name_Fixed_IO => Ada_Wide_Text_IO_Fixed_IO,
@@ -913,12 +1121,16 @@ package body Rtsfind is
-- we must indicate that they are visible.
if Name_Buffer (1 .. 12) = "a-textio.ads" then
- Load_RTU (Name_Map (Chrs), In_Use (Cunit_Entity (U)));
+ Load_RTU
+ (Name_Map (Chrs),
+ Use_Setting => In_Use (Cunit_Entity (U)));
Set_Is_Visible_Child_Unit
(RT_Unit_Table (Name_Map (Chrs)).Entity);
elsif Name_Buffer (1 .. 12) = "a-witeio.ads" then
- Load_RTU (Wide_Name_Map (Chrs), In_Use (Cunit_Entity (U)));
+ Load_RTU
+ (Wide_Name_Map (Chrs),
+ Use_Setting => In_Use (Cunit_Entity (U)));
Set_Is_Visible_Child_Unit
(RT_Unit_Table (Wide_Name_Map (Chrs)).Entity);
end if;
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index 8e675c55122..000202cb63a 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -50,6 +50,25 @@ package Rtsfind is
-- delays; eventually, packages implementing delays will be found
-- relative to the package that declares the time type.
+ -- Names of the form Ada_Finalization_xxx are second level children
+ -- of Ada.Finalization.
+
+ -- Names of the form Ada_Interrupts_xxx are second level children
+ -- of Ada.Interrupts. This is needed for Ada.Interrupts.Names which
+ -- is used by pragma Interrupt_State.
+
+ -- Names of the form Ada_Real_Time_xxx are second level children
+ -- of Ada.Real_Time.
+
+ -- Names of the form Ada_Streams_xxx are second level children
+ -- of Ada.Streams.
+
+ -- Names of the form Ada_Text_IO_xxx are second level children
+ -- of Ada.Text_IO.
+
+ -- Names of the form Ada_Wide_Text_IO_xxx are second level children
+ -- of Ada.Wide_Text_IO.
+
-- Names of the form Interfaces_xxx are first level children of
-- Interfaces_CPP refers to package Interfaces.CPP
@@ -107,6 +126,10 @@ package Rtsfind is
Ada_Finalization_List_Controller,
+ -- Children of Ada.Interrupts
+
+ Ada_Interrupts_Names,
+
-- Children of Ada.Real_Time
Ada_Real_Time_Delays,
@@ -153,29 +176,26 @@ package Rtsfind is
System_Assertions,
System_Aux_DEC,
System_Bit_Ops,
+ System_Boolean_Array_Operations,
System_Checked_Pools,
+ System_Compare_Array_Signed_16,
+ System_Compare_Array_Signed_32,
+ System_Compare_Array_Signed_64,
+ System_Compare_Array_Signed_8,
+ System_Compare_Array_Unsigned_16,
+ System_Compare_Array_Unsigned_32,
+ System_Compare_Array_Unsigned_64,
+ System_Compare_Array_Unsigned_8,
System_Exception_Table,
System_Exceptions,
- System_Exn_Flt,
System_Exn_Int,
- System_Exn_LFlt,
- System_Exn_LInt,
System_Exn_LLF,
System_Exn_LLI,
- System_Exn_SFlt,
- System_Exn_SInt,
- System_Exn_SSI,
- System_Exp_Flt,
System_Exp_Int,
- System_Exp_LFlt,
System_Exp_LInt,
- System_Exp_LLF,
System_Exp_LLI,
System_Exp_LLU,
System_Exp_Mod,
- System_Exp_SFlt,
- System_Exp_SInt,
- System_Exp_SSI,
System_Exp_Uns,
System_Fat_Flt,
System_Fat_LFlt,
@@ -199,6 +219,7 @@ package Rtsfind is
System_Interrupts,
System_Machine_Code,
System_Mantissa,
+ System_Memcop,
System_Pack_03,
System_Pack_05,
System_Pack_06,
@@ -331,6 +352,10 @@ package Rtsfind is
Ada_Finalization_List_Controller .. Ada_Finalization_List_Controller;
-- Range of values for children of Ada.Finalization
+ subtype Ada_Interrupts_Child is Ada_Child range
+ Ada_Interrupts_Names .. Ada_Interrupts_Names;
+ -- Range of values for children of Ada.Interrupts
+
subtype Ada_Real_Time_Child is Ada_Child
range Ada_Real_Time_Delays .. Ada_Real_Time_Delays;
-- Range of values for children of Ada.Real_Time
@@ -373,40 +398,6 @@ package Rtsfind is
System_Tasking_Async_Delays_Enqueue_RT;
-- Range of values for children of System.Tasking.Async_Delays
- OK_To_Use_In_No_Run_Time_Mode : array (RTU_Id) of Boolean :=
- (Ada_Tags => True,
- Ada_Exceptions => True,
- Interfaces => True,
- System => True,
- System_Fat_Flt => True,
- System_Fat_LFlt => True,
- System_Fat_LLF => True,
- System_Fat_SFlt => True,
- System_Machine_Code => True,
- System_Storage_Elements => True,
- System_Unsigned_Types => True,
- System_Secondary_Stack => True,
- others => False);
- -- This array defines the set of packages that can legitimately be
- -- accessed by Rtsfind in No_Run_Time mode. Any attempt to load
- -- any other package in this mode will result in a message noting
- -- use of a feature not supported in high integrity mode.
-
- OK_To_Use_In_Ravenscar_Mode : array (RTU_Id) of Boolean :=
- (System_Interrupts => True,
- System_Tasking => True,
- System_Tasking_Protected_Objects => True,
- System_Tasking_Restricted_Stages => True,
- System_Tasking_Protected_Objects_Single_Entry => True,
- System_Task_Info => True,
- System_Parameters => True,
- Ada_Real_Time => True,
- Ada_Real_Time_Delays => True,
- others => False);
- -- This array defines the set of packages that can legitimately be
- -- accessed by Rtsfind in Ravenscar mode, in addition to the
- -- No_Run_Time units which are also allowed.
-
--------------------------
-- Runtime Entity Table --
--------------------------
@@ -435,6 +426,7 @@ package Rtsfind is
RE_Null,
+ RE_Exceptions_Available_In_HIE, -- Ada.Exceptions
RE_Code_Loc, -- Ada.Exceptions
RE_Current_Target_Exception, -- Ada.Exceptions (JGNAT use only)
RE_Exception_Id, -- Ada.Exceptions
@@ -455,10 +447,13 @@ package Rtsfind is
RE_Simple_List_Controller, -- Ada.Finalization.List_Controller
RE_List_Controller, -- Ada.Finalization.List_Controller
- RE_Interrupt_Id, -- Ada.Interrupts
+ RE_Interrupt_ID, -- Ada.Interrupts
+
+ RE_Names, -- Ada.Interupts.Names
RE_Root_Stream_Type, -- Ada.Streams
RE_Stream_Element, -- Ada.Streams
+ RE_Stream_Element_Count, -- Ada.Streams
RE_Stream_Element_Offset, -- Ada.Streams
RE_Stream_Element_Array, -- Ada.Streams
@@ -490,6 +485,7 @@ package Rtsfind is
RE_Tag, -- Ada.Tags
RE_Address_Array, -- Ada.Tags
+ RE_Abort_Task, -- Ada.Task_Identification
RE_Current_Task, -- Ada.Task_Identification
RO_AT_Task_ID, -- Ada.Task_Identification
@@ -582,8 +578,35 @@ package Rtsfind is
RE_Bit_Or, -- System.Bit_Ops
RE_Bit_Xor, -- System.Bit_Ops
+ RE_Boolean_Array, -- System_Boolean_Array_Operations,
+ RE_Vector_Not, -- System_Boolean_Array_Operations,
+ RE_Vector_And, -- System_Boolean_Array_Operations,
+ RE_Vector_Or, -- System_Boolean_Array_Operations,
+ RE_Vector_Nand, -- System_Boolean_Array_Operations,
+ RE_Vector_Nor, -- System_Boolean_Array_Operations,
+ RE_Vector_Nxor, -- System_Boolean_Array_Operations,
+ RE_Vector_Xor, -- System_Boolean_Array_Operations,
+
RE_Checked_Pool, -- System.Checked_Pools
+ RE_Compare_Array_S8, -- System.Compare_Array_Signed_8
+ RE_Compare_Array_S8_Unaligned, -- System.Compare_Array_Signed_8
+
+ RE_Compare_Array_S16, -- System.Compare_Array_Signed_16
+
+ RE_Compare_Array_S32, -- System.Compare_Array_Signed_16
+
+ RE_Compare_Array_S64, -- System.Compare_Array_Signed_16
+
+ RE_Compare_Array_U8, -- System.Compare_Array_Unsigned_8
+ RE_Compare_Array_U8_Unaligned, -- System.Compare_Array_Unsigned_8
+
+ RE_Compare_Array_U16, -- System.Compare_Array_Unsigned_16
+
+ RE_Compare_Array_U32, -- System.Compare_Array_Unsigned_16
+
+ RE_Compare_Array_U64, -- System.Compare_Array_Unsigned_16
+
RE_Register_Exception, -- System.Exception_Table
RE_All_Others_Id, -- System.Exceptions
@@ -600,46 +623,20 @@ package Rtsfind is
RE_Subprogram_Descriptors_Record, -- System.Exceptions
RE_Subprogram_Descriptors_Ptr, -- System.Exceptions
- RE_Exn_Float, -- System.Exn_Flt
-
RE_Exn_Integer, -- System.Exn_Int
- RE_Exn_Long_Float, -- System.Exn_LFlt
-
- RE_Exn_Long_Integer, -- System.Exn_LInt
-
RE_Exn_Long_Long_Float, -- System.Exn_LLF
RE_Exn_Long_Long_Integer, -- System.Exn_LLI
- RE_Exn_Short_Float, -- System.Exn_SFlt
-
- RE_Exn_Short_Integer, -- System.Exn_SInt
-
- RE_Exn_Short_Short_Integer, -- System.Exn_SSI
-
- RE_Exp_Float, -- System.Exp_Flt
-
RE_Exp_Integer, -- System.Exp_Int
- RE_Exp_Long_Float, -- System.Exp_LFlt
-
- RE_Exp_Long_Integer, -- System.Exp_LInt
-
- RE_Exp_Long_Long_Float, -- System.Exp_LLF
-
RE_Exp_Long_Long_Integer, -- System.Exp_LLI
RE_Exp_Long_Long_Unsigned, -- System.Exp_LLU
RE_Exp_Modular, -- System.Exp_Mod
- RE_Exp_Short_Float, -- System.Exp_SFlt
-
- RE_Exp_Short_Integer, -- System.Exp_SInt
-
- RE_Exp_Short_Short_Integer, -- System.Exp_SSI
-
RE_Exp_Unsigned, -- System.Exp_Uns
RE_Fat_Float, -- System.Fat_Flt
@@ -701,6 +698,7 @@ package Rtsfind is
RE_Install_Handlers, -- System.Interrupts
RE_Register_Interrupt_Handler, -- System.Interrupts
RE_Static_Interrupt_Protection, -- System.Interrupts
+ RE_System_Interrupt_Id, -- System.Interrupts
RE_Asm_Insn, -- System.Machine_Code
RE_Asm_Input_Operand, -- System.Machine_Code
@@ -708,6 +706,9 @@ package Rtsfind is
RE_Mantissa_Value, -- System_Mantissa
+ RE_memcpy, -- System_Memcop
+ RE_memmove, -- System_Memcop
+
RE_Bits_03, -- System.Pack_03
RE_Get_03, -- System.Pack_03
RE_Set_03, -- System.Pack_03
@@ -1054,6 +1055,8 @@ package Rtsfind is
RE_To_Address, -- System.Storage_Elements
RE_Root_Storage_Pool, -- System.Storage_Pools
+ RE_Allocate_Any, -- System_Storage_Pools,
+ RE_Deallocate_Any, -- System_Storage_Pools,
RE_Thin_Pointer, -- System.Stream_Attributes
RE_Fat_Pointer, -- System.Stream_Attributes
@@ -1098,11 +1101,12 @@ package Rtsfind is
RE_W_U, -- System.Stream_Attributes
RE_W_WC, -- System.Stream_Attributes
+ RE_Block_Stream_Ops_OK, -- System.Stream_Attributes
+
RE_Str_Concat, -- System.String_Ops
RE_Str_Concat_CC, -- System.String_Ops
RE_Str_Concat_CS, -- System.String_Ops
RE_Str_Concat_SC, -- System.String_Ops
- RE_Str_Equal, -- System.String_Ops
RE_Str_Normalize, -- System.String_Ops
RE_Wide_Str_Normalize, -- System.String_Ops
@@ -1112,9 +1116,7 @@ package Rtsfind is
RE_Str_Concat_5, -- System.String_Ops_Concat_5
- RE_Free_Task_Image, -- System.Task_Info
RE_Task_Info_Type, -- System.Task_Info
- RE_Task_Image_Type, -- System_Task_Info
RE_Unspecified_Task_Info, -- System.Task_Info
RE_Library_Task_Level, -- System.Tasking
@@ -1166,11 +1168,14 @@ package Rtsfind is
RE_Bits_2, -- System.Unsigned_Types
RE_Bits_4, -- System.Unsigned_Types
RE_Float_Unsigned, -- System.Unsigned_Types
+ RE_Long_Unsigned, -- System.Unsigned_Types
RE_Long_Long_Unsigned, -- System.Unsigned_Types
RE_Packed_Byte, -- System.Unsigned_Types
RE_Packed_Bytes1, -- System.Unsigned_Types
RE_Packed_Bytes2, -- System.Unsigned_Types
RE_Packed_Bytes4, -- System.Unsigned_Types
+ RE_Short_Unsigned, -- System.Unsigned_Types
+ RE_Short_Short_Unsigned, -- System.Unsigned_Types
RE_Unsigned, -- System.Unsigned_Types
RE_Value_Boolean, -- System.Val_Bool
@@ -1357,6 +1362,7 @@ package Rtsfind is
RE_Null => RTU_Null,
+ RE_Exceptions_Available_In_HIE => Ada_Exceptions,
RE_Code_Loc => Ada_Exceptions,
RE_Current_Target_Exception => Ada_Exceptions, -- of JGNAT
RE_Exception_Id => Ada_Exceptions,
@@ -1377,10 +1383,13 @@ package Rtsfind is
RE_Simple_List_Controller => Ada_Finalization_List_Controller,
RE_List_Controller => Ada_Finalization_List_Controller,
- RE_Interrupt_Id => Ada_Interrupts,
+ RE_Interrupt_ID => Ada_Interrupts,
+
+ RE_Names => Ada_Interrupts_Names,
RE_Root_Stream_Type => Ada_Streams,
RE_Stream_Element => Ada_Streams,
+ RE_Stream_Element_Count => Ada_Streams,
RE_Stream_Element_Offset => Ada_Streams,
RE_Stream_Element_Array => Ada_Streams,
@@ -1412,6 +1421,7 @@ package Rtsfind is
RE_Tag => Ada_Tags,
RE_Address_Array => Ada_Tags,
+ RE_Abort_Task => Ada_Task_Identification,
RE_Current_Task => Ada_Task_Identification,
RO_AT_Task_ID => Ada_Task_Identification,
@@ -1504,6 +1514,33 @@ package Rtsfind is
RE_Checked_Pool => System_Checked_Pools,
+ RE_Boolean_Array => System_Boolean_Array_Operations,
+ RE_Vector_Not => System_Boolean_Array_Operations,
+ RE_Vector_And => System_Boolean_Array_Operations,
+ RE_Vector_Or => System_Boolean_Array_Operations,
+ RE_Vector_Nand => System_Boolean_Array_Operations,
+ RE_Vector_Nor => System_Boolean_Array_Operations,
+ RE_Vector_Nxor => System_Boolean_Array_Operations,
+ RE_Vector_Xor => System_Boolean_Array_Operations,
+
+ RE_Compare_Array_S8 => System_Compare_Array_Signed_8,
+ RE_Compare_Array_S8_Unaligned => System_Compare_Array_Signed_8,
+
+ RE_Compare_Array_S16 => System_Compare_Array_Signed_16,
+
+ RE_Compare_Array_S32 => System_Compare_Array_Signed_32,
+
+ RE_Compare_Array_S64 => System_Compare_Array_Signed_64,
+
+ RE_Compare_Array_U8 => System_Compare_Array_Unsigned_8,
+ RE_Compare_Array_U8_Unaligned => System_Compare_Array_Unsigned_8,
+
+ RE_Compare_Array_U16 => System_Compare_Array_Unsigned_16,
+
+ RE_Compare_Array_U32 => System_Compare_Array_Unsigned_32,
+
+ RE_Compare_Array_U64 => System_Compare_Array_Unsigned_64,
+
RE_Register_Exception => System_Exception_Table,
RE_All_Others_Id => System_Exceptions,
@@ -1520,46 +1557,20 @@ package Rtsfind is
RE_Subprogram_Descriptors_Record => System_Exceptions,
RE_Subprogram_Descriptors_Ptr => System_Exceptions,
- RE_Exn_Float => System_Exn_Flt,
-
RE_Exn_Integer => System_Exn_Int,
- RE_Exn_Long_Float => System_Exn_LFlt,
-
- RE_Exn_Long_Integer => System_Exn_LInt,
-
RE_Exn_Long_Long_Float => System_Exn_LLF,
RE_Exn_Long_Long_Integer => System_Exn_LLI,
- RE_Exn_Short_Float => System_Exn_SFlt,
-
- RE_Exn_Short_Integer => System_Exn_SInt,
-
- RE_Exn_Short_Short_Integer => System_Exn_SSI,
-
- RE_Exp_Float => System_Exp_Flt,
-
RE_Exp_Integer => System_Exp_Int,
- RE_Exp_Long_Float => System_Exp_LFlt,
-
- RE_Exp_Long_Integer => System_Exp_LInt,
-
- RE_Exp_Long_Long_Float => System_Exp_LLF,
-
RE_Exp_Long_Long_Integer => System_Exp_LLI,
RE_Exp_Long_Long_Unsigned => System_Exp_LLU,
RE_Exp_Modular => System_Exp_Mod,
- RE_Exp_Short_Float => System_Exp_SFlt,
-
- RE_Exp_Short_Integer => System_Exp_SInt,
-
- RE_Exp_Short_Short_Integer => System_Exp_SSI,
-
RE_Exp_Unsigned => System_Exp_Uns,
RE_Fat_Float => System_Fat_Flt,
@@ -1621,6 +1632,7 @@ package Rtsfind is
RE_Install_Handlers => System_Interrupts,
RE_Register_Interrupt_Handler => System_Interrupts,
RE_Static_Interrupt_Protection => System_Interrupts,
+ RE_System_Interrupt_Id => System_Interrupts,
RE_Asm_Insn => System_Machine_Code,
RE_Asm_Input_Operand => System_Machine_Code,
@@ -1628,6 +1640,9 @@ package Rtsfind is
RE_Mantissa_Value => System_Mantissa,
+ RE_memcpy => System_Memcop,
+ RE_memmove => System_Memcop,
+
RE_Bits_03 => System_Pack_03,
RE_Get_03 => System_Pack_03,
RE_Set_03 => System_Pack_03,
@@ -1974,6 +1989,8 @@ package Rtsfind is
RE_To_Address => System_Storage_Elements,
RE_Root_Storage_Pool => System_Storage_Pools,
+ RE_Allocate_Any => System_Storage_Pools,
+ RE_Deallocate_Any => System_Storage_Pools,
RE_Thin_Pointer => System_Stream_Attributes,
RE_Fat_Pointer => System_Stream_Attributes,
@@ -2018,8 +2035,9 @@ package Rtsfind is
RE_W_U => System_Stream_Attributes,
RE_W_WC => System_Stream_Attributes,
+ RE_Block_Stream_Ops_OK => System_Stream_Attributes,
+
RE_Str_Concat => System_String_Ops,
- RE_Str_Equal => System_String_Ops,
RE_Str_Normalize => System_String_Ops,
RE_Wide_Str_Normalize => System_String_Ops,
RE_Str_Concat_CC => System_String_Ops,
@@ -2032,9 +2050,7 @@ package Rtsfind is
RE_Str_Concat_5 => System_String_Ops_Concat_5,
- RE_Free_Task_Image => System_Task_Info,
RE_Task_Info_Type => System_Task_Info,
- RE_Task_Image_Type => System_Task_Info,
RE_Unspecified_Task_Info => System_Task_Info,
RE_Library_Task_Level => System_Tasking,
@@ -2086,11 +2102,14 @@ package Rtsfind is
RE_Bits_2 => System_Unsigned_Types,
RE_Bits_4 => System_Unsigned_Types,
RE_Float_Unsigned => System_Unsigned_Types,
+ RE_Long_Unsigned => System_Unsigned_Types,
RE_Long_Long_Unsigned => System_Unsigned_Types,
RE_Packed_Byte => System_Unsigned_Types,
RE_Packed_Bytes1 => System_Unsigned_Types,
RE_Packed_Bytes2 => System_Unsigned_Types,
RE_Packed_Bytes4 => System_Unsigned_Types,
+ RE_Short_Unsigned => System_Unsigned_Types,
+ RE_Short_Short_Unsigned => System_Unsigned_Types,
RE_Unsigned => System_Unsigned_Types,
RE_Value_Boolean => System_Val_Bool,
@@ -2303,6 +2322,63 @@ package Rtsfind is
RE_Expunge_Unactivated_Tasks => System_Tasking_Stages,
RE_Terminated => System_Tasking_Stages);
+ --------------------------------
+ -- Configurable Run-Time Mode --
+ --------------------------------
+
+ -- Part of the job of Rtsfind is to enforce run-time restrictions in
+ -- configurable run-time mode. This is done by monitoring implicit access
+ -- to the run time library requested by calls to the RTE function. A call
+ -- may be invalid in configurable run-time mode for either of the
+ -- following two reasons:
+
+ -- 1. File in which entity lives is not present in run-time library
+ -- 2. File is present, but entity is not defined in the file
+
+ -- In normal mode, either or these two situations is a fatal error
+ -- that indicates that the run-time library is incorrectly configured,
+ -- and a fatal error message is issued to signal this error.
+
+ -- In configurable run-time mode, either of these two situations indicates
+ -- simply that the corresponding operation is not available in the current
+ -- run-time that is use. This is not a configuration error, but rather a
+ -- natural result of a limited run-time. This situation is signalled by
+ -- raising the exception RE_Not_Available. The caller must respond to
+ -- this exception by posting an appropriate error message.
+
+ ----------------------
+ -- No_Run_Time_Mode --
+ ----------------------
+
+ -- For backwards compatibility with previous versions of GNAT, the
+ -- compiler recognizes the pragma No_Run_Time. This provides a special
+ -- version of configurable run-time mode that operates with the standard
+ -- run-time library, but allows only a subset of entities to be
+ -- accessed. If any other entity is accessed, then it is treated
+ -- as a configurable run-time violation, and the exception
+ -- RE_Not_Availble is raised.
+
+ -- The following array defines the set of units that contain entities
+ -- that can be referenced in No_Run_Time mode. For each of these units,
+ -- all entities defined in the unit can be used in this mode.
+
+ OK_No_Run_Time_Unit : constant array (RTU_Id) of Boolean :=
+ (Ada_Exceptions => True,
+ Ada_Tags => True,
+ Interfaces => True,
+ System => True,
+ System_Parameters => True,
+ System_Fat_Flt => True,
+ System_Fat_LFlt => True,
+ System_Fat_LLF => True,
+ System_Fat_SFlt => True,
+ System_Machine_Code => True,
+ System_Secondary_Stack => True,
+ System_Storage_Elements => True,
+ System_Task_Info => True,
+ System_Unsigned_Types => True,
+ others => False);
+
-----------------
-- Subprograms --
-----------------
@@ -2313,20 +2389,33 @@ package Rtsfind is
-- Initialize_Snames (since names it enters into name table must come
-- after names entered by Snames).
+ RE_Not_Available : exception;
+ -- Raised by RTE if the requested entity is not available. This can
+ -- occur either because the file in which the entity should be found
+ -- does not exist, or because the entity is not present in the file.
+
function RTE (E : RE_Id) return Entity_Id;
-- Given the entity defined in the above tables, as identified by the
-- corresponding value in the RE_Id enumeration type, returns the Id
-- of the corresponding entity, first loading in (parsing, analyzing and
- -- expanding) its spec if the unit has not already been loaded. If the
- -- unit cannot be found, or if it does not contain the specified entity,
- -- then an appropriate error message is output ("run-time configuration
- -- error") and an Unrecoverable_Error exception is raised. There is one
- -- situation in which RTE can generate an error message, and that is if
- -- an unuathorized entity is accessed in high integrity mode. If this
- -- occurs, the result returned may be Empty, and the caller must deal
- -- with this possibility if the call to RTE may occur in high integrity
- -- mode (often this will have been ruled out by specific checks for
- -- high integrity mode prior to the RTE call).
+ -- expanding) its spec if the unit has not already been loaded.
+ --
+ -- Note: In the case of a package, RTE can return either an entity that
+ -- is declared at the top level of the package, or the package entity
+ -- itself. If an entity within the package has the same simple name as
+ -- the package, then the entity within the package is returned rather
+ --
+ -- If RTE returns, the returned value is the required entity
+ --
+ -- If the entity is not available, then an error message is given The
+ -- form of the message depends on whether we are in configurable run time
+ -- mode or not. In configurable run time mode, a missing entity is not
+ -- that surprising and merely says that the particular construct is not
+ -- supported by the run-time in use. If we are not in configurable run
+ -- time mode, a missing entity is some kind of run-time configuration
+ -- error. In either case, the result of the call is to raise the exception
+ -- RE_Not_Available, which should terminate the expansion of the current
+ -- construct.
function Is_RTE (Ent : Entity_Id; E : RE_Id) return Boolean;
-- This function determines if the given entity corresponds to the entity
@@ -2336,6 +2425,19 @@ package Rtsfind is
-- immediately, since obviously Ent cannot be the entity in question if the
-- corresponding unit has not been loaded.
+ function Is_RTU (Ent : Entity_Id; U : RTU_Id) return Boolean;
+ pragma Inline (Is_RTU);
+ -- This function determines if the given entity corresponds to the entity
+ -- for the unit referenced by U. If this unit has not been loaded, the
+ -- answer will always be False. If the unit has been loaded, then the
+ -- entity id values are compared and True is returned if Ent is the
+ -- entity for this unit.
+
+ function RTE_Available (E : RE_Id) return Boolean;
+ -- Returns true if a call to RTE will succeed without raising an
+ -- exception and without generating an error message, i.e. if the
+ -- call will obtain the desired entity without any problems.
+
procedure Text_IO_Kludge (Nam : Node_Id);
-- In Ada 83, and hence for compatibility in Ada 9X, package Text_IO has
-- generic subpackages (e.g. Integer_IO). They really should be child
diff --git a/gcc/ada/s-addima.ads b/gcc/ada/s-addima.ads
index ccc299104bb..d346d28278c 100644
--- a/gcc/ada/s-addima.ads
+++ b/gcc/ada/s-addima.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 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,6 +35,9 @@
-- procedure that gives an (implementation dependent) string which
-- identifies an address.
+-- This unit may be used directly from an application program by providing
+-- an appropriate WITH, and the interface can be expected to remain stable.
+
function System.Address_Image (A : Address) return String;
pragma Pure (System.Address_Image);
-- Returns string (hexadecimal digits with upper case letters) representing
diff --git a/gcc/ada/s-arit64.adb b/gcc/ada/s-arit64.adb
index 6d2790f1959..6efaa12a9d7 100644
--- a/gcc/ada/s-arit64.adb
+++ b/gcc/ada/s-arit64.adb
@@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
-with GNAT.Exceptions; use GNAT.Exceptions;
+with System.Pure_Exceptions; use System.Pure_Exceptions;
with Interfaces; use Interfaces;
with Unchecked_Conversion;
diff --git a/gcc/ada/s-assert.adb b/gcc/ada/s-assert.adb
index 09afe0d5e3c..e5651f11120 100644
--- a/gcc/ada/s-assert.adb
+++ b/gcc/ada/s-assert.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1997 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- --
diff --git a/gcc/ada/s-assert.ads b/gcc/ada/s-assert.ads
index e51663c79cb..b9b5ecf00be 100644
--- a/gcc/ada/s-assert.ads
+++ b/gcc/ada/s-assert.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1998 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- --
@@ -31,6 +31,11 @@
-- --
------------------------------------------------------------------------------
+-- This package provides support for the GNAT assert pragma
+
+-- This unit may be used directly from an application program by providing
+-- an appropriate WITH, and the interface can be expected to remain stable.
+
package System.Assertions is
Assert_Failure : exception;
diff --git a/gcc/ada/s-atacco.adb b/gcc/ada/s-atacco.adb
index a249901613c..1be1f2a83ab 100644
--- a/gcc/ada/s-atacco.adb
+++ b/gcc/ada/s-atacco.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -31,31 +31,10 @@
-- --
------------------------------------------------------------------------------
-with Unchecked_Conversion;
package body System.Address_To_Access_Conversions is
-
- ----------------
- -- To_Address --
- ----------------
-
- function To_Address (Value : Object_Pointer) return Address is
+ -- This body is now superfluous and should be removed.
+ procedure Nothing is
begin
- if Value = null then
- return Null_Address;
- else
- return Value.all'Address;
- end if;
- end To_Address;
-
- ----------------
- -- To_Pointer --
- ----------------
-
- function To_Pointer (Value : Address) return Object_Pointer is
- function A_To_P is new Unchecked_Conversion (Address, Object_Pointer);
-
- begin
- return A_To_P (Value);
- end To_Pointer;
-
+ null;
+ end Nothing;
end System.Address_To_Access_Conversions;
diff --git a/gcc/ada/s-atacco.ads b/gcc/ada/s-atacco.ads
index 815a731245e..51139f567e6 100644
--- a/gcc/ada/s-atacco.ads
+++ b/gcc/ada/s-atacco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -41,17 +41,22 @@ generic
package System.Address_To_Access_Conversions is
pragma Preelaborate (Address_To_Access_Conversions);
+ pragma Compile_Time_Warning
+ (Object'Unconstrained_Array,
+ "Object is unconstrained array type" & ASCII.LF &
+ "To_Pointer results may not have bounds");
+
+ xyz : Boolean := Object'Constrained;
+
type Object_Pointer is access all Object;
for Object_Pointer'Size use Standard'Address_Size;
function To_Pointer (Value : Address) return Object_Pointer;
function To_Address (Value : Object_Pointer) return Address;
- pragma Convention (Intrinsic, To_Pointer);
- pragma Convention (Intrinsic, To_Address);
+ pragma Import (Intrinsic, To_Pointer);
+ pragma Import (Intrinsic, To_Address);
private
- pragma Inline_Always (To_Pointer);
- pragma Inline_Always (To_Address);
-
+ procedure Nothing; -- For now, until body is removed ???
end System.Address_To_Access_Conversions;
diff --git a/gcc/ada/s-auxdec.adb b/gcc/ada/s-auxdec.adb
index d29ff62172b..51d6ac55842 100644
--- a/gcc/ada/s-auxdec.adb
+++ b/gcc/ada/s-auxdec.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -26,7 +26,7 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT was Originally developed by the GNAT team at New YOrk University. --
+-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-auxdec.ads b/gcc/ada/s-auxdec.ads
index 1a602843d1a..c517ae5ee30 100644
--- a/gcc/ada/s-auxdec.ads
+++ b/gcc/ada/s-auxdec.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -433,17 +433,41 @@ private
-- them intrinsic, since the backend can handle them, but the front
-- end is not prepared to deal with them, so at least inline them.
- pragma Inline ("+");
- pragma Inline ("-");
- pragma Inline ("not");
- pragma Inline ("and");
- pragma Inline ("or");
- pragma Inline ("xor");
+ pragma Inline_Always ("+");
+ pragma Inline_Always ("-");
+ pragma Inline_Always ("not");
+ pragma Inline_Always ("and");
+ pragma Inline_Always ("or");
+ pragma Inline_Always ("xor");
-- Other inlined subprograms
- pragma Inline (Fetch_From_Address);
- pragma Inline (Assign_To_Address);
+ pragma Inline_Always (Fetch_From_Address);
+ pragma Inline_Always (Assign_To_Address);
+
+ -- Synchronization related subprograms. These are declared to have
+ -- convention C so that the critical parameters are passed by reference.
+ -- Without this, the parameters are passed by copy, creating load/store
+ -- race conditions. We also inline them, since this seems more in the
+ -- spirit of the original (hardware instrinsic) routines.
+
+ pragma Convention (C, Clear_Interlocked);
+ pragma Inline_Always (Clear_Interlocked);
+
+ pragma Convention (C, Set_Interlocked);
+ pragma Inline_Always (Set_Interlocked);
+
+ pragma Convention (C, Add_Interlocked);
+ pragma Inline_Always (Add_Interlocked);
+
+ pragma Convention (C, Add_Atomic);
+ pragma Inline_Always (Add_Atomic);
+
+ pragma Convention (C, And_Atomic);
+ pragma Inline_Always (And_Atomic);
+
+ pragma Convention (C, Or_Atomic);
+ pragma Inline_Always (Or_Atomic);
-- Provide proper unchecked conversion definitions for transfer
-- functions. Note that we need this level of indirection because
diff --git a/gcc/ada/s-bitops.adb b/gcc/ada/s-bitops.adb
index 2ec4c3e733f..1e0032271ef 100644
--- a/gcc/ada/s-bitops.adb
+++ b/gcc/ada/s-bitops.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,9 +31,10 @@
-- --
------------------------------------------------------------------------------
-with GNAT.Exceptions; use GNAT.Exceptions;
-with System; use System;
-with System.Unsigned_Types; use System.Unsigned_Types;
+with System; use System;
+with System.Pure_Exceptions; use System.Pure_Exceptions;
+with System.Unsigned_Types; use System.Unsigned_Types;
+
with Unchecked_Conversion;
package body System.Bit_Ops is
@@ -66,7 +67,6 @@ package body System.Bit_Ops is
(1 - LE) * 2#1111_1100# + LE * 2#0011_1111#,
(1 - LE) * 2#1111_1110# + LE * 2#0111_1111#);
-
-----------------------
-- Local Subprograms --
-----------------------
diff --git a/gcc/ada/s-boarop.ads b/gcc/ada/s-boarop.ads
new file mode 100644
index 00000000000..db34b66ab27
--- /dev/null
+++ b/gcc/ada/s-boarop.ads
@@ -0,0 +1,65 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . B O O L E A N _ A R R A Y _ O P E R A T I O N S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains functions for runtime operations on boolean arrays
+
+with System.Generic_Vector_Operations;
+with System.Vectors.Boolean_Operations;
+package System.Boolean_Array_Operations is
+pragma Pure (Boolean_Array_Operations);
+ type Boolean_Array is array (Integer range <>) of Boolean;
+
+ package Boolean_Operations renames System.Vectors.Boolean_Operations;
+
+ package Vector_Operations is
+ new Generic_Vector_Operations (Boolean, Integer, Boolean_Array);
+
+ generic procedure Binary_Operation
+ renames Vector_Operations.Binary_Operation;
+
+ generic procedure Unary_Operation
+ renames Vector_Operations.Unary_Operation;
+
+ procedure Vector_Not is
+ new Unary_Operation ("not", Boolean_Operations."not");
+ procedure Vector_And is new Binary_Operation ("and", System.Vectors."and");
+ procedure Vector_Or is new Binary_Operation ("or", System.Vectors."or");
+ procedure Vector_Xor is new Binary_Operation ("xor", System.Vectors."xor");
+
+ procedure Vector_Nand is
+ new Binary_Operation (Boolean_Operations.Nand, Boolean_Operations.Nand);
+ procedure Vector_Nor is
+ new Binary_Operation (Boolean_Operations.Nor, Boolean_Operations.Nor);
+ procedure Vector_Nxor is
+ new Binary_Operation (Boolean_Operations.Nxor, Boolean_Operations.Nxor);
+end System.Boolean_Array_Operations;
diff --git a/gcc/ada/s-carsi8.adb b/gcc/ada/s-carsi8.adb
new file mode 100644
index 00000000000..ebc86e78223
--- /dev/null
+++ b/gcc/ada/s-carsi8.adb
@@ -0,0 +1,141 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 8 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+
+package body System.Compare_Array_Signed_8 is
+
+ type Word is mod 2 ** 32;
+ -- Used to process operands by words
+
+ type Big_Words is array (Natural) of Word;
+ type Big_Words_Ptr is access Big_Words;
+ -- Array type used to access by words
+
+ type Byte is range -128 .. +127;
+ for Byte'Size use 8;
+ -- Used to process operands by bytes
+
+ type Big_Bytes is array (Natural) of Byte;
+ type Big_Bytes_Ptr is access Big_Bytes;
+ -- Array type used to access by bytes
+
+ function To_Big_Words is new
+ Unchecked_Conversion (System.Address, Big_Words_Ptr);
+
+ function To_Big_Bytes is new
+ Unchecked_Conversion (System.Address, Big_Bytes_Ptr);
+
+ ----------------------
+ -- Compare_Array_S8 --
+ ----------------------
+
+ function Compare_Array_S8
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer
+ is
+ Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len);
+
+ begin
+ -- If operands are non-aligned, or length is too short, go by bytes
+
+ if (((Left or Right) and 2#11#) /= 0) or else Compare_Len < 4 then
+ return Compare_Array_S8_Unaligned (Left, Right, Left_Len, Right_Len);
+ end if;
+
+ -- Here we can go by words
+
+ declare
+ LeftP : constant Big_Words_Ptr := To_Big_Words (Left);
+ RightP : constant Big_Words_Ptr := To_Big_Words (Right);
+ Clen4 : constant Natural := Compare_Len / 4 - 1;
+ Clen4F : constant Natural := Clen4 * 4;
+
+ begin
+ for J in 0 .. Clen4 loop
+ if LeftP (J) /= RightP (J) then
+ return Compare_Array_S8_Unaligned
+ (Left + Address (4 * J),
+ Right + Address (4 * J),
+ 4, 4);
+ end if;
+ end loop;
+
+ return Compare_Array_S8_Unaligned
+ (Left + Address (Clen4F),
+ Right + Address (Clen4F),
+ Left_Len - Clen4F,
+ Right_Len - Clen4F);
+ end;
+ end Compare_Array_S8;
+
+ --------------------------------
+ -- Compare_Array_S8_Unaligned --
+ --------------------------------
+
+ function Compare_Array_S8_Unaligned
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer
+ is
+ Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len);
+
+ LeftP : constant Big_Bytes_Ptr := To_Big_Bytes (Left);
+ RightP : constant Big_Bytes_Ptr := To_Big_Bytes (Right);
+
+ begin
+ for J in 0 .. Compare_Len - 1 loop
+ if LeftP (J) /= RightP (J) then
+ if LeftP (J) > RightP (J) then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+ end loop;
+
+ if Left_Len = Right_Len then
+ return 0;
+ elsif Left_Len > Right_Len then
+ return +1;
+ else
+ return -1;
+ end if;
+ end Compare_Array_S8_Unaligned;
+
+end System.Compare_Array_Signed_8;
diff --git a/gcc/ada/s-carsi8.ads b/gcc/ada/s-carsi8.ads
new file mode 100644
index 00000000000..64a52059e15
--- /dev/null
+++ b/gcc/ada/s-carsi8.ads
@@ -0,0 +1,66 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 8 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains functions for runtime comparisons on arrays whose
+-- elements are 8-bit discrete type values to be treated as signed.
+
+package System.Compare_Array_Signed_8 is
+
+ -- Note: although the functions in this package are in a sense Pure, the
+ -- package cannot be declared as Pure, since the arguments are addresses,
+ -- not the data, and the result is not pure wrt the address values.
+
+ function Compare_Array_S8
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer;
+ -- Compare the array starting at address Left of length Left_Len
+ -- with the array starting at address Right of length Right_Len.
+ -- The comparison is in the normal Ada semantic sense of array
+ -- comparison. The result is -1,0,+1 for Left<Right, Left=Right,
+ -- Left>Right respectively. This function works with 4 byte words
+ -- if the operands are aligned on 4-byte boundaries and long enough.
+
+ function Compare_Array_S8_Unaligned
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer;
+ -- Same functionality as Compare_Array_U8 but always proceeds by
+ -- bytes. Used when the caller knows that the operands are unaligned,
+ -- or short enough that it makes no sense to go by words.
+
+end System.Compare_Array_Signed_8;
diff --git a/gcc/ada/s-carun8.adb b/gcc/ada/s-carun8.adb
new file mode 100644
index 00000000000..26a314e2c71
--- /dev/null
+++ b/gcc/ada/s-carun8.adb
@@ -0,0 +1,140 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 8 --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+
+package body System.Compare_Array_Unsigned_8 is
+
+ type Word is mod 2 ** 32;
+ -- Used to process operands by words
+
+ type Big_Words is array (Natural) of Word;
+ type Big_Words_Ptr is access Big_Words;
+ -- Array type used to access by words
+
+ type Byte is mod 2 ** 8;
+ -- Used to process operands by bytes
+
+ type Big_Bytes is array (Natural) of Byte;
+ type Big_Bytes_Ptr is access Big_Bytes;
+ -- Array type used to access by bytes
+
+ function To_Big_Words is new
+ Unchecked_Conversion (System.Address, Big_Words_Ptr);
+
+ function To_Big_Bytes is new
+ Unchecked_Conversion (System.Address, Big_Bytes_Ptr);
+
+ ----------------------
+ -- Compare_Array_U8 --
+ ----------------------
+
+ function Compare_Array_U8
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer
+ is
+ Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len);
+
+ begin
+ -- If operands are non-aligned, or length is too short, go by bytes
+
+ if (((Left or Right) and 2#11#) /= 0) or else Compare_Len < 4 then
+ return Compare_Array_U8_Unaligned (Left, Right, Left_Len, Right_Len);
+ end if;
+
+ -- Here we can go by words
+
+ declare
+ LeftP : constant Big_Words_Ptr := To_Big_Words (Left);
+ RightP : constant Big_Words_Ptr := To_Big_Words (Right);
+ Clen4 : constant Natural := Compare_Len / 4 - 1;
+ Clen4F : constant Natural := Clen4 * 4;
+
+ begin
+ for J in 0 .. Clen4 loop
+ if LeftP (J) /= RightP (J) then
+ return Compare_Array_U8_Unaligned
+ (Left + Address (4 * J),
+ Right + Address (4 * J),
+ 4, 4);
+ end if;
+ end loop;
+
+ return Compare_Array_U8_Unaligned
+ (Left + Address (Clen4F),
+ Right + Address (Clen4F),
+ Left_Len - Clen4F,
+ Right_Len - Clen4F);
+ end;
+ end Compare_Array_U8;
+
+ --------------------------------
+ -- Compare_Array_U8_Unaligned --
+ --------------------------------
+
+ function Compare_Array_U8_Unaligned
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer
+ is
+ Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len);
+
+ LeftP : constant Big_Bytes_Ptr := To_Big_Bytes (Left);
+ RightP : constant Big_Bytes_Ptr := To_Big_Bytes (Right);
+
+ begin
+ for J in 0 .. Compare_Len - 1 loop
+ if LeftP (J) /= RightP (J) then
+ if LeftP (J) > RightP (J) then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+ end loop;
+
+ if Left_Len = Right_Len then
+ return 0;
+ elsif Left_Len > Right_Len then
+ return +1;
+ else
+ return -1;
+ end if;
+ end Compare_Array_U8_Unaligned;
+
+end System.Compare_Array_Unsigned_8;
diff --git a/gcc/ada/s-carun8.ads b/gcc/ada/s-carun8.ads
new file mode 100644
index 00000000000..e6ff79aa95a
--- /dev/null
+++ b/gcc/ada/s-carun8.ads
@@ -0,0 +1,66 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 8 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains functions for runtime comparisons on arrays whose
+-- elements are 8-bit discrete type values to be treated as unsigned.
+
+package System.Compare_Array_Unsigned_8 is
+
+ -- Note: although the functions in this package are in a sense Pure, the
+ -- package cannot be declared as Pure, since the arguments are addresses,
+ -- not the data, and the result is not pure wrt the address values.
+
+ function Compare_Array_U8
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer;
+ -- Compare the array starting at address Left of length Left_Len
+ -- with the array starting at address Right of length Right_Len.
+ -- The comparison is in the normal Ada semantic sense of array
+ -- comparison. The result is -1,0,+1 for Left<Right, Left=Right,
+ -- Left>Right respectively. This function works with 4 byte words
+ -- if the operands are aligned on 4-byte boundaries and long enough.
+
+ function Compare_Array_U8_Unaligned
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer;
+ -- Same functionality as Compare_Array_U8 but always proceeds by
+ -- bytes. Used when the caller knows that the operands are unaligned,
+ -- or short enough that it makes no sense to go by words.
+
+end System.Compare_Array_Unsigned_8;
diff --git a/gcc/ada/s-casi16.adb b/gcc/ada/s-casi16.adb
new file mode 100644
index 00000000000..dc417e3884d
--- /dev/null
+++ b/gcc/ada/s-casi16.adb
@@ -0,0 +1,137 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 16 --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+
+package body System.Compare_Array_Signed_16 is
+
+ type Word is mod 2 ** 32;
+ -- Used to process operands by words
+
+ type Half is range -(2 ** 15) .. (2 ** 15) - 1;
+ for Half'Size use 16;
+ -- Used to process operands by half words
+
+ type Uhalf is record
+ H : Half;
+ end record;
+ pragma Pack (Uhalf);
+ for Uhalf'Alignment use 1;
+ -- Used to process operands when unaligned
+
+ type WP is access Word;
+ type HP is access Half;
+ type UP is access Uhalf;
+
+ function W is new Unchecked_Conversion (Address, WP);
+ function H is new Unchecked_Conversion (Address, HP);
+ function U is new Unchecked_Conversion (Address, UP);
+
+ -----------------------
+ -- Compare_Array_S16 --
+ -----------------------
+
+ function Compare_Array_S16
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer
+ is
+ Clen : Natural := Natural'Min (Left_Len, Right_Len);
+ -- Number of elements left to compare
+
+ L : Address := Left;
+ R : Address := Right;
+ -- Pointers to next elements to compare
+
+ begin
+ -- Go by words if possible
+
+ if ((Left or Right) and (4 - 1)) = 0 then
+ while Clen > 1
+ and then W (L).all = W (R).all
+ loop
+ Clen := Clen - 2;
+ L := L + 4;
+ R := R + 4;
+ end loop;
+ end if;
+
+ -- Case of going by aligned half words
+
+ if ((Left or Right) and (2 - 1)) = 0 then
+ while Clen /= 0 loop
+ if H (L).all /= H (R).all then
+ if H (L).all > H (R).all then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+
+ Clen := Clen - 1;
+ L := L + 2;
+ R := R + 2;
+ end loop;
+
+ -- Case of going by unaligned half words
+
+ else
+ while Clen /= 0 loop
+ if U (L).H /= U (R).H then
+ if U (L).H > U (R).H then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+
+ Clen := Clen - 1;
+ L := L + 2;
+ R := R + 2;
+ end loop;
+ end if;
+
+ -- Here if common section equal, result decided by lengths
+
+ if Left_Len = Right_Len then
+ return 0;
+ elsif Left_Len > Right_Len then
+ return +1;
+ else
+ return -1;
+ end if;
+ end Compare_Array_S16;
+
+end System.Compare_Array_Signed_16;
diff --git a/gcc/ada/s-casi16.ads b/gcc/ada/s-casi16.ads
new file mode 100644
index 00000000000..234b360fae3
--- /dev/null
+++ b/gcc/ada/s-casi16.ads
@@ -0,0 +1,56 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 1 6 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains functions for runtime comparisons on arrays whose
+-- elements are 16-bit discrete type values to be treated as signed.
+
+package System.Compare_Array_Signed_16 is
+
+ -- Note: although the functions in this package are in a sense Pure, the
+ -- package cannot be declared as Pure, since the arguments are addresses,
+ -- not the data, and the result is not pure wrt the address values.
+
+ function Compare_Array_S16
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer;
+ -- Compare the array starting at address Left of length Left_Len
+ -- with the array starting at address Right of length Right_Len.
+ -- The comparison is in the normal Ada semantic sense of array
+ -- comparison. The result is -1,0,+1 for Left<Right, Left=Right,
+ -- Left>Right respectively. This function works with 4 byte words
+ -- if the operands are aligned on 4-byte boundaries and long enough.
+
+end System.Compare_Array_Signed_16;
diff --git a/gcc/ada/s-casi32.adb b/gcc/ada/s-casi32.adb
new file mode 100644
index 00000000000..2f280180ba4
--- /dev/null
+++ b/gcc/ada/s-casi32.adb
@@ -0,0 +1,120 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 3 2 --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+
+package body System.Compare_Array_Signed_32 is
+
+ type Word is range -2**31 .. 2**31 - 1;
+ for Word'Size use 32;
+ -- Used to process operands by words
+
+ type Uword is record
+ W : Word;
+ end record;
+ pragma Pack (Uword);
+ for Uword'Alignment use 1;
+ -- Used to process operands when unaligned
+
+ type WP is access Word;
+ type UP is access Uword;
+
+ function W is new Unchecked_Conversion (Address, WP);
+ function U is new Unchecked_Conversion (Address, UP);
+
+ -----------------------
+ -- Compare_Array_S32 --
+ -----------------------
+
+ function Compare_Array_S32
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer
+ is
+ Clen : Natural := Natural'Min (Left_Len, Right_Len);
+ -- Number of elements left to compare
+
+ L : Address := Left;
+ R : Address := Right;
+ -- Pointers to next elements to compare
+
+ begin
+ -- Case of going by aligned words
+
+ if ((Left or Right) and (4 - 1)) = 0 then
+ while Clen /= 0 loop
+ if W (L).all /= W (R).all then
+ if W (L).all > W (R).all then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+
+ Clen := Clen - 1;
+ L := L + 4;
+ R := R + 4;
+ end loop;
+
+ -- Case of going by unaligned words
+
+ else
+ while Clen /= 0 loop
+ if U (L).W /= U (R).W then
+ if U (L).W > U (R).W then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+
+ Clen := Clen - 1;
+ L := L + 4;
+ R := R + 4;
+ end loop;
+ end if;
+
+ -- Here if common section equal, result decided by lengths
+
+ if Left_Len = Right_Len then
+ return 0;
+ elsif Left_Len > Right_Len then
+ return +1;
+ else
+ return -1;
+ end if;
+ end Compare_Array_S32;
+
+end System.Compare_Array_Signed_32;
diff --git a/gcc/ada/s-casi32.ads b/gcc/ada/s-casi32.ads
new file mode 100644
index 00000000000..c97911d8812
--- /dev/null
+++ b/gcc/ada/s-casi32.ads
@@ -0,0 +1,55 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains functions for runtime comparisons on arrays whose
+-- elements are 32-bit discrete type values to be treated as signed.
+
+package System.Compare_Array_Signed_32 is
+
+ -- Note: although the functions in this package are in a sense Pure, the
+ -- package cannot be declared as Pure, since the arguments are addresses,
+ -- not the data, and the result is not pure wrt the address values.
+
+ function Compare_Array_S32
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer;
+ -- Compare the array starting at address Left of length Left_Len
+ -- with the array starting at address Right of length Right_Len.
+ -- The comparison is in the normal Ada semantic sense of array
+ -- comparison. The result is -1,0,+1 for Left<Right, Left=Right,
+ -- Left>Right respectively.
+
+end System.Compare_Array_Signed_32;
diff --git a/gcc/ada/s-casi64.adb b/gcc/ada/s-casi64.adb
new file mode 100644
index 00000000000..5d6cea980e9
--- /dev/null
+++ b/gcc/ada/s-casi64.adb
@@ -0,0 +1,120 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 6 4 --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+
+package body System.Compare_Array_Signed_64 is
+
+ type Word is range -2**63 .. 2**63 - 1;
+ for Word'Size use 64;
+ -- Used to process operands by words
+
+ type Uword is record
+ W : Word;
+ end record;
+ pragma Pack (Uword);
+ for Uword'Alignment use 1;
+ -- Used to process operands when unaligned
+
+ type WP is access Word;
+ type UP is access Uword;
+
+ function W is new Unchecked_Conversion (Address, WP);
+ function U is new Unchecked_Conversion (Address, UP);
+
+ -----------------------
+ -- Compare_Array_S64 --
+ -----------------------
+
+ function Compare_Array_S64
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer
+ is
+ Clen : Natural := Natural'Min (Left_Len, Right_Len);
+ -- Number of elements left to compare
+
+ L : Address := Left;
+ R : Address := Right;
+ -- Pointers to next elements to compare
+
+ begin
+ -- Case of going by aligned words
+
+ if ((Left or Right) and (8 - 1)) = 0 then
+ while Clen /= 0 loop
+ if W (L).all /= W (R).all then
+ if W (L).all > W (R).all then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+
+ Clen := Clen - 1;
+ L := L + 8;
+ R := R + 8;
+ end loop;
+
+ -- Case of going by unaligned words
+
+ else
+ while Clen /= 0 loop
+ if U (L).W /= U (R).W then
+ if U (L).W > U (R).W then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+
+ Clen := Clen - 1;
+ L := L + 8;
+ R := R + 8;
+ end loop;
+ end if;
+
+ -- Here if common section equal, result decided by lengths
+
+ if Left_Len = Right_Len then
+ return 0;
+ elsif Left_Len > Right_Len then
+ return +1;
+ else
+ return -1;
+ end if;
+ end Compare_Array_S64;
+
+end System.Compare_Array_Signed_64;
diff --git a/gcc/ada/s-casi64.ads b/gcc/ada/s-casi64.ads
new file mode 100644
index 00000000000..bc4d3b23ebc
--- /dev/null
+++ b/gcc/ada/s-casi64.ads
@@ -0,0 +1,55 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 6 4 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains functions for runtime comparisons on arrays whose
+-- elements are 64-bit discrete type values to be treated as signed.
+
+package System.Compare_Array_Signed_64 is
+
+ -- Note: although the functions in this package are in a sense Pure, the
+ -- package cannot be declared as Pure, since the arguments are addresses,
+ -- not the data, and the result is not pure wrt the address values.
+
+ function Compare_Array_S64
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer;
+ -- Compare the array starting at address Left of length Left_Len
+ -- with the array starting at address Right of length Right_Len.
+ -- The comparison is in the normal Ada semantic sense of array
+ -- comparison. The result is -1,0,+1 for Left<Right, Left=Right,
+ -- Left>Right respectively.
+
+end System.Compare_Array_Signed_64;
diff --git a/gcc/ada/s-casuti.adb b/gcc/ada/s-casuti.adb
new file mode 100644
index 00000000000..7c6b26248bd
--- /dev/null
+++ b/gcc/ada/s-casuti.adb
@@ -0,0 +1,105 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . C A S E _ U T I L --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Case_Util is
+
+ --------------
+ -- To_Lower --
+ --------------
+
+ function To_Lower (A : Character) return Character is
+ A_Val : constant Natural := Character'Pos (A);
+
+ begin
+ if A in 'A' .. 'Z'
+ or else A_Val in 16#C0# .. 16#D6#
+ or else A_Val in 16#D8# .. 16#DE#
+ then
+ return Character'Val (A_Val + 16#20#);
+ else
+ return A;
+ end if;
+ end To_Lower;
+
+ procedure To_Lower (A : in out String) is
+ begin
+ for J in A'Range loop
+ A (J) := To_Lower (A (J));
+ end loop;
+ end To_Lower;
+
+ --------------
+ -- To_Mixed --
+ --------------
+
+ procedure To_Mixed (A : in out String) is
+ Ucase : Boolean := True;
+
+ begin
+ for J in A'Range loop
+ if Ucase then
+ A (J) := To_Upper (A (J));
+ else
+ A (J) := To_Lower (A (J));
+ end if;
+
+ Ucase := A (J) = '_';
+ end loop;
+ end To_Mixed;
+
+ --------------
+ -- To_Upper --
+ --------------
+
+ function To_Upper (A : Character) return Character is
+ A_Val : constant Natural := Character'Pos (A);
+
+ begin
+ if A in 'a' .. 'z'
+ or else A_Val in 16#E0# .. 16#F6#
+ or else A_Val in 16#F8# .. 16#FE#
+ then
+ return Character'Val (A_Val - 16#20#);
+ else
+ return A;
+ end if;
+ end To_Upper;
+
+ procedure To_Upper (A : in out String) is
+ begin
+ for J in A'Range loop
+ A (J) := To_Upper (A (J));
+ end loop;
+ end To_Upper;
+
+end System.Case_Util;
diff --git a/gcc/ada/s-casuti.ads b/gcc/ada/s-casuti.ads
new file mode 100644
index 00000000000..2f839cd4dea
--- /dev/null
+++ b/gcc/ada/s-casuti.ads
@@ -0,0 +1,66 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . C A S E _ U T I L --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Simple casing functions
+
+-- This package provides simple casing functions that do not require the
+-- overhead of the full casing tables found in Ada.Characters.Handling.
+
+-- Note that all the routines in this package are available to the user
+-- via GNAT.Case_Util, which imports all the entities from this package.
+
+package System.Case_Util is
+pragma Pure (Case_Util);
+
+ -- Note: all the following functions handle the full Latin-1 set
+
+ function To_Upper (A : Character) return Character;
+ -- Converts A to upper case if it is a lower case letter, otherwise
+ -- returns the input argument unchanged.
+
+ procedure To_Upper (A : in out String);
+ -- Folds all characters of string A to upper csae
+
+ function To_Lower (A : Character) return Character;
+ -- Converts A to lower case if it is an upper case letter, otherwise
+ -- returns the input argument unchanged.
+
+ procedure To_Lower (A : in out String);
+ -- Folds all characters of string A to lower case
+
+ procedure To_Mixed (A : in out String);
+ -- Converts A to mixed case (i.e. lower case, except for initial
+ -- character and any character after an underscore, which are
+ -- converted to upper case.
+
+end System.Case_Util;
diff --git a/gcc/ada/s-caun16.adb b/gcc/ada/s-caun16.adb
new file mode 100644
index 00000000000..c9d1ffa3a94
--- /dev/null
+++ b/gcc/ada/s-caun16.adb
@@ -0,0 +1,137 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 16 --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+
+package body System.Compare_Array_Unsigned_16 is
+
+ type Word is mod 2 ** 32;
+ -- Used to process operands by words
+
+ type Half is mod 2 ** 16;
+ for Half'Size use 16;
+ -- Used to process operands by half words
+
+ type Uhalf is record
+ H : Half;
+ end record;
+ pragma Pack (Uhalf);
+ for Uhalf'Alignment use 1;
+ -- Used to process operands when unaligned
+
+ type WP is access Word;
+ type HP is access Half;
+ type UP is access Uhalf;
+
+ function W is new Unchecked_Conversion (Address, WP);
+ function H is new Unchecked_Conversion (Address, HP);
+ function U is new Unchecked_Conversion (Address, UP);
+
+ -----------------------
+ -- Compare_Array_U16 --
+ -----------------------
+
+ function Compare_Array_U16
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer
+ is
+ Clen : Natural := Natural'Min (Left_Len, Right_Len);
+ -- Number of elements left to compare
+
+ L : Address := Left;
+ R : Address := Right;
+ -- Pointers to next elements to compare
+
+ begin
+ -- Go by words if possible
+
+ if ((Left or Right) and (4 - 1)) = 0 then
+ while Clen > 1
+ and then W (L).all = W (R).all
+ loop
+ Clen := Clen - 2;
+ L := L + 4;
+ R := R + 4;
+ end loop;
+ end if;
+
+ -- Case of going by aligned half words
+
+ if ((Left or Right) and (2 - 1)) = 0 then
+ while Clen /= 0 loop
+ if H (L).all /= H (R).all then
+ if H (L).all > H (R).all then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+
+ Clen := Clen - 1;
+ L := L + 2;
+ R := R + 2;
+ end loop;
+
+ -- Case of going by unaligned half words
+
+ else
+ while Clen /= 0 loop
+ if U (L).H /= U (R).H then
+ if U (L).H > U (R).H then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+
+ Clen := Clen - 1;
+ L := L + 2;
+ R := R + 2;
+ end loop;
+ end if;
+
+ -- Here if common section equal, result decided by lengths
+
+ if Left_Len = Right_Len then
+ return 0;
+ elsif Left_Len > Right_Len then
+ return +1;
+ else
+ return -1;
+ end if;
+ end Compare_Array_U16;
+
+end System.Compare_Array_Unsigned_16;
diff --git a/gcc/ada/s-caun16.ads b/gcc/ada/s-caun16.ads
new file mode 100644
index 00000000000..e395c378b49
--- /dev/null
+++ b/gcc/ada/s-caun16.ads
@@ -0,0 +1,56 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 1 6 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains functions for runtime comparisons on arrays whose
+-- elements are 16-bit discrete type values to be treated as unsigned.
+
+package System.Compare_Array_Unsigned_16 is
+
+ -- Note: although the functions in this package are in a sense Pure, the
+ -- package cannot be declared as Pure, since the arguments are addresses,
+ -- not the data, and the result is not pure wrt the address values.
+
+ function Compare_Array_U16
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer;
+ -- Compare the array starting at address Left of length Left_Len
+ -- with the array starting at address Right of length Right_Len.
+ -- The comparison is in the normal Ada semantic sense of array
+ -- comparison. The result is -1,0,+1 for Left<Right, Left=Right,
+ -- Left>Right respectively. This function works with 4 byte words
+ -- if the operands are aligned on 4-byte boundaries and long enough.
+
+end System.Compare_Array_Unsigned_16;
diff --git a/gcc/ada/s-caun32.adb b/gcc/ada/s-caun32.adb
new file mode 100644
index 00000000000..830312f5f8e
--- /dev/null
+++ b/gcc/ada/s-caun32.adb
@@ -0,0 +1,120 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 3 2 --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+
+package body System.Compare_Array_Unsigned_32 is
+
+ type Word is mod 2 ** 32;
+ for Word'Size use 32;
+ -- Used to process operands by words
+
+ type Uword is record
+ W : Word;
+ end record;
+ pragma Pack (Uword);
+ for Uword'Alignment use 1;
+ -- Used to process operands when unaligned
+
+ type WP is access Word;
+ type UP is access Uword;
+
+ function W is new Unchecked_Conversion (Address, WP);
+ function U is new Unchecked_Conversion (Address, UP);
+
+ -----------------------
+ -- Compare_Array_U32 --
+ -----------------------
+
+ function Compare_Array_U32
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer
+ is
+ Clen : Natural := Natural'Min (Left_Len, Right_Len);
+ -- Number of elements left to compare
+
+ L : Address := Left;
+ R : Address := Right;
+ -- Pointers to next elements to compare
+
+ begin
+ -- Case of going by aligned words
+
+ if ((Left or Right) and (4 - 1)) = 0 then
+ while Clen /= 0 loop
+ if W (L).all /= W (R).all then
+ if W (L).all > W (R).all then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+
+ Clen := Clen - 1;
+ L := L + 4;
+ R := R + 4;
+ end loop;
+
+ -- Case of going by unaligned words
+
+ else
+ while Clen /= 0 loop
+ if U (L).W /= U (R).W then
+ if U (L).W > U (R).W then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+
+ Clen := Clen - 1;
+ L := L + 4;
+ R := R + 4;
+ end loop;
+ end if;
+
+ -- Here if common section equal, result decided by lengths
+
+ if Left_Len = Right_Len then
+ return 0;
+ elsif Left_Len > Right_Len then
+ return +1;
+ else
+ return -1;
+ end if;
+ end Compare_Array_U32;
+
+end System.Compare_Array_Unsigned_32;
diff --git a/gcc/ada/s-caun32.ads b/gcc/ada/s-caun32.ads
new file mode 100644
index 00000000000..0ca7d0c7c00
--- /dev/null
+++ b/gcc/ada/s-caun32.ads
@@ -0,0 +1,55 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 3 2 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains functions for runtime comparisons on arrays whose
+-- elements are 32-bit discrete type values to be treated as unsigned.
+
+package System.Compare_Array_Unsigned_32 is
+
+ -- Note: although the functions in this package are in a sense Pure, the
+ -- package cannot be declared as Pure, since the arguments are addresses,
+ -- not the data, and the result is not pure wrt the address values.
+
+ function Compare_Array_U32
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer;
+ -- Compare the array starting at address Left of length Left_Len
+ -- with the array starting at address Right of length Right_Len.
+ -- The comparison is in the normal Ada semantic sense of array
+ -- comparison. The result is -1,0,+1 for Left<Right, Left=Right,
+ -- Left>Right respectively.
+
+end System.Compare_Array_Unsigned_32;
diff --git a/gcc/ada/s-caun64.adb b/gcc/ada/s-caun64.adb
new file mode 100644
index 00000000000..c05a47f0a4d
--- /dev/null
+++ b/gcc/ada/s-caun64.adb
@@ -0,0 +1,119 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 6 4 --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+
+package body System.Compare_Array_Unsigned_64 is
+
+ type Word is mod 2 ** 64;
+ -- Used to process operands by words
+
+ type Uword is record
+ W : Word;
+ end record;
+ pragma Pack (Uword);
+ for Uword'Alignment use 1;
+ -- Used to process operands when unaligned
+
+ type WP is access Word;
+ type UP is access Uword;
+
+ function W is new Unchecked_Conversion (Address, WP);
+ function U is new Unchecked_Conversion (Address, UP);
+
+ -----------------------
+ -- Compare_Array_U64 --
+ -----------------------
+
+ function Compare_Array_U64
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer
+ is
+ Clen : Natural := Natural'Min (Left_Len, Right_Len);
+ -- Number of elements left to compare
+
+ L : Address := Left;
+ R : Address := Right;
+ -- Pointers to next elements to compare
+
+ begin
+ -- Case of going by aligned words
+
+ if ((Left or Right) and (8 - 1)) = 0 then
+ while Clen /= 0 loop
+ if W (L).all /= W (R).all then
+ if W (L).all > W (R).all then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+
+ Clen := Clen - 1;
+ L := L + 8;
+ R := R + 8;
+ end loop;
+
+ -- Case of going by unaligned words
+
+ else
+ while Clen /= 0 loop
+ if U (L).W /= U (R).W then
+ if U (L).W > U (R).W then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+
+ Clen := Clen - 1;
+ L := L + 8;
+ R := R + 8;
+ end loop;
+ end if;
+
+ -- Here if common section equal, result decided by lengths
+
+ if Left_Len = Right_Len then
+ return 0;
+ elsif Left_Len > Right_Len then
+ return +1;
+ else
+ return -1;
+ end if;
+ end Compare_Array_U64;
+
+end System.Compare_Array_Unsigned_64;
diff --git a/gcc/ada/s-caun64.ads b/gcc/ada/s-caun64.ads
new file mode 100644
index 00000000000..b0446d6416c
--- /dev/null
+++ b/gcc/ada/s-caun64.ads
@@ -0,0 +1,55 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 6 4 --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains functions for runtime comparisons on arrays whose
+-- elements are 64-bit discrete type values to be treated as unsigned.
+
+package System.Compare_Array_Unsigned_64 is
+
+ -- Note: although the functions in this package are in a sense Pure, the
+ -- package cannot be declared as Pure, since the arguments are addresses,
+ -- not the data, and the result is not pure wrt the address values.
+
+ function Compare_Array_U64
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer;
+ -- Compare the array starting at address Left of length Left_Len
+ -- with the array starting at address Right of length Right_Len.
+ -- The comparison is in the normal Ada semantic sense of array
+ -- comparison. The result is -1,0,+1 for Left<Right, Left=Right,
+ -- Left>Right respectively.
+
+end System.Compare_Array_Unsigned_64;
diff --git a/gcc/ada/s-crc32.adb b/gcc/ada/s-crc32.adb
index 6f7b5050041..4f156ec03a4 100644
--- a/gcc/ada/s-crc32.adb
+++ b/gcc/ada/s-crc32.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -39,7 +40,7 @@ package body System.CRC32 is
-- from various possible byte values. Doing a table lookup is quicker
-- than processing the byte bit by bit.
- Table : array (CRC32 range 0 .. 255) of CRC32 :=
+ Table : constant array (CRC32 range 0 .. 255) of CRC32 :=
(16#0000_0000#, 16#7707_3096#, 16#EE0E_612C#, 16#9909_51BA#,
16#076D_C419#, 16#706A_F48F#, 16#E963_A535#, 16#9E64_95A3#,
16#0EDB_8832#, 16#79DC_B8A4#, 16#E0D5_E91E#, 16#97D2_D988#,
diff --git a/gcc/ada/s-crc32.ads b/gcc/ada/s-crc32.ads
index 0acf0f96061..897a95af255 100644
--- a/gcc/ada/s-crc32.ads
+++ b/gcc/ada/s-crc32.ads
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-direio.adb b/gcc/ada/s-direio.adb
index 46a4eace2dd..8f43e740d87 100644
--- a/gcc/ada/s-direio.adb
+++ b/gcc/ada/s-direio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -58,7 +58,7 @@ package body System.Direct_IO is
-------------------
function AFCB_Allocate (Control_Block : Direct_AFCB) return FCB.AFCB_Ptr is
- pragma Warnings (Off, Control_Block);
+ pragma Unreferenced (Control_Block);
begin
return new Direct_AFCB;
@@ -71,7 +71,7 @@ package body System.Direct_IO is
-- No special processing required for Direct_IO close
procedure AFCB_Close (File : access Direct_AFCB) is
- pragma Warnings (Off, File);
+ pragma Unreferenced (File);
begin
null;
@@ -104,11 +104,14 @@ package body System.Direct_IO is
Name : in String := "";
Form : in String := "")
is
- File_Control_Block : Direct_AFCB;
+ Dummy_File_Control_Block : Direct_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => Mode,
Name => Name,
Form => Form,
@@ -147,11 +150,14 @@ package body System.Direct_IO is
Name : in String;
Form : in String := "")
is
- File_Control_Block : Direct_AFCB;
+ Dummy_File_Control_Block : Direct_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => Mode,
Name => Name,
Form => Form,
diff --git a/gcc/ada/s-errrep.adb b/gcc/ada/s-errrep.adb
index 02e59cec48f..419b5a436e0 100644
--- a/gcc/ada/s-errrep.adb
+++ b/gcc/ada/s-errrep.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2000 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-errrep.ads b/gcc/ada/s-errrep.ads
index daba34e9105..330d7768978 100644
--- a/gcc/ada/s-errrep.ads
+++ b/gcc/ada/s-errrep.ads
@@ -6,7 +6,8 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-1998 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-exctab.adb b/gcc/ada/s-exctab.adb
index de9e9bdeadb..c0c758edb42 100644
--- a/gcc/ada/s-exctab.adb
+++ b/gcc/ada/s-exctab.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -31,7 +31,8 @@
-- --
------------------------------------------------------------------------------
-with GNAT.HTable;
+with System.HTable;
+with System.Soft_Links; use System.Soft_Links;
package body System.Exception_Table is
@@ -46,7 +47,7 @@ package body System.Exception_Table is
function Equal (A, B : Big_String_Ptr) return Boolean;
function Get_Key (T : Exception_Data_Ptr) return Big_String_Ptr;
- package Exception_HTable is new GNAT.HTable.Static_HTable (
+ package Exception_HTable is new System.HTable.Static_HTable (
Header_Num => HTable_Headers,
Element => Exception_Data,
Elmt_Ptr => Exception_Data_Ptr,
@@ -97,6 +98,29 @@ package body System.Exception_Table is
return T.Full_Name;
end Get_Key;
+ -------------------------------
+ -- Get_Registered_Exceptions --
+ -------------------------------
+
+ procedure Get_Registered_Exceptions
+ (List : out Exception_Data_Array;
+ Last : out Integer)
+ is
+ Data : Exception_Data_Ptr := Exception_HTable.Get_First;
+
+ begin
+ Lock_Task.all;
+ Last := List'First - 1;
+
+ while Last < List'Last and then Data /= null loop
+ Last := Last + 1;
+ List (Last) := Data;
+ Data := Exception_HTable.Get_Next;
+ end loop;
+
+ Unlock_Task.all;
+ end Get_Registered_Exceptions;
+
----------
-- Hash --
----------
@@ -124,9 +148,12 @@ package body System.Exception_Table is
-- Internal_Exception --
------------------------
- type String_Ptr is access all String;
+ function Internal_Exception
+ (X : String;
+ Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr
+ is
+ type String_Ptr is access all String;
- function Internal_Exception (X : String) return Exception_Data_Ptr is
Copy : aliased String (X'First .. X'Last + 1);
Res : Exception_Data_Ptr;
Dyn_Copy : String_Ptr;
@@ -140,7 +167,7 @@ package body System.Exception_Table is
-- situation in the distributed case when an exception is defined only
-- in a partition
- if Res = null then
+ if Res = null and then Create_If_Not_Exist then
Dyn_Copy := new String'(Copy);
Res :=
@@ -150,7 +177,8 @@ package body System.Exception_Table is
Name_Length => Copy'Length,
Full_Name => To_Ptr (Dyn_Copy.all'Address),
HTable_Ptr => null,
- Import_Code => 0);
+ Import_Code => 0,
+ Raise_Hook => null);
Register_Exception (Res);
end if;
@@ -167,6 +195,29 @@ package body System.Exception_Table is
Exception_HTable.Set (X);
end Register_Exception;
+ ---------------------------------
+ -- Registered_Exceptions_Count --
+ ---------------------------------
+
+ function Registered_Exceptions_Count return Natural is
+ Count : Natural := 0;
+ Data : Exception_Data_Ptr := Exception_HTable.Get_First;
+
+ begin
+ -- We need to lock the runtime in the meantime, to avoid concurrent
+ -- access since we have only one iterator.
+
+ Lock_Task.all;
+
+ while Data /= null loop
+ Count := Count + 1;
+ Data := Exception_HTable.Get_Next;
+ end loop;
+
+ Unlock_Task.all;
+ return Count;
+ end Registered_Exceptions_Count;
+
-----------------
-- Set_HT_Link --
-----------------
@@ -179,6 +230,8 @@ package body System.Exception_Table is
T.HTable_Ptr := Next;
end Set_HT_Link;
+-- Register the standard exceptions at elaboration time
+
begin
Register_Exception (Abort_Signal_Def'Access);
Register_Exception (Tasking_Error_Def'Access);
diff --git a/gcc/ada/s-exctab.ads b/gcc/ada/s-exctab.ads
index 10789dca825..592670672b1 100644
--- a/gcc/ada/s-exctab.ads
+++ b/gcc/ada/s-exctab.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-1999 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -31,6 +31,10 @@
-- --
------------------------------------------------------------------------------
+-- This package implements the interface used to maintain a table of
+-- registered exception names, for the implementation of the mapping
+-- of names to exceptions (used for exception streams and attributes)
+
with System.Standard_Library;
package System.Exception_Table is
@@ -40,10 +44,32 @@ pragma Elaborate_Body;
procedure Register_Exception (X : SSL.Exception_Data_Ptr);
pragma Inline (Register_Exception);
- -- Register an exception in the hash table mapping
+ -- Register an exception in the hash table mapping. This function is
+ -- called during elaboration of library packages. For exceptions that
+ -- are declared within subprograms, the registration occurs the first
+ -- time that an exception is elaborated during a call of the subprogram.
+ --
+ -- Note: all calls to Register_Exception other than those to register the
+ -- predefined exceptions are suppressed if the application is compiled
+ -- with pragma Restrictions (No_Exception_Registration).
- function Internal_Exception (X : String) return SSL.Exception_Data_Ptr;
+ function Internal_Exception
+ (X : String;
+ Create_If_Not_Exist : Boolean := True) return SSL.Exception_Data_Ptr;
-- Given an exception_name X, returns a pointer to the actual internal
- -- exception data.
+ -- exception data. A new entry is created in the table if X does not
+ -- exist yet and Create_If_Not_Exist is True. If it is false and X
+ -- does not exist yet, null is returned.
+
+ function Registered_Exceptions_Count return Natural;
+ -- Return the number of currently registered exceptions.
+
+ type Exception_Data_Array is array (Natural range <>)
+ of SSL.Exception_Data_Ptr;
+
+ procedure Get_Registered_Exceptions
+ (List : out Exception_Data_Array;
+ Last : out Integer);
+ -- Return the list of registered exceptions.
end System.Exception_Table;
diff --git a/gcc/ada/s-expgen.ads b/gcc/ada/s-exnint.adb
index 6209abff8a7..432922147af 100644
--- a/gcc/ada/s-expgen.ads
+++ b/gcc/ada/s-exnint.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
--- S Y S T E M . E X P _ G E N --
+-- S Y S T E M . E X N _ I N T --
-- --
--- S p e c --
+-- B o d y --
-- --
--- Copyright (C) 1992,1993,1994,1995 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- --
@@ -31,34 +31,46 @@
-- --
------------------------------------------------------------------------------
--- This package contains the generic functions which are instantiated with
--- predefined integer and real types to generate the runtime exponentiation
--- functions called by expanded code generated by Expand_Op_Expon. This
--- version of the package contains routines that are compiled with overflow
--- checks enabled, so they are called for exponentiation operations which
--- require overflow checking
+package body System.Exn_Int is
-package System.Exp_Gen is
-pragma Pure (System.Exp_Gen);
+ -----------------
+ -- Exn_Integer --
+ -----------------
- -- Exponentiation for float types (checks on)
+ function Exn_Integer
+ (Left : Integer;
+ Right : Natural)
+ return Integer
+ is
+ pragma Suppress (Division_Check);
+ pragma Suppress (Overflow_Check);
- generic
- type Type_Of_Base is digits <>;
+ Result : Integer := 1;
+ Factor : Integer := Left;
+ Exp : Natural := Right;
- function Exp_Float_Type
- (Left : Type_Of_Base;
- Right : Integer)
- return Type_Of_Base;
+ begin
+ -- We use the standard logarithmic approach, Exp gets shifted right
+ -- testing successive low order bits and Factor is the value of the
+ -- base raised to the next power of 2.
- -- Exponentiation for signed integer types (checks on)
+ -- Note: it is not worth special casing base values -1, 0, +1 since
+ -- the expander does this when the base is a literal, and other cases
+ -- will be extremely rare.
- generic
- type Type_Of_Base is range <>;
+ if Exp /= 0 then
+ loop
+ if Exp rem 2 /= 0 then
+ Result := Result * Factor;
+ end if;
- function Exp_Integer_Type
- (Left : Type_Of_Base;
- Right : Natural)
- return Type_Of_Base;
+ Exp := Exp / 2;
+ exit when Exp = 0;
+ Factor := Factor * Factor;
+ end loop;
+ end if;
+
+ return Result;
+ end Exn_Integer;
-end System.Exp_Gen;
+end System.Exn_Int;
diff --git a/gcc/ada/s-exnint.ads b/gcc/ada/s-exnint.ads
index c2f3fea8e1c..d601b86d537 100644
--- a/gcc/ada/s-exnint.ads
+++ b/gcc/ada/s-exnint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993 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- --
@@ -33,12 +33,12 @@
-- Integer exponentiation (checks off)
-with System.Exn_Gen;
-
package System.Exn_Int is
pragma Pure (Exn_Int);
- function Exn_Integer is
- new System.Exn_Gen.Exn_Integer_Type (Integer);
+ function Exn_Integer
+ (Left : Integer;
+ Right : Natural)
+ return Integer;
end System.Exn_Int;
diff --git a/gcc/ada/s-exngen.adb b/gcc/ada/s-exnllf.adb
index 247a65b7ecd..a66bc43030c 100644
--- a/gcc/ada/s-exngen.adb
+++ b/gcc/ada/s-exnllf.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
--- S Y S T E M . E X N _ G E N --
+-- S Y S T E M . E X N _ L L F --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -31,23 +31,19 @@
-- --
------------------------------------------------------------------------------
-package body System.Exn_Gen is
+package body System.Exn_LLF is
- --------------------
- -- Exn_Float_Type --
- --------------------
+ -------------------------
+ -- Exn_Long_Long_Float --
+ -------------------------
- function Exn_Float_Type
- (Left : Type_Of_Base;
+ function Exn_Long_Long_Float
+ (Left : Long_Long_Float;
Right : Integer)
- return Type_Of_Base
+ return Long_Long_Float
is
- pragma Suppress (Division_Check);
- pragma Suppress (Overflow_Check);
- pragma Suppress (Range_Check);
-
- Result : Type_Of_Base := 1.0;
- Factor : Type_Of_Base := Left;
+ Result : Long_Long_Float := 1.0;
+ Factor : Long_Long_Float := Left;
Exp : Integer := Right;
begin
@@ -70,21 +66,20 @@ package body System.Exn_Gen is
return Result;
- -- Negative exponent. For a zero base, we should arguably return an
- -- infinity of the right sign, but it is not clear that there is
- -- proper authorization to do so, so for now raise Constraint_Error???
+ -- Here we have a negative exponent, and we compute the result as:
- elsif Factor = 0.0 then
- raise Constraint_Error;
+ -- 1.0 / (Left ** (-Right))
- -- Here we have a non-zero base and a negative exponent
+ -- Note that the case of Left being zero is not special, it will
+ -- simply result in a division by zero at the end, yielding a
+ -- correctly signed infinity, or possibly generating an overflow.
- else
- -- For the negative exponent case, a constraint error during this
- -- calculation happens if Factor gets too large, and the proper
- -- response is to return 0.0, since what we essentially have is
- -- 1.0 / infinity, and the closest model number will be zero.
+ -- Note on overflow: The coding of this routine assumes that the
+ -- target generates infinities with standard IEEE semantics. If this
+ -- is not the case, then the code below may raise Constraint_Error.
+ -- This follows the implementation permission given in RM 4.5.6(12).
+ else
begin
loop
if Exp rem 2 /= 0 then
@@ -97,56 +92,8 @@ package body System.Exn_Gen is
end loop;
return 1.0 / Result;
-
- exception
-
- when Constraint_Error =>
- return 0.0;
end;
end if;
- end Exn_Float_Type;
-
- ----------------------
- -- Exn_Integer_Type --
- ----------------------
-
- -- Note that negative exponents get a constraint error because the
- -- subtype of the Right argument (the exponent) is Natural.
-
- function Exn_Integer_Type
- (Left : Type_Of_Base;
- Right : Natural)
- return Type_Of_Base
- is
- pragma Suppress (Division_Check);
- pragma Suppress (Overflow_Check);
-
- Result : Type_Of_Base := 1;
- Factor : Type_Of_Base := Left;
- Exp : Natural := Right;
-
- begin
- -- We use the standard logarithmic approach, Exp gets shifted right
- -- testing successive low order bits and Factor is the value of the
- -- base raised to the next power of 2.
-
- -- Note: it is not worth special casing the cases of base values -1,0,+1
- -- since the expander does this when the base is a literal, and other
- -- cases will be extremely rare.
-
- if Exp /= 0 then
- loop
- if Exp rem 2 /= 0 then
- Result := Result * Factor;
- end if;
-
- Exp := Exp / 2;
- exit when Exp = 0;
- Factor := Factor * Factor;
- end loop;
- end if;
-
- return Result;
- end Exn_Integer_Type;
+ end Exn_Long_Long_Float;
-end System.Exn_Gen;
+end System.Exn_LLF;
diff --git a/gcc/ada/s-exnllf.ads b/gcc/ada/s-exnllf.ads
index 20a91d3fb22..20a0bb96d39 100644
--- a/gcc/ada/s-exnllf.ads
+++ b/gcc/ada/s-exnllf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994 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- --
@@ -33,12 +33,12 @@
-- Long_Long_Float exponentiation (checks off)
-with System.Exn_Gen;
-
package System.Exn_LLF is
pragma Pure (Exn_LLF);
- function Exn_Long_Long_Float is
- new System.Exn_Gen.Exn_Float_Type (Long_Long_Float);
+ function Exn_Long_Long_Float
+ (Left : Long_Long_Float;
+ Right : Integer)
+ return Long_Long_Float;
end System.Exn_LLF;
diff --git a/gcc/ada/s-exnlli.adb b/gcc/ada/s-exnlli.adb
new file mode 100644
index 00000000000..fdff0ca9bf7
--- /dev/null
+++ b/gcc/ada/s-exnlli.adb
@@ -0,0 +1,76 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X N _ L L I --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Exn_LLI is
+
+ ---------------------------
+ -- Exn_Long_Long_Integer --
+ ---------------------------
+
+ function Exn_Long_Long_Integer
+ (Left : Long_Long_Integer;
+ Right : Natural)
+ return Long_Long_Integer
+ is
+ pragma Suppress (Division_Check);
+ pragma Suppress (Overflow_Check);
+
+ Result : Long_Long_Integer := 1;
+ Factor : Long_Long_Integer := Left;
+ Exp : Natural := Right;
+
+ begin
+ -- We use the standard logarithmic approach, Exp gets shifted right
+ -- testing successive low order bits and Factor is the value of the
+ -- base raised to the next power of 2.
+
+ -- Note: it is not worth special casing base values -1, 0, +1 since
+ -- the expander does this when the base is a literal, and other cases
+ -- will be extremely rare.
+
+ if Exp /= 0 then
+ loop
+ if Exp rem 2 /= 0 then
+ Result := Result * Factor;
+ end if;
+
+ Exp := Exp / 2;
+ exit when Exp = 0;
+ Factor := Factor * Factor;
+ end loop;
+ end if;
+
+ return Result;
+ end Exn_Long_Long_Integer;
+
+end System.Exn_LLI;
diff --git a/gcc/ada/s-exnlli.ads b/gcc/ada/s-exnlli.ads
index b583bda7008..38f5743abb8 100644
--- a/gcc/ada/s-exnlli.ads
+++ b/gcc/ada/s-exnlli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993 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- --
@@ -33,12 +33,12 @@
-- Long_Long_Integer exponentiation (checks off)
-with System.Exn_Gen;
-
package System.Exn_LLI is
pragma Pure (Exn_LLI);
- function Exn_Long_Long_Integer is
- new System.Exn_Gen.Exn_Integer_Type (Long_Long_Integer);
+ function Exn_Long_Long_Integer
+ (Left : Long_Long_Integer;
+ Right : Natural)
+ return Long_Long_Integer;
end System.Exn_LLI;
diff --git a/gcc/ada/s-exnsin.ads b/gcc/ada/s-exnsin.ads
deleted file mode 100644
index 55ea294c2fc..00000000000
--- a/gcc/ada/s-exnsin.ads
+++ /dev/null
@@ -1,44 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUNTIME COMPONENTS --
--- --
--- S Y S T E M . E X N _ S I N T --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Short_Integer exponentiation (checks off)
-
-with System.Exn_Gen;
-
-package System.Exn_SInt is
-pragma Pure (Exn_SInt);
-
- function Exn_Short_Integer is
- new System.Exn_Gen.Exn_Integer_Type (Short_Integer);
-
-end System.Exn_SInt;
diff --git a/gcc/ada/s-exnssi.ads b/gcc/ada/s-exnssi.ads
deleted file mode 100644
index 61cb5a88299..00000000000
--- a/gcc/ada/s-exnssi.ads
+++ /dev/null
@@ -1,44 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUNTIME COMPONENTS --
--- --
--- S Y S T E M . E X N _ S S I --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Short_Short_Integer exponentiation (checks off)
-
-with System.Exn_Gen;
-
-package System.Exn_SSI is
-pragma Pure (Exn_SSI);
-
- function Exn_Short_Short_Integer is
- new System.Exn_Gen.Exn_Integer_Type (Short_Short_Integer);
-
-end System.Exn_SSI;
diff --git a/gcc/ada/s-expgen.adb b/gcc/ada/s-expgen.adb
deleted file mode 100644
index dea4340be40..00000000000
--- a/gcc/ada/s-expgen.adb
+++ /dev/null
@@ -1,181 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUNTIME COMPONENTS --
--- --
--- S Y S T E M . E X P _ G E N --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package body System.Exp_Gen is
-
- --------------------
- -- Exp_Float_Type --
- --------------------
-
- function Exp_Float_Type
- (Left : Type_Of_Base;
- Right : Integer)
- return Type_Of_Base
- is
- Result : Type_Of_Base := 1.0;
- Factor : Type_Of_Base := Left;
- Exp : Integer := Right;
-
- begin
- -- We use the standard logarithmic approach, Exp gets shifted right
- -- testing successive low order bits and Factor is the value of the
- -- base raised to the next power of 2. For positive exponents we
- -- multiply the result by this factor, for negative exponents, we
- -- divide by this factor.
-
- if Exp >= 0 then
-
- -- For a positive exponent, if we get a constraint error during
- -- this loop, it is an overflow, and the constraint error will
- -- simply be passed on to the caller.
-
- loop
- if Exp rem 2 /= 0 then
- declare
- pragma Unsuppress (All_Checks);
- begin
- Result := Result * Factor;
- end;
- end if;
-
- Exp := Exp / 2;
- exit when Exp = 0;
-
- declare
- pragma Unsuppress (All_Checks);
- begin
- Factor := Factor * Factor;
- end;
- end loop;
-
- return Result;
-
- -- Now we know that the exponent is negative, check for case of
- -- base of 0.0 which always generates a constraint error.
-
- elsif Factor = 0.0 then
- raise Constraint_Error;
-
- -- Here we have a negative exponent with a non-zero base
-
- else
-
- -- For the negative exponent case, a constraint error during this
- -- calculation happens if Factor gets too large, and the proper
- -- response is to return 0.0, since what we essenmtially have is
- -- 1.0 / infinity, and the closest model number will be zero.
-
- begin
- loop
- if Exp rem 2 /= 0 then
- declare
- pragma Unsuppress (All_Checks);
- begin
- Result := Result * Factor;
- end;
- end if;
-
- Exp := Exp / 2;
- exit when Exp = 0;
-
- declare
- pragma Unsuppress (All_Checks);
- begin
- Factor := Factor * Factor;
- end;
- end loop;
-
- declare
- pragma Unsuppress (All_Checks);
- begin
- return 1.0 / Result;
- end;
-
- exception
-
- when Constraint_Error =>
- return 0.0;
- end;
- end if;
- end Exp_Float_Type;
-
- ----------------------
- -- Exp_Integer_Type --
- ----------------------
-
- -- Note that negative exponents get a constraint error because the
- -- subtype of the Right argument (the exponent) is Natural.
-
- function Exp_Integer_Type
- (Left : Type_Of_Base;
- Right : Natural)
- return Type_Of_Base
- is
- Result : Type_Of_Base := 1;
- Factor : Type_Of_Base := Left;
- Exp : Natural := Right;
-
- begin
- -- We use the standard logarithmic approach, Exp gets shifted right
- -- testing successive low order bits and Factor is the value of the
- -- base raised to the next power of 2.
-
- -- Note: it is not worth special casing the cases of base values -1,0,+1
- -- since the expander does this when the base is a literal, and other
- -- cases will be extremely rare.
-
- if Exp /= 0 then
- loop
- if Exp rem 2 /= 0 then
- declare
- pragma Unsuppress (All_Checks);
- begin
- Result := Result * Factor;
- end;
- end if;
-
- Exp := Exp / 2;
- exit when Exp = 0;
-
- declare
- pragma Unsuppress (All_Checks);
- begin
- Factor := Factor * Factor;
- end;
- end loop;
- end if;
-
- return Result;
- end Exp_Integer_Type;
-
-end System.Exp_Gen;
diff --git a/gcc/ada/s-expint.adb b/gcc/ada/s-expint.adb
new file mode 100644
index 00000000000..e1f50c799da
--- /dev/null
+++ b/gcc/ada/s-expint.adb
@@ -0,0 +1,85 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P I N T --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Exp_Int is
+
+ -----------------
+ -- Exp_Integer --
+ -----------------
+
+ -- Note that negative exponents get a constraint error because the
+ -- subtype of the Right argument (the exponent) is Natural.
+
+ function Exp_Integer
+ (Left : Integer;
+ Right : Natural)
+ return Integer
+ is
+ Result : Integer := 1;
+ Factor : Integer := Left;
+ Exp : Natural := Right;
+
+ begin
+ -- We use the standard logarithmic approach, Exp gets shifted right
+ -- testing successive low order bits and Factor is the value of the
+ -- base raised to the next power of 2.
+
+ -- Note: it is not worth special casing base values -1, 0, +1 since
+ -- the expander does this when the base is a literal, and other cases
+ -- will be extremely rare.
+
+ if Exp /= 0 then
+ loop
+ if Exp rem 2 /= 0 then
+ declare
+ pragma Unsuppress (All_Checks);
+ begin
+ Result := Result * Factor;
+ end;
+ end if;
+
+ Exp := Exp / 2;
+ exit when Exp = 0;
+
+ declare
+ pragma Unsuppress (All_Checks);
+ begin
+ Factor := Factor * Factor;
+ end;
+ end loop;
+ end if;
+
+ return Result;
+ end Exp_Integer;
+
+end System.Exp_Int;
diff --git a/gcc/ada/s-expint.ads b/gcc/ada/s-expint.ads
index 7c81a060e2a..49b27ae2093 100644
--- a/gcc/ada/s-expint.ads
+++ b/gcc/ada/s-expint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993 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- --
@@ -33,11 +33,12 @@
-- Integer exponentiation (checks on)
-with System.Exp_Gen;
-
package System.Exp_Int is
pragma Pure (Exp_Int);
- function Exp_Integer is new System.Exp_Gen.Exp_Integer_Type (Integer);
+ function Exp_Integer
+ (Left : Integer;
+ Right : Natural)
+ return Integer;
end System.Exp_Int;
diff --git a/gcc/ada/s-expllf.ads b/gcc/ada/s-expllf.ads
deleted file mode 100644
index 8b91ce23f1a..00000000000
--- a/gcc/ada/s-expllf.ads
+++ /dev/null
@@ -1,44 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUNTIME COMPONENTS --
--- --
--- S Y S T E M . E X P _ L L F --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Long_Long_Float exponentiation (checks on)
-
-with System.Exp_Gen;
-
-package System.Exp_LLF is
-pragma Pure (Exp_LLF);
-
- function Exp_Long_Long_Float is
- new System.Exp_Gen.Exp_Float_Type (Long_Long_Float);
-
-end System.Exp_LLF;
diff --git a/gcc/ada/s-explli.adb b/gcc/ada/s-explli.adb
new file mode 100644
index 00000000000..15eb0dfa611
--- /dev/null
+++ b/gcc/ada/s-explli.adb
@@ -0,0 +1,85 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . E X P L L I --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Exp_LLI is
+
+ ---------------------------
+ -- Exp_Long_Long_Integer --
+ ---------------------------
+
+ -- Note that negative exponents get a constraint error because the
+ -- subtype of the Right argument (the exponent) is Natural.
+
+ function Exp_Long_Long_Integer
+ (Left : Long_Long_Integer;
+ Right : Natural)
+ return Long_Long_Integer
+ is
+ Result : Long_Long_Integer := 1;
+ Factor : Long_Long_Integer := Left;
+ Exp : Natural := Right;
+
+ begin
+ -- We use the standard logarithmic approach, Exp gets shifted right
+ -- testing successive low order bits and Factor is the value of the
+ -- base raised to the next power of 2.
+
+ -- Note: it is not worth special casing base values -1, 0, +1 since
+ -- the expander does this when the base is a literal, and other cases
+ -- will be extremely rare.
+
+ if Exp /= 0 then
+ loop
+ if Exp rem 2 /= 0 then
+ declare
+ pragma Unsuppress (All_Checks);
+ begin
+ Result := Result * Factor;
+ end;
+ end if;
+
+ Exp := Exp / 2;
+ exit when Exp = 0;
+
+ declare
+ pragma Unsuppress (All_Checks);
+ begin
+ Factor := Factor * Factor;
+ end;
+ end loop;
+ end if;
+
+ return Result;
+ end Exp_Long_Long_Integer;
+
+end System.Exp_LLI;
diff --git a/gcc/ada/s-explli.ads b/gcc/ada/s-explli.ads
index 0f7f46c36ec..27d72d55a00 100644
--- a/gcc/ada/s-explli.ads
+++ b/gcc/ada/s-explli.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993 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- --
@@ -33,12 +33,12 @@
-- Long_Long_Integer exponentiation
-with System.Exp_Gen;
-
package System.Exp_LLI is
pragma Pure (Exp_LLI);
- function Exp_Long_Long_Integer is
- new System.Exp_Gen.Exp_Integer_Type (Long_Long_Integer);
+ function Exp_Long_Long_Integer
+ (Left : Long_Long_Integer;
+ Right : Natural)
+ return Long_Long_Integer;
end System.Exp_LLI;
diff --git a/gcc/ada/s-expsfl.ads b/gcc/ada/s-expsfl.ads
deleted file mode 100644
index 5e05d570828..00000000000
--- a/gcc/ada/s-expsfl.ads
+++ /dev/null
@@ -1,44 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUNTIME COMPONENTS --
--- --
--- S Y S T E M . E X P _ S F L T --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Short_Float exponentiation (checks on)
-
-with System.Exp_Gen;
-
-package System.Exp_SFlt is
-pragma Pure (Exp_SFlt);
-
- function Exp_Short_Float is
- new System.Exp_Gen.Exp_Float_Type (Short_Float);
-
-end System.Exp_SFlt;
diff --git a/gcc/ada/s-expsin.ads b/gcc/ada/s-expsin.ads
deleted file mode 100644
index b3baf54c636..00000000000
--- a/gcc/ada/s-expsin.ads
+++ /dev/null
@@ -1,44 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUNTIME COMPONENTS --
--- --
--- S Y S T E M . E X P _ S I N T --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Short_Integer exponentiation (checks on)
-
-with System.Exp_Gen;
-
-package System.Exp_SInt is
-pragma Pure (Exp_SInt);
-
- function Exp_Short_Integer is
- new System.Exp_Gen.Exp_Integer_Type (Short_Integer);
-
-end System.Exp_SInt;
diff --git a/gcc/ada/s-expssi.ads b/gcc/ada/s-expssi.ads
deleted file mode 100644
index d570a9557c0..00000000000
--- a/gcc/ada/s-expssi.ads
+++ /dev/null
@@ -1,44 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUNTIME COMPONENTS --
--- --
--- S Y S T E M . E X P S S I --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Short_Short_Integer exponentiation (checks on)
-
-with System.Exp_Gen;
-
-package System.Exp_SSI is
-pragma Pure (Exp_SSI);
-
- function Exp_Short_Short_Integer is
- new System.Exp_Gen.Exp_Integer_Type (Short_Short_Integer);
-
-end System.Exp_SSI;
diff --git a/gcc/ada/s-expuns.ads b/gcc/ada/s-expuns.ads
index 7c5869ade31..964e843f242 100644
--- a/gcc/ada/s-expuns.ads
+++ b/gcc/ada/s-expuns.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
--- S Y S T E M . E X P _ U N S --
+-- S Y S T E M . E X P _ U N S --
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1997 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- --
diff --git a/gcc/ada/s-fatflt.ads b/gcc/ada/s-fatflt.ads
index b69e7d0c25b..cba06c3aa25 100644
--- a/gcc/ada/s-fatflt.ads
+++ b/gcc/ada/s-fatflt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994,1995,1996 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- --
@@ -39,7 +39,7 @@ with System.Fat_Gen;
package System.Fat_Flt is
pragma Pure (Fat_Flt);
- -- Note the only entity from this package that is accessed by Rtsfind
+ -- Note the only entity from this package that is acccessed by Rtsfind
-- is the name of the package instantiation. Entities within this package
-- (i.e. the individual floating-point attribute routines) are accessed
-- by name using selected notation.
diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb
index e3dcadc03d1..c0f53b15657 100644
--- a/gcc/ada/s-fatgen.adb
+++ b/gcc/ada/s-fatgen.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -43,7 +43,6 @@ with System;
package body System.Fat_Gen is
Float_Radix : constant T := T (T'Machine_Radix);
- Float_Radix_Inv : constant T := 1.0 / Float_Radix;
Radix_To_M_Minus_1 : constant T := Float_Radix ** (T'Machine_Mantissa - 1);
pragma Assert (T'Machine_Radix = 2);
@@ -163,7 +162,7 @@ package body System.Fat_Gen is
---------------
procedure Decompose (XX : T; Frac : out T; Expo : out UI) is
- X : T := T'Machine (XX);
+ X : constant T := T'Machine (XX);
begin
if X = 0.0 then
@@ -738,7 +737,11 @@ package body System.Fat_Gen is
-- The Float_Rep type is an array of Float_Word elements. This
-- representation is chosen to make it possible to size the
- -- type based on a generic parameter.
+ -- type based on a generic parameter. Since the array size is
+ -- known at compile-time, efficient code can still be generated.
+ -- The size of Float_Word elements should be large enough to allow
+ -- accessing the exponent in one read, but small enough so that all
+ -- floating point object sizes are a multiple of the Float_Word'Size.
-- The following conditions must be met for all possible
-- instantiations of the attributes package:
@@ -752,13 +755,20 @@ package body System.Fat_Gen is
-- and the exponent is in the following bits.
-- Unused bits (if any) are in the least significant part.
- type Float_Word is mod 2**32;
+ type Float_Word is mod 2**Positive'Min (System.Word_Size, 32);
type Rep_Index is range 0 .. 7;
Rep_Last : constant Rep_Index := (T'Size - 1) / Float_Word'Size;
type Float_Rep is array (Rep_Index range 0 .. Rep_Last) of Float_Word;
+ pragma Suppress_Initialization (Float_Rep);
+ -- This pragma supresses the generation of an initialization procedure
+ -- for type Float_Rep when operating in Initialize/Normalize_Scalars
+ -- mode. This is not just a matter of efficiency, but of functionality,
+ -- since Valid has a pragma Inline_Always, which is not permitted if
+ -- there are nested subprograms present.
+
Most_Significant_Word : constant Rep_Index :=
Rep_Last * Standard'Default_Bit_Order;
-- Finding the location of the Exponent_Word is a bit tricky.
@@ -831,4 +841,21 @@ package body System.Fat_Gen is
((E = IEEE_Emin - 1) and then abs To_Float (SR) = 1.0);
end Valid;
+ ---------------------
+ -- Unaligned_Valid --
+ ---------------------
+
+ function Unaligned_Valid (A : System.Address) return Boolean is
+ subtype FS is String (1 .. T'Size / Character'Size);
+ type FSP is access FS;
+
+ function To_FSP is new Ada.Unchecked_Conversion (Address, FSP);
+
+ Local_T : aliased T;
+
+ begin
+ To_FSP (Local_T'Address).all := To_FSP (A).all;
+ return Valid (Local_T'Access);
+ end Unaligned_Valid;
+
end System.Fat_Gen;
diff --git a/gcc/ada/s-fatgen.ads b/gcc/ada/s-fatgen.ads
index 9db87e056b0..1dfc2a72338 100644
--- a/gcc/ada/s-fatgen.ads
+++ b/gcc/ada/s-fatgen.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -93,10 +93,30 @@ pragma Pure (Fat_Gen);
-- passed by reference (access) here, as the object of type T may
-- be an abnormal value that cannot be passed in a floating-point
-- register, and the whole point of 'Valid is to prevent exceptions.
+ -- Note that the object of type T must have the natural alignment
+ -- for type T. See Unaligned_Valid for further discussion.
+
+ function Unaligned_Valid (A : System.Address) return Boolean;
+ -- This version of Valid is used if the floating-point value to
+ -- be checked is not known to be aligned (for example it appears
+ -- in a packed record). In this case, we cannot call Valid since
+ -- Valid assumes proper full alignment. Instead Unaligned_Valid
+ -- performs the same processing for a possibly unaligned float,
+ -- by first doing a copy and then calling Valid. One might think
+ -- that the front end could simply do a copy to an aligned temp,
+ -- but remember that we may have an abnormal value that cannot
+ -- be copied into a floating-point register, so things are a bit
+ -- trickier than one might expect.
+ --
+ -- Note: Unaligned_Valid is never called for a target which does
+ -- not require strict alignment (e.g. the ia32/x86), since on a
+ -- target not requiring strict alignment, it is fine to pass a
+ -- non-aligned value to the standard Valid routine.
private
pragma Inline (Machine);
pragma Inline (Model);
pragma Inline_Always (Valid);
+ pragma Inline_Always (Unaligned_Valid);
end System.Fat_Gen;
diff --git a/gcc/ada/s-fatlfl.ads b/gcc/ada/s-fatlfl.ads
index 452373c9775..9361addae07 100644
--- a/gcc/ada/s-fatlfl.ads
+++ b/gcc/ada/s-fatlfl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994,1995,1996 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- --
@@ -39,7 +39,7 @@ with System.Fat_Gen;
package System.Fat_LFlt is
pragma Pure (Fat_LFlt);
- -- Note the only entity from this package that is accessed by Rtsfind
+ -- Note the only entity from this package that is acccessed by Rtsfind
-- is the name of the package instantiation. Entities within this package
-- (i.e. the individual floating-point attribute routines) are accessed
-- by name using selected notation.
diff --git a/gcc/ada/s-fatllf.ads b/gcc/ada/s-fatllf.ads
index a4b5e65ada7..1735442b2ed 100644
--- a/gcc/ada/s-fatllf.ads
+++ b/gcc/ada/s-fatllf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994,1995,1996 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- --
@@ -39,7 +39,7 @@ with System.Fat_Gen;
package System.Fat_LLF is
pragma Pure (Fat_LLF);
- -- Note the only entity from this package that is accessed by Rtsfind
+ -- Note the only entity from this package that is acccessed by Rtsfind
-- is the name of the package instantiation. Entities within this package
-- (i.e. the individual floating-point attribute routines) are accessed
-- by name using selected notation.
diff --git a/gcc/ada/s-fatsfl.ads b/gcc/ada/s-fatsfl.ads
index 6c4710a2c2d..5606af7b816 100644
--- a/gcc/ada/s-fatsfl.ads
+++ b/gcc/ada/s-fatsfl.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994,1995,1996 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- --
@@ -39,7 +39,7 @@ with System.Fat_Gen;
package System.Fat_SFlt is
pragma Pure (Fat_SFlt);
- -- Note the only entity from this package that is accessed by Rtsfind
+ -- Note the only entity from this package that is acccessed by Rtsfind
-- is the name of the package instantiation. Entities within this package
-- (i.e. the individual floating-point attribute routines) are accessed
-- by name using selected notation.
diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb
index dcac47f608e..9028fd694ba 100644
--- a/gcc/ada/s-fileio.adb
+++ b/gcc/ada/s-fileio.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- --
@@ -129,9 +129,11 @@ package body System.File_IO is
procedure Chain_File (File : AFCB_Ptr) is
begin
-- Take a task lock, to protect the global data value Open_Files
- -- No exception handler needed, since we cannot get an exception.
SSL.Lock_Task.all;
+
+ -- Do the chaining operation locked
+
File.Next := Open_Files;
File.Prev := null;
Open_Files := File;
@@ -141,6 +143,11 @@ package body System.File_IO is
end if;
SSL.Unlock_Task.all;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
end Chain_File;
---------------------
@@ -192,6 +199,10 @@ package body System.File_IO is
Check_File_Open (File);
AFCB_Close (File);
+ -- Take a task lock, to protect the global data value Open_Files
+
+ SSL.Lock_Task.all;
+
-- Sever the association between the given file and its associated
-- external file. The given file is left closed. Do not perform system
-- closes on the standard input, output and error files and also do
@@ -231,27 +242,16 @@ package body System.File_IO is
end if;
-- Dechain file from list of open files and then free the storage
- -- Since this is a global data structure, we have to protect against
- -- multiple tasks attempting to access this list.
-
- -- Note that we do not use an exception handler to unlock here since
- -- no exception can occur inside the lock/unlock pair.
-
- begin
- SSL.Lock_Task.all;
-
- if File.Prev = null then
- Open_Files := File.Next;
- else
- File.Prev.Next := File.Next;
- end if;
- if File.Next /= null then
- File.Next.Prev := File.Prev;
- end if;
+ if File.Prev = null then
+ Open_Files := File.Next;
+ else
+ File.Prev.Next := File.Next;
+ end if;
- SSL.Unlock_Task.all;
- end;
+ if File.Next /= null then
+ File.Next.Prev := File.Prev;
+ end if;
-- Deallocate some parts of the file structure that were kept in heap
-- storage with the exception of system files (standard input, output
@@ -268,6 +268,13 @@ package body System.File_IO is
if Close_Status /= 0 then
raise Device_Error;
end if;
+
+ SSL.Unlock_Task.all;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
end Close;
------------
@@ -332,11 +339,17 @@ package body System.File_IO is
procedure Finalize (V : in out File_IO_Clean_Up_Type) is
pragma Warnings (Off, V);
- Discard : int;
Fptr1 : AFCB_Ptr;
Fptr2 : AFCB_Ptr;
+ Discard : int;
+ pragma Unreferenced (Discard);
+
begin
+ -- Take a lock to protect global Open_Files data structure
+
+ SSL.Lock_Task.all;
+
-- First close all open files (the slightly complex form of this loop
-- is required because Close as a side effect nulls out its argument)
@@ -356,6 +369,12 @@ package body System.File_IO is
Temp_Files := Temp_Files.Next;
end loop;
+ SSL.Unlock_Task.all;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
end Finalize;
-----------
@@ -595,9 +614,11 @@ package body System.File_IO is
-------------------
procedure Make_Buffered
- (File : AFCB_Ptr;
- Buf_Siz : Interfaces.C_Streams.size_t) is
- status : Integer;
+ (File : AFCB_Ptr;
+ Buf_Siz : Interfaces.C_Streams.size_t)
+ is
+ status : Integer;
+ pragma Unreferenced (status);
begin
status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz);
@@ -609,8 +630,10 @@ package body System.File_IO is
procedure Make_Line_Buffered
(File : AFCB_Ptr;
- Line_Siz : Interfaces.C_Streams.size_t) is
- status : Integer;
+ Line_Siz : Interfaces.C_Streams.size_t)
+ is
+ status : Integer;
+ pragma Unreferenced (status);
begin
status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz);
@@ -622,6 +645,7 @@ package body System.File_IO is
procedure Make_Unbuffered (File : AFCB_Ptr) is
status : Integer;
+ pragma Unreferenced (status);
begin
status := setvbuf (File.Stream, Null_Address, IONBF, 0);
@@ -659,7 +683,7 @@ package body System.File_IO is
procedure Open
(File_Ptr : in out AFCB_Ptr;
- Dummy_FCB : in out AFCB'Class;
+ Dummy_FCB : in AFCB'Class;
Mode : File_Mode;
Name : String;
Form : String;
@@ -668,6 +692,10 @@ package body System.File_IO is
Text : Boolean;
C_Stream : FILEs := NULL_Stream)
is
+ pragma Warnings (Off, Dummy_FCB);
+ -- Yes we know this is never assigned a value. That's intended, since
+ -- all we ever use of this value is the tag for dispatching purposes.
+
procedure Tmp_Name (Buffer : Address);
pragma Import (C, Tmp_Name, "__gnat_tmp_name");
-- set buffer (a String address) with a temporary filename.
@@ -811,6 +839,12 @@ package body System.File_IO is
P : AFCB_Ptr;
begin
+ -- Take a task lock to protect Open_Files
+
+ SSL.Lock_Task.all;
+
+ -- Search list of open files
+
P := Open_Files;
while P /= null loop
if Fullname (1 .. Full_Name_Len) = P.Name.all then
@@ -849,6 +883,13 @@ package body System.File_IO is
P := P.Next;
end loop;
+
+ SSL.Unlock_Task.all;
+
+ exception
+ when others =>
+ SSL.Unlock_Task.all;
+ raise;
end;
end if;
diff --git a/gcc/ada/s-fileio.ads b/gcc/ada/s-fileio.ads
index 54085186c66..fe06807d165 100644
--- a/gcc/ada/s-fileio.ads
+++ b/gcc/ada/s-fileio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -49,7 +49,7 @@ package System.File_IO is
procedure Open
(File_Ptr : in out FCB.AFCB_Ptr;
- Dummy_FCB : in out FCB.AFCB'Class;
+ Dummy_FCB : in FCB.AFCB'Class;
Mode : FCB.File_Mode;
Name : String;
Form : String;
diff --git a/gcc/ada/s-finimp.adb b/gcc/ada/s-finimp.adb
index bc1a2f18e65..5d06b3a551d 100644
--- a/gcc/ada/s-finimp.adb
+++ b/gcc/ada/s-finimp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -84,13 +84,16 @@ package body System.Finalization_Implementation is
function RC_Offset (T : Ada.Tags.Tag) return SSE.Storage_Offset;
pragma Import (Ada, RC_Offset, "ada__tags__get_rc_offset");
- function Parent_Size (Obj : Address) return SSE.Storage_Count;
+ function Parent_Size (Obj : Address; T : Ada.Tags.Tag)
+ return SSE.Storage_Count;
pragma Import (Ada, Parent_Size, "ada__tags__parent_size");
- function Get_RC_Dynamically (Obj : Address) return Address;
- -- Given an the address of an object (obj) of a tagged extension with
- -- controlled component, computes the address of the record controller
- -- located just after the _parent field
+ function Parent_Tag (T : Ada.Tags.Tag) return Ada.Tags.Tag;
+ pragma Import (Ada, Parent_Tag, "ada__tags__parent_tag");
+
+ function Get_Deep_Controller (Obj : System.Address) return RC_Ptr;
+ -- Given the address (obj) of a tagged object, return a
+ -- pointer to the record controller of this object.
-------------
-- Adjust --
@@ -103,13 +106,17 @@ package body System.Finalization_Implementation is
Object.My_Address - Object'Address;
procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr);
- -- Subtract the offset to the pointer
+ -- Substract the offset to the pointer
procedure Reverse_Adjust (P : Finalizable_Ptr);
- -- Adjust the components in the reverse order in which they are stored
+ -- Ajust the components in the reverse order in which they are stored
-- on the finalization list. (Adjust and Finalization are not done in
-- the same order)
+ ----------------
+ -- Ptr_Adjust --
+ ----------------
+
procedure Ptr_Adjust (Ptr : in out Finalizable_Ptr) is
begin
if Ptr /= null then
@@ -117,6 +124,10 @@ package body System.Finalization_Implementation is
end if;
end Ptr_Adjust;
+ --------------------
+ -- Reverse_Adjust --
+ --------------------
+
procedure Reverse_Adjust (P : Finalizable_Ptr) is
begin
if P /= null then
@@ -210,7 +221,6 @@ package body System.Finalization_Implementation is
L := Obj'Unchecked_Access;
end;
end if;
-
end Attach_To_Final_List;
---------------------
@@ -222,27 +232,18 @@ package body System.Finalization_Implementation is
A : System.Address;
B : Short_Short_Integer)
is
- V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
+ V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
+ Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
- -- Has controlled components
-
- if Offset /= 0 then
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
-
+ if Controller /= null then
Adjust (Controller.all);
Attach_To_Final_List (L, Controller.all, B);
+ end if;
-- Is controlled
- elsif V.all in Finalizable then
+ if V.all in Finalizable then
Adjust (V.all);
Attach_To_Final_List (L, Finalizable (V.all), 1);
end if;
@@ -257,24 +258,17 @@ package body System.Finalization_Implementation is
A : System.Address;
B : Short_Short_Integer)
is
- V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
+ V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
+ Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
- if Offset /= 0 then
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
-
+ if Controller /= null then
Attach_To_Final_List (L, Controller.all, B);
+ end if;
-- Is controlled
- elsif V.all in Finalizable then
+ if V.all in Finalizable then
Attach_To_Final_List (L, V.all, B);
end if;
end Deep_Tag_Attach;
@@ -290,30 +284,21 @@ package body System.Finalization_Implementation is
is
pragma Warnings (Off, L);
- V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
+ V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
+ Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
- -- Has controlled components
-
- if Offset /= 0 then
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
-
+ if Controller /= null then
if B then
Finalize_One (Controller.all);
else
Finalize (Controller.all);
end if;
+ end if;
-- Is controlled
- elsif V.all in Finalizable then
+ if V.all in Finalizable then
if B then
Finalize_One (V.all);
else
@@ -331,32 +316,23 @@ package body System.Finalization_Implementation is
A : System.Address;
B : Short_Short_Integer)
is
- V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
- Offset : constant SSE.Storage_Offset := RC_Offset (V'Tag);
-
- Controller : RC_Ptr;
+ V : constant SFR.Finalizable_Ptr := To_Finalizable_Ptr (A);
+ Controller : constant RC_Ptr := Get_Deep_Controller (A);
begin
-- This procedure should not be called if the object has no
-- controlled components
- if Offset = 0 then
-
+ if Controller = null then
raise Program_Error;
-- Has controlled components
else
- if Offset > 0 then
- Controller := To_RC_Ptr (A + Offset);
- else
- Controller := To_RC_Ptr (Get_RC_Dynamically (A));
- end if;
+ Initialize (Controller.all);
+ Attach_To_Final_List (L, Controller.all, B);
end if;
- Initialize (Controller.all);
- Attach_To_Final_List (L, Controller.all, B);
-
-- Is controlled
if V.all in Finalizable then
@@ -437,10 +413,10 @@ package body System.Finalization_Implementation is
P : Finalizable_Ptr := L;
Q : Finalizable_Ptr;
- type Fake_Exception_Occurrence is record
+ type Fake_Exception_Occurence is record
Id : Exception_Id;
end record;
- type Ptr is access all Fake_Exception_Occurrence;
+ type Ptr is access all Fake_Exception_Occurence;
-- Let's get the current exception before starting to finalize in
-- order to check if we are in the abort case if an exception is
@@ -448,8 +424,9 @@ package body System.Finalization_Implementation is
function To_Ptr is new
Ada.Unchecked_Conversion (Exception_Occurrence_Access, Ptr);
- X : Exception_Id :=
- To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
+
+ X : constant Exception_Id :=
+ To_Ptr (System.Soft_Links.Get_Current_Excep.all).Id;
begin
while P /= null loop
@@ -479,36 +456,72 @@ package body System.Finalization_Implementation is
when E_Occ : others => Raise_From_Finalize (null, False, E_Occ);
end Finalize_One;
- ------------------------
- -- Get_RC_Dynamically --
- ------------------------
+ -------------------------
+ -- Get_Deep_Controller --
+ -------------------------
- function Get_RC_Dynamically (Obj : Address) return Address is
+ function Get_Deep_Controller (Obj : System.Address) return RC_Ptr is
+ The_Tag : Ada.Tags.Tag := To_Finalizable_Ptr (Obj)'Tag;
+ Offset : SSE.Storage_Offset := RC_Offset (The_Tag);
- -- define a faked record controller to avoid generating
- -- unnecessary expanded code for controlled types
+ begin
- type Faked_Record_Controller is record
- Tag, Prec, Next : Address;
- end record;
+ -- Fetch the controller from the Parent or above if necessary
+ -- when there are no controller at this level
- -- Reconstruction of a type with characteristics
- -- comparable to the original type
+ while Offset = -2 loop
+ The_Tag := Parent_Tag (The_Tag);
+ Offset := RC_Offset (The_Tag);
+ end loop;
- D : constant := Storage_Unit - 1;
+ -- No Controlled component case
- type Faked_Type_Of_Obj is record
- Parent : SSE.Storage_Array
- (1 .. (Parent_Size (Obj) + D) / Storage_Unit);
- Controller : Faked_Record_Controller;
- end record;
+ if Offset = 0 then
+ return null;
- type Obj_Ptr is access all Faked_Type_Of_Obj;
- function To_Obj_Ptr is new Ada.Unchecked_Conversion (Address, Obj_Ptr);
+ -- The _controller Offset is known statically
- begin
- return To_Obj_Ptr (Obj).Controller'Address;
- end Get_RC_Dynamically;
+ elsif Offset > 0 then
+ return To_RC_Ptr (Obj + Offset);
+
+ -- At this stage, we know that the controller is part of the
+ -- ancestor corresponding to the tag "The_Tag" and that its parent
+ -- is variable sized. We assume that the _controller is the first
+ -- compoment right after the parent.
+ -- ??? note that it may not be true if there are new discriminants.
+
+ else -- Offset = -1
+
+ declare
+ -- define a faked record controller to avoid generating
+ -- unnecessary expanded code for controlled types
+
+ type Faked_Record_Controller is record
+ Tag, Prec, Next : Address;
+ end record;
+
+ -- Reconstruction of a type with characteristics
+ -- comparable to the original type
+
+ D : constant := Storage_Unit - 1;
+
+ type Parent_Type is new SSE.Storage_Array
+ (1 .. (Parent_Size (Obj, The_Tag) + D) / Storage_Unit);
+ for Parent_Type'Alignment use Address'Alignment;
+
+ type Faked_Type_Of_Obj is record
+ Parent : Parent_Type;
+ Controller : Faked_Record_Controller;
+ end record;
+ type Obj_Ptr is access all Faked_Type_Of_Obj;
+ function To_Obj_Ptr is
+ new Ada.Unchecked_Conversion (Address, Obj_Ptr);
+
+ begin
+ return To_RC_Ptr (To_Obj_Ptr (Obj).Controller'Address);
+ end;
+ end if;
+ end Get_Deep_Controller;
----------------
-- Initialize --
diff --git a/gcc/ada/s-finimp.ads b/gcc/ada/s-finimp.ads
index 2e959a238fd..d83670a48ea 100644
--- a/gcc/ada/s-finimp.ads
+++ b/gcc/ada/s-finimp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1998 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- --
@@ -36,7 +36,7 @@ with System.Finalization_Root;
package System.Finalization_Implementation is
pragma Elaborate_Body (Finalization_Implementation);
- package SFR renames System.Finalization_Root;
+ package SFR renames System.Finalization_Root;
------------------------------------------------
-- Finalization Management Abstract Interface --
@@ -58,7 +58,7 @@ pragma Elaborate_Body (Finalization_Implementation);
-- attachement, 1 for simple linked lists or 2 for doubly linked lists
-- or even 3 for a simple attachement of a whole array of elements.
-- Attachement to a simply linked list is not protected against
- -- concurrent access and should only be used in context where it
+ -- concurrent access and should only be used in contexts where it
-- doesn't matter, such as for objects allocated on the stack. In the
-- case of an attachment on a doubly linked list, L must not be null
-- and Obj will be inserted AFTER the first element and the attachment
@@ -80,33 +80,33 @@ pragma Elaborate_Body (Finalization_Implementation);
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer);
- -- Generic initialize for tagged objects with controlled components. A
- -- is the address of the object, L the finalization list when it needs
- -- to be attached and B the attachement level (see Attach_To_Final_List)
+ -- Generic initialize for tagged objects with controlled components.
+ -- A is the address of the object, L the finalization list when it needs
+ -- to be attached and B the attachement level (see Attach_To_Final_List).
procedure Deep_Tag_Adjust
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer);
- -- Generic adjust for tagged objects with controlled components. A
- -- is the address of the object, L the finalization list when it needs
- -- to be attached and B the attachement level (see Attach_To_Final_List)
+ -- Generic adjust for tagged objects with controlled components.
+ -- A is the address of the object, L the finalization list when it needs
+ -- to be attached and B the attachement level (see Attach_To_Final_List).
procedure Deep_Tag_Finalize
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Boolean);
- -- Generic finalize for tagged objects with controlled components. A
- -- is the address of the object, L the finalization list when it needs
- -- to be attached and B the attachement level (see Attach_To_Final_List)
+ -- Generic finalize for tagged objects with controlled components.
+ -- A is the address of the object, L the finalization list when it needs
+ -- to be attached and B the attachement level (see Attach_To_Final_List).
procedure Deep_Tag_Attach
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer);
- -- Generic attachement for tagged objects with controlled components. A
- -- is the address of the object, L the finalization list when it needs
- -- to be attached and B the attachement level (see Attach_To_Final_List)
+ -- Generic attachement for tagged objects with controlled components.
+ -- A is the address of the object, L the finalization list when it needs
+ -- to be attached and B the attachement level (see Attach_To_Final_List).
-----------------------------
-- Record Controller Types --
@@ -115,18 +115,18 @@ pragma Elaborate_Body (Finalization_Implementation);
-- Definition of the types of the controller component that is included
-- in records containing controlled components. This controller is
-- attached to the finalization chain of the upper-level and carries
- -- the pointer of the finalization chain for the lower level
+ -- the pointer of the finalization chain for the lower level.
type Limited_Record_Controller is new SFR.Root_Controlled with record
F : SFR.Finalizable_Ptr;
end record;
procedure Initialize (Object : in out Limited_Record_Controller);
- -- Does nothing
+ -- Does nothing.
procedure Finalize (Object : in out Limited_Record_Controller);
-- Finalize the controlled components of the enclosing record by
- -- following the list starting at Object.F
+ -- following the list starting at Object.F.
type Record_Controller is
new Limited_Record_Controller with record
@@ -137,13 +137,13 @@ pragma Elaborate_Body (Finalization_Implementation);
-- Initialize the field My_Address to the Object'Address
procedure Adjust (Object : in out Record_Controller);
- -- Adjust the components and their finalization pointers by subtracting
- -- by the offset of the target and the source addresses of the assignment
+ -- Adjust the components and their finalization pointers by substracting
+ -- by the offset of the target and the source addresses of the assignment.
-- Inherit Finalize from Limited_Record_Controller
procedure Detach_From_Final_List (Obj : in out SFR.Finalizable);
- -- Remove the specified object from its Final list which must be a
+ -- Remove the specified object from its Final list, which must be a
-- doubly linked list.
end System.Finalization_Implementation;
diff --git a/gcc/ada/s-finroo.adb b/gcc/ada/s-finroo.adb
index 15b7df0ed17..4c95f3f5135 100644
--- a/gcc/ada/s-finroo.adb
+++ b/gcc/ada/s-finroo.adb
@@ -4,9 +4,9 @@
-- --
-- S Y S T E M . F I N A L I Z A T I O N _ R O O T --
-- --
--- S p e c --
+-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
diff --git a/gcc/ada/s-finroo.ads b/gcc/ada/s-finroo.ads
index 32ca1eece0f..9d620f1e534 100644
--- a/gcc/ada/s-finroo.ads
+++ b/gcc/ada/s-finroo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 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- --
@@ -30,6 +30,7 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+
with Ada.Streams;
package System.Finalization_Root is
pragma Preelaborate (Finalization_Root);
diff --git a/gcc/ada/s-geveop.adb b/gcc/ada/s-geveop.adb
new file mode 100644
index 00000000000..f183a213b39
--- /dev/null
+++ b/gcc/ada/s-geveop.adb
@@ -0,0 +1,123 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . G E N E R I C _ V E C T O R _ O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System; use System;
+with System.Storage_Elements; use System.Storage_Elements;
+with Ada.Unchecked_Conversion; use Ada;
+
+package body System.Generic_Vector_Operations is
+ VU : constant Address := Vectors.Vector'Size / Storage_Unit;
+ EU : constant Address := Element_Array'Component_Size / Storage_Unit;
+
+ ----------------------
+ -- Binary_Operation --
+ ----------------------
+
+ procedure Binary_Operation
+ (R, X, Y : System.Address;
+ Length : System.Storage_Elements.Storage_Count)
+ is
+ RA : Address := R;
+ XA : Address := X;
+ YA : Address := Y;
+ -- Address of next element to process in R, X and Y
+
+ Unaligned : constant Boolean := (RA or XA or YA) mod VU /= 0;
+ -- False iff one or more argument addresses is not aligned
+
+ type Vector_Ptr is access all Vectors.Vector;
+ type Element_Ptr is access all Element;
+
+ function VP is new Unchecked_Conversion (Address, Vector_Ptr);
+ function EP is new Unchecked_Conversion (Address, Element_Ptr);
+
+ SA : Address := XA + ((Length + 0) / VU * VU
+ and (Boolean'Pos (Unaligned) - Address'(1)));
+ -- First address of argument X to start serial processing
+
+ begin
+ while XA < SA loop
+ VP (RA).all := Vector_Op (VP (XA).all, VP (YA).all);
+ XA := XA + VU;
+ YA := YA + VU;
+ RA := RA + VU;
+ end loop;
+
+ while XA < X + Length loop
+ EP (RA).all := Element_Op (EP (XA).all, EP (YA).all);
+ XA := XA + EU;
+ YA := YA + EU;
+ RA := RA + EU;
+ end loop;
+ end Binary_Operation;
+
+ ----------------------
+ -- Unary_Operation --
+ ----------------------
+
+ procedure Unary_Operation
+ (R, X : System.Address;
+ Length : System.Storage_Elements.Storage_Count)
+ is
+ RA : Address := R;
+ XA : Address := X;
+ -- Address of next element to process in R and X
+
+ Unaligned : constant Boolean := (RA or XA) mod VU /= 0;
+ -- False iff one or more argument addresses is not aligned
+
+ type Vector_Ptr is access all Vectors.Vector;
+ type Element_Ptr is access all Element;
+
+ function VP is new Unchecked_Conversion (Address, Vector_Ptr);
+ function EP is new Unchecked_Conversion (Address, Element_Ptr);
+
+ SA : Address := XA + ((Length + 0) / VU * VU
+ and (Boolean'Pos (Unaligned) - Address'(1)));
+ -- First address of argument X to start serial processing
+
+ begin
+ while XA < SA loop
+ VP (RA).all := Vector_Op (VP (XA).all);
+ XA := XA + VU;
+ RA := RA + VU;
+ end loop;
+
+ while XA < X + Length loop
+ EP (RA).all := Element_Op (EP (XA).all);
+ XA := XA + EU;
+ RA := RA + EU;
+ end loop;
+ end Unary_Operation;
+
+end System.Generic_Vector_Operations;
diff --git a/gcc/ada/s-geveop.ads b/gcc/ada/s-geveop.ads
new file mode 100644
index 00000000000..4a256fbcad2
--- /dev/null
+++ b/gcc/ada/s-geveop.ads
@@ -0,0 +1,66 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . G E N E R I C _ V E C T O R _ O P E R A T I O N S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains generic procedures for vector operations on arrays.
+-- If the arguments are aligned on word boundaries and the word size is a
+-- multiple M of the element size, the operations will be done M elements
+-- at a time using vector operations on a word.
+
+-- All routines assume argument arrays have the same length, and arguments
+-- with mode "in" do not alias arguments with mode "out" or "in out".
+-- If the number N of elements to be processed is not a multiple of M
+-- the final N rem M elements will be processed one item at a time.
+
+with System.Vectors;
+with System.Storage_Elements;
+generic
+ type Element is (<>);
+ type Index is (<>);
+ type Element_Array is array (Index range <>) of Element;
+package System.Generic_Vector_Operations is
+pragma Pure (Generic_Vector_Operations);
+
+ generic
+ with function Element_Op (X, Y : Element) return Element;
+ with function Vector_Op (X, Y : Vectors.Vector) return Vectors.Vector;
+ procedure Binary_Operation
+ (R, X, Y : System.Address;
+ Length : System.Storage_Elements.Storage_Count);
+
+ generic
+ with function Element_Op (X : Element) return Element;
+ with function Vector_Op (X : Vectors.Vector) return Vectors.Vector;
+ procedure Unary_Operation
+ (R, X : System.Address;
+ Length : System.Storage_Elements.Storage_Count);
+end System.Generic_Vector_Operations;
diff --git a/gcc/ada/s-gloloc.adb b/gcc/ada/s-gloloc.adb
index cd8b0ff2b36..92fd2ffca00 100644
--- a/gcc/ada/s-gloloc.adb
+++ b/gcc/ada/s-gloloc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,18 +26,18 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with GNAT.Task_Lock;
+with System.Soft_Links;
+-- used for Lock_Task, Unlock_Task
package body System.Global_Locks is
type String_Access is access String;
- package TSL renames GNAT.Task_Lock;
-
Dir_Separator : Character;
pragma Import (C, Dir_Separator, "__gnat_dir_separator");
@@ -64,8 +64,7 @@ package body System.Global_Locks is
-- Acquire_Lock --
------------------
- procedure Acquire_Lock
- (Lock : in out Lock_Type) is
+ procedure Acquire_Lock (Lock : in out Lock_Type) is
begin
Lock_File
(Lock_Table (Lock).Dir.all,
@@ -76,17 +75,14 @@ package body System.Global_Locks is
-- Create_Lock --
-----------------
- procedure Create_Lock
- (Lock : out Lock_Type;
- Name : in String)
- is
+ procedure Create_Lock (Lock : out Lock_Type; Name : in String) is
L : Lock_Type;
begin
- TSL.Lock;
+ System.Soft_Links.Lock_Task.all;
Last_Lock := Last_Lock + 1;
L := Last_Lock;
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
if L > Lock_Table'Last then
raise Lock_Error;
@@ -94,10 +90,8 @@ package body System.Global_Locks is
for J in reverse Name'Range loop
if Name (J) = Dir_Separator then
- Lock_Table (L).Dir
- := new String'(Name (Name'First .. J - 1));
- Lock_Table (L).File
- := new String'(Name (J + 1 .. Name'Last));
+ Lock_Table (L).Dir := new String'(Name (Name'First .. J - 1));
+ Lock_Table (L).File := new String'(Name (J + 1 .. Name'Last));
exit;
end if;
end loop;
@@ -131,9 +125,11 @@ package body System.Global_Locks is
if Try_Lock (C_Dir'Address, C_File'Address) = 1 then
return;
end if;
+
exit when I = Retries;
delay Wait;
end loop;
+
raise Lock_Error;
end Lock_File;
@@ -141,12 +137,10 @@ package body System.Global_Locks is
-- Release_Lock --
------------------
- procedure Release_Lock
- (Lock : in out Lock_Type)
- is
+ procedure Release_Lock (Lock : in out Lock_Type) is
S : aliased String :=
- Lock_Table (Lock).Dir.all & Dir_Separator &
- Lock_Table (Lock).File.all & ASCII.NUL;
+ Lock_Table (Lock).Dir.all & Dir_Separator &
+ Lock_Table (Lock).File.all & ASCII.NUL;
procedure unlink (A : System.Address);
pragma Import (C, unlink, "unlink");
diff --git a/gcc/ada/s-gloloc.ads b/gcc/ada/s-gloloc.ads
index 99c57c60022..e11473789dd 100644
--- a/gcc/ada/s-gloloc.ads
+++ b/gcc/ada/s-gloloc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -43,20 +44,17 @@ package System.Global_Locks is
-- uniquely defined between the partitions because of its name.
Null_Lock : constant Lock_Type;
+ -- This needs comments ???
- procedure Create_Lock
- (Lock : out Lock_Type;
- Name : in String);
+ procedure Create_Lock (Lock : out Lock_Type; Name : in String);
-- Create or retrieve a global lock for the current partition using
-- its Name.
- procedure Acquire_Lock
- (Lock : in out Lock_Type);
+ procedure Acquire_Lock (Lock : in out Lock_Type);
-- If the lock cannot be acquired because someone already owns it, this
-- procedure is supposed to wait and retry forever.
- procedure Release_Lock
- (Lock : in out Lock_Type);
+ procedure Release_Lock (Lock : in out Lock_Type);
private
diff --git a/gcc/ada/s-hibaen.ads b/gcc/ada/s-hibaen.ads
new file mode 100644
index 00000000000..286449f45da
--- /dev/null
+++ b/gcc/ada/s-hibaen.ads
@@ -0,0 +1,101 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . H I E _ B A C K _ E N D --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2001-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides an interface used in HI-E mode to determine
+-- whether or not the back end can handle certain constructs in a manner
+-- that is consistent with certification requirements.
+
+-- The approach is to define entities which may or may not be present in
+-- a HI-E configured library. If the entity is present then the compiler
+-- operating in HI-E mode will allow the corresponding operation. If the
+-- entity is not present, the corresponding construct will be flagged as
+-- not permitted in High Integrity mode.
+
+-- The default version of this unit delivered with the HI-E compiler is
+-- configured in a manner appropriate for the target, but it is possible
+-- to reconfigure the run-time to change the settings as required.
+
+-- This unit is not used and never accessed by the compiler unless it is
+-- operating in HI-E mode, so the settings are irrelevant. However, we
+-- do include a standard version with all entities present in the standard
+-- run-time for use when pragma No_Run_Time is specified.
+
+package System.HIE_Back_End is
+
+ type Dummy is null record;
+ pragma Suppress_Initialization (Dummy);
+ -- This is the type used for the entities below. No properties of this
+ -- type are ever referenced, and in particular, the entities are defined
+ -- as variables, but their values are never referenced
+
+ HIE_64_Bit_Divides : Dummy;
+ -- This entity controls whether the front end allows 64-bit integer
+ -- divide operations, including the case where division of 32-bit
+ -- fixed-point operands requires 64-bit arithmetic. This can safely
+ -- be set as High_Integrity on 64-bit machines which provide this
+ -- operation as a native instruction, but on most 32-bit machines
+ -- a run time call (e.g. to __divdi3 in gcclib) is required. If a
+ -- certifiable version of this routine is available, then setting
+ -- this entity to High_Integrity with a pragma will cause appropriate
+ -- calls to be generated, allowing 64-bit integer division operations.
+
+ HIE_Long_Shifts : Dummy;
+ -- This entity controls whether the front end allows generation of
+ -- long shift instructions, i.e. shifts that operate on 64-bit values.
+ -- Such shifts are required for the implementation of fixed-point
+ -- types longer than 32 bits. This can safetly be set as High_Integrity
+ -- on 64-bit machines that provide this operation at the hardware level,
+ -- but on some 32-bit machines a run time call is required. If there
+ -- is a certifiable version available of the relevant run-time routines,
+ -- then setting this entity to High_Integrity with a pragma will cause
+ -- appropriate calls to be generated, allowing the declaration and use
+ -- of fixed-point types longer than 32 bits.
+
+ HIE_Aggregates : Dummy;
+ -- In the general case, the use of aggregates may generate calls
+ -- to run-time routines in the C library, including memset, memcpy,
+ -- memmove, and bcopy. This entity can be set to High_Integrity with
+ -- a pragma if certifiable versions of all these routines are available,
+ -- in which case aggregates are permitted in HI-E mode. Otherwise the
+ -- HI-E compiler will reject any use of aggregates.
+
+ HIE_Composite_Assignments : Dummy;
+ -- The assignment of composite objects other than small records and
+ -- arrays whose size is 64-bits or less and is set by an explicit
+ -- size clause may generate calls to memcpy, memmove, and bcopy.
+ -- If certifiable versions of all these routines are available, then
+ -- this entity may be set to High_Integrity using a pragma, in which
+ -- case such assignments are permitted. Otherwise the HI-E compiler
+ -- will reject any such composite assignments.
+
+end System.HIE_Back_End;
diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb
new file mode 100644
index 00000000000..2d2b422a0c1
--- /dev/null
+++ b/gcc/ada/s-htable.adb
@@ -0,0 +1,362 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . H T A B L E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1995-2002 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Deallocation;
+
+package body System.HTable is
+
+ --------------------
+ -- Static_HTable --
+ --------------------
+
+ package body Static_HTable is
+
+ Table : array (Header_Num) of Elmt_Ptr;
+
+ Iterator_Index : Header_Num;
+ Iterator_Ptr : Elmt_Ptr;
+ Iterator_Started : Boolean := False;
+
+ function Get_Non_Null return Elmt_Ptr;
+ -- Returns Null_Ptr if Iterator_Started is false of the Table is
+ -- empty. Returns Iterator_Ptr if non null, or the next non null
+ -- element in table if any.
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get (K : Key) return Elmt_Ptr is
+ Elmt : Elmt_Ptr;
+
+ begin
+ Elmt := Table (Hash (K));
+
+ loop
+ if Elmt = Null_Ptr then
+ return Null_Ptr;
+
+ elsif Equal (Get_Key (Elmt), K) then
+ return Elmt;
+
+ else
+ Elmt := Next (Elmt);
+ end if;
+ end loop;
+ end Get;
+
+ ---------------
+ -- Get_First --
+ ---------------
+
+ function Get_First return Elmt_Ptr is
+ begin
+ Iterator_Started := True;
+ Iterator_Index := Table'First;
+ Iterator_Ptr := Table (Iterator_Index);
+ return Get_Non_Null;
+ end Get_First;
+
+ --------------
+ -- Get_Next --
+ --------------
+
+ function Get_Next return Elmt_Ptr is
+ begin
+ if not Iterator_Started then
+ return Null_Ptr;
+ end if;
+
+ Iterator_Ptr := Next (Iterator_Ptr);
+ return Get_Non_Null;
+ end Get_Next;
+
+ ------------------
+ -- Get_Non_Null --
+ ------------------
+
+ function Get_Non_Null return Elmt_Ptr is
+ begin
+ while Iterator_Ptr = Null_Ptr loop
+ if Iterator_Index = Table'Last then
+ Iterator_Started := False;
+ return Null_Ptr;
+ end if;
+
+ Iterator_Index := Iterator_Index + 1;
+ Iterator_Ptr := Table (Iterator_Index);
+ end loop;
+
+ return Iterator_Ptr;
+ end Get_Non_Null;
+
+ ------------
+ -- Remove --
+ ------------
+
+ procedure Remove (K : Key) is
+ Index : constant Header_Num := Hash (K);
+ Elmt : Elmt_Ptr;
+ Next_Elmt : Elmt_Ptr;
+
+ begin
+ Elmt := Table (Index);
+
+ if Elmt = Null_Ptr then
+ return;
+
+ elsif Equal (Get_Key (Elmt), K) then
+ Table (Index) := Next (Elmt);
+
+ else
+ loop
+ Next_Elmt := Next (Elmt);
+
+ if Next_Elmt = Null_Ptr then
+ return;
+
+ elsif Equal (Get_Key (Next_Elmt), K) then
+ Set_Next (Elmt, Next (Next_Elmt));
+ return;
+
+ else
+ Elmt := Next_Elmt;
+ end if;
+ end loop;
+ end if;
+ end Remove;
+
+ -----------
+ -- Reset --
+ -----------
+
+ procedure Reset is
+ begin
+ for J in Table'Range loop
+ Table (J) := Null_Ptr;
+ end loop;
+ end Reset;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (E : Elmt_Ptr) is
+ Index : Header_Num;
+
+ begin
+ Index := Hash (Get_Key (E));
+ Set_Next (E, Table (Index));
+ Table (Index) := E;
+ end Set;
+
+ end Static_HTable;
+
+ --------------------
+ -- Simple_HTable --
+ --------------------
+
+ package body Simple_HTable is
+
+ type Element_Wrapper;
+ type Elmt_Ptr is access all Element_Wrapper;
+ type Element_Wrapper is record
+ K : Key;
+ E : Element;
+ Next : Elmt_Ptr;
+ end record;
+
+ procedure Free is new
+ Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
+
+ procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
+ function Next (E : Elmt_Ptr) return Elmt_Ptr;
+ function Get_Key (E : Elmt_Ptr) return Key;
+
+ package Tab is new Static_HTable (
+ Header_Num => Header_Num,
+ Element => Element_Wrapper,
+ Elmt_Ptr => Elmt_Ptr,
+ Null_Ptr => null,
+ Set_Next => Set_Next,
+ Next => Next,
+ Key => Key,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => Equal);
+
+ ---------
+ -- Get --
+ ---------
+
+ function Get (K : Key) return Element is
+ Tmp : constant Elmt_Ptr := Tab.Get (K);
+
+ begin
+ if Tmp = null then
+ return No_Element;
+ else
+ return Tmp.E;
+ end if;
+ end Get;
+
+ ---------------
+ -- Get_First --
+ ---------------
+
+ function Get_First return Element is
+ Tmp : constant Elmt_Ptr := Tab.Get_First;
+
+ begin
+ if Tmp = null then
+ return No_Element;
+ else
+ return Tmp.E;
+ end if;
+ end Get_First;
+
+ -------------
+ -- Get_Key --
+ -------------
+
+ function Get_Key (E : Elmt_Ptr) return Key is
+ begin
+ return E.K;
+ end Get_Key;
+
+ --------------
+ -- Get_Next --
+ --------------
+
+ function Get_Next return Element is
+ Tmp : constant Elmt_Ptr := Tab.Get_Next;
+
+ begin
+ if Tmp = null then
+ return No_Element;
+ else
+ return Tmp.E;
+ end if;
+ end Get_Next;
+
+ ----------
+ -- Next --
+ ----------
+
+ function Next (E : Elmt_Ptr) return Elmt_Ptr is
+ begin
+ return E.Next;
+ end Next;
+
+ ------------
+ -- Remove --
+ ------------
+
+ procedure Remove (K : Key) is
+ Tmp : Elmt_Ptr;
+
+ begin
+ Tmp := Tab.Get (K);
+
+ if Tmp /= null then
+ Tab.Remove (K);
+ Free (Tmp);
+ end if;
+ end Remove;
+
+ -----------
+ -- Reset --
+ -----------
+
+ procedure Reset is
+ E1, E2 : Elmt_Ptr;
+
+ begin
+ E1 := Tab.Get_First;
+ while E1 /= null loop
+ E2 := Tab.Get_Next;
+ Free (E1);
+ E1 := E2;
+ end loop;
+
+ Tab.Reset;
+ end Reset;
+
+ ---------
+ -- Set --
+ ---------
+
+ procedure Set (K : Key; E : Element) is
+ Tmp : constant Elmt_Ptr := Tab.Get (K);
+
+ begin
+ if Tmp = null then
+ Tab.Set (new Element_Wrapper'(K, E, null));
+ else
+ Tmp.E := E;
+ end if;
+ end Set;
+
+ --------------
+ -- Set_Next --
+ --------------
+
+ procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
+ begin
+ E.Next := Next;
+ end Set_Next;
+ end Simple_HTable;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (Key : String) return Header_Num is
+
+ type Uns is mod 2 ** 32;
+
+ function Rotate_Left (Value : Uns; Amount : Natural) return Uns;
+ pragma Import (Intrinsic, Rotate_Left);
+
+ Tmp : Uns := 0;
+
+ begin
+ for J in Key'Range loop
+ Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J));
+ end loop;
+
+ return Header_Num'First +
+ Header_Num'Base (Tmp mod Header_Num'Range_Length);
+ end Hash;
+
+end System.HTable;
diff --git a/gcc/ada/s-htable.ads b/gcc/ada/s-htable.ads
new file mode 100644
index 00000000000..ae1764a3681
--- /dev/null
+++ b/gcc/ada/s-htable.ads
@@ -0,0 +1,198 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . H T A B L E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1995-2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Hash table searching routines
+
+-- This package contains two separate packages. The Simple_HTable package
+-- provides a very simple abstraction that associates one element to one
+-- key value and takes care of all allocations automatically using the heap.
+-- The Static_HTable package provides a more complex interface that allows
+-- complete control over allocation.
+
+package System.HTable is
+pragma Preelaborate (HTable);
+
+ -------------------
+ -- Simple_HTable --
+ -------------------
+
+ -- A simple hash table abstraction, easy to instantiate, easy to use.
+ -- The table associates one element to one key with the procedure Set.
+ -- Get retrieves the Element stored for a given Key. The efficiency of
+ -- retrieval is function of the size of the Table parameterized by
+ -- Header_Num and the hashing function Hash.
+
+ generic
+ type Header_Num is range <>;
+ -- An integer type indicating the number and range of hash headers.
+
+ type Element is private;
+ -- The type of element to be stored
+
+ No_Element : Element;
+ -- The object that is returned by Get when no element has been set for
+ -- a given key
+
+ type Key is private;
+ with function Hash (F : Key) return Header_Num;
+ with function Equal (F1, F2 : Key) return Boolean;
+
+ package Simple_HTable is
+
+ procedure Set (K : Key; E : Element);
+ -- Associates an element with a given key. Overrides any previously
+ -- associated element.
+
+ procedure Reset;
+ -- Removes and frees all elements in the table
+
+ function Get (K : Key) return Element;
+ -- Returns the Element associated with a key or No_Element if the
+ -- given key has not associated element
+
+ procedure Remove (K : Key);
+ -- Removes the latest inserted element pointer associated with the
+ -- given key if any, does nothing if none.
+
+ function Get_First return Element;
+ -- Returns No_Element if the HTable is empty, otherwise returns one
+ -- non specified element. There is no guarantee that 2 calls to this
+ -- function will return the same element.
+
+ function Get_Next return Element;
+ -- Returns a non-specified element that has not been returned by the
+ -- same function since the last call to Get_First or No_Element if
+ -- there is no such element. If there is no call to 'Set' in between
+ -- Get_Next calls, all the elements of the HTable will be traversed.
+ end Simple_HTable;
+
+ -------------------
+ -- Static_HTable --
+ -------------------
+
+ -- A low-level Hash-Table abstraction, not as easy to instantiate as
+ -- Simple_HTable but designed to allow complete control over the
+ -- allocation of necessary data structures. Particularly useful when
+ -- dynamic allocation is not desired. The model is that each Element
+ -- contains its own Key that can be retrieved by Get_Key. Furthermore,
+ -- Element provides a link that can be used by the HTable for linking
+ -- elements with same hash codes:
+
+ -- Element
+
+ -- +-------------------+
+ -- | Key |
+ -- +-------------------+
+ -- : other data :
+ -- +-------------------+
+ -- | Next Elmt |
+ -- +-------------------+
+
+ generic
+ type Header_Num is range <>;
+ -- An integer type indicating the number and range of hash headers.
+
+ type Element (<>) is limited private;
+ -- The type of element to be stored. This is historically part of the
+ -- interface, even though it is not used at all in the operations of
+ -- the package.
+
+ pragma Warnings (Off, Element);
+ -- We have to kill warnings here, because Element is and always
+ -- has been unreferenced, but we cannot remove it at this stage,
+ -- since this unit is in wide use, and it certainly seems harmless.
+
+ type Elmt_Ptr is private;
+ -- The type used to reference an element (will usually be an access
+ -- type, but could be some other form of type such as an integer type).
+
+ Null_Ptr : Elmt_Ptr;
+ -- The null value of the Elmt_Ptr type.
+
+ with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
+ with function Next (E : Elmt_Ptr) return Elmt_Ptr;
+ -- The type must provide an internal link for the sake of the
+ -- staticness of the HTable.
+
+ type Key is limited private;
+ with function Get_Key (E : Elmt_Ptr) return Key;
+ with function Hash (F : Key) return Header_Num;
+ with function Equal (F1, F2 : Key) return Boolean;
+
+ package Static_HTable is
+
+ procedure Reset;
+ -- Resets the hash table by setting all its elements to Null_Ptr. The
+ -- effect is to clear the hash table so that it can be reused. For the
+ -- most common case where Elmt_Ptr is an access type, and Null_Ptr is
+ -- null, this is only needed if the same table is reused in a new
+ -- context. If Elmt_Ptr is other than an access type, or Null_Ptr is
+ -- other than null, then Reset must be called before the first use
+ -- of the hash table.
+
+ procedure Set (E : Elmt_Ptr);
+ -- Insert the element pointer in the HTable
+
+ function Get (K : Key) return Elmt_Ptr;
+ -- Returns the latest inserted element pointer with the given Key
+ -- or null if none.
+
+ procedure Remove (K : Key);
+ -- Removes the latest inserted element pointer associated with the
+ -- given key if any, does nothing if none.
+
+ function Get_First return Elmt_Ptr;
+ -- Returns Null_Ptr if the HTable is empty, otherwise returns one
+ -- non specified element. There is no guarantee that 2 calls to this
+ -- function will return the same element.
+
+ function Get_Next return Elmt_Ptr;
+ -- Returns a non-specified element that has not been returned by the
+ -- same function since the last call to Get_First or Null_Ptr if
+ -- there is no such element or Get_First has bever been called. If
+ -- there is no call to 'Set' in between Get_Next calls, all the
+ -- elements of the HTable will be traversed.
+
+ end Static_HTable;
+
+ ----------
+ -- Hash --
+ ----------
+
+ -- A generic hashing function working on String keys
+
+ generic
+ type Header_Num is range <>;
+ function Hash (Key : String) return Header_Num;
+
+end System.HTable;
diff --git a/gcc/ada/s-imgdec.adb b/gcc/ada/s-imgdec.adb
index 86a64b1ff72..6da73666dcb 100644
--- a/gcc/ada/s-imgdec.adb
+++ b/gcc/ada/s-imgdec.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/s-imgenu.adb b/gcc/ada/s-imgenu.adb
index 17d8e74c624..3b7ab8fa962 100644
--- a/gcc/ada/s-imgenu.adb
+++ b/gcc/ada/s-imgenu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -54,8 +54,8 @@ package body System.Img_Enum is
IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
- Start : Natural := Natural (IndexesT (Pos));
- Next : Natural := Natural (IndexesT (Pos + 1));
+ Start : constant Natural := Natural (IndexesT (Pos));
+ Next : constant Natural := Natural (IndexesT (Pos + 1));
subtype Result_Type is String (1 .. Next - Start);
-- We need this result type to force the result to have the
@@ -84,8 +84,8 @@ package body System.Img_Enum is
IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
- Start : Natural := Natural (IndexesT (Pos));
- Next : Natural := Natural (IndexesT (Pos + 1));
+ Start : constant Natural := Natural (IndexesT (Pos));
+ Next : constant Natural := Natural (IndexesT (Pos + 1));
subtype Result_Type is String (1 .. Next - Start);
-- We need this result type to force the result to have the
@@ -114,8 +114,8 @@ package body System.Img_Enum is
IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
- Start : Natural := Natural (IndexesT (Pos));
- Next : Natural := Natural (IndexesT (Pos + 1));
+ Start : constant Natural := Natural (IndexesT (Pos));
+ Next : constant Natural := Natural (IndexesT (Pos + 1));
subtype Result_Type is String (1 .. Next - Start);
-- We need this result type to force the result to have the
diff --git a/gcc/ada/s-imgrea.adb b/gcc/ada/s-imgrea.adb
index 89bbccef576..a214da52852 100644
--- a/gcc/ada/s-imgrea.adb
+++ b/gcc/ada/s-imgrea.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -87,7 +87,18 @@ package body System.Img_Real is
S : String (1 .. Long_Long_Float'Width);
begin
- if not Is_Negative (V) then
+ -- Decide wether a blank should be prepended before the call to
+ -- Set_Image_Real. We generate a blank for positive values, and
+ -- also for positive zeroes. For negative zeroes, we generate a
+ -- space only if Signed_Zeroes is True (the RM only permits the
+ -- output of -0.0 on targets where this is the case). We can of
+ -- course still see a -0.0 on a target where Signed_Zeroes is
+ -- False (since this attribute refers to the proper handling of
+ -- negative zeroes, not to their existence).
+
+ if not Is_Negative (V)
+ or else (not Long_Long_Float'Signed_Zeros and then V = -0.0)
+ then
S (1) := ' ';
P := 1;
end if;
@@ -466,6 +477,47 @@ package body System.Img_Real is
Reset;
Scale := 0;
+ -- Deal with invalid values first,
+
+ if not V'Valid then
+
+ -- Note that we're taking our chances here, as V might be
+ -- an invalid bit pattern resulting from erroneous execution
+ -- (caused by using uninitialized variables for example).
+
+ -- No matter what, we'll at least get reasonable behaviour,
+ -- converting to infinity or some other value, or causing an
+ -- exception to be raised is fine.
+
+ -- If the following test succeeds, then we definitely have
+ -- an infinite value, so we print Inf.
+
+ if V > Long_Long_Float'Last then
+ Set ('+');
+ Set ('I');
+ Set ('n');
+ Set ('f');
+ Set_Special_Fill (4);
+
+ -- In all other cases we print NaN
+
+ elsif V < Long_Long_Float'First then
+ Set ('-');
+ Set ('I');
+ Set ('n');
+ Set ('f');
+ Set_Special_Fill (4);
+
+ else
+ Set ('N');
+ Set ('a');
+ Set ('N');
+ Set_Special_Fill (3);
+ end if;
+
+ return;
+ end if;
+
-- Positive values
if V > 0.0 then
@@ -499,44 +551,22 @@ package body System.Img_Real is
end if;
return;
- end if;
-
- -- Deal with invalid values
-
- if not X'Valid then
-
- -- Note that we're taking our chances here, as X might be
- -- an invalid bit pattern resulting from erroneous execution
- -- (caused by using uninitialized variables for example).
-
- -- No matter what, we'll at least get reasonable behaviour,
- -- converting to infinity or some other value, or causing an
- -- exception to be raised is fine.
-
- -- If the following test succeeds, then we definitely have
- -- an infinite value, so we print Inf.
-
- if X > Long_Long_Float'Last then
- Set (Sign);
- Set ('I');
- Set ('n');
- Set ('f');
- Set_Special_Fill (4);
- -- In all other cases we print NaN
+ else
+ -- It should not be possible for a NaN to end up here.
+ -- Either the 'Valid test has failed, or we have some form
+ -- of erroneous execution. Raise Constraint_Error instead of
+ -- attempting to go ahead printing the value.
- else
- Set ('N');
- Set ('a');
- Set ('N');
- Set_Special_Fill (3);
- end if;
+ raise Constraint_Error;
+ end if;
- return;
+ -- X and Sign are set here, and X is known to be a valid,
+ -- non-zero floating-point number.
-- Case of non-zero value with Exp = 0
- elsif Exp = 0 then
+ if Exp = 0 then
-- First step is to multiply by 10 ** Nfrac to get an integer
-- value to be output, an then add 0.5 to round the result.
diff --git a/gcc/ada/s-imgwch.adb b/gcc/ada/s-imgwch.adb
index 9765b6abf60..61bf08fa130 100644
--- a/gcc/ada/s-imgwch.adb
+++ b/gcc/ada/s-imgwch.adb
@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1998, 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- --
diff --git a/gcc/ada/s-inmaop.ads b/gcc/ada/s-inmaop.ads
index 42538f444d5..d83f12184af 100644
--- a/gcc/ada/s-inmaop.ads
+++ b/gcc/ada/s-inmaop.ads
@@ -28,7 +28,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb
index a0a1ad57552..dc578bc1ce0 100644
--- a/gcc/ada/s-interr.adb
+++ b/gcc/ada/s-interr.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. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -135,7 +135,6 @@ package body System.Interrupts is
use Tasking;
use Ada.Exceptions;
- package PRI renames System.Task_Primitives;
package POP renames System.Task_Primitives.Operations;
package PIO renames System.Task_Primitives.Interrupt_Operations;
package IMNG renames System.Interrupt_Management;
@@ -191,6 +190,11 @@ package body System.Interrupts is
task type Server_Task (Interrupt : Interrupt_ID) is
pragma Priority (System.Interrupt_Priority'Last);
+ -- Note: the above pragma Priority is strictly speaking improper
+ -- since it is outside the range of allowed priorities, but the
+ -- compiler treats system units specially and does not apply
+ -- this range checking rule to system units.
+
end Server_Task;
type Server_Task_Access is access Server_Task;
@@ -370,8 +374,8 @@ package body System.Interrupts is
-- detach handlers attached through pragma Attach_Handler.
procedure Detach_Handler
- (Interrupt : in Interrupt_ID;
- Static : in Boolean := False)
+ (Interrupt : Interrupt_ID;
+ Static : Boolean := False)
is
begin
if Is_Reserved (Interrupt) then
@@ -406,9 +410,9 @@ package body System.Interrupts is
procedure Exchange_Handler
(Old_Handler : out Parameterless_Handler;
- New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean := False)
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean := False)
is
begin
if Is_Reserved (Interrupt) then
@@ -429,6 +433,7 @@ package body System.Interrupts is
begin
-- ??? loop to be executed only when we're not doing library level
-- finalization, since in this case all interrupt tasks are gone.
+
if not Interrupt_Manager'Terminated then
for N in reverse Object.Previous_Handlers'Range loop
Interrupt_Manager.Attach_Handler
@@ -447,8 +452,14 @@ package body System.Interrupts is
-- Has_Interrupt_Or_Attach_Handler --
-------------------------------------
+ -- Need comments as to why these always return True
+
function Has_Interrupt_Or_Attach_Handler
- (Object : access Dynamic_Interrupt_Protection) return Boolean is
+ (Object : access Dynamic_Interrupt_Protection)
+ return Boolean
+ is
+ pragma Unreferenced (Object);
+
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
@@ -457,6 +468,8 @@ package body System.Interrupts is
(Object : access Static_Interrupt_Protection)
return Boolean
is
+ pragma Unreferenced (Object);
+
begin
return True;
end Has_Interrupt_Or_Attach_Handler;
@@ -481,7 +494,7 @@ package body System.Interrupts is
procedure Install_Handlers
(Object : access Static_Interrupt_Protection;
- New_Handlers : in New_Handler_Array)
+ New_Handlers : New_Handler_Array)
is
begin
for N in New_Handlers'Range loop
@@ -712,7 +725,6 @@ package body System.Interrupts is
Intwait_Mask : aliased IMNG.Interrupt_Mask;
Ret_Interrupt : Interrupt_ID;
Old_Mask : aliased IMNG.Interrupt_Mask;
- Self_ID : Task_ID := POP.Self;
Old_Handler : Parameterless_Handler;
---------------------
@@ -731,14 +743,14 @@ package body System.Interrupts is
procedure Unprotected_Exchange_Handler
(Old_Handler : out Parameterless_Handler;
- New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean;
- Restoration : in Boolean := False);
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False);
procedure Unprotected_Detach_Handler
- (Interrupt : in Interrupt_ID;
- Static : in Boolean);
+ (Interrupt : Interrupt_ID;
+ Static : Boolean);
------------------
-- Bind_Handler --
@@ -806,8 +818,8 @@ package body System.Interrupts is
--------------------------------
procedure Unprotected_Detach_Handler
- (Interrupt : in Interrupt_ID;
- Static : in Boolean)
+ (Interrupt : Interrupt_ID;
+ Static : Boolean)
is
Old_Handler : Parameterless_Handler;
@@ -857,12 +869,13 @@ package body System.Interrupts is
procedure Unprotected_Exchange_Handler
(Old_Handler : out Parameterless_Handler;
- New_Handler : in Parameterless_Handler;
- Interrupt : in Interrupt_ID;
- Static : in Boolean;
- Restoration : in Boolean := False) is
+ New_Handler : Parameterless_Handler;
+ Interrupt : Interrupt_ID;
+ Static : Boolean;
+ Restoration : Boolean := False) is
begin
if User_Entry (Interrupt).T /= Null_Task then
+
-- In case we have an Interrupt Entry already installed.
-- raise a program error. (propagate it to the caller).
@@ -870,10 +883,10 @@ package body System.Interrupts is
"An interrupt is already installed");
end if;
- -- Note : A null handler with Static = True will
- -- pass the following check. That is the case when we want to
- -- Detach a handler regardless of the Static status
- -- of the current_Handler.
+ -- Note : A null handler with Static = True will pass the
+ -- following check. That is the case when we want to Detach a
+ -- handler regardless of the Static status of the current_Handler.
+
-- We don't check anything if Restoration is True, since we
-- may be detaching a static handler to restore a dynamic one.
@@ -981,7 +994,7 @@ package body System.Interrupts is
-- Abort_Task_Interrupt is one of the Interrupt unmasked
-- in all tasks. We mask the Interrupt in this particular task
- -- so that "sigwait" is possible to catch an explicitly sent
+ -- so that "sigwait" is possible to catch an explicitely sent
-- Abort_Task_Interrupt from the Server_Tasks.
-- This sigwaiting is needed so that we make sure a Server_Task is
@@ -1061,7 +1074,7 @@ package body System.Interrupts is
-- it was ever ignored.
Ignored (Interrupt) := False;
- User_Entry (Interrupt) := Entry_Assoc' (T => T, E => E);
+ User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
-- Indicate the attachment of Interrupt Entry in ATCB.
-- This is need so that when an Interrupt Entry task
@@ -1263,7 +1276,7 @@ package body System.Interrupts is
-- Abort_Task_Interrupt is one of the Interrupt unmasked
-- in all tasks. We mask the Interrupt in this particular task
- -- so that "sigwait" is possible to catch an explicitly sent
+ -- so that "sigwait" is possible to catch an explicitely sent
-- Abort_Task_Interrupt from the Interrupt_Manager.
-- There are two Interrupt interrupts that this task catch through
diff --git a/gcc/ada/s-interr.ads b/gcc/ada/s-interr.ads
index b91932162d5..8a97735b5ce 100644
--- a/gcc/ada/s-interr.ads
+++ b/gcc/ada/s-interr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -73,6 +73,12 @@ package System.Interrupts is
type Interrupt_ID is range 0 .. System.OS_Interface.Max_Interrupt;
+ -- The following renaming is introduced so that the type is accessible
+ -- through rtsfind, otherwise the name clashes with its homonym in
+ -- ada.interrupts.
+
+ subtype System_Interrupt_Id is Interrupt_ID;
+
type Parameterless_Handler is access protected procedure;
----------------------
diff --git a/gcc/ada/s-intman.ads b/gcc/ada/s-intman.ads
index 306df161741..2353c9b29bf 100644
--- a/gcc/ada/s-intman.ads
+++ b/gcc/ada/s-intman.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,36 +27,36 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
--- This package encapsulates and centralizes information about
--- all uses of interrupts (or signals), including the
--- target-dependent mapping of interrupts (or signals) to exceptions.
+-- This package encapsulates and centralizes information about all
+-- uses of interrupts (or signals), including the target-dependent
+-- mapping of interrupts (or signals) to exceptions.
--- PLEASE DO NOT add any with-clauses to this package.
--- This is designed to work for both tasking and non-tasking systems,
--- without pulling in any of the tasking support.
+-- Unlike the original design, System.Interrupt_Management can only
+-- be used for tasking systems.
-- PLEASE DO NOT remove the Elaborate_Body pragma from this package.
-- Elaboration of this package should happen early, as most other
--- initializations depend on it.
--- Forcing immediate elaboration of the body also helps to enforce
--- the design assumption that this is a second-level
--- package, just one level above System.OS_Interface, with no
--- cross-dependences.
+-- initializations depend on it. Forcing immediate elaboration of
+-- the body also helps to enforce the design assumption that this
+-- is a second-level package, just one level above System.OS_Interface
+-- with no cross-dependencies.
-- PLEASE DO NOT put any subprogram declarations with arguments of
--- type Interrupt_ID into the visible part of this package.
--- The type Interrupt_ID is used to derive the type in Ada.Interrupts,
--- and adding more operations to that type would be illegal according
--- to the Ada Reference Manual. (This is the reason why the signals sets
--- below are implemented as visible arrays rather than functions.)
+-- type Interrupt_ID into the visible part of this package. The type
+-- Interrupt_ID is used to derive the type in Ada.Interrupts, and
+-- adding more operations to that type would be illegal according
+-- to the Ada Reference Manual. This is the reason why the signals
+-- sets are implemeneted using visible arrays rather than functions.
with System.OS_Interface;
--- used for Signal
--- sigset_t
+-- used for sigset_t
+
+with Interfaces.C;
+-- used for int
package System.Interrupt_Management is
@@ -64,53 +64,44 @@ package System.Interrupt_Management is
type Interrupt_Mask is limited private;
- type Interrupt_ID is new System.OS_Interface.Signal;
+ type Interrupt_ID is new Interfaces.C.int
+ range 0 .. System.OS_Interface.Max_Interrupt;
type Interrupt_Set is array (Interrupt_ID) of Boolean;
-- The following objects serve as constants, but are initialized
- -- in the body to aid portability. This permits us
- -- to use more portable names for interrupts,
- -- where distinct names may map to the same interrupt ID value.
+ -- in the body to aid portability. This permits us to use more
+ -- portable names for interrupts, where distinct names may map to
+ -- the same interrupt ID value.
+ --
-- For example, suppose SIGRARE is a signal that is not defined on
- -- all systems, but is always reserved when it is defined.
- -- If we have the convention that ID zero is not used for any "real"
+ -- all systems, but is always reserved when it is defined. If we
+ -- have the convention that ID zero is not used for any "real"
-- signals, and SIGRARE = 0 when SIGRARE is not one of the locally
-- supported signals, we can write
-- Reserved (SIGRARE) := true;
-- and the initialization code will be portable.
Abort_Task_Interrupt : Interrupt_ID;
- -- The interrupt that is used to implement task abortion,
- -- if an interrupt is used for that purpose.
- -- This is one of the reserved interrupts.
+ -- The interrupt that is used to implement task abortion if
+ -- an interrupt is used for that purpose. This is one of the
+ -- reserved interrupts.
Keep_Unmasked : Interrupt_Set := (others => False);
- -- Keep_Unmasked (I) is true iff the interrupt I is
- -- one that must be kept unmasked at all times,
- -- except (perhaps) for short critical sections.
- -- This includes interrupts that are mapped to exceptions
- -- (see System.Interrupt_Exceptions.Is_Exception), but may also
- -- include interrupts (e.g. timer) that need to be kept unmasked
- -- for other reasons.
- -- Where interrupts are implemented as OS signals, and signal masking
- -- is per-task, the interrupt should be unmasked in ALL TASKS.
+ -- Keep_Unmasked (I) is true iff the interrupt I is one that must
+ -- that must be kept unmasked at all times, except (perhaps) for
+ -- short critical sections. This includes interrupts that are
+ -- mapped to exceptions (see System.Interrupt_Exceptions.Is_Exception),
+ -- but may also include interrupts (e.g. timer) that need to be kept
+ -- unmasked for other reasons. Where interrupts are implemented as
+ -- OS signals, and signal masking is per-task, the interrupt should
+ -- be unmasked in ALL TASKS.
Reserve : Interrupt_Set := (others => False);
- -- Reserve (I) is true iff the interrupt I is one that
- -- cannot be permitted to be attached to a user handler.
- -- The possible reasons are many. For example,
- -- it may be mapped to an exception, used to implement task abortion,
- -- or used to implement time delays.
-
- Keep_Masked : Interrupt_Set := (others => False);
- -- Keep_Masked (I) is true iff the interrupt I must always be masked.
- -- Where interrupts are implemented as OS signals, and signal masking
- -- is per-task, the interrupt should be masked in ALL TASKS.
- -- There might not be any interrupts in this class, depending on
- -- the environment. For example, if interrupts are OS signals
- -- and signal masking is per-task, use of the sigwait operation
- -- requires the signal be masked in all tasks.
+ -- Reserve (I) is true iff the interrupt I is one that cannot be
+ -- permitted to be attached to a user handler. The possible reasons
+ -- are many. For example, it may be mapped to an exception used to
+ -- implement task abortion, or used to implement time delays.
procedure Initialize_Interrupts;
-- On systems where there is no signal inheritance between tasks (e.g
@@ -120,6 +111,7 @@ package System.Interrupt_Management is
private
type Interrupt_Mask is new System.OS_Interface.sigset_t;
- -- in some implementation Interrupt_Mask can be represented
+ -- In some implementation Interrupt_Mask can be represented
-- as a linked list.
+
end System.Interrupt_Management;
diff --git a/gcc/ada/s-maccod.ads b/gcc/ada/s-maccod.ads
index 0be10349bf8..b08c3bb17b2 100644
--- a/gcc/ada/s-maccod.ads
+++ b/gcc/ada/s-maccod.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 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- --
diff --git a/gcc/ada/s-mastop.adb b/gcc/ada/s-mastop.adb
index fa77d641fda..65e2e3a6bc6 100644
--- a/gcc/ada/s-mastop.adb
+++ b/gcc/ada/s-mastop.adb
@@ -28,7 +28,7 @@
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-mastop.ads b/gcc/ada/s-mastop.ads
index 53e11b4aea2..960707d6fbe 100644
--- a/gcc/ada/s-mastop.ads
+++ b/gcc/ada/s-mastop.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-memcop.ads b/gcc/ada/s-memcop.ads
new file mode 100644
index 00000000000..d71d48f17ca
--- /dev/null
+++ b/gcc/ada/s-memcop.ads
@@ -0,0 +1,76 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M E M O R Y _ C O P Y --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides general block copy mechanisms analgous to those
+-- provided by the C routines memcpy and memmove allowing for copies with
+-- and without possible overflow.
+
+package System.Memory_Copy is
+pragma Preelaborate;
+
+ type size_t is mod 2 ** Standard'Address_Size;
+ -- Note: the reason we redefine this here instead of using the
+ -- definition in Interfaces.C is that we do not want to drag in
+ -- all of Interfaces.C just because System.Memory_Copy is used.
+
+ procedure memcpy (S1 : Address; S2 : Address; N : size_t);
+ -- Copies N storage units from area starting at S2 to area starting
+ -- at S1 without any check for buffer overflow. The memory areas
+ -- must not overlap, or the result of this call is undefined.
+
+ procedure memmove (S1 : Address; S2 : Address; N : size_t);
+ -- Copies N storage units from area starting at S2 to area starting
+ -- at S1 without any check for buffer overflow. The difference between
+ -- this memmove and memcpy is that with memmove, the storage areas may
+ -- overlap (forwards or backwards) and the result is correct (i.e. it
+ -- is as if S2 is first moved to a temporary area, and then this area
+ -- is copied to S1 in a separate step).
+
+private
+
+ -- In the standard library, these are just interfaced to the C routines.
+ -- But in the HI-E (high integrity version) they may be reprogrammed to
+ -- meet certification requirements (and marked High_Integrity).
+
+ -- Note that in high integrity mode these routines are by default not
+ -- available, and the HI-E compiler will as a result generate implicit
+ -- loops (which will violate the restriction No_Implicit_Loops).
+
+ pragma Import (C, memcpy, "memcpy");
+ pragma Import (C, memmove, "memmove");
+
+end System.Memory_Copy;
diff --git a/gcc/ada/s-memory.adb b/gcc/ada/s-memory.adb
index aff4623e31d..cdbb22e8908 100644
--- a/gcc/ada/s-memory.adb
+++ b/gcc/ada/s-memory.adb
@@ -4,13 +4,9 @@
-- --
-- S Y S T E M . M E M O R Y --
-- --
--- S p e c --
+-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
+-- Copyright (C) 2001-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- --
@@ -128,7 +124,7 @@ package body System.Memory is
return System.Address
is
Result : System.Address;
- Actual_Size : size_t := Size;
+ Actual_Size : constant size_t := Size;
begin
if Size = size_t'Last then
diff --git a/gcc/ada/s-memory.ads b/gcc/ada/s-memory.ads
index 16742357209..d1203381460 100644
--- a/gcc/ada/s-memory.ads
+++ b/gcc/ada/s-memory.ads
@@ -6,11 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
+-- Copyright (C) 2001-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- --
@@ -43,28 +39,70 @@
-- that the ali and object files for this unit are found in the object
-- search path.
+-- This unit may be used directly from an application program by providing
+-- an appropriate WITH, and the interface can be expected to remain stable.
+
package System.Memory is
pragma Elaborate_Body;
type size_t is mod 2 ** Standard'Address_Size;
+ -- Note: the reason we redefine this here instead of using the
+ -- definition in Interfaces.C is that we do not want to drag in
+ -- all of Interfaces.C just because System.Memory is used.
function Alloc (Size : size_t) return System.Address;
- -- malloc for use by GNAT, with error checking and task lockout,
- -- as well as allocation tracking.
+ -- This is the low level allocation routine. Given a size in storage
+ -- units, it returns the address of a maximally aligned block of
+ -- memory. The implementation of this routine is guaranteed to be
+ -- task safe, and also aborts are deferred if necessary.
+ --
+ -- If size_t is set to size_t'Last on entry, then a Storage_Error
+ -- exception is raised with a message "object too large".
+ --
+ -- If size_t is set to zero on entry, then a minimal (but non-zero)
+ -- size block is allocated.
+ --
+ -- Note: this is roughly equivalent to the standard C malloc call
+ -- with the additional semantics as described above.
procedure Free (Ptr : System.Address);
- -- free for use by GNAT, with task lockout and allocation tracking.
+ -- This is the low level free routine. It frees a block previously
+ -- allocated with a call to Alloc. As in the case of Alloc, this
+ -- call is guaranteed task safe, and aborts are deferred.
+ --
+ -- Note: this is roughly equivalent to the standard C free call
+ -- with the additional semantics as described above.
function Realloc
(Ptr : System.Address;
Size : size_t)
return System.Address;
- -- realloc for use by GNAT, with error checking and task lockout.
+ -- This is the low level reallocation routine. It takes an existing
+ -- block address returned by a previous call to Alloc or Realloc,
+ -- and reallocates the block. The size can either be increased or
+ -- decreased. If possible the reallocation is done in place, so that
+ -- the returned result is the same as the value of Ptr on entry.
+ -- However, it may be necessary to relocate the block to another
+ -- address, in which case the information is copied to the new
+ -- block, and the old block is freed. The implementation of this
+ -- routine is guaranteed to be task safe, and also aborts are
+ -- deferred as necessary.
+ --
+ -- If size_t is set to size_t'Last on entry, then a Storage_Error
+ -- exception is raised with a message "object too large".
+ --
+ -- If size_t is set to zero on entry, then a minimal (but non-zero)
+ -- size block is allocated.
+ --
+ -- Note: this is roughly equivalent to the standard C realloc call
+ -- with the additional semantics as described above.
private
- pragma Export (C, Alloc, "__gnat_malloc");
- pragma Export (C, Free, "__gnat_free");
+ -- The following names are used from the generated compiler code
+
+ pragma Export (C, Alloc, "__gnat_malloc");
+ pragma Export (C, Free, "__gnat_free");
pragma Export (C, Realloc, "__gnat_realloc");
end System.Memory;
diff --git a/gcc/ada/s-osprim.ads b/gcc/ada/s-osprim.ads
index 381dd5eb5fa..76cebb5ad20 100644
--- a/gcc/ada/s-osprim.ads
+++ b/gcc/ada/s-osprim.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -41,13 +41,17 @@
package System.OS_Primitives is
- Max_Sensible_Delay : constant Duration := 183 * 24 * 60 * 60.0;
+ Max_Sensible_Delay : constant Duration :=
+ Duration'Min (183 * 24 * 60 * 60.0,
+ Duration'Last);
-- Max of half a year delay, needed to prevent exceptions for large
-- delay values. It seems unlikely that any test will notice this
-- restriction, except in the case of applications setting the clock at
-- at run time (see s-tastim.adb). Also note that a larger value might
-- cause problems (e.g overflow, or more likely OS limitation in the
- -- primitives used).
+ -- primitives used). In the case where half a year is too long (which
+ -- occurs in high integrity mode with 32-bit words, and possibly on
+ -- some specific ports of GNAT), Duration'Last is used instead.
function Clock return Duration;
pragma Inline (Clock);
diff --git a/gcc/ada/s-parame.ads b/gcc/ada/s-parame.ads
index 87e6fa99a41..1e7fe650fad 100644
--- a/gcc/ada/s-parame.ads
+++ b/gcc/ada/s-parame.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -94,6 +94,11 @@ pragma Pure (Parameters);
-- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
-- otherwise return given Size
+ Default_Env_Stack_Size : constant Size_Type := 8_192_000;
+ -- Assumed size of the environment task, if no other information
+ -- is available. This value is used when stack checking is
+ -- enabled and no GNAT_STACK_LIMIT environment variable is set.
+
Stack_Grows_Down : constant Boolean := True;
-- This constant indicates whether the stack grows up (False) or
-- down (True) in memory as functions are called. It is used for
@@ -136,8 +141,8 @@ pragma Pure (Parameters);
---------------------
-- In the following sections, constant parameters are defined to
- -- allow some optimizations within the tasking run time based on
- -- restrictions on the tasking features.
+ -- allow some optimizations and fine tuning within the tasking run time
+ -- based on restrictions on the tasking features.
----------------------
-- Locking Strategy --
@@ -177,6 +182,14 @@ pragma Pure (Parameters);
-- point. A value of False for Dynamic_Priority_Support corresponds
-- to pragma Restrictions (No_Dynamic_Priorities);
+ ---------------------
+ -- Task Attributes --
+ ---------------------
+
+ Default_Attribute_Count : constant := 4;
+ -- Number of pre-allocated Address-sized task attributes stored in the
+ -- task control block.
+
--------------------
-- Runtime Traces --
--------------------
diff --git a/gcc/ada/s-parint.ads b/gcc/ada/s-parint.ads
index 34c873a55d8..d37325e5acf 100644
--- a/gcc/ada/s-parint.ads
+++ b/gcc/ada/s-parint.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,6 +31,9 @@
-- --
------------------------------------------------------------------------------
+-- This unit may be used directly from an application program by providing
+-- an appropriate WITH, and the interface can be expected to remain stable.
+
with Ada.Exceptions;
with Interfaces;
with System.RPC;
diff --git a/gcc/ada/s-pooloc.adb b/gcc/ada/s-pooloc.adb
index 8272ae333bb..99e6c8d92cf 100644
--- a/gcc/ada/s-pooloc.adb
+++ b/gcc/ada/s-pooloc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,7 +33,8 @@
with System.Memory;
with System.Storage_Elements;
-with System.Address_To_Access_Conversions;
+
+with Unchecked_Conversion;
package body System.Pool_Local is
@@ -44,16 +45,18 @@ package body System.Pool_Local is
Pointers_Size : constant SSE.Storage_Offset := 2 * Pointer_Size;
type Acc_Address is access all Address;
- package Addr is new Address_To_Access_Conversions (Address);
+ function To_Acc_Address is new Unchecked_Conversion (Address, Acc_Address);
-----------------------
-- Local Subprograms --
-----------------------
function Next (A : Address) return Acc_Address;
+ pragma Inline (Next);
-- Given an address of a block, return an access to the next block
function Prev (A : Address) return Acc_Address;
+ pragma Inline (Prev);
-- Given an address of a block, return an access to the previous block
--------------
@@ -144,7 +147,7 @@ package body System.Pool_Local is
function Next (A : Address) return Acc_Address is
begin
- return Acc_Address (Addr.To_Pointer (A));
+ return To_Acc_Address (A);
end Next;
----------
@@ -153,7 +156,7 @@ package body System.Pool_Local is
function Prev (A : Address) return Acc_Address is
begin
- return Acc_Address (Addr.To_Pointer (A + Pointer_Size));
+ return To_Acc_Address (A + Pointer_Size);
end Prev;
end System.Pool_Local;
diff --git a/gcc/ada/s-pooloc.ads b/gcc/ada/s-pooloc.ads
index 2c3c04550d5..24d29af4c67 100644
--- a/gcc/ada/s-pooloc.ads
+++ b/gcc/ada/s-pooloc.ads
@@ -50,8 +50,6 @@ pragma Elaborate_Body;
-- Space of allocated objects is reclaimed at pool finalization
-- Manages a list of allocated objects
- -- Default pool in the compiler for access types locally declared
-
type Unbounded_Reclaim_Pool is new
System.Pool_Global.Unbounded_No_Reclaim_Pool with
record
diff --git a/gcc/ada/s-poosiz.adb b/gcc/ada/s-poosiz.adb
index ad6f759f669..54db1329517 100644
--- a/gcc/ada/s-poosiz.adb
+++ b/gcc/ada/s-poosiz.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,17 +32,19 @@
------------------------------------------------------------------------------
with System.Storage_Elements;
-with System.Address_To_Access_Conversions;
+
+with Unchecked_Conversion;
package body System.Pool_Size is
package SSE renames System.Storage_Elements;
use type SSE.Storage_Offset;
- package SC is new Address_To_Access_Conversions (SSE.Storage_Count);
+ type Storage_Count_Access is access SSE.Storage_Count;
+ function To_Storage_Count_Access is
+ new Unchecked_Conversion (Address, Storage_Count_Access);
- SC_Size : constant
- := SSE.Storage_Count'Object_Size / System.Storage_Unit;
+ SC_Size : constant := SSE.Storage_Count'Object_Size / System.Storage_Unit;
package Variable_Size_Management is
@@ -85,7 +87,7 @@ package body System.Pool_Size is
elsif Pool.First_Free /= 0 then
Address := Pool.The_Pool (Pool.First_Free)'Address;
- Pool.First_Free := SC.To_Pointer (Address).all;
+ Pool.First_Free := To_Storage_Count_Access (Address).all;
elsif
Pool.First_Empty <= (Pool.Pool_Size - Pool.Aligned_Elmt_Size + 1)
@@ -113,7 +115,7 @@ package body System.Pool_Size is
Vsize.Deallocate (Pool, Address, Storage_Size, Alignment);
else
- SC.To_Pointer (Address).all := Pool.First_Free;
+ To_Storage_Count_Access (Address).all := Pool.First_Free;
Pool.First_Free := Address - Pool.The_Pool'Address + 1;
end if;
end Deallocate;
@@ -274,7 +276,7 @@ package body System.Pool_Size is
Align_Size : constant SSE.Storage_Count :=
((Storage_Size + Alignment - 1) / Alignment) *
Alignment;
- Chunk : SSE.Storage_Count := Chunk_Of (Pool, Address);
+ Chunk : constant SSE.Storage_Count := Chunk_Of (Pool, Address);
begin
-- Attach the freed chunk to the chain
@@ -313,7 +315,14 @@ package body System.Pool_Size is
return SSE.Storage_Count
is
begin
- return SC.To_Pointer (Pool.The_Pool (Chunk + SC_Size)'Address).all;
+ pragma Warnings (Off);
+ -- Kill alignment warnings, we are careful to make sure
+ -- that the alignment is correct.
+
+ return To_Storage_Count_Access
+ (Pool.The_Pool (Chunk + SC_Size)'Address).all;
+
+ pragma Warnings (On);
end Next;
--------------
@@ -325,7 +334,14 @@ package body System.Pool_Size is
Chunk, Next : SSE.Storage_Count)
is
begin
- SC.To_Pointer (Pool.The_Pool (Chunk + SC_Size)'Address).all := Next;
+ pragma Warnings (Off);
+ -- Kill alignment warnings, we are careful to make sure
+ -- that the alignment is correct.
+
+ To_Storage_Count_Access
+ (Pool.The_Pool (Chunk + SC_Size)'Address).all := Next;
+
+ pragma Warnings (On);
end Set_Next;
--------------
@@ -337,7 +353,14 @@ package body System.Pool_Size is
Chunk, Size : SSE.Storage_Count)
is
begin
- SC.To_Pointer (Pool.The_Pool (Chunk)'Address).all := Size;
+ pragma Warnings (Off);
+ -- Kill alignment warnings, we are careful to make sure
+ -- that the alignment is correct.
+
+ To_Storage_Count_Access
+ (Pool.The_Pool (Chunk)'Address).all := Size;
+
+ pragma Warnings (On);
end Set_Size;
----------
@@ -350,7 +373,13 @@ package body System.Pool_Size is
return SSE.Storage_Count
is
begin
- return SC.To_Pointer (Pool.The_Pool (Chunk)'Address).all;
+ pragma Warnings (Off);
+ -- Kill alignment warnings, we are careful to make sure
+ -- that the alignment is correct.
+
+ return To_Storage_Count_Access (Pool.The_Pool (Chunk)'Address).all;
+
+ pragma Warnings (On);
end Size;
end Variable_Size_Management;
diff --git a/gcc/ada/s-proinf.ads b/gcc/ada/s-proinf.ads
index 99f0e3c2cb9..6fdeef44a63 100644
--- a/gcc/ada/s-proinf.ads
+++ b/gcc/ada/s-proinf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -30,16 +30,15 @@
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+
-- This package contains the definitions and routines used as parameters
-- to the run-time system at program startup.
package System.Program_Info is
- function Default_Task_Stack return Integer;
- --
+ function Default_Task_Stack return Integer;
-- The default stack size for each created thread. This default value
-- can be overriden on a per-task basis by the language-defined
-- Storage_Size pragma.
- --
end System.Program_Info;
diff --git a/gcc/ada/s-purexc.ads b/gcc/ada/s-purexc.ads
new file mode 100644
index 00000000000..8c73ff59dc1
--- /dev/null
+++ b/gcc/ada/s-purexc.ads
@@ -0,0 +1,77 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . P U R E _ E X C E P T I O N S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2000-2002 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides an interface for raising predefined exceptions
+-- with an exception message. It can be used from Pure units. This unit
+-- is for internal use only, it is not generally available to applications.
+
+package System.Pure_Exceptions is
+pragma Pure (Pure_Exceptions);
+
+ type Exception_Type is limited null record;
+ -- Type used to specify which exception to raise
+
+ -- Really Exception_Type is Exception_Id, but Exception_Id can't be
+ -- used directly since it is declared in the non-pure unit Ada.Exceptions,
+
+ -- Exception_Id is in fact simply a pointer to the type Exception_Data
+ -- declared in System.Standard_Library (which is also non-pure). So what
+ -- we do is to define it here as a by reference type (any by reference
+ -- type would do), and then Import the definitions from Standard_Library.
+ -- Since this is a by reference type, these will be passed by reference,
+ -- which has the same effect as passing a pointer.
+
+ -- This type is not private because keeping it by reference would require
+ -- defining it in a way (e.g a tagged type) that would drag other run time
+ -- files, which is unwanted in the case of e.g ravenscar where we want to
+ -- minimize the number of run time files needed by default.
+
+ CE : constant Exception_Type; -- Constraint_Error
+ PE : constant Exception_Type; -- Program_Error
+ SE : constant Exception_Type; -- Storage_Error
+ TE : constant Exception_Type; -- Tasking_Error
+ -- One of these constants is used in the call to specify the exception
+
+ procedure Raise_Exception (E : Exception_Type; Message : String);
+ pragma Import (Ada, Raise_Exception, "__gnat_raise_exception");
+ pragma No_Return (Raise_Exception);
+ -- Raise specified exception with specified message
+
+private
+ pragma Import (C, CE, "constraint_error");
+ pragma Import (C, PE, "program_error");
+ pragma Import (C, SE, "storage_error");
+ pragma Import (C, TE, "tasking_error");
+ -- References to the exception structures in the standard library
+
+end System.Pure_Exceptions;
diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads
new file mode 100644
index 00000000000..cd4004c834a
--- /dev/null
+++ b/gcc/ada/s-rident.ads
@@ -0,0 +1,156 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . R I D E N T --
+-- --
+-- S p e c --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package defines the set of restriction identifiers. It is a generic
+-- package that is instantiated by the compiler/binder in package Rident, and
+-- is instantiated in package System.Restrictions for use at run-time.
+
+-- The reason that we make this a generic package is so that in the case of
+-- the instantiation in Rident for use at compile time and bind time, we can
+-- generate normal image tables for the enumeration types, which are needed
+-- for diagnostic and informational messages. At run-time we really do not
+-- want to waste the space for these image tables, and they are not needed,
+-- so we can do the instantiation under control of Discard_Names to remove
+-- the tables.
+
+generic
+package System.Rident is
+
+ -- The following enumeration type defines the set of restriction
+ -- identifiers not taking a parameter that are implemented in GNAT.
+ -- To add a new restriction identifier, add an entry with the name
+ -- to be used in the pragma, and add appropriate calls to the
+ -- Restrict.Check_Restriction routine.
+
+ type Restriction_Id is (
+
+ -- The following cases are checked for consistency in the binder
+
+ Boolean_Entry_Barriers, -- GNAT (Ravenscar)
+ No_Abort_Statements, -- (RM D.7(5), H.4(3))
+ No_Access_Subprograms, -- (RM H.4(17))
+ No_Allocators, -- (RM H.4(7))
+ No_Asynchronous_Control, -- (RM D.7(10))
+ No_Calendar, -- GNAT
+ No_Delay, -- (RM H.4(21))
+ No_Dispatch, -- (RM H.4(19))
+ No_Dynamic_Interrupts, -- GNAT
+ No_Dynamic_Priorities, -- (RM D.9(9))
+ No_Enumeration_Maps, -- GNAT
+ No_Entry_Calls_In_Elaboration_Code, -- GNAT
+ No_Entry_Queue, -- GNAT (Ravenscar)
+ No_Exception_Handlers, -- GNAT
+ No_Exception_Registration, -- GNAT
+ No_Exceptions, -- (RM H.4(12))
+ No_Finalization, -- GNAT
+ No_Fixed_Point, -- (RM H.4(15))
+ No_Floating_Point, -- (RM H.4(14))
+ No_IO, -- (RM H.4(20))
+ No_Implicit_Conditionals, -- GNAT
+ No_Implicit_Dynamic_Code, -- GNAT
+ No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3))
+ No_Implicit_Loops, -- GNAT
+ No_Initialize_Scalars, -- GNAT
+ No_Local_Allocators, -- (RM H.4(8))
+ No_Local_Protected_Objects, -- GNAT
+ No_Nested_Finalization, -- (RM D.7(4))
+ No_Protected_Type_Allocators, -- GNAT
+ No_Protected_Types, -- (RM H.4(5))
+ No_Recursion, -- (RM H.4(22))
+ No_Reentrancy, -- (RM H.4(23))
+ No_Relative_Delay, -- GNAT (Ravenscar)
+ No_Requeue, -- GNAT
+ No_Secondary_Stack, -- GNAT
+ No_Select_Statements, -- GNAT (Ravenscar)
+ No_Standard_Storage_Pools, -- GNAT
+ No_Streams, -- GNAT
+ No_Task_Allocators, -- (RM D.7(7))
+ No_Task_Attributes, -- GNAT
+ No_Task_Hierarchy, -- (RM D.7(3), H.4(3))
+ No_Task_Termination, -- GNAT (Ravenscar)
+ No_Tasking, -- GNAT
+ No_Terminate_Alternatives, -- (RM D.7(6))
+ No_Unchecked_Access, -- (RM H.4(18))
+ No_Unchecked_Conversion, -- (RM H.4(16))
+ No_Unchecked_Deallocation, -- (RM H.4(9))
+ No_Wide_Characters, -- GNAT
+ Static_Priorities, -- GNAT
+ Static_Storage_Size, -- GNAT
+
+ -- The following cases do not require partition-wide checks
+
+ Immediate_Reclamation, -- (RM H.4(10))
+ No_Implementation_Attributes, -- GNAT
+ No_Implementation_Pragmas, -- GNAT
+ No_Implementation_Restrictions, -- GNAT
+ No_Elaboration_Code, -- GNAT
+
+ Not_A_Restriction_Id);
+
+ subtype All_Restrictions is Restriction_Id range
+ Boolean_Entry_Barriers .. No_Elaboration_Code;
+ -- All restrictions except Not_A_Restriction_Id
+
+ -- The following range of Restriction identifiers is checked for
+ -- consistency across a partition. The generated ali file is marked
+ -- for each entry to show one of three possibilities:
+ --
+ -- Corresponding restriction is set (so unit does not violate it)
+ -- Corresponding restriction is not violated
+ -- Corresponding restriction is violated
+
+ subtype Partition_Restrictions is Restriction_Id range
+ Boolean_Entry_Barriers .. Static_Storage_Size;
+
+ -- The following set of Restriction identifiers is not checked for
+ -- consistency across a partition. The generated ali file still
+ -- contains indications of the above three possibilities for the
+ -- purposes of listing applicable restrictions.
+
+ subtype Compilation_Unit_Restrictions is Restriction_Id range
+ Immediate_Reclamation .. No_Elaboration_Code;
+
+ -- The following enumeration type defines the set of restriction
+ -- parameter identifiers taking a parameter that are implemented in
+ -- GNAT. To add a new restriction parameter identifier, add an entry
+ -- with the name to be used in the pragma, and add appropriate
+ -- calls to Restrict.Check_Restriction.
+
+ -- Note: the GNAT implementation currently only accomodates restriction
+ -- parameter identifiers whose expression value is a non-negative
+ -- integer. This is true for all language defined parameters.
+
+ type Restriction_Parameter_Id is (
+ Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3))
+ Max_Entry_Queue_Depth, -- GNAT
+ Max_Protected_Entries, -- (RM D.7(14))
+ Max_Select_Alternatives, -- (RM D.7(12))
+ Max_Storage_At_Blocking, -- (RM D.7(17))
+ Max_Task_Entries, -- (RM D.7(13), H.4(3))
+ Max_Tasks, -- (RM D.7(19), H.4(3))
+ Not_A_Restriction_Parameter_Id);
+
+end System.Rident;
diff --git a/gcc/ada/s-scaval.adb b/gcc/ada/s-scaval.adb
new file mode 100644
index 00000000000..97a5f87d9ba
--- /dev/null
+++ b/gcc/ada/s-scaval.adb
@@ -0,0 +1,266 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . S C A L A R _ V A L U E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+
+package body System.Scalar_Values is
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize (Mode1 : Character; Mode2 : Character) is
+ C1 : Character := Mode1;
+ C2 : Character := Mode2;
+
+ procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
+ pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr");
+
+ subtype String2 is String (1 .. 2);
+ type String2_Ptr is access all String2;
+
+ Env_Value_Ptr : aliased String2_Ptr;
+ Env_Value_Length : aliased Integer;
+
+ EV_Val : aliased constant String :=
+ "GNAT_INIT_SCALARS" & ASCII.NUL;
+
+ B : Byte1;
+
+ EFloat : constant Boolean := Long_Long_Float'Size > Long_Float'Size;
+ -- Set True if we are on an x86 with 96-bit floats for extended
+
+ type ByteLF is array (0 .. 7 + 4 * Boolean'Pos (EFloat)) of Byte1;
+ -- Type used to initialize Long_Long_Float values used on x86 and
+ -- any other target with the same 80-bit floating-point values that
+ -- GCC always stores in 96-bits. Note that we are assuming Intel
+ -- format little-endian addressing for this type. On non-Intel
+ -- architectures, this is the same length as Byte8 and holds
+ -- a Long_Float value.
+
+ -- The following variables are used to initialize the float values
+ -- by overlay. We can't assign directly to the float values, since
+ -- we may be assigning signalling Nan's that will cause a trap if
+ -- loaded into a floating-point register.
+
+ IV_Isf : aliased Byte4; -- Initialize short float
+ IV_Ifl : aliased Byte4; -- Initialize float
+ IV_Ilf : aliased Byte8; -- Initialize long float
+ IV_Ill : aliased ByteLF; -- Initialize long long float
+
+ for IV_Isf'Address use IS_Isf'Address;
+ for IV_Ifl'Address use IS_Ifl'Address;
+ for IV_Ilf'Address use IS_Ilf'Address;
+ for IV_Ill'Address use IS_Ill'Address;
+
+ -- The following pragmas are used to suppress initialization
+
+ pragma Import (Ada, IV_Isf);
+ pragma Import (Ada, IV_Ifl);
+ pragma Import (Ada, IV_Ilf);
+ pragma Import (Ada, IV_Ill);
+
+ begin
+ -- Acquire environment variable value if necessary
+
+ if C1 = 'E' and then C2 = 'V' then
+ Get_Env_Value_Ptr
+ (EV_Val'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
+
+ -- Ignore if length is not 2
+
+ if Env_Value_Length /= 2 then
+ C1 := 'I';
+ C2 := 'N';
+
+ -- Length is 2, see if it is a valid value
+
+ else
+ -- Acquire two characters and fold to upper case
+
+ C1 := Env_Value_Ptr (1);
+ C2 := Env_Value_Ptr (2);
+
+ if C1 in 'a' .. 'z' then
+ C1 := Character'Val (Character'Pos (C1) - 32);
+ end if;
+
+ if C2 in 'a' .. 'z' then
+ C2 := Character'Val (Character'Pos (C2) - 32);
+ end if;
+
+ -- IN/LO/HI are ok values
+
+ if (C1 = 'I' and then C2 = 'N')
+ or else
+ (C1 = 'L' and then C2 = 'O')
+ or else
+ (C1 = 'H' and then C2 = 'I')
+ then
+ null;
+
+ -- Try for valid hex digits
+
+ elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'Z')
+ or else
+ (C2 in '0' .. '9' or else C2 in 'A' .. 'Z')
+ then
+ null;
+
+ -- Otherwise environment value is bad, ignore and use IN (invalid)
+
+ else
+ C1 := 'I';
+ C2 := 'N';
+ end if;
+ end if;
+ end if;
+
+ -- IN (invalid value)
+
+ if C1 = 'I' and then C2 = 'N' then
+ IS_Is1 := 16#80#;
+ IS_Is2 := 16#8000#;
+ IS_Is4 := 16#8000_0000#;
+ IS_Is8 := 16#8000_0000_0000_0000#;
+
+ IS_Iu1 := 16#FF#;
+ IS_Iu2 := 16#FFFF#;
+ IS_Iu4 := 16#FFFF_FFFF#;
+ IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
+
+ IV_Isf := IS_Iu4;
+ IV_Ifl := IS_Iu4;
+ IV_Ilf := IS_Iu8;
+
+ if EFloat then
+ IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0);
+ end if;
+
+ -- LO (Low values)
+
+ elsif C1 = 'L' and then C2 = 'O' then
+ IS_Is1 := 16#80#;
+ IS_Is2 := 16#8000#;
+ IS_Is4 := 16#8000_0000#;
+ IS_Is8 := 16#8000_0000_0000_0000#;
+
+ IS_Iu1 := 16#00#;
+ IS_Iu2 := 16#0000#;
+ IS_Iu4 := 16#0000_0000#;
+ IS_Iu8 := 16#0000_0000_0000_0000#;
+
+ IV_Isf := 16#FF80_0000#;
+ IV_Ifl := 16#FF80_0000#;
+ IV_Ilf := 16#FFF0_0000_0000_0000#;
+
+ if EFloat then
+ IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0);
+ end if;
+
+ -- HI (High values)
+
+ elsif C1 = 'H' and then C2 = 'I' then
+ IS_Is1 := 16#7F#;
+ IS_Is2 := 16#7FFF#;
+ IS_Is4 := 16#7FFF_FFFF#;
+ IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#;
+
+ IS_Iu1 := 16#FF#;
+ IS_Iu2 := 16#FFFF#;
+ IS_Iu4 := 16#FFFF_FFFF#;
+ IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#;
+
+ IV_Isf := 16#7F80_0000#;
+ IV_Ifl := 16#7F80_0000#;
+ IV_Ilf := 16#7FF0_0000_0000_0000#;
+
+ if EFloat then
+ IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0);
+ end if;
+
+ -- -Shh (hex byte)
+
+ else
+ -- Convert the two hex digits (we know they are valid here)
+
+ if C1 in '0' .. '9' then
+ B := Character'Pos (C1) - Character'Pos ('0');
+ else
+ B := Character'Pos (C1) - (Character'Pos ('A') - 10);
+ end if;
+
+ if C2 in '0' .. '9' then
+ B := B * 16 + Character'Pos (C2) - Character'Pos ('0');
+ else
+ B := B * 16 + Character'Pos (C2) - (Character'Pos ('A') - 10);
+ end if;
+
+ -- Initialize data values from the hex value
+
+ IS_Is1 := B;
+ IS_Is2 := 2**8 * Byte2 (IS_Is1) + Byte2 (IS_Is1);
+ IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2);
+ IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4);
+
+ IS_Iu1 := IS_Is1;
+ IS_Iu2 := IS_Is2;
+ IS_Iu4 := IS_Is4;
+ IS_Iu8 := IS_Is8;
+
+ IV_Isf := IS_Is4;
+ IV_Ifl := IS_Is4;
+ IV_Ilf := IS_Is8;
+
+ if EFloat then
+ IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B);
+ end if;
+ end if;
+
+ -- If no separate Long_Long_Float, then use Long_Float value as
+ -- Long_Long_Float initial value.
+
+ if not EFloat then
+ declare
+ pragma Warnings (Off);
+ function To_ByteLF is new Unchecked_Conversion (Byte8, ByteLF);
+ pragma Warnings (On);
+ begin
+ IV_Ill := To_ByteLF (IV_Ilf);
+ end;
+ end if;
+
+
+ end Initialize;
+
+end System.Scalar_Values;
diff --git a/gcc/ada/s-scaval.ads b/gcc/ada/s-scaval.ads
index 07324b6724c..9db3c9830d8 100644
--- a/gcc/ada/s-scaval.ads
+++ b/gcc/ada/s-scaval.ads
@@ -3,9 +3,10 @@
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . S C A L A R _ V A L U E S --
+-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -37,37 +38,45 @@
-- by the use of pragma Import.
package System.Scalar_Values is
-pragma Pure (Scalar_Values);
+
+ -- Note: logically this package should be Pure since it can be accessed
+ -- from pure units, but the IS_xxx variables below get set at run time,
+ -- so they have to be library level variables. In fact we only ever
+ -- access this from generated code, and the compiler knows that it is
+ -- OK to access this unit from generated code.
type Byte1 is mod 2 ** 8;
type Byte2 is mod 2 ** 16;
type Byte4 is mod 2 ** 32;
type Byte8 is mod 2 ** 64;
- IS_Is1 : constant Byte1; -- Initialize 1 byte signed value
- IS_Is2 : constant Byte2; -- Initialize 2 byte signed value
- IS_Is4 : constant Byte4; -- Initialize 4 byte signed value
- IS_Is8 : constant Byte8; -- Initialize 8 byte signed value
- IS_Iu1 : constant Byte1; -- Initialize 1 byte unsigned value
- IS_Iu2 : constant Byte2; -- Initialize 2 byte unsigned value
- IS_Iu4 : constant Byte4; -- Initialize 4 byte unsigned value
- IS_Iu8 : constant Byte8; -- Initialize 8 byte unsigned value
- IS_Isf : constant Short_Float; -- Initialize short float value
- IS_Ifl : constant Float; -- Initialize float value
- IS_Ilf : constant Long_Float; -- Initialize long float value
- IS_Ill : constant Long_Long_Float; -- Initialize long long float value
+ -- The explicit initializations here are not really required, since these
+ -- variables are always set by System.Scalar_Values.Initialize.
+
+ IS_Is1 : Byte1 := 0; -- Initialize 1 byte signed
+ IS_Is2 : Byte2 := 0; -- Initialize 2 byte signed
+ IS_Is4 : Byte4 := 0; -- Initialize 4 byte signed
+ IS_Is8 : Byte8 := 0; -- Initialize 8 byte signed
+ IS_Iu1 : Byte1 := 0; -- Initialize 1 byte unsigned
+ IS_Iu2 : Byte2 := 0; -- Initialize 2 byte unsigned
+ IS_Iu4 : Byte4 := 0; -- Initialize 4 byte unsigned
+ IS_Iu8 : Byte8 := 0; -- Initialize 8 byte unsigned
+
+ -- The float definitions are aliased, because we use overlays to set them
+
+ IS_Isf : aliased Short_Float := 0.0; -- Initialize short float
+ IS_Ifl : aliased Float := 0.0; -- Initialize float
+ IS_Ilf : aliased Long_Float := 0.0; -- Initialize long float
+ IS_Ill : aliased Long_Long_Float := 0.0; -- Initialize long long float
- pragma Import (Ada, IS_Is1, "__gnat_Is1");
- pragma Import (Ada, IS_Is2, "__gnat_Is2");
- pragma Import (Ada, IS_Is4, "__gnat_Is4");
- pragma Import (Ada, IS_Is8, "__gnat_Is8");
- pragma Import (Ada, IS_Iu1, "__gnat_Iu1");
- pragma Import (Ada, IS_Iu2, "__gnat_Iu2");
- pragma Import (Ada, IS_Iu4, "__gnat_Iu4");
- pragma Import (Ada, IS_Iu8, "__gnat_Iu8");
- pragma Import (Ada, IS_Isf, "__gnat_Isf");
- pragma Import (Ada, IS_Ifl, "__gnat_Ifl");
- pragma Import (Ada, IS_Ilf, "__gnat_Ilf");
- pragma Import (Ada, IS_Ill, "__gnat_Ill");
+ procedure Initialize (Mode1 : Character; Mode2 : Character);
+ -- This procedure is called from the binder when Initialize_Scalars mode
+ -- is active. The arguments are the two characters from the -S switch,
+ -- with letters forced upper case. So for example if -S5a is given, then
+ -- Mode1 will be '5' and Mode2 will be 'A'. If the parameters are EV,
+ -- then this routine reads the environment variable GNAT_INIT_SCALARS.
+ -- The possible settings are the same as those for the -S switch (except
+ -- for EV), i.e. IN/LO/HO/xx, xx = 2 hex digits. If no -S switch is given
+ -- then the default of IN (invalid values) is passed on the call.
end System.Scalar_Values;
diff --git a/gcc/ada/s-secsta.adb b/gcc/ada/s-secsta.adb
index 63182aa6972..ecb5e9e401e 100644
--- a/gcc/ada/s-secsta.adb
+++ b/gcc/ada/s-secsta.adb
@@ -128,8 +128,7 @@ package body System.Secondary_Stack is
((Mark_Id (Storage_Size) + Max_Align - 1) / Max_Align)
* Max_Align;
- Count_Unreleased_Chunks : Natural;
- To_Be_Released_Chunk : Chunk_Ptr;
+ To_Be_Released_Chunk : Chunk_Ptr;
begin
-- If the secondary stack is fixed in the primary stack, then the
@@ -159,8 +158,6 @@ package body System.Secondary_Stack is
-- Find out if the available memory in the current chunk is sufficient.
-- if not, go to the next one and eventally create the necessary room
- Count_Unreleased_Chunks := 0;
-
while Chunk.Last - Stack.Top + 1 < Max_Size loop
if Chunk.Next /= null then
diff --git a/gcc/ada/s-secsta.ads b/gcc/ada/s-secsta.ads
index 0530ed4761d..e292d6a6bd9 100644
--- a/gcc/ada/s-secsta.ads
+++ b/gcc/ada/s-secsta.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1999 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- --
@@ -41,18 +41,18 @@ package System.Secondary_Stack is
-- Default size of a secondary stack
procedure SS_Init
- (Stk : in out System.Address;
+ (Stk : in out System.Address;
Size : Natural := Default_Secondary_Stack_Size);
-- Initialize the secondary stack with a main stack of the given Size.
--
-- If System.Parameters.Sec_Stack_Ratio equals Dynamic, Stk is really an
- -- "out" parameter that will be allocated on the heap. Then all further
+ -- OUT parameter that will be allocated on the heap. Then all further
-- allocations which do not overflow the main stack will not generate
-- dynamic (de)allocation calls. If the main Stack overflows, a new
-- chuck of at least the same size will be allocated and linked to the
-- previous chunk.
--
- -- Otherwise (Sec_Stack_Ratio between 0 and 100), Stk is an "in" parameter
+ -- Otherwise (Sec_Stack_Ratio between 0 and 100), Stk is an IN parameter
-- that is already pointing to a Stack_Id. The secondary stack in this case
-- is fixed, and any attempt to allocated more than the initial size will
-- result in a Storage_Error being raised.
@@ -87,10 +87,9 @@ package System.Secondary_Stack is
procedure SS_Info;
-- Debugging procedure used to print out secondary Stack allocation
-- information. This procedure is generic in order to avoid a direct
- -- dependence on a particular IO package.
+ -- dependance on a particular IO package.
private
-
SS_Pool : Integer;
-- Unused entity that is just present to ease the sharing of the pool
-- mechanism for specific allocation/deallocation in the compiler
diff --git a/gcc/ada/s-sequio.adb b/gcc/ada/s-sequio.adb
index 7e66bbe4573..b9c5a901858 100644
--- a/gcc/ada/s-sequio.adb
+++ b/gcc/ada/s-sequio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -94,17 +94,20 @@ package body System.Sequential_IO is
Name : in String := "";
Form : in String := "")
is
- File_Control_Block : Sequential_AFCB;
+ Dummy_File_Control_Block : Sequential_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
- Mode => Mode,
- Name => Name,
- Form => Form,
- Amethod => 'Q',
- Creat => True,
- Text => False);
+ Dummy_FCB => Dummy_File_Control_Block,
+ Mode => Mode,
+ Name => Name,
+ Form => Form,
+ Amethod => 'Q',
+ Creat => True,
+ Text => False);
end Create;
----------
@@ -117,11 +120,14 @@ package body System.Sequential_IO is
Name : in String;
Form : in String := "")
is
- File_Control_Block : Sequential_AFCB;
+ Dummy_File_Control_Block : Sequential_AFCB;
+ pragma Warnings (Off, Dummy_File_Control_Block);
+ -- Yes, we know this is never assigned a value, only the tag
+ -- is used for dispatching purposes, so that's expected.
begin
FIO.Open (File_Ptr => AP (File),
- Dummy_FCB => File_Control_Block,
+ Dummy_FCB => Dummy_File_Control_Block,
Mode => Mode,
Name => Name,
Form => Form,
diff --git a/gcc/ada/s-shasto.adb b/gcc/ada/s-shasto.adb
index 2f7f0637ce8..328050e94ac 100644
--- a/gcc/ada/s-shasto.adb
+++ b/gcc/ada/s-shasto.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -36,16 +36,14 @@ with Ada.IO_Exceptions;
with Ada.Streams;
with Ada.Streams.Stream_IO;
-with GNAT.HTable;
with System.Global_Locks;
-with GNAT.OS_Lib;
-with GNAT.Task_Lock;
-
-use type GNAT.OS_Lib.String_Access;
+with System.Soft_Links;
with System;
with System.File_Control_Block;
with System.File_IO;
+with System.HTable;
+
with Unchecked_Deallocation;
with Unchecked_Conversion;
@@ -53,17 +51,17 @@ package body System.Shared_Storage is
package AS renames Ada.Streams;
- package OS renames GNAT.OS_Lib;
-
package IOX renames Ada.IO_Exceptions;
package FCB renames System.File_Control_Block;
package SFI renames System.File_IO;
- package TSL renames GNAT.Task_Lock;
+ type String_Access is access String;
+ procedure Free is new Unchecked_Deallocation
+ (Object => String, Name => String_Access);
- Dir : OS.String_Access;
+ Dir : String_Access;
-- Holds the directory
------------------------------------------------
@@ -98,14 +96,14 @@ package body System.Shared_Storage is
type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry;
type Shared_Var_File_Entry is record
- Name : OS.String_Access;
+ Name : String_Access;
-- Name of variable, as passed to Read_File/Write_File routines
Stream : File_Stream_Access;
-- Stream_IO file for the shared variable file
- Next : Shared_Var_File_Entry_Ptr;
- Prev : Shared_Var_File_Entry_Ptr;
+ Next : Shared_Var_File_Entry_Ptr;
+ Prev : Shared_Var_File_Entry_Ptr;
-- Links for LRU chain
end record;
@@ -129,15 +127,15 @@ package body System.Shared_Storage is
-- LRU_Tail points to the most recently used entry, whose next pointer
-- is null. These pointers are null only if the list is empty.
- function Hash (F : OS.String_Access) return Hash_Header;
- function Equal (F1, F2 : OS.String_Access) return Boolean;
+ function Hash (F : String_Access) return Hash_Header;
+ function Equal (F1, F2 : String_Access) return Boolean;
-- Hash and equality functions for hash table
- package SFT is new GNAT.HTable.Simple_HTable
+ package SFT is new System.HTable.Simple_HTable
(Header_Num => Hash_Header,
Element => Shared_Var_File_Entry_Ptr,
No_Element => null,
- Key => OS.String_Access,
+ Key => String_Access,
Hash => Hash,
Equal => Equal);
@@ -194,7 +192,7 @@ package body System.Shared_Storage is
LRU_Head := Freed.Next;
SFT.Remove (Freed.Name);
SIO.Close (Freed.Stream.File);
- OS.Free (Freed.Name);
+ Free (Freed.Name);
Free (Freed.Stream);
Free (Freed);
@@ -223,7 +221,7 @@ package body System.Shared_Storage is
-- Equal --
-----------
- function Equal (F1, F2 : OS.String_Access) return Boolean is
+ function Equal (F1, F2 : String_Access) return Boolean is
begin
return F1.all = F2.all;
end Equal;
@@ -232,7 +230,7 @@ package body System.Shared_Storage is
-- Hash --
----------
- function Hash (F : OS.String_Access) return Hash_Header is
+ function Hash (F : String_Access) return Hash_Header is
N : Natural := 0;
begin
@@ -250,9 +248,29 @@ package body System.Shared_Storage is
----------------
procedure Initialize is
+ procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
+ pragma Import (C, Get_Env_Value_Ptr, "__gnat_get_env_value_ptr");
+
+ procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
+ pragma Import (C, Strncpy, "strncpy");
+
+ Dir_Name : aliased constant String :=
+ "SHARED_MEMORY_DIRECTORY" & ASCII.NUL;
+
+ Env_Value_Ptr : aliased Address;
+ Env_Value_Length : aliased Integer;
+
begin
if Dir = null then
- Dir := OS.Getenv ("SHARED_MEMORY_DIRECTORY");
+ Get_Env_Value_Ptr
+ (Dir_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
+
+ Dir := new String (1 .. Env_Value_Length);
+
+ if Env_Value_Length > 0 then
+ Strncpy (Dir.all'Address, Env_Value_Ptr, Env_Value_Length);
+ end if;
+
System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock");
end if;
end Initialize;
@@ -264,9 +282,11 @@ package body System.Shared_Storage is
procedure Read
(Stream : in out File_Stream_Type;
Item : out AS.Stream_Element_Array;
- Last : out AS.Stream_Element_Offset) is
+ Last : out AS.Stream_Element_Offset)
+ is
begin
SIO.Read (Stream.File, Item, Last);
+
exception when others =>
Last := Item'Last;
end Read;
@@ -313,8 +333,9 @@ package body System.Shared_Storage is
procedure Shared_Var_Close (Var : in SIO.Stream_Access) is
pragma Warnings (Off, Var);
+
begin
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
end Shared_Var_Close;
---------------------
@@ -325,22 +346,22 @@ package body System.Shared_Storage is
pragma Warnings (Off, Var);
begin
- TSL.Lock;
+ System.Soft_Links.Lock_Task.all;
Initialize;
if Lock_Count /= 0 then
Lock_Count := Lock_Count + 1;
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
else
Lock_Count := 1;
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
System.Global_Locks.Acquire_Lock (Global_Lock);
end if;
exception
when others =>
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
raise;
end Shared_Var_Lock;
@@ -354,7 +375,7 @@ package body System.Shared_Storage is
use type Ada.Streams.Stream_IO.File_Mode;
begin
- TSL.Lock;
+ System.Soft_Links.Lock_Task.all;
SFE := Retrieve (Var);
-- Here if file is not already open, try to open it
@@ -381,7 +402,7 @@ package body System.Shared_Storage is
when IOX.Name_Error =>
Free (SFE);
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
return null;
end;
@@ -400,7 +421,7 @@ package body System.Shared_Storage is
exception
when others =>
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
raise;
end Shared_Var_ROpen;
@@ -412,18 +433,18 @@ package body System.Shared_Storage is
pragma Warnings (Off, Var);
begin
- TSL.Lock;
+ System.Soft_Links.Lock_Task.all;
Initialize;
Lock_Count := Lock_Count - 1;
if Lock_Count = 0 then
System.Global_Locks.Release_Lock (Global_Lock);
end if;
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
exception
when others =>
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
raise;
end Shared_Var_Unlock;
@@ -437,7 +458,7 @@ package body System.Shared_Storage is
use type Ada.Streams.Stream_IO.File_Mode;
begin
- TSL.Lock;
+ System.Soft_Links.Lock_Task.all;
SFE := Retrieve (Var);
if SFE = null then
@@ -491,7 +512,7 @@ package body System.Shared_Storage is
exception
when others =>
- TSL.Unlock;
+ System.Soft_Links.Unlock_Task.all;
raise;
end Shared_Var_WOpen;
@@ -501,7 +522,8 @@ package body System.Shared_Storage is
procedure Write
(Stream : in out File_Stream_Type;
- Item : in AS.Stream_Element_Array) is
+ Item : in AS.Stream_Element_Array)
+ is
begin
SIO.Write (Stream.File, Item);
end Write;
diff --git a/gcc/ada/s-shasto.ads b/gcc/ada/s-shasto.ads
index 69ddebaf158..02d2dd0b368 100644
--- a/gcc/ada/s-shasto.ads
+++ b/gcc/ada/s-shasto.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-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- --
@@ -31,13 +31,17 @@
-- --
------------------------------------------------------------------------------
--- This package manages the shared/persistent storage required for
+-- This package manages the shared/persistant storage required for
-- full implementation of variables in Shared_Passive packages, more
-- precisely variables whose enclosing dynamic scope is a shared
-- passive package. This implementation is specific to GNAT and GLADE
-- provides a more general implementation not dedicated to file
-- storage.
+-- This unit (and shared passive partitions) are supported on all
+-- GNAT implementations except on OpenVMS (where problems arise from
+-- trying to share files, and with version numbers of files)
+
-- --------------------------
-- -- Shared Storage Model --
-- --------------------------
diff --git a/gcc/ada/s-soflin.ads b/gcc/ada/s-soflin.ads
index 96d2155c21d..5b34562e355 100644
--- a/gcc/ada/s-soflin.ads
+++ b/gcc/ada/s-soflin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -326,9 +326,12 @@ package System.Soft_Links is
-- current exception. Note that any exception in the same task
-- destroys this information, so the data in this variable must
-- be copied out before another exception can occur.
+ --
+ -- Also act as a list of the active exceptions in the case of the GCC
+ -- exception mechanism, organized as a stack with the most recent first.
Machine_State_Addr : Address := Null_Address;
- --
+ -- Machine state address. Used by front-end zero cost exception
end record;
procedure Create_TSD (New_TSD : in out TSD);
diff --git a/gcc/ada/s-stache.adb b/gcc/ada/s-stache.adb
index f93f3fa7059..65e816b654f 100644
--- a/gcc/ada/s-stache.adb
+++ b/gcc/ada/s-stache.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2002 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -39,14 +39,7 @@ with System.Soft_Links;
package body System.Stack_Checking is
- Kilobyte : constant Storage_Offset := 1024;
- Default_Env_Stack_Size : constant Storage_Offset := 8000 * Kilobyte;
- -- This size is assumed for the environment stack when no size has been
- -- set by the runtime, and no GNAT_STACK_LIMIT environment variable was
- -- present. The value is chosen to be just under 8 MB whic is the actual
- -- default size on some systems including GNU/LinuxThreads, so we will get
- -- correct storage errors on those systems without setting environment
- -- variables.
+ Kilobyte : constant := 1024;
function Set_Stack_Info (Stack : access Stack_Access) return Stack_Access;
@@ -94,7 +87,7 @@ package body System.Stack_Checking is
is
type Frame_Mark is null record;
Frame_Location : Frame_Mark;
- Frame_Address : Address := Frame_Location'Address;
+ Frame_Address : constant Address := Frame_Location'Address;
My_Stack : Stack_Access;
Limit_Chars : System.Address;
@@ -121,7 +114,7 @@ package body System.Stack_Checking is
if My_Stack.Size = 0 then
- My_Stack.Size := Default_Env_Stack_Size;
+ My_Stack.Size := Storage_Offset (Default_Env_Stack_Size);
-- When the environment variable GNAT_STACK_LIMIT is set,
-- set Environment_Stack_Size to that number of kB.
diff --git a/gcc/ada/s-stache.ads b/gcc/ada/s-stache.ads
index d8bdbb35a13..f253eb2ac88 100644
--- a/gcc/ada/s-stache.ads
+++ b/gcc/ada/s-stache.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -90,7 +90,7 @@ private
(Limit => System.Null_Address,
Base => System.Null_Address,
Size => 0);
- -- Use explicit assignment to avoid elaboration code (call to _init_proc).
+ -- Use explicit assignment to avoid elaboration code (call to init proc).
Null_Stack : constant Stack_Access := Null_Stack_Info'Access;
-- Stack_Access value that will return a Stack_Base and Stack_Limit
@@ -100,5 +100,6 @@ private
pragma Export (C, Cache, "_gnat_stack_cache");
pragma Export (C, Stack_Check, "_gnat_stack_check");
+ pragma Export (C, Set_Stack_Size, "__gnat_set_stack_size");
end System.Stack_Checking;
diff --git a/gcc/ada/s-stalib.adb b/gcc/ada/s-stalib.adb
index 096eac45b42..acb1a9bf879 100644
--- a/gcc/ada/s-stalib.adb
+++ b/gcc/ada/s-stalib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1995-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- --
@@ -47,7 +47,7 @@ with System.Soft_Links;
-- Referenced directly from generated code using external symbols so it
-- must always be present in a build, even if no unit has a direct with
-- of this unit. Also referenced from exception handling routines.
--- This is needed for programs that don't use exceptions explicitly but
+-- This is needed for programs that don't use exceptions explicitely but
-- direct calls to Ada.Exceptions are generated by gigi (for example,
-- by calling __gnat_raise_constraint_error directly).
@@ -88,4 +88,19 @@ package body System.Standard_Library is
end if;
end Adafinal;
+ -----------------
+ -- Break_Start --
+ -----------------
+
+ procedure Break_Start;
+ pragma Export (C, Break_Start, "__gnat_break_start");
+ -- This is a dummy procedure that is called at the start of execution.
+ -- Its sole purpose is to provide a well defined point for the placement
+ -- of a main program breakpoint.
+
+ procedure Break_Start is
+ begin
+ null;
+ end Break_Start;
+
end System.Standard_Library;
diff --git a/gcc/ada/s-stalib.ads b/gcc/ada/s-stalib.ads
index e443239bdca..bdd447538f8 100644
--- a/gcc/ada/s-stalib.ads
+++ b/gcc/ada/s-stalib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -56,7 +56,7 @@ with Unchecked_Conversion;
package System.Standard_Library is
pragma Suppress (All_Checks);
- -- Suppress explicitly all the checks to work around the Solaris linker
+ -- Suppress explicitely all the checks to work around the Solaris linker
-- bug when using gnatmake -f -a (but without -gnatp). This is not needed
-- with Solaris 2.6, so eventually can be removed ???
@@ -90,6 +90,9 @@ package System.Standard_Library is
-- Exception Declarations and Data --
-------------------------------------
+ type Raise_Action is access procedure;
+ -- A pointer to a procedure used in the Raise_Hook field
+
type Exception_Data;
type Exception_Data_Ptr is access all Exception_Data;
-- An equivalent of Exception_Id that is public
@@ -134,6 +137,13 @@ package System.Standard_Library is
-- implementations (we might well extend this mechanism for other
-- systems in the future).
+ Raise_Hook : Raise_Action;
+ -- This field can be used to place a "hook" on an exception. If the
+ -- value is non-null, then it points to a procedure which is called
+ -- whenever the exception is raised. This call occurs immediately,
+ -- before any other actions taken by the raise (and in particular
+ -- before any unwinding of the stack occurs).
+
end record;
-- Definitions for standard predefined exceptions defined in Standard,
@@ -157,7 +167,8 @@ package System.Standard_Library is
Name_Length => Constraint_Error_Name'Length,
Full_Name => To_Ptr (Constraint_Error_Name'Address),
HTable_Ptr => null,
- Import_Code => 0);
+ Import_Code => 0,
+ Raise_Hook => null);
Numeric_Error_Def : aliased Exception_Data :=
(Not_Handled_By_Others => False,
@@ -165,7 +176,8 @@ package System.Standard_Library is
Name_Length => Numeric_Error_Name'Length,
Full_Name => To_Ptr (Numeric_Error_Name'Address),
HTable_Ptr => null,
- Import_Code => 0);
+ Import_Code => 0,
+ Raise_Hook => null);
Program_Error_Def : aliased Exception_Data :=
(Not_Handled_By_Others => False,
@@ -173,7 +185,8 @@ package System.Standard_Library is
Name_Length => Program_Error_Name'Length,
Full_Name => To_Ptr (Program_Error_Name'Address),
HTable_Ptr => null,
- Import_Code => 0);
+ Import_Code => 0,
+ Raise_Hook => null);
Storage_Error_Def : aliased Exception_Data :=
(Not_Handled_By_Others => False,
@@ -181,7 +194,8 @@ package System.Standard_Library is
Name_Length => Storage_Error_Name'Length,
Full_Name => To_Ptr (Storage_Error_Name'Address),
HTable_Ptr => null,
- Import_Code => 0);
+ Import_Code => 0,
+ Raise_Hook => null);
Tasking_Error_Def : aliased Exception_Data :=
(Not_Handled_By_Others => False,
@@ -189,7 +203,8 @@ package System.Standard_Library is
Name_Length => Tasking_Error_Name'Length,
Full_Name => To_Ptr (Tasking_Error_Name'Address),
HTable_Ptr => null,
- Import_Code => 0);
+ Import_Code => 0,
+ Raise_Hook => null);
Abort_Signal_Def : aliased Exception_Data :=
(Not_Handled_By_Others => True,
@@ -197,7 +212,8 @@ package System.Standard_Library is
Name_Length => Abort_Signal_Name'Length,
Full_Name => To_Ptr (Abort_Signal_Name'Address),
HTable_Ptr => null,
- Import_Code => 0);
+ Import_Code => 0,
+ Raise_Hook => null);
pragma Export (C, Constraint_Error_Def, "constraint_error");
pragma Export (C, Numeric_Error_Def, "numeric_error");
diff --git a/gcc/ada/s-stoele.ads b/gcc/ada/s-stoele.ads
index 3d9f7c22b96..b22a1ccf113 100644
--- a/gcc/ada/s-stoele.ads
+++ b/gcc/ada/s-stoele.ads
@@ -6,10 +6,32 @@
-- --
-- S p e c --
-- --
--- This specification is adapted from the Ada Reference Manual for use with --
--- GNAT. In accordance with the copyright of that document, you can freely --
--- copy and modify this specification, provided that if you redistribute a --
--- modified version, any changes that you have made are clearly indicated. --
+-- Copyright (C) 2002-2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the implementation dependent sections of this file. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
@@ -17,18 +39,21 @@
-- extra declarations that can be introduced into System using Extend_System.
-- It is a good idea to avoid use clauses for this package!
-pragma Warnings (Off);
--- This is to stop bootstrap problems with the use of Inline_Always
--- To be removed (along with redundant Inline pragmas) in 3.13.
-
package System.Storage_Elements is
pragma Pure (Storage_Elements);
-- Note that we take advantage of the implementation permission to make
-- this unit Pure instead of Preelaborable; see RM 13.7.1(15).
+-- We also add the pragma Pure_Function to the operations in this package,
+-- because otherwise functions with parameters derived from Address are
+-- treated as non-pure by the back-end (see exp_ch6.adb). This is because
+-- in many cases such a parameter is used to hide read/out access to objects,
+-- and it would be unsafe to treat such functions as pure.
+
type Storage_Offset is range
-(2 ** (Standard."-" (Standard'Address_Size, 1))) ..
+(2 ** (Standard."-" (Standard'Address_Size, 1))) - 1;
+
-- Note: the reason for the qualification of "-" here by Standard is
-- that we have a current bug in GNAT that otherwise causes a bogus
-- ambiguity when this unit is analyzed in an Rtsfind context.
@@ -46,31 +71,31 @@ pragma Pure (Storage_Elements);
function "+" (Left : Address; Right : Storage_Offset) return Address;
pragma Convention (Intrinsic, "+");
- pragma Inline ("+");
pragma Inline_Always ("+");
+ pragma Pure_Function ("+");
function "+" (Left : Storage_Offset; Right : Address) return Address;
pragma Convention (Intrinsic, "+");
- pragma Inline ("+");
pragma Inline_Always ("+");
+ pragma Pure_Function ("+");
function "-" (Left : Address; Right : Storage_Offset) return Address;
pragma Convention (Intrinsic, "-");
- pragma Inline ("-");
pragma Inline_Always ("-");
+ pragma Pure_Function ("+");
function "-" (Left, Right : Address) return Storage_Offset;
pragma Convention (Intrinsic, "-");
- pragma Inline ("-");
pragma Inline_Always ("-");
+ pragma Pure_Function ("-");
function "mod"
(Left : Address;
Right : Storage_Offset)
return Storage_Offset;
pragma Convention (Intrinsic, "mod");
- pragma Inline ("mod");
pragma Inline_Always ("mod");
+ pragma Pure_Function ("mod");
-- Conversion to/from integers
@@ -78,12 +103,12 @@ pragma Pure (Storage_Elements);
function To_Address (Value : Integer_Address) return Address;
pragma Convention (Intrinsic, To_Address);
- pragma Inline (To_Address);
pragma Inline_Always (To_Address);
+ pragma Pure_Function (To_Address);
function To_Integer (Value : Address) return Integer_Address;
pragma Convention (Intrinsic, To_Integer);
- pragma Inline (To_Integer);
pragma Inline_Always (To_Integer);
+ pragma Pure_Function (To_Integer);
end System.Storage_Elements;
diff --git a/gcc/ada/s-stopoo.adb b/gcc/ada/s-stopoo.adb
new file mode 100644
index 00000000000..14e6fb68922
--- /dev/null
+++ b/gcc/ada/s-stopoo.adb
@@ -0,0 +1,65 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . S T O R A G E _ P O O L S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Storage_Pools is
+
+ ------------------
+ -- Allocate_Any --
+ ------------------
+
+ procedure Allocate_Any
+ (Pool : in out Root_Storage_Pool'Class;
+ Storage_Address : out Address;
+ Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count)
+ is
+ begin
+ Allocate
+ (Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
+ end Allocate_Any;
+
+ --------------------
+ -- Deallocate_Any --
+ --------------------
+
+ procedure Deallocate_Any
+ (Pool : in out Root_Storage_Pool'Class;
+ Storage_Address : Address;
+ Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count)
+ is
+ begin
+ Deallocate
+ (Pool, Storage_Address, Size_In_Storage_Elements, Alignment);
+ end Deallocate_Any;
+end System.Storage_Pools;
diff --git a/gcc/ada/s-stopoo.ads b/gcc/ada/s-stopoo.ads
index 4892e692383..22664393561 100644
--- a/gcc/ada/s-stopoo.ads
+++ b/gcc/ada/s-stopoo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -64,6 +64,25 @@ package System.Storage_Pools is
is abstract;
private
+ -- The following two procedures support the use of class-wide pool
+ -- objects in storage pools. When a local type is given a class-wide
+ -- storage pool, allocation and deallocation for the type must dispatch
+ -- to the operation of the specific pool, which is achieved by a call
+ -- to these procedures. (When the pool type is specific, the back-end
+ -- generates a call to the statically identified operation of the type).
+
+ procedure Allocate_Any
+ (Pool : in out Root_Storage_Pool'Class;
+ Storage_Address : out Address;
+ Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count);
+
+ procedure Deallocate_Any
+ (Pool : in out Root_Storage_Pool'Class;
+ Storage_Address : Address;
+ Size_In_Storage_Elements : System.Storage_Elements.Storage_Count;
+ Alignment : System.Storage_Elements.Storage_Count);
+
type Root_Storage_Pool is abstract
new Ada.Finalization.Limited_Controlled with null record;
end System.Storage_Pools;
diff --git a/gcc/ada/s-stratt.adb b/gcc/ada/s-stratt.adb
index 897b6daa2c5..a81895fd8aa 100644
--- a/gcc/ada/s-stratt.adb
+++ b/gcc/ada/s-stratt.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1998, 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- --
@@ -79,7 +79,6 @@ package body System.Stream_Attributes is
function From_AD is new UC (Fat_Pointer, S_AD);
function From_AS is new UC (Thin_Pointer, S_AS);
- function From_C is new UC (Character, S_C);
function From_F is new UC (Float, S_F);
function From_I is new UC (Integer, S_I);
function From_LF is new UC (Long_Float, S_LF);
@@ -100,7 +99,6 @@ package body System.Stream_Attributes is
function To_AD is new UC (S_AD, Fat_Pointer);
function To_AS is new UC (S_AS, Thin_Pointer);
- function To_C is new UC (S_C, Character);
function To_F is new UC (S_F, Float);
function To_I is new UC (S_I, Integer);
function To_LF is new UC (S_LF, Long_Float);
@@ -185,7 +183,7 @@ package body System.Stream_Attributes is
if L < T'Last then
raise Err;
else
- return To_C (T);
+ return Character'Val (T (1));
end if;
end I_C;
@@ -498,9 +496,10 @@ package body System.Stream_Attributes is
---------
procedure W_C (Stream : access RST; Item : in Character) is
- T : constant S_C := From_C (Item);
+ T : S_C;
begin
+ T (1) := Character'Pos (Item);
Ada.Streams.Write (Stream.all, T);
end W_C;
diff --git a/gcc/ada/s-stratt.ads b/gcc/ada/s-stratt.ads
index 926c6f6a0eb..a62feba078f 100644
--- a/gcc/ada/s-stratt.ads
+++ b/gcc/ada/s-stratt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 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- --
@@ -53,6 +53,8 @@ pragma Preelaborate (Stream_Attributes);
subtype RST is Ada.Streams.Root_Stream_Type'Class;
+ subtype SEC is Ada.Streams.Stream_Element_Count;
+
-- Enumeration types are usually transferred using the routine for the
-- corresponding integer. The exception is that special routines are
-- provided for Boolean and the character types, in case the protocol
@@ -148,6 +150,28 @@ pragma Preelaborate (Stream_Attributes);
procedure W_U (Stream : access RST; Item : in UST.Unsigned);
procedure W_WC (Stream : access RST; Item : in Wide_Character);
+ ----------------------------
+ -- Composite Input/Output --
+ ----------------------------
+
+ -- The following Boolean constant is defined and set to True only if the
+ -- stream representation of a series of elementary items of the same
+ -- type (one of the types handled by the above procedures) has the same
+ -- representation as an array of such items in memory. This allows such
+ -- a series of items to be read or written as a block, instead of
+ -- element by element.
+
+ -- If the stream representation does not have this property for all the
+ -- above types, then this constant can be omitted or set to False,
+ -- and the front end will generate element-by-element operations.
+
+ -- This interface assumes that a Stream_Element has the same size as
+ -- a Storage_Unit. If that is not the case, then this flag should
+ -- also be omitted (or set to False).
+
+ Block_Stream_Ops_OK : constant Boolean := True;
+ -- Set to False if block stream operations not permitted
+
private
pragma Inline (I_AD);
pragma Inline (I_AS);
diff --git a/gcc/ada/s-strcom.adb b/gcc/ada/s-strcom.adb
new file mode 100644
index 00000000000..bc72db5e3eb
--- /dev/null
+++ b/gcc/ada/s-strcom.adb
@@ -0,0 +1,140 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . S T R I N G _ C O M P A R E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Unchecked_Conversion;
+
+package body System.String_Compare is
+
+ type Word is mod 2 ** 32;
+ -- Used to process operands by words
+
+ type Big_Words is array (Natural) of Word;
+ type Big_Words_Ptr is access Big_Words;
+ -- Array type used to access by words
+
+ type Byte is mod 2 ** 8;
+ -- Used to process operands by bytes
+
+ type Big_Bytes is array (Natural) of Byte;
+ type Big_Bytes_Ptr is access Big_Bytes;
+ -- Array type used to access by bytes
+
+ function To_Big_Words is new
+ Unchecked_Conversion (System.Address, Big_Words_Ptr);
+
+ function To_Big_Bytes is new
+ Unchecked_Conversion (System.Address, Big_Bytes_Ptr);
+
+ -----------------
+ -- Str_Compare --
+ -----------------
+
+ function Str_Compare
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer
+ is
+ Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len);
+
+ begin
+ -- If operands are non-aligned, or length is too short, go by bytes
+
+ if (((Left or Right) and 2#11#) /= 0) or else Compare_Len < 4 then
+ return Str_Compare_Bytes (Left, Right, Left_Len, Right_Len);
+ end if;
+
+ -- Here we can go by words
+
+ declare
+ LeftP : constant Big_Words_Ptr := To_Big_Words (Left);
+ RightP : constant Big_Words_Ptr := To_Big_Words (Right);
+ Clen4 : constant Natural := Compare_Len / 4 - 1;
+ Clen4F : constant Natural := Clen4 * 4;
+
+ begin
+ for J in 0 .. Clen4 loop
+ if LeftP (J) /= RightP (J) then
+ return Str_Compare_Bytes
+ (Left + Address (4 * J),
+ Right + Address (4 * J),
+ 4, 4);
+ end if;
+ end loop;
+
+ return Str_Compare_Bytes
+ (Left + Address (Clen4F),
+ Right + Address (Clen4F),
+ Left_Len - Clen4F,
+ Right_Len - Clen4F);
+ end;
+ end Str_Compare;
+
+ -----------------------
+ -- Str_Compare_Bytes --
+ -----------------------
+
+ function Str_Compare_Bytes
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer
+ is
+ Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len);
+
+ LeftP : constant Big_Bytes_Ptr := To_Big_Bytes (Left);
+ RightP : constant Big_Bytes_Ptr := To_Big_Bytes (Right);
+
+ begin
+ for J in 0 .. Compare_Len - 1 loop
+ if LeftP (J) /= RightP (J) then
+ if LeftP (J) > RightP (J) then
+ return +1;
+ else
+ return -1;
+ end if;
+ end if;
+ end loop;
+
+ if Left_Len = Right_Len then
+ return 0;
+ elsif Left_Len > Right_Len then
+ return +1;
+ else
+ return -1;
+ end if;
+ end Str_Compare_Bytes;
+
+end System.String_Compare;
diff --git a/gcc/ada/s-strcom.ads b/gcc/ada/s-strcom.ads
new file mode 100644
index 00000000000..bfd5b39417d
--- /dev/null
+++ b/gcc/ada/s-strcom.ads
@@ -0,0 +1,61 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY COMPONENTS --
+-- --
+-- S Y S T E M . S T R I N G _ C O M P A R E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains functions for runtime comparisons on strings
+
+package System.String_Compare is
+
+ function Str_Compare
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer;
+ -- Compare the string starting at address Left of length Left_Len
+ -- with the string starting at address Right of length Right_Len.
+ -- The comparison is in the normal Ada semantic sense of string
+ -- comparison. The result is -1,0,+1 for Left<Right, Left=Right,
+ -- Left>Right respectively. This function works with 4 byte words
+ -- if the operands are aligned on 4-byte boundaries and long enough.
+
+ function Str_Compare_Bytes
+ (Left : System.Address;
+ Right : System.Address;
+ Left_Len : Natural;
+ Right_Len : Natural)
+ return Integer;
+ -- Same functionality as Str_Compare but always proceeds by bytes.
+ -- Used when the caller knows that the operands are unaligned, or
+ -- short enough that it makes no sense to go by words.
+
+end System.String_Compare;
diff --git a/gcc/ada/s-strops.adb b/gcc/ada/s-strops.adb
index 01b431dc1be..5440f72f53e 100644
--- a/gcc/ada/s-strops.adb
+++ b/gcc/ada/s-strops.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -102,26 +102,6 @@ package body System.String_Ops is
end if;
end Str_Concat_SC;
- ---------------
- -- Str_Equal --
- ---------------
-
- function Str_Equal (A, B : String) return Boolean is
- begin
- if A'Length /= B'Length then
- return False;
-
- else
- for J in A'Range loop
- if A (J) /= B (J + (B'First - A'First)) then
- return False;
- end if;
- end loop;
-
- return True;
- end if;
- end Str_Equal;
-
-------------------
-- Str_Normalize --
-------------------
diff --git a/gcc/ada/s-strops.ads b/gcc/ada/s-strops.ads
index b204a83a12e..aac2fd66f81 100644
--- a/gcc/ada/s-strops.ads
+++ b/gcc/ada/s-strops.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,6 +32,7 @@
------------------------------------------------------------------------------
-- This package contains functions for runtime operations on strings
+-- (other than runtime comparison, found in s-strcom.ads).
package System.String_Ops is
pragma Pure (String_Ops);
@@ -48,9 +49,6 @@ pragma Pure (String_Ops);
function Str_Concat_CC (X, Y : Character) return String;
-- Concatenate two characters
- function Str_Equal (A, B : String) return Boolean;
- -- Compare two strings for equality
-
procedure Str_Normalize (A : in out String);
-- Initialize String object if pragma Normalize_Scalars is in effect.
diff --git a/gcc/ada/s-strxdr.adb b/gcc/ada/s-strxdr.adb
new file mode 100644
index 00000000000..0a13cf38850
--- /dev/null
+++ b/gcc/ada/s-strxdr.adb
@@ -0,0 +1,1811 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUNTIME COMPONENTS --
+-- --
+-- S Y S T E M . S T R E A M _ A T T R I B U T E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1996-2003 Free Software Foundation, Inc. --
+-- --
+-- GARLIC is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GARLIC is distributed in the hope that it will be useful, but --
+-- WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABI- --
+-- LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
+-- License for more details. You should have received a copy of the GNU --
+-- General Public License distributed with GARLIC; see file COPYING. If --
+-- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, --
+-- Boston, MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This file is an alternate version of s-stratt.adb based on the XDR
+-- standard. It is especially useful for exchanging streams between two
+-- different systems with different basic type representations and endianess.
+
+with Ada.Streams; use Ada.Streams;
+with Ada.Unchecked_Conversion;
+
+package body System.Stream_Attributes is
+
+ pragma Suppress (Range_Check);
+ pragma Suppress (Overflow_Check);
+
+ use UST;
+
+ Data_Error : exception;
+ -- Exception raised if insufficient data read.
+
+ SU : constant := System.Storage_Unit;
+ -- XXXXX pragma Assert (SU = 8);
+
+ BB : constant := 2 ** SU; -- Byte base
+ BL : constant := 2 ** SU - 1; -- Byte last
+ BS : constant := 2 ** (SU - 1); -- Byte sign
+
+ US : constant := Unsigned'Size; -- Unsigned size
+ UB : constant := (US - 1) / SU + 1; -- Unsigned byte
+ UL : constant := 2 ** US - 1; -- Unsigned last
+
+ subtype SE is Ada.Streams.Stream_Element;
+ subtype SEA is Ada.Streams.Stream_Element_Array;
+ subtype SEO is Ada.Streams.Stream_Element_Offset;
+
+ generic function UC renames Ada.Unchecked_Conversion;
+
+ type Field_Type is
+ record
+ E_Size : Integer; -- Exponent bit size
+ E_Bias : Integer; -- Exponent bias
+ F_Size : Integer; -- Fraction bit size
+ E_Last : Integer; -- Max exponent value
+ F_Mask : SE; -- Mask to apply on first fraction byte
+ E_Bytes : SEO; -- N. of exponent bytes completly used
+ F_Bytes : SEO; -- N. of fraction bytes completly used
+ F_Bits : Integer; -- N. of bits used on first fraction word
+ end record;
+
+ type Precision is (Single, Double, Quadruple);
+
+ Fields : constant array (Precision) of Field_Type := (
+
+ -- Single precision
+
+ (E_Size => 8,
+ E_Bias => 127,
+ F_Size => 23,
+ E_Last => 2 ** 8 - 1,
+ F_Mask => 16#7F#, -- 2 ** 7 - 1,
+ E_Bytes => 2,
+ F_Bytes => 3,
+ F_Bits => 23 mod US),
+
+ -- Double precision
+
+ (E_Size => 11,
+ E_Bias => 1023,
+ F_Size => 52,
+ E_Last => 2 ** 11 - 1,
+ F_Mask => 16#0F#, -- 2 ** 4 - 1,
+ E_Bytes => 2,
+ F_Bytes => 7,
+ F_Bits => 52 mod US),
+
+ -- Quadruple precision
+
+ (E_Size => 15,
+ E_Bias => 16383,
+ F_Size => 112,
+ E_Last => 2 ** 8 - 1,
+ F_Mask => 16#FF#, -- 2 ** 8 - 1,
+ E_Bytes => 2,
+ F_Bytes => 14,
+ F_Bits => 112 mod US));
+
+ -- The representation of all items requires a multiple of four bytes
+ -- (or 32 bits) of data. The bytes are numbered 0 through n-1. The bytes
+ -- are read or written to some byte stream such that byte m always
+ -- precedes byte m+1. If the n bytes needed to contain the data are not
+ -- a multiple of four, then the n bytes are followed by enough (0 to 3)
+ -- residual zero bytes, r, to make the total byte count a multiple of 4.
+
+ -- An XDR signed integer is a 32-bit datum that encodes an integer
+ -- in the range [-2147483648,2147483647]. The integer is represented
+ -- in two's complement notation. The most and least significant bytes
+ -- are 0 and 3, respectively. Integers are declared as follows:
+ --
+ -- (MSB) (LSB)
+ -- +-------+-------+-------+-------+
+ -- |byte 0 |byte 1 |byte 2 |byte 3 |
+ -- +-------+-------+-------+-------+
+ -- <------------32 bits------------>
+
+ SSI_L : constant := 1;
+ SI_L : constant := 2;
+ I_L : constant := 4;
+ LI_L : constant := 8;
+ LLI_L : constant := 8;
+
+ subtype XDR_S_SSI is SEA (1 .. SSI_L);
+ subtype XDR_S_SI is SEA (1 .. SI_L);
+ subtype XDR_S_I is SEA (1 .. I_L);
+ subtype XDR_S_LI is SEA (1 .. LI_L);
+ subtype XDR_S_LLI is SEA (1 .. LLI_L);
+
+ function Short_Short_Integer_To_XDR_S_SSI is
+ new Ada.Unchecked_Conversion (Short_Short_Integer, XDR_S_SSI);
+ function XDR_S_SSI_To_Short_Short_Integer is
+ new Ada.Unchecked_Conversion (XDR_S_SSI, Short_Short_Integer);
+
+ function Short_Integer_To_XDR_S_SI is
+ new Ada.Unchecked_Conversion (Short_Integer, XDR_S_SI);
+ function XDR_S_SI_To_Short_Integer is
+ new Ada.Unchecked_Conversion (XDR_S_SI, Short_Integer);
+
+ function Integer_To_XDR_S_I is
+ new Ada.Unchecked_Conversion (Integer, XDR_S_I);
+ function XDR_S_I_To_Integer is
+ new Ada.Unchecked_Conversion (XDR_S_I, Integer);
+
+ function Long_Long_Integer_To_XDR_S_LI is
+ new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LI);
+ function XDR_S_LI_To_Long_Long_Integer is
+ new Ada.Unchecked_Conversion (XDR_S_LI, Long_Long_Integer);
+
+ function Long_Long_Integer_To_XDR_S_LLI is
+ new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LLI);
+ function XDR_S_LLI_To_Long_Long_Integer is
+ new Ada.Unchecked_Conversion (XDR_S_LLI, Long_Long_Integer);
+
+ -- An XDR unsigned integer is a 32-bit datum that encodes a nonnegative
+ -- integer in the range [0,4294967295]. It is represented by an unsigned
+ -- binary number whose most and least significant bytes are 0 and 3,
+ -- respectively. An unsigned integer is declared as follows:
+ --
+ -- (MSB) (LSB)
+ -- +-------+-------+-------+-------+
+ -- |byte 0 |byte 1 |byte 2 |byte 3 |
+ -- +-------+-------+-------+-------+
+ -- <------------32 bits------------>
+
+ SSU_L : constant := 1;
+ SU_L : constant := 2;
+ U_L : constant := 4;
+ LU_L : constant := 8;
+ LLU_L : constant := 8;
+
+ subtype XDR_S_SSU is SEA (1 .. SSU_L);
+ subtype XDR_S_SU is SEA (1 .. SU_L);
+ subtype XDR_S_U is SEA (1 .. U_L);
+ subtype XDR_S_LU is SEA (1 .. LU_L);
+ subtype XDR_S_LLU is SEA (1 .. LLU_L);
+
+ type XDR_SSU is mod BB ** SSU_L;
+ type XDR_SU is mod BB ** SU_L;
+ type XDR_U is mod BB ** U_L;
+
+ function Short_Unsigned_To_XDR_S_SU is
+ new Ada.Unchecked_Conversion (Short_Unsigned, XDR_S_SU);
+ function XDR_S_SU_To_Short_Unsigned is
+ new Ada.Unchecked_Conversion (XDR_S_SU, Short_Unsigned);
+
+ function Unsigned_To_XDR_S_U is
+ new Ada.Unchecked_Conversion (Unsigned, XDR_S_U);
+ function XDR_S_U_To_Unsigned is
+ new Ada.Unchecked_Conversion (XDR_S_U, Unsigned);
+
+ function Long_Long_Unsigned_To_XDR_S_LU is
+ new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LU);
+ function XDR_S_LU_To_Long_Long_Unsigned is
+ new Ada.Unchecked_Conversion (XDR_S_LU, Long_Long_Unsigned);
+
+ function Long_Long_Unsigned_To_XDR_S_LLU is
+ new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LLU);
+ function XDR_S_LLU_To_Long_Long_Unsigned is
+ new Ada.Unchecked_Conversion (XDR_S_LLU, Long_Long_Unsigned);
+
+ -- The standard defines the floating-point data type "float" (32 bits
+ -- or 4 bytes). The encoding used is the IEEE standard for normalized
+ -- single-precision floating-point numbers.
+
+ -- The standard defines the encoding for the double-precision
+ -- floating-point data type "double" (64 bits or 8 bytes). The
+ -- encoding used is the IEEE standard for normalized double-precision
+ -- floating-point numbers.
+
+ SF_L : constant := 4; -- Single precision
+ F_L : constant := 4; -- Single precision
+ LF_L : constant := 8; -- Double precision
+ LLF_L : constant := 16; -- Quadruple precision
+
+ TM_L : constant := 8;
+ subtype XDR_S_TM is SEA (1 .. TM_L);
+ type XDR_TM is mod BB ** TM_L;
+
+ type XDR_SA is mod 2 ** Standard'Address_Size;
+ function To_XDR_SA is new UC (System.Address, XDR_SA);
+ function To_XDR_SA is new UC (XDR_SA, System.Address);
+
+ -- Enumerations have the same representation as signed integers.
+ -- Enumerations are handy for describing subsets of the integers.
+
+ -- Booleans are important enough and occur frequently enough to warrant
+ -- their own explicit type in the standard. Booleans are declared as
+ -- an enumeration, with FALSE = 0 and TRUE = 1.
+
+ -- The standard defines a string of n (numbered 0 through n-1) ASCII
+ -- bytes to be the number n encoded as an unsigned integer (as described
+ -- above), and followed by the n bytes of the string. Byte m of the string
+ -- always precedes byte m+1 of the string, and byte 0 of the string always
+ -- follows the string's length. If n is not a multiple of four, then the
+ -- n bytes are followed by enough (0 to 3) residual zero bytes, r, to make
+ -- the total byte count a multiple of four.
+
+ -- To fit with XDR string, do not consider character as an enumeration
+ -- type.
+
+ C_L : constant := 1;
+ subtype XDR_S_C is SEA (1 .. C_L);
+
+ -- Consider Wide_Character as an enumeration type
+
+ WC_L : constant := 4;
+ subtype XDR_S_WC is SEA (1 .. WC_L);
+ type XDR_WC is mod BB ** WC_L;
+
+ -- Optimization: if we already have the correct Bit_Order, then some
+ -- computations can be avoided since the source and the target will be
+ -- identical anyway. They will be replaced by direct unchecked
+ -- conversions.
+
+ Optimize_Integers : constant Boolean :=
+ Default_Bit_Order = High_Order_First;
+
+ ----------
+ -- I_AD --
+ ----------
+
+ function I_AD (Stream : access RST) return Fat_Pointer is
+ FP : Fat_Pointer;
+
+ begin
+ FP.P1 := I_AS (Stream).P1;
+ FP.P2 := I_AS (Stream).P1;
+
+ return FP;
+ end I_AD;
+
+ ----------
+ -- I_AS --
+ ----------
+
+ function I_AS (Stream : access RST) return Thin_Pointer is
+ S : XDR_S_TM;
+ L : SEO;
+ U : XDR_TM := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_TM (S (N));
+ end loop;
+
+ return (P1 => To_XDR_SA (XDR_SA (U)));
+ end if;
+ end I_AS;
+
+ ---------
+ -- I_B --
+ ---------
+
+ function I_B (Stream : access RST) return Boolean is
+ begin
+ case I_SSU (Stream) is
+ when 0 => return False;
+ when 1 => return True;
+ when others => raise Data_Error;
+ end case;
+ end I_B;
+
+ ---------
+ -- I_C --
+ ---------
+
+ function I_C (Stream : access RST) return Character is
+ S : XDR_S_C;
+ L : SEO;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ else
+
+ -- Use Ada requirements on Character representation clause
+
+ return Character'Val (S (1));
+ end if;
+ end I_C;
+
+ ---------
+ -- I_F --
+ ---------
+
+ function I_F (Stream : access RST) return Float is
+ I : constant Precision := Single;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Last : Integer renames Fields (I).E_Last;
+ F_Mask : SE renames Fields (I).F_Mask;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+
+ Positive : Boolean;
+ Exponent : Long_Unsigned;
+ Fraction : Long_Unsigned;
+ Result : Float;
+ S : SEA (1 .. F_L);
+ L : SEO;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ end if;
+
+ -- Extract Fraction, Sign and Exponent
+
+ Fraction := Long_Unsigned (S (F_L + 1 - F_Bytes) and F_Mask);
+ for N in F_L + 2 - F_Bytes .. F_L loop
+ Fraction := Fraction * BB + Long_Unsigned (S (N));
+ end loop;
+ Result := Float'Scaling (Float (Fraction), -F_Size);
+
+ if BS <= S (1) then
+ Positive := False;
+ Exponent := Long_Unsigned (S (1) - BS);
+ else
+ Positive := True;
+ Exponent := Long_Unsigned (S (1));
+ end if;
+
+ for N in 2 .. E_Bytes loop
+ Exponent := Exponent * BB + Long_Unsigned (S (N));
+ end loop;
+ Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+
+ -- NaN or Infinities
+
+ if Integer (Exponent) = E_Last then
+ raise Constraint_Error;
+
+ elsif Exponent = 0 then
+
+ -- Signed zeros
+
+ if Fraction = 0 then
+ null;
+
+ -- Denormalized float
+
+ else
+ Result := Float'Scaling (Result, 1 - E_Bias);
+ end if;
+
+ -- Normalized float
+
+ else
+ Result := Float'Scaling
+ (1.0 + Result, Integer (Exponent) - E_Bias);
+ end if;
+
+ if not Positive then
+ Result := -Result;
+ end if;
+
+ return Result;
+ end I_F;
+
+ ---------
+ -- I_I --
+ ---------
+
+ function I_I (Stream : access RST) return Integer is
+ S : XDR_S_I;
+ L : SEO;
+ U : XDR_U := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return XDR_S_I_To_Integer (S);
+
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_U (S (N));
+ end loop;
+
+ -- Test sign and apply two complement notation
+
+ if S (1) < BL then
+ return Integer (U);
+
+ else
+ return Integer (-((XDR_U'Last xor U) + 1));
+ end if;
+ end if;
+ end I_I;
+
+ ----------
+ -- I_LF --
+ ----------
+
+ function I_LF (Stream : access RST) return Long_Float is
+ I : constant Precision := Double;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Last : Integer renames Fields (I).E_Last;
+ F_Mask : SE renames Fields (I).F_Mask;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+
+ Positive : Boolean;
+ Exponent : Long_Unsigned;
+ Fraction : Long_Long_Unsigned;
+ Result : Long_Float;
+ S : SEA (1 .. LF_L);
+ L : SEO;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ end if;
+
+ -- Extract Fraction, Sign and Exponent
+
+ Fraction := Long_Long_Unsigned (S (LF_L + 1 - F_Bytes) and F_Mask);
+ for N in LF_L + 2 - F_Bytes .. LF_L loop
+ Fraction := Fraction * BB + Long_Long_Unsigned (S (N));
+ end loop;
+
+ Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size);
+
+ if BS <= S (1) then
+ Positive := False;
+ Exponent := Long_Unsigned (S (1) - BS);
+ else
+ Positive := True;
+ Exponent := Long_Unsigned (S (1));
+ end if;
+
+ for N in 2 .. E_Bytes loop
+ Exponent := Exponent * BB + Long_Unsigned (S (N));
+ end loop;
+
+ Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+
+ -- NaN or Infinities
+
+ if Integer (Exponent) = E_Last then
+ raise Constraint_Error;
+
+ elsif Exponent = 0 then
+
+ -- Signed zeros
+
+ if Fraction = 0 then
+ null;
+
+ -- Denormalized float
+
+ else
+ Result := Long_Float'Scaling (Result, 1 - E_Bias);
+ end if;
+
+ -- Normalized float
+
+ else
+ Result := Long_Float'Scaling
+ (1.0 + Result, Integer (Exponent) - E_Bias);
+ end if;
+
+ if not Positive then
+ Result := -Result;
+ end if;
+
+ return Result;
+ end I_LF;
+
+ ----------
+ -- I_LI --
+ ----------
+
+ function I_LI (Stream : access RST) return Long_Integer is
+ S : XDR_S_LI;
+ L : SEO;
+ U : Unsigned := 0;
+ X : Long_Unsigned := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return Long_Integer (XDR_S_LI_To_Long_Long_Integer (S));
+
+ else
+
+ -- Compute using machine unsigned
+ -- rather than long_long_unsigned
+
+ for N in S'Range loop
+ U := U * BB + Unsigned (S (N));
+
+ -- We have filled an unsigned
+
+ if N mod UB = 0 then
+ X := Shift_Left (X, US) + Long_Unsigned (U);
+ U := 0;
+ end if;
+ end loop;
+
+ -- Test sign and apply two complement notation
+
+ if S (1) < BL then
+ return Long_Integer (X);
+ else
+ return Long_Integer (-((Long_Unsigned'Last xor X) + 1));
+ end if;
+
+ end if;
+ end I_LI;
+
+ -----------
+ -- I_LLF --
+ -----------
+
+ function I_LLF (Stream : access RST) return Long_Long_Float is
+ I : constant Precision := Quadruple;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Last : Integer renames Fields (I).E_Last;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+
+ Positive : Boolean;
+ Exponent : Long_Unsigned;
+ Fraction_1 : Long_Long_Unsigned := 0;
+ Fraction_2 : Long_Long_Unsigned := 0;
+ Result : Long_Long_Float;
+ HF : constant Natural := F_Size / 2;
+ S : SEA (1 .. LLF_L);
+ L : SEO;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ end if;
+
+ -- Extract Fraction, Sign and Exponent
+
+ for I in LLF_L - F_Bytes + 1 .. LLF_L - 7 loop
+ Fraction_1 := Fraction_1 * BB + Long_Long_Unsigned (S (I));
+ end loop;
+
+ for I in SEO (LLF_L - 6) .. SEO (LLF_L) loop
+ Fraction_2 := Fraction_2 * BB + Long_Long_Unsigned (S (I));
+ end loop;
+
+ Result := Long_Long_Float'Scaling (Long_Long_Float (Fraction_2), -HF);
+ Result := Long_Long_Float (Fraction_1) + Result;
+ Result := Long_Long_Float'Scaling (Result, HF - F_Size);
+
+ if BS <= S (1) then
+ Positive := False;
+ Exponent := Long_Unsigned (S (1) - BS);
+ else
+ Positive := True;
+ Exponent := Long_Unsigned (S (1));
+ end if;
+
+ for N in 2 .. E_Bytes loop
+ Exponent := Exponent * BB + Long_Unsigned (S (N));
+ end loop;
+
+ Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+
+ -- NaN or Infinities
+
+ if Integer (Exponent) = E_Last then
+ raise Constraint_Error;
+
+ elsif Exponent = 0 then
+
+ -- Signed zeros
+
+ if Fraction_1 = 0 and then Fraction_2 = 0 then
+ null;
+
+ -- Denormalized float
+
+ else
+ Result := Long_Long_Float'Scaling (Result, 1 - E_Bias);
+ end if;
+
+ -- Normalized float
+
+ else
+ Result := Long_Long_Float'Scaling
+ (1.0 + Result, Integer (Exponent) - E_Bias);
+ end if;
+
+ if not Positive then
+ Result := -Result;
+ end if;
+
+ return Result;
+ end I_LLF;
+
+ -----------
+ -- I_LLI --
+ -----------
+
+ function I_LLI (Stream : access RST) return Long_Long_Integer is
+ S : XDR_S_LLI;
+ L : SEO;
+ U : Unsigned := 0;
+ X : Long_Long_Unsigned := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ elsif Optimize_Integers then
+ return XDR_S_LLI_To_Long_Long_Integer (S);
+ else
+
+ -- Compute using machine unsigned for computing
+ -- rather than long_long_unsigned.
+
+ for N in S'Range loop
+ U := U * BB + Unsigned (S (N));
+
+ -- We have filled an unsigned
+
+ if N mod UB = 0 then
+ X := Shift_Left (X, US) + Long_Long_Unsigned (U);
+ U := 0;
+ end if;
+ end loop;
+
+ -- Test sign and apply two complement notation
+
+ if S (1) < BL then
+ return Long_Long_Integer (X);
+ else
+ return Long_Long_Integer (-((Long_Long_Unsigned'Last xor X) + 1));
+ end if;
+ end if;
+ end I_LLI;
+
+ -----------
+ -- I_LLU --
+ -----------
+
+ function I_LLU (Stream : access RST) return Long_Long_Unsigned is
+ S : XDR_S_LLU;
+ L : SEO;
+ U : Unsigned := 0;
+ X : Long_Long_Unsigned := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ elsif Optimize_Integers then
+ return XDR_S_LLU_To_Long_Long_Unsigned (S);
+ else
+
+ -- Compute using machine unsigned
+ -- rather than long_long_unsigned.
+
+ for N in S'Range loop
+ U := U * BB + Unsigned (S (N));
+
+ -- We have filled an unsigned
+
+ if N mod UB = 0 then
+ X := Shift_Left (X, US) + Long_Long_Unsigned (U);
+ U := 0;
+ end if;
+ end loop;
+
+ return X;
+ end if;
+ end I_LLU;
+
+ ----------
+ -- I_LU --
+ ----------
+
+ function I_LU (Stream : access RST) return Long_Unsigned is
+ S : XDR_S_LU;
+ L : SEO;
+ U : Unsigned := 0;
+ X : Long_Unsigned := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ elsif Optimize_Integers then
+ return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S));
+ else
+
+ -- Compute using machine unsigned
+ -- rather than long_unsigned.
+
+ for N in S'Range loop
+ U := U * BB + Unsigned (S (N));
+
+ -- We have filled an unsigned
+
+ if N mod UB = 0 then
+ X := Shift_Left (X, US) + Long_Unsigned (U);
+ U := 0;
+ end if;
+ end loop;
+
+ return X;
+ end if;
+ end I_LU;
+
+ ----------
+ -- I_SF --
+ ----------
+
+ function I_SF (Stream : access RST) return Short_Float is
+ I : constant Precision := Single;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Last : Integer renames Fields (I).E_Last;
+ F_Mask : SE renames Fields (I).F_Mask;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+
+ Exponent : Long_Unsigned;
+ Fraction : Long_Unsigned;
+ Positive : Boolean;
+ Result : Short_Float;
+ S : SEA (1 .. SF_L);
+ L : SEO;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ end if;
+
+ -- Extract Fraction, Sign and Exponent
+
+ Fraction := Long_Unsigned (S (SF_L + 1 - F_Bytes) and F_Mask);
+ for N in SF_L + 2 - F_Bytes .. SF_L loop
+ Fraction := Fraction * BB + Long_Unsigned (S (N));
+ end loop;
+ Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size);
+
+ if BS <= S (1) then
+ Positive := False;
+ Exponent := Long_Unsigned (S (1) - BS);
+ else
+ Positive := True;
+ Exponent := Long_Unsigned (S (1));
+ end if;
+
+ for N in 2 .. E_Bytes loop
+ Exponent := Exponent * BB + Long_Unsigned (S (N));
+ end loop;
+ Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+
+ -- NaN or Infinities
+
+ if Integer (Exponent) = E_Last then
+ raise Constraint_Error;
+
+ elsif Exponent = 0 then
+
+ -- Signed zeros
+
+ if Fraction = 0 then
+ null;
+
+ -- Denormalized float
+
+ else
+ Result := Short_Float'Scaling (Result, 1 - E_Bias);
+ end if;
+
+ -- Normalized float
+
+ else
+ Result := Short_Float'Scaling
+ (1.0 + Result, Integer (Exponent) - E_Bias);
+ end if;
+
+ if not Positive then
+ Result := -Result;
+ end if;
+
+ return Result;
+ end I_SF;
+
+ ----------
+ -- I_SI --
+ ----------
+
+ function I_SI (Stream : access RST) return Short_Integer is
+ S : XDR_S_SI;
+ L : SEO;
+ U : XDR_SU := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return XDR_S_SI_To_Short_Integer (S);
+
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_SU (S (N));
+ end loop;
+
+ -- Test sign and apply two complement notation
+
+ if S (1) < BL then
+ return Short_Integer (U);
+ else
+ return Short_Integer (-((XDR_SU'Last xor U) + 1));
+ end if;
+ end if;
+ end I_SI;
+
+ -----------
+ -- I_SSI --
+ -----------
+
+ function I_SSI (Stream : access RST) return Short_Short_Integer is
+ S : XDR_S_SSI;
+ L : SEO;
+ U : XDR_SSU;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ elsif Optimize_Integers then
+ return XDR_S_SSI_To_Short_Short_Integer (S);
+ else
+ U := XDR_SSU (S (1));
+
+ -- Test sign and apply two complement notation
+
+ if S (1) < BL then
+ return Short_Short_Integer (U);
+ else
+ return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1));
+ end if;
+ end if;
+ end I_SSI;
+
+ -----------
+ -- I_SSU --
+ -----------
+
+ function I_SSU (Stream : access RST) return Short_Short_Unsigned is
+ S : XDR_S_SSU;
+ L : SEO;
+ U : XDR_SSU := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ else
+ U := XDR_SSU (S (1));
+
+ return Short_Short_Unsigned (U);
+ end if;
+ end I_SSU;
+
+ ----------
+ -- I_SU --
+ ----------
+
+ function I_SU (Stream : access RST) return Short_Unsigned is
+ S : XDR_S_SU;
+ L : SEO;
+ U : XDR_SU := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ elsif Optimize_Integers then
+ return XDR_S_SU_To_Short_Unsigned (S);
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_SU (S (N));
+ end loop;
+
+ return Short_Unsigned (U);
+ end if;
+ end I_SU;
+
+ ---------
+ -- I_U --
+ ---------
+
+ function I_U (Stream : access RST) return Unsigned is
+ S : XDR_S_U;
+ L : SEO;
+ U : XDR_U := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+
+ elsif Optimize_Integers then
+ return XDR_S_U_To_Unsigned (S);
+
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_U (S (N));
+ end loop;
+
+ return Unsigned (U);
+ end if;
+ end I_U;
+
+ ----------
+ -- I_WC --
+ ----------
+
+ function I_WC (Stream : access RST) return Wide_Character is
+ S : XDR_S_WC;
+ L : SEO;
+ U : XDR_WC := 0;
+
+ begin
+ Ada.Streams.Read (Stream.all, S, L);
+
+ if L /= S'Last then
+ raise Data_Error;
+ else
+ for N in S'Range loop
+ U := U * BB + XDR_WC (S (N));
+ end loop;
+
+ -- Use Ada requirements on Wide_Character representation clause
+
+ return Wide_Character'Val (U);
+ end if;
+ end I_WC;
+
+ ----------
+ -- W_AD --
+ ----------
+
+ procedure W_AD (Stream : access RST; Item : in Fat_Pointer) is
+ S : XDR_S_TM;
+ U : XDR_TM;
+
+ begin
+ U := XDR_TM (To_XDR_SA (Item.P1));
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ Ada.Streams.Write (Stream.all, S);
+
+ U := XDR_TM (To_XDR_SA (Item.P2));
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ Ada.Streams.Write (Stream.all, S);
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end W_AD;
+
+ ----------
+ -- W_AS --
+ ----------
+
+ procedure W_AS (Stream : access RST; Item : in Thin_Pointer) is
+ S : XDR_S_TM;
+ U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1));
+
+ begin
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ Ada.Streams.Write (Stream.all, S);
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end W_AS;
+
+ ---------
+ -- W_B --
+ ---------
+
+ procedure W_B (Stream : access RST; Item : in Boolean) is
+ begin
+ if Item then
+ W_SSU (Stream, 1);
+ else
+ W_SSU (Stream, 0);
+ end if;
+ end W_B;
+
+ ---------
+ -- W_C --
+ ---------
+
+ procedure W_C (Stream : access RST; Item : in Character) is
+ S : XDR_S_C;
+
+ pragma Assert (C_L = 1);
+
+ begin
+
+ -- Use Ada requirements on Character representation clause
+
+ S (1) := SE (Character'Pos (Item));
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_C;
+
+ ---------
+ -- W_F --
+ ---------
+
+ procedure W_F (Stream : access RST; Item : in Float) is
+ I : constant Precision := Single;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+ F_Mask : SE renames Fields (I).F_Mask;
+
+ Exponent : Long_Unsigned;
+ Fraction : Long_Unsigned;
+ Positive : Boolean;
+ E : Integer;
+ F : Float;
+ S : SEA (1 .. F_L) := (others => 0);
+
+ begin
+ if not Item'Valid then
+ raise Constraint_Error;
+ end if;
+
+ -- Compute Sign
+
+ Positive := (0.0 <= Item);
+ F := abs (Item);
+
+ -- Signed zero
+
+ if F = 0.0 then
+ Exponent := 0;
+ Fraction := 0;
+
+ else
+ E := Float'Exponent (F) - 1;
+
+ -- Denormalized float
+
+ if E <= -E_Bias then
+ F := Float'Scaling (F, F_Size + E_Bias - 1);
+ E := -E_Bias;
+ else
+ F := Float'Scaling (Float'Fraction (F), F_Size + 1);
+ end if;
+
+ -- Compute Exponent and Fraction
+
+ Exponent := Long_Unsigned (E + E_Bias);
+ Fraction := Long_Unsigned (F * 2.0) / 2;
+ end if;
+
+ -- Store Fraction
+
+ for I in reverse F_L - F_Bytes + 1 .. F_L loop
+ S (I) := SE (Fraction mod BB);
+ Fraction := Fraction / BB;
+ end loop;
+
+ -- Remove implicit bit
+
+ S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask;
+
+ -- Store Exponent (not always at the beginning of a byte)
+
+ Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+ for N in reverse 1 .. E_Bytes loop
+ S (N) := SE (Exponent mod BB) + S (N);
+ Exponent := Exponent / BB;
+ end loop;
+
+ -- Store Sign
+
+ if not Positive then
+ S (1) := S (1) + BS;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_F;
+
+ ---------
+ -- W_I --
+ ---------
+
+ procedure W_I (Stream : access RST; Item : in Integer) is
+ S : XDR_S_I;
+ U : XDR_U;
+
+ begin
+ if Optimize_Integers then
+ S := Integer_To_XDR_S_I (Item);
+ else
+
+ -- Test sign and apply two complement notation
+
+ if Item < 0 then
+ U := XDR_U'Last xor XDR_U (-(Item + 1));
+ else
+ U := XDR_U (Item);
+ end if;
+
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_I;
+
+ ----------
+ -- W_LF --
+ ----------
+
+ procedure W_LF (Stream : access RST; Item : in Long_Float) is
+ I : constant Precision := Double;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+ F_Mask : SE renames Fields (I).F_Mask;
+
+ Exponent : Long_Unsigned;
+ Fraction : Long_Long_Unsigned;
+ Positive : Boolean;
+ E : Integer;
+ F : Long_Float;
+ S : SEA (1 .. LF_L) := (others => 0);
+
+ begin
+ if not Item'Valid then
+ raise Constraint_Error;
+ end if;
+
+ -- Compute Sign
+
+ Positive := (0.0 <= Item);
+ F := abs (Item);
+
+ -- Signed zero
+
+ if F = 0.0 then
+ Exponent := 0;
+ Fraction := 0;
+
+ else
+ E := Long_Float'Exponent (F) - 1;
+
+ -- Denormalized float
+
+ if E <= -E_Bias then
+ E := -E_Bias;
+ F := Long_Float'Scaling (F, F_Size + E_Bias - 1);
+ else
+ F := Long_Float'Scaling (F, F_Size - E);
+ end if;
+
+ -- Compute Exponent and Fraction
+
+ Exponent := Long_Unsigned (E + E_Bias);
+ Fraction := Long_Long_Unsigned (F * 2.0) / 2;
+ end if;
+
+ -- Store Fraction
+
+ for I in reverse LF_L - F_Bytes + 1 .. LF_L loop
+ S (I) := SE (Fraction mod BB);
+ Fraction := Fraction / BB;
+ end loop;
+
+ -- Remove implicit bit
+
+ S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask;
+
+ -- Store Exponent (not always at the beginning of a byte)
+
+ Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+ for N in reverse 1 .. E_Bytes loop
+ S (N) := SE (Exponent mod BB) + S (N);
+ Exponent := Exponent / BB;
+ end loop;
+
+ -- Store Sign
+
+ if not Positive then
+ S (1) := S (1) + BS;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_LF;
+
+ ----------
+ -- W_LI --
+ ----------
+
+ procedure W_LI (Stream : access RST; Item : in Long_Integer) is
+ S : XDR_S_LI;
+ U : Unsigned;
+ X : Long_Unsigned;
+
+ begin
+ if Optimize_Integers then
+ S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item));
+ else
+
+ -- Test sign and apply two complement notation
+
+ if Item < 0 then
+ X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1));
+ else
+ X := Long_Unsigned (Item);
+ end if;
+
+ -- Compute using machine unsigned
+ -- rather than long_unsigned.
+
+ for N in reverse S'Range loop
+
+ -- We have filled an unsigned
+
+ if (LU_L - N) mod UB = 0 then
+ U := Unsigned (X and UL);
+ X := Shift_Right (X, US);
+ end if;
+
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_LI;
+
+ -----------
+ -- W_LLF --
+ -----------
+
+ procedure W_LLF (Stream : access RST; Item : in Long_Long_Float) is
+ I : constant Precision := Quadruple;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+
+ HFS : constant Integer := F_Size / 2;
+
+ Exponent : Long_Unsigned;
+ Fraction_1 : Long_Long_Unsigned;
+ Fraction_2 : Long_Long_Unsigned;
+ Positive : Boolean;
+ E : Integer;
+ F : Long_Long_Float := Item;
+ S : SEA (1 .. LLF_L) := (others => 0);
+
+ begin
+ if not Item'Valid then
+ raise Constraint_Error;
+ end if;
+
+ -- Compute Sign
+
+ Positive := (0.0 <= Item);
+ if F < 0.0 then
+ F := -Item;
+ end if;
+
+ -- Signed zero
+
+ if F = 0.0 then
+ Exponent := 0;
+ Fraction_1 := 0;
+ Fraction_2 := 0;
+
+ else
+ E := Long_Long_Float'Exponent (F) - 1;
+
+ -- Denormalized float
+
+ if E <= -E_Bias then
+ F := Long_Long_Float'Scaling (F, E_Bias - 1);
+ E := -E_Bias;
+ else
+ F := Long_Long_Float'Scaling
+ (Long_Long_Float'Fraction (F), 1);
+ end if;
+
+ -- Compute Exponent and Fraction
+
+ Exponent := Long_Unsigned (E + E_Bias);
+ F := Long_Long_Float'Scaling (F, F_Size - HFS);
+ Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F));
+ F := Long_Long_Float (F - Long_Long_Float (Fraction_1));
+ F := Long_Long_Float'Scaling (F, HFS);
+ Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F));
+ end if;
+
+ -- Store Fraction_1
+
+ for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop
+ S (I) := SE (Fraction_1 mod BB);
+ Fraction_1 := Fraction_1 / BB;
+ end loop;
+
+ -- Store Fraction_2
+
+ for I in reverse LLF_L - 6 .. LLF_L loop
+ S (SEO (I)) := SE (Fraction_2 mod BB);
+ Fraction_2 := Fraction_2 / BB;
+ end loop;
+
+ -- Store Exponent (not always at the beginning of a byte)
+
+ Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+ for N in reverse 1 .. E_Bytes loop
+ S (N) := SE (Exponent mod BB) + S (N);
+ Exponent := Exponent / BB;
+ end loop;
+
+ -- Store Sign
+
+ if not Positive then
+ S (1) := S (1) + BS;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_LLF;
+
+ -----------
+ -- W_LLI --
+ -----------
+
+ procedure W_LLI (Stream : access RST; Item : in Long_Long_Integer) is
+ S : XDR_S_LLI;
+ U : Unsigned;
+ X : Long_Long_Unsigned;
+
+ begin
+ if Optimize_Integers then
+ S := Long_Long_Integer_To_XDR_S_LLI (Item);
+ else
+
+ -- Test sign and apply two complement notation
+
+ if Item < 0 then
+ X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1));
+ else
+ X := Long_Long_Unsigned (Item);
+ end if;
+
+ -- Compute using machine unsigned
+ -- rather than long_long_unsigned.
+
+ for N in reverse S'Range loop
+
+ -- We have filled an unsigned
+
+ if (LLU_L - N) mod UB = 0 then
+ U := Unsigned (X and UL);
+ X := Shift_Right (X, US);
+ end if;
+
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_LLI;
+
+ -----------
+ -- W_LLU --
+ -----------
+
+ procedure W_LLU (Stream : access RST; Item : in Long_Long_Unsigned) is
+ S : XDR_S_LLU;
+ U : Unsigned;
+ X : Long_Long_Unsigned := Item;
+
+ begin
+ if Optimize_Integers then
+ S := Long_Long_Unsigned_To_XDR_S_LLU (Item);
+ else
+ -- Compute using machine unsigned
+ -- rather than long_long_unsigned.
+
+ for N in reverse S'Range loop
+
+ -- We have filled an unsigned
+
+ if (LLU_L - N) mod UB = 0 then
+ U := Unsigned (X and UL);
+ X := Shift_Right (X, US);
+ end if;
+
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_LLU;
+
+ ----------
+ -- W_LU --
+ ----------
+
+ procedure W_LU (Stream : access RST; Item : in Long_Unsigned) is
+ S : XDR_S_LU;
+ U : Unsigned;
+ X : Long_Unsigned := Item;
+
+ begin
+ if Optimize_Integers then
+ S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item));
+ else
+ -- Compute using machine unsigned
+ -- rather than long_unsigned.
+
+ for N in reverse S'Range loop
+
+ -- We have filled an unsigned
+
+ if (LU_L - N) mod UB = 0 then
+ U := Unsigned (X and UL);
+ X := Shift_Right (X, US);
+ end if;
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_LU;
+
+ ----------
+ -- W_SF --
+ ----------
+
+ procedure W_SF (Stream : access RST; Item : in Short_Float) is
+ I : constant Precision := Single;
+ E_Size : Integer renames Fields (I).E_Size;
+ E_Bias : Integer renames Fields (I).E_Bias;
+ E_Bytes : SEO renames Fields (I).E_Bytes;
+ F_Bytes : SEO renames Fields (I).F_Bytes;
+ F_Size : Integer renames Fields (I).F_Size;
+ F_Mask : SE renames Fields (I).F_Mask;
+
+ Exponent : Long_Unsigned;
+ Fraction : Long_Unsigned;
+ Positive : Boolean;
+ E : Integer;
+ F : Short_Float;
+ S : SEA (1 .. SF_L) := (others => 0);
+
+ begin
+ if not Item'Valid then
+ raise Constraint_Error;
+ end if;
+
+ -- Compute Sign
+
+ Positive := (0.0 <= Item);
+ F := abs (Item);
+
+ -- Signed zero
+
+ if F = 0.0 then
+ Exponent := 0;
+ Fraction := 0;
+
+ else
+ E := Short_Float'Exponent (F) - 1;
+
+ -- Denormalized float
+
+ if E <= -E_Bias then
+ E := -E_Bias;
+ F := Short_Float'Scaling (F, F_Size + E_Bias - 1);
+ else
+ F := Short_Float'Scaling (F, F_Size - E);
+ end if;
+
+ -- Compute Exponent and Fraction
+
+ Exponent := Long_Unsigned (E + E_Bias);
+ Fraction := Long_Unsigned (F * 2.0) / 2;
+ end if;
+
+ -- Store Fraction
+
+ for I in reverse SF_L - F_Bytes + 1 .. SF_L loop
+ S (I) := SE (Fraction mod BB);
+ Fraction := Fraction / BB;
+ end loop;
+
+ -- Remove implicit bit
+
+ S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask;
+
+ -- Store Exponent (not always at the beginning of a byte)
+
+ Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1);
+ for N in reverse 1 .. E_Bytes loop
+ S (N) := SE (Exponent mod BB) + S (N);
+ Exponent := Exponent / BB;
+ end loop;
+
+ -- Store Sign
+
+ if not Positive then
+ S (1) := S (1) + BS;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_SF;
+
+ ----------
+ -- W_SI --
+ ----------
+
+ procedure W_SI (Stream : access RST; Item : in Short_Integer) is
+ S : XDR_S_SI;
+ U : XDR_SU;
+
+ begin
+ if Optimize_Integers then
+ S := Short_Integer_To_XDR_S_SI (Item);
+ else
+
+ -- Test sign and apply two complement's notation
+
+ if Item < 0 then
+ U := XDR_SU'Last xor XDR_SU (-(Item + 1));
+ else
+ U := XDR_SU (Item);
+ end if;
+
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_SI;
+
+ -----------
+ -- W_SSI --
+ -----------
+
+ procedure W_SSI (Stream : access RST; Item : in Short_Short_Integer) is
+ S : XDR_S_SSI;
+ U : XDR_SSU;
+
+ begin
+ if Optimize_Integers then
+ S := Short_Short_Integer_To_XDR_S_SSI (Item);
+ else
+
+ -- Test sign and apply two complement's notation
+
+ if Item < 0 then
+ U := XDR_SSU'Last xor XDR_SSU (-(Item + 1));
+ else
+ U := XDR_SSU (Item);
+ end if;
+
+ S (1) := SE (U);
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_SSI;
+
+ -----------
+ -- W_SSU --
+ -----------
+
+ procedure W_SSU (Stream : access RST; Item : in Short_Short_Unsigned) is
+ S : XDR_S_SSU;
+ U : XDR_SSU := XDR_SSU (Item);
+
+ begin
+ S (1) := SE (U);
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_SSU;
+
+ ----------
+ -- W_SU --
+ ----------
+
+ procedure W_SU (Stream : access RST; Item : in Short_Unsigned) is
+ S : XDR_S_SU;
+ U : XDR_SU := XDR_SU (Item);
+
+ begin
+ if Optimize_Integers then
+ S := Short_Unsigned_To_XDR_S_SU (Item);
+ else
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_SU;
+
+ ---------
+ -- W_U --
+ ---------
+
+ procedure W_U (Stream : access RST; Item : in Unsigned) is
+ S : XDR_S_U;
+ U : XDR_U := XDR_U (Item);
+
+ begin
+ if Optimize_Integers then
+ S := Unsigned_To_XDR_S_U (Item);
+ else
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end if;
+
+ Ada.Streams.Write (Stream.all, S);
+ end W_U;
+
+ ----------
+ -- W_WC --
+ ----------
+
+ procedure W_WC (Stream : access RST; Item : in Wide_Character) is
+ S : XDR_S_WC;
+ U : XDR_WC;
+
+ begin
+
+ -- Use Ada requirements on Wide_Character representation clause
+
+ U := XDR_WC (Wide_Character'Pos (Item));
+
+ for N in reverse S'Range loop
+ S (N) := SE (U mod BB);
+ U := U / BB;
+ end loop;
+
+ Ada.Streams.Write (Stream.all, S);
+
+ if U /= 0 then
+ raise Data_Error;
+ end if;
+ end W_WC;
+
+end System.Stream_Attributes;
diff --git a/gcc/ada/s-taasde.adb b/gcc/ada/s-taasde.adb
index 2439c464357..c2e129c6af6 100644
--- a/gcc/ada/s-taasde.adb
+++ b/gcc/ada/s-taasde.adb
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -318,9 +318,7 @@ package body System.Tasking.Async_Delays is
Timedout : Boolean;
Yielded : Boolean;
Now : Duration;
- Dequeued,
- Tpred,
- Tsucc : Delay_Block_Access;
+ Dequeued : Delay_Block_Access;
Dequeued_Task : Task_ID;
begin
@@ -376,7 +374,7 @@ package body System.Tasking.Async_Delays is
-- Dequeue the waiting task from the front of the queue.
pragma Debug (System.Tasking.Debug.Trace
- ("Timer service: waking up waiting task", 'E'));
+ (Timer_Server_ID, "Timer service: waking up waiting task", 'E'));
Dequeued := Timer_Queue.Succ;
Timer_Queue.Succ := Dequeued.Succ;
diff --git a/gcc/ada/s-taasde.ads b/gcc/ada/s-taasde.ads
index 76a9dff9037..1be2904d2aa 100644
--- a/gcc/ada/s-taasde.ads
+++ b/gcc/ada/s-taasde.ads
@@ -26,9 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-tadeca.adb b/gcc/ada/s-tadeca.adb
index fb9c00731e6..537df810d12 100644
--- a/gcc/ada/s-tadeca.adb
+++ b/gcc/ada/s-tadeca.adb
@@ -26,9 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-tadeca.ads b/gcc/ada/s-tadeca.ads
index be4ed3e7824..f8a363c38c8 100644
--- a/gcc/ada/s-tadeca.ads
+++ b/gcc/ada/s-tadeca.ads
@@ -26,9 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-tadert.adb b/gcc/ada/s-tadert.adb
index bb4f908a551..a5573cd9309 100644
--- a/gcc/ada/s-tadert.adb
+++ b/gcc/ada/s-tadert.adb
@@ -26,9 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-tadert.ads b/gcc/ada/s-tadert.ads
index 5e406271430..c5ad715889d 100644
--- a/gcc/ada/s-tadert.ads
+++ b/gcc/ada/s-tadert.ads
@@ -26,9 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-taenca.adb b/gcc/ada/s-taenca.adb
index 68ab1ae0da1..cdc9f6f0cd5 100644
--- a/gcc/ada/s-taenca.adb
+++ b/gcc/ada/s-taenca.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -40,7 +40,6 @@ with System.Task_Primitives.Operations;
with System.Tasking.Initialization;
-- used for Change_Base_Priority
--- Poll_Base_Priority_Change_At_Entry_Call
-- Dynamic_Priority_Support
-- Defer_Abort/Undefer_Abort
@@ -103,6 +102,9 @@ package body System.Tasking.Entry_Calls is
-- and then checked again once it has been locked.
--
-- If Single_Lock and server is a PO, release RTS_Lock.
+ --
+ -- This should only be called by the Entry_Call.Self.
+ -- It should be holding no other ATCB locks at the time.
procedure Unlock_Server (Entry_Call : Entry_Call_Link);
-- STPO.Unlock the server targeted by Entry_Call. The server must
@@ -124,11 +126,18 @@ package body System.Tasking.Entry_Calls is
-- This procedure performs priority change of a queued call and
-- dequeuing of an entry call when the call is cancelled.
-- If the call is dequeued the state should be set to Cancelled.
+ -- Call only with abort deferred and holding lock of Self_ID. This
+ -- is a bit of common code for all entry calls. The effect is to do
+ -- any deferred base priority change operation, in case some other
+ -- task called STPO.Set_Priority while the current task had abort deferred,
+ -- and to dequeue the call if the call has been aborted.
procedure Poll_Base_Priority_Change_At_Entry_Call
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link);
pragma Inline (Poll_Base_Priority_Change_At_Entry_Call);
+ -- A specialized version of Poll_Base_Priority_Change,
+ -- that does the optional entry queue reordering.
-- Has to be called with the Self_ID's ATCB write-locked.
-- May temporariliy release the lock.
@@ -136,18 +145,6 @@ package body System.Tasking.Entry_Calls is
-- Check_Exception --
---------------------
- -- Raise any pending exception from the Entry_Call.
-
- -- This should be called at the end of every compiler interface
- -- procedure that implements an entry call.
-
- -- In principle, the caller should not be abort-deferred (unless
- -- the application program violates the Ada language rules by doing
- -- entry calls from within protected operations -- an erroneous practice
- -- apparently followed with success by some adventurous GNAT users).
- -- Absolutely, the caller should not be holding any locks, or there
- -- will be deadlock.
-
procedure Check_Exception
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link)
@@ -157,7 +154,7 @@ package body System.Tasking.Entry_Calls is
use type Ada.Exceptions.Exception_Id;
procedure Internal_Raise (X : Ada.Exceptions.Exception_Id);
- pragma Import (C, Internal_Raise, "__gnat_raise_with_msg");
+ pragma Import (C, Internal_Raise, "__gnat_raise_after_setup");
E : constant Ada.Exceptions.Exception_Id :=
Entry_Call.Exception_To_Raise;
@@ -172,15 +169,9 @@ package body System.Tasking.Entry_Calls is
end if;
end Check_Exception;
- -----------------------------------------
+ ------------------------------------------
-- Check_Pending_Actions_For_Entry_Call --
- -----------------------------------------
-
- -- Call only with abort deferred and holding lock of Self_ID. This
- -- is a bit of common code for all entry calls. The effect is to do
- -- any deferred base priority change operation, in case some other
- -- task called STPO.Set_Priority while the current task had abort deferred,
- -- and to dequeue the call if the call has been aborted.
+ ------------------------------------------
procedure Check_Pending_Actions_For_Entry_Call
(Self_ID : Task_ID;
@@ -221,9 +212,6 @@ package body System.Tasking.Entry_Calls is
-- Lock_Server --
-----------------
- -- This should only be called by the Entry_Call.Self.
- -- It should be holding no other ATCB locks at the time.
-
procedure Lock_Server (Entry_Call : Entry_Call_Link) is
Test_Task : Task_ID;
Test_PO : Protection_Entries_Access;
@@ -326,9 +314,6 @@ package body System.Tasking.Entry_Calls is
-- Poll_Base_Priority_Change_At_Entry_Call --
---------------------------------------------
- -- A specialized version of Poll_Base_Priority_Change,
- -- that does the optional entry queue reordering.
-
procedure Poll_Base_Priority_Change_At_Entry_Call
(Self_ID : Task_ID;
Entry_Call : Entry_Call_Link) is
@@ -567,11 +552,33 @@ package body System.Tasking.Entry_Calls is
Send_Trace_Info (W_Completion);
end if;
+ -- Try to remove calls to Sleep in the loop below by letting the caller
+ -- a chance of getting ready immediately, using Unlock & Yield.
+ -- See similar action in Wait_For_Call & Selective_Wait.
+
+ if Single_Lock then
+ STPO.Unlock_RTS;
+ else
+ STPO.Unlock (Self_Id);
+ end if;
+
+ if Entry_Call.State < Done then
+ STPO.Yield;
+ end if;
+
+ if Single_Lock then
+ STPO.Lock_RTS;
+ else
+ STPO.Write_Lock (Self_Id);
+ end if;
+
Self_Id.Common.State := Entry_Caller_Sleep;
loop
Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call);
+
exit when Entry_Call.State >= Done;
+
STPO.Sleep (Self_Id, Entry_Caller_Sleep);
end loop;
diff --git a/gcc/ada/s-taenca.ads b/gcc/ada/s-taenca.ads
index 2fef2cdfe8c..15785d837e9 100644
--- a/gcc/ada/s-taenca.ads
+++ b/gcc/ada/s-taenca.ads
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-taprob.adb b/gcc/ada/s-taprob.adb
index 4663110652b..a5f62784e5e 100644
--- a/gcc/ada/s-taprob.adb
+++ b/gcc/ada/s-taprob.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2001 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-taprob.ads b/gcc/ada/s-taprob.ads
index ea3a1ff65c9..2419759131e 100644
--- a/gcc/ada/s-taprob.ads
+++ b/gcc/ada/s-taprob.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,13 +27,13 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides necessary definitions to handle simple (i.e without
-- entries) protected objects.
---
+
-- All the routines that handle protected objects with entries have been moved
-- to two children: Entries and Operations. Note that Entries only contains
-- the type declaration and the OO primitives. This is needed to avoid
@@ -55,13 +55,13 @@ package System.Tasking.Protected_Objects is
---------------------------------
-- The compiler will expand in the GNAT tree the following construct:
- --
+
-- protected PO is
-- procedure P;
-- private
-- open : boolean := false;
-- end PO;
- --
+
-- protected body PO is
-- procedure P is
-- ...variable declarations...
@@ -69,9 +69,9 @@ package System.Tasking.Protected_Objects is
-- ...B...
-- end P;
-- end PO;
- --
+
-- as follows:
- --
+
-- protected type poT is
-- procedure p;
-- private
@@ -84,18 +84,18 @@ package System.Tasking.Protected_Objects is
-- procedure poPT__pN (_object : in out poTV);
-- procedure poPT__pP (_object : in out poTV);
-- freeze poTV [
- -- procedure _init_proc (_init : in out poTV) is
+ -- procedure poTVI (_init : in out poTV) is
-- begin
-- _init.open := false;
- -- _init_proc (_init._object);
+ -- object-init-proc (_init._object);
-- initialize_protection (_init._object'unchecked_access,
-- unspecified_priority);
-- return;
-- end _init_proc;
-- ]
-- po : poT;
- -- _init_proc (poTV!(po));
- --
+ -- poTVI (poTV!(po));
+
-- procedure poPT__pN (_object : in out poTV) is
-- poR : protection renames _object._object;
-- openP : boolean renames _object.open;
@@ -104,7 +104,7 @@ package System.Tasking.Protected_Objects is
-- ...B...
-- return;
-- end poPT__pN;
- --
+
-- procedure poPT__pP (_object : in out poTV) is
-- procedure _clean is
-- begin
@@ -209,10 +209,6 @@ private
L : aliased Task_Primitives.Lock;
Ceiling : System.Any_Priority;
end record;
- pragma Volatile (Protection);
- for Protection'Alignment use Standard'Maximum_Alignment;
- -- Needed so that we can uncheck convert a Protection_Access to a
- -- Protection_Entries_Access.
procedure Finalize_Protection (Object : in out Protection);
-- Clean up a Protection object; in particular, finalize the associated
diff --git a/gcc/ada/s-taprop.ads b/gcc/ada/s-taprop.ads
index 9f7c8f7e32b..e572a431b5d 100644
--- a/gcc/ada/s-taprop.ads
+++ b/gcc/ada/s-taprop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -335,8 +335,8 @@ package System.Task_Primitives.Operations is
-- Pending priority changes are handled internally.
procedure Sleep
- (Self_ID : ST.Task_ID;
- Reason : System.Tasking.Task_States);
+ (Self_ID : ST.Task_ID;
+ Reason : System.Tasking.Task_States);
pragma Inline (Sleep);
-- Wait until the current task, T, is signaled to wake up.
--
@@ -367,10 +367,10 @@ package System.Task_Primitives.Operations is
-- Combination of Sleep (above) and Timed_Delay
procedure Timed_Delay
- (Self_ID : ST.Task_ID;
- Time : Duration;
- Mode : ST.Delay_Modes);
- -- Implements the semantics of the delay statement. It is assumed that
+ (Self_ID : ST.Task_ID;
+ Time : Duration;
+ Mode : ST.Delay_Modes);
+ -- Implement the semantics of the delay statement. It is assumed that
-- the caller is not abort-deferred and does not hold any locks.
procedure Wakeup
@@ -383,12 +383,19 @@ package System.Task_Primitives.Operations is
function Environment_Task return ST.Task_ID;
pragma Inline (Environment_Task);
- -- returns the task ID of the environment task
+ -- Return the task ID of the environment task
-- Consider putting this into a variable visible directly
-- by the rest of the runtime system. ???
function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id;
- -- returns the thread id of the specified task.
+ -- Return the thread id of the specified task
+
+ function Is_Valid_Task return Boolean;
+ pragma Inline (Is_Valid_Task);
+ -- Does the calling thread have an ATCB?
+
+ function Register_Foreign_Thread return ST.Task_ID;
+ -- Allocate and initialize a new ATCB for the current thread
-----------------------
-- RTS Entrance/Exit --
diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb
index 2cd2e161705..919db007d5b 100644
--- a/gcc/ada/s-tarest.adb
+++ b/gcc/ada/s-tarest.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2002, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -51,7 +51,6 @@ with System.Parameters;
with System.Task_Info;
-- used for Task_Info_Type
--- Task_Image_Type
with System.Task_Primitives.Operations;
-- used for Enter_Task
@@ -106,6 +105,8 @@ package body System.Tasking.Restricted.Stages is
-- all nested locks must be released before other tasks competing for the
-- tasking lock are released.
+ -- See s-tasini.adb for more information on the following functions.
+
function Get_Jmpbuf_Address return Address;
procedure Set_Jmpbuf_Address (Addr : Address);
@@ -213,6 +214,10 @@ package body System.Tasking.Restricted.Stages is
ID : Task_ID := Self_ID;
pragma Volatile (ID);
+ pragma Warnings (Off, ID);
+ -- Turn off warnings (stand alone volatile constant has to be
+ -- imported, so we cannot just make ID constant).
+
-- Do not delete this variable.
-- In some targets, we need this variable to implement a fast Self.
@@ -437,7 +442,7 @@ package body System.Tasking.Restricted.Stages is
Discriminants : System.Address;
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
- Task_Image : System.Task_Info.Task_Image_Type;
+ Task_Image : String;
Created_Task : out Task_ID)
is
T : Task_ID;
@@ -482,7 +487,11 @@ package body System.Tasking.Restricted.Stages is
end if;
T.Entry_Calls (1).Self := T;
- T.Common.Task_Image := Task_Image;
+
+ T.Common.Task_Image_Len :=
+ Integer'Min (T.Common.Task_Image'Length, Task_Image'Length);
+ T.Common.Task_Image (1 .. T.Common.Task_Image_Len) := Task_Image;
+
Unlock (Self_ID);
if Single_Lock then
@@ -508,6 +517,7 @@ package body System.Tasking.Restricted.Stages is
procedure Finalize_Global_Tasks is
Self_ID : constant Task_ID := STPO.Self;
+
begin
pragma Assert (Self_ID = STPO.Environment_Task);
diff --git a/gcc/ada/s-tarest.ads b/gcc/ada/s-tarest.ads
index fb4f007fe5b..56d1f3d6a5d 100644
--- a/gcc/ada/s-tarest.ads
+++ b/gcc/ada/s-tarest.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1999, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -59,19 +59,19 @@ package System.Tasking.Restricted.Stages is
---------------------------------
-- The compiler will expand in the GNAT tree the following construct:
- --
+
-- task type T (Discr : Integer);
- --
+
-- task body T is
-- ...declarations, possibly some controlled...
-- begin
-- ...B...;
-- end T;
- --
+
-- T1 : T (1);
- --
+
-- as follows:
- --
+
-- task type t (discr : integer);
-- tE : aliased boolean := false;
-- tZ : size_type := unspecified_size;
@@ -80,23 +80,23 @@ package System.Tasking.Restricted.Stages is
-- end record;
-- procedure tB (_task : access tV);
-- freeze tV [
- -- procedure _init_proc (_init : in out tV; _master : master_id;
- -- _chain : in out activation_chain; _task_id : in task_image_type;
+ -- procedure tVIP (_init : in out tV; _master : master_id;
+ -- _chain : in out activation_chain; _task_name : in string;
-- discr : integer) is
-- begin
-- _init.discr := discr;
-- _init._task_id := null;
-- create_restricted_task (unspecified_priority, tZ,
-- unspecified_task_info, task_procedure_access!(tB'address),
- -- _init'address, tE'unchecked_access, _chain, _task_id, _init.
+ -- _init'address, tE'unchecked_access, _chain, _task_name, _init.
-- _task_id);
-- return;
- -- end _init_proc;
+ -- end tVIP;
-- ]
- --
+
-- _chain : aliased activation_chain;
- -- _init_proc (_chain);
- --
+ -- activation_chainIP (_chain);
+
-- procedure tB (_task : access tV) is
-- discr : integer renames _task.discr;
--
@@ -114,12 +114,12 @@ package System.Tasking.Restricted.Stages is
-- at end
-- _clean;
-- end tB;
- --
+
-- tE := true;
-- t1 : t (1);
- -- t1I : task_image_type := new string'"t1";
- -- _init_proc (t1, 3, _chain, t1I, 1);
- --
+ -- t1S : constant String := "t1";
+ -- tIP (t1, 3, _chain, t1S, 1);
+
-- activate_restricted_tasks (_chain'unchecked_access);
procedure Create_Restricted_Task
@@ -130,7 +130,7 @@ package System.Tasking.Restricted.Stages is
Discriminants : System.Address;
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
- Task_Image : System.Task_Info.Task_Image_Type;
+ Task_Image : String;
Created_Task : out Task_ID);
-- Compiler interface only. Do not call from within the RTS.
-- This must be called to create a new task.
@@ -145,12 +145,12 @@ package System.Tasking.Restricted.Stages is
-- are those of the task to create. This parameter should be passed as
-- the single argument to State.
-- Elaborated is a pointer to a Boolean that must be set to true on exit
- -- if the task could be successfully elaborated.
+ -- if the task could be sucessfully elaborated.
-- Chain is a linked list of task that needs to be created. On exit,
-- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID
-- will be Created_Task (e.g the created task will be linked at the front
-- of Chain).
- -- Task_Image is a pointer to a string created by the compiler that the
+ -- Task_Image is a string created by the compiler that the
-- run time can store to ease the debugging and the
-- Ada.Task_Identification facility.
-- Created_Task is the resulting task.
diff --git a/gcc/ada/s-tasdeb.adb b/gcc/ada/s-tasdeb.adb
index c437117bc47..f8f50b9a1bb 100644
--- a/gcc/ada/s-tasdeb.adb
+++ b/gcc/ada/s-tasdeb.adb
@@ -27,21 +27,21 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This package encapsulates all direct interfaces to task debugging services
--- that are needed by gdb with gnat mode (1.13 and higher)
+-- that are needed by gdb with gnat mode.
-- Note : This file *must* be compiled with debugging information
-- Do not add any dependency to GNARL packages since this package is used
-- in both normal and restricted (ravenscar) environments.
-with System.Task_Info,
- System.Task_Primitives.Operations,
- Unchecked_Conversion;
+with Interfaces.C;
+with System.Task_Primitives.Operations;
+with Unchecked_Conversion;
package body System.Tasking.Debug is
@@ -49,25 +49,8 @@ package body System.Tasking.Debug is
package STPO renames System.Task_Primitives.Operations;
- type Integer_Address is mod 2 ** Standard'Address_Size;
-
- function "+" is new
- Unchecked_Conversion (Task_ID, Integer_Address);
-
- Hex_Address_Width : constant := (Standard'Address_Size / 4);
-
- Hex_Digits : constant array (0 .. Integer_Address'(15)) of Character :=
- "0123456789abcdef";
-
- subtype Buf_Range is Integer range 1 .. 80;
- type Buf_Array is array (Buf_Range) of aliased Character;
-
- type Buffer is record
- Next : Buf_Range := Buf_Range'First;
- Chars : Buf_Array := (Buf_Range => ' ');
- end record;
-
- type Buffer_Ptr is access all Buffer;
+ function To_Integer is new
+ Unchecked_Conversion (Task_ID, System.Address);
type Trace_Flag_Set is array (Character) of Boolean;
@@ -77,98 +60,31 @@ package body System.Tasking.Debug is
-- Local Subprograms --
-----------------------
- procedure Put
- (T : ST.Task_ID;
- Width : Integer;
- Buffer : Buffer_Ptr);
- -- Put TCB pointer T, (coded in hexadecimal) into Buffer
- -- right-justified in Width characters.
-
- procedure Put
- (N : Integer_Address;
- Width : Integer;
- Buffer : Buffer_Ptr);
- -- Put N (coded in decimal) into Buf right-justified in Width
- -- characters starting at Buf (Next).
-
- procedure Put
- (S : String;
- Width : Integer;
- Buffer : Buffer_Ptr);
- -- Put string S into Buf left-justified in Width characters
- -- starting with space in Buf (Next), truncated as necessary.
-
- procedure Put
- (C : Character;
- Buffer : Buffer_Ptr);
- -- Put character C into Buf, left-justified, starting at Buf (Next)
-
- procedure Space (Buffer : Buffer_Ptr);
- -- Increment Next, resulting in a space
-
- procedure Space
- (N : Integer;
- Buffer : Buffer_Ptr);
- -- Increment Next by N, resulting in N spaces
-
- procedure Clear (Buffer : Buffer_Ptr);
- -- Clear Buf and reset Next to 1
-
- procedure Write_Buf (Buffer : Buffer_Ptr);
- -- Write contents of Buf (1 .. Next) to standard output
-
- -----------
- -- Clear --
- -----------
-
- procedure Clear (Buffer : Buffer_Ptr) is
- Next : Buf_Range renames Buffer.Next;
- Buf : Buf_Array renames Buffer.Chars;
-
- begin
- Buf := (Buf_Range => ' ');
- Next := 1;
- end Clear;
+ procedure write (Fd : Integer; S : String; Count : size_t);
+ pragma Import (C, write);
- -----------
- -- Image --
- -----------
+ procedure Put (S : String);
+ -- Display S on standard output.
- function Image (T : ST.Task_ID) return String is
- Buf : aliased Buffer;
- Result : String (1 .. Hex_Address_Width + 21);
+ procedure Put_Line (S : String := "");
+ -- Display S on standard output with an additional line terminator.
- use type System.Task_Info.Task_Image_Type;
+ --------------------
+ -- Get_User_State --
+ --------------------
+ function Get_User_State return Long_Integer is
begin
- Clear (Buf'Unchecked_Access);
- Put (T, Hex_Address_Width, Buf'Unchecked_Access);
- Put (':', Buf'Unchecked_Access);
- Put (Integer_Address (T.Serial_Number), 4, Buf'Unchecked_Access);
- Space (Buf'Unchecked_Access);
-
- if T.Common.Task_Image = null then
- Put ("", 15, Buf'Unchecked_Access);
- else
- Put (T.Common.Task_Image.all, 15, Buf'Unchecked_Access);
- end if;
-
- for J in Result'Range loop
- Result (J) := Buf.Chars (J);
- end loop;
-
- return Result;
- end Image;
+ return STPO.Self.User_State;
+ end Get_User_State;
----------------
-- List_Tasks --
----------------
procedure List_Tasks is
- C : ST.Task_ID;
-
+ C : Task_ID;
begin
- Print_Task_Info_Header;
C := All_Tasks_List;
while C /= null loop
@@ -177,29 +93,6 @@ package body System.Tasking.Debug is
end loop;
end List_Tasks;
- -----------------------
- -- Print_Accept_Info --
- -----------------------
-
- procedure Print_Accept_Info (T : ST.Task_ID) is
- Buf : aliased Buffer;
-
- begin
- if T.Open_Accepts = null then
- return;
- end if;
-
- Clear (Buf'Unchecked_Access);
- Space (10, Buf'Unchecked_Access);
- Put ("accepting:", 11, Buf'Unchecked_Access);
-
- for J in T.Open_Accepts.all'Range loop
- Put (Integer_Address (T.Open_Accepts (J).S), 3, Buf'Unchecked_Access);
- end loop;
-
- Write_Buf (Buf'Unchecked_Access);
- end Print_Accept_Info;
-
------------------------
-- Print_Current_Task --
------------------------
@@ -213,311 +106,117 @@ package body System.Tasking.Debug is
-- Print_Task_Info --
---------------------
- procedure Print_Task_Info (T : ST.Task_ID) is
+ procedure Print_Task_Info (T : Task_ID) is
Entry_Call : Entry_Call_Link;
- Buf : aliased Buffer;
-
- use type System.Task_Info.Task_Image_Type;
+ Parent : Task_ID;
begin
- Clear (Buf'Unchecked_Access);
- Put (T, Hex_Address_Width, Buf'Unchecked_Access);
- Put (':', Buf'Unchecked_Access);
- Put (' ', Buf'Unchecked_Access);
- Put (':', Buf'Unchecked_Access);
-
if T = null then
- Put (" null task", 10, Buf'Unchecked_Access);
- Write_Buf (Buf'Unchecked_Access);
+ Put_Line ("null task");
return;
end if;
- Put (Integer_Address (T.Serial_Number), 4, Buf'Unchecked_Access);
- Space (Buf'Unchecked_Access);
+ Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len) & ": " &
+ Task_States'Image (T.Common.State));
- if T.Common.Task_Image = null then
- Put ("", 15, Buf'Unchecked_Access);
- else
- Put (T.Common.Task_Image.all, 15, Buf'Unchecked_Access);
- end if;
+ Parent := T.Common.Parent;
- Space (Buf'Unchecked_Access);
- Put (Task_States'Image (T.Common.State), 10, Buf'Unchecked_Access);
- Space (Buf'Unchecked_Access);
-
- if T.Callable then
- Put ('C', Buf'Unchecked_Access);
+ if Parent = null then
+ Put (", parent: <none>");
else
- Space (Buf'Unchecked_Access);
+ Put (", parent: " &
+ Parent.Common.Task_Image (1 .. Parent.Common.Task_Image_Len));
end if;
- if T.Open_Accepts /= null then
- Put ('A', Buf'Unchecked_Access);
- else
- Space (Buf'Unchecked_Access);
- end if;
-
- if T.Common.Call /= null then
- Put ('C', Buf'Unchecked_Access);
- else
- Space (Buf'Unchecked_Access);
- end if;
+ Put (", prio:" & T.Common.Current_Priority'Img);
- if T.Terminate_Alternative then
- Put ('T', Buf'Unchecked_Access);
- else
- Space (Buf'Unchecked_Access);
+ if not T.Callable then
+ Put (", not callable");
end if;
if T.Aborting then
- Put ('A', Buf'Unchecked_Access);
- else
- Space (Buf'Unchecked_Access);
+ Put (", aborting");
end if;
- if T.Deferral_Level = 0 then
- Space (3, Buf'Unchecked_Access);
- else
- Put ('D', Buf'Unchecked_Access);
- if T.Deferral_Level < 0 then
- Put ("<0", 2, Buf'Unchecked_Access);
- elsif T.Deferral_Level > 1 then
- Put (Integer_Address (T.Deferral_Level), 2, Buf'Unchecked_Access);
- else
- Space (2, Buf'Unchecked_Access);
- end if;
+ if T.Deferral_Level /= 0 then
+ Put (", abort deferred");
end if;
- Space (Buf'Unchecked_Access);
- Put (Integer_Address (T.Master_of_Task), 1, Buf'Unchecked_Access);
- Space (Buf'Unchecked_Access);
- Put (Integer_Address (T.Master_Within), 1, Buf'Unchecked_Access);
- Put (',', Buf'Unchecked_Access);
- Space (Buf'Unchecked_Access);
- Put (Integer_Address (T.Awake_Count), 1, Buf'Unchecked_Access);
- Space (Buf'Unchecked_Access);
- Put (Integer_Address (T.Alive_Count), 1, Buf'Unchecked_Access);
- Put (',', Buf'Unchecked_Access);
- Space (Buf'Unchecked_Access);
- Put (Integer_Address (T.ATC_Nesting_Level), 1, Buf'Unchecked_Access);
- Space (Buf'Unchecked_Access);
- Put (Integer_Address (T.Pending_ATC_Level), 1, Buf'Unchecked_Access);
- Put (',', Buf'Unchecked_Access);
- Space (Buf'Unchecked_Access);
- Put (Integer_Address (T.Common.Wait_Count), 1, Buf'Unchecked_Access);
- Put (',', Buf'Unchecked_Access);
- Space (Buf'Unchecked_Access);
- Put (Integer_Address (T.User_State), 1, Buf'Unchecked_Access);
- Write_Buf (Buf'Unchecked_Access);
-
if T.Common.Call /= null then
Entry_Call := T.Common.Call;
- Clear (Buf'Unchecked_Access);
- Space (10, Buf'Unchecked_Access);
- Put ("serving:", 8, Buf'Unchecked_Access);
+ Put (", serving:");
while Entry_Call /= null loop
- Put (Integer_Address
- (Entry_Call.Self.Serial_Number), 5, Buf'Unchecked_Access);
+ Put (To_Integer (Entry_Call.Self)'Img);
Entry_Call := Entry_Call.Acceptor_Prev_Call;
end loop;
-
- Write_Buf (Buf'Unchecked_Access);
end if;
- Print_Accept_Info (T);
- end Print_Task_Info;
-
- ----------------------------
- -- Print_Task_Info_Header --
- ----------------------------
-
- procedure Print_Task_Info_Header is
- Buf : aliased Buffer;
-
- begin
- Clear (Buf'Unchecked_Access);
- Put ("TASK_ID", Hex_Address_Width, Buf'Unchecked_Access);
- Put (':', Buf'Unchecked_Access);
- Put ('F', Buf'Unchecked_Access);
- Put (':', Buf'Unchecked_Access);
- Put ("SERIAL_NUMBER", 4, Buf'Unchecked_Access);
- Space (Buf'Unchecked_Access);
- Put (" NAME", 15, Buf'Unchecked_Access);
- Put (" STATE", 10, Buf'Unchecked_Access);
- Space (11, Buf'Unchecked_Access);
- Put ("MAST", 5, Buf'Unchecked_Access);
- Put ("AWAK", 5, Buf'Unchecked_Access);
- Put ("ATC", 5, Buf'Unchecked_Access);
- Put ("WT", 3, Buf'Unchecked_Access);
- Put ("DBG", 3, Buf'Unchecked_Access);
- Write_Buf (Buf'Unchecked_Access);
- end Print_Task_Info_Header;
-
- ---------
- -- Put --
- ---------
-
- procedure Put
- (T : ST.Task_ID;
- Width : Integer;
- Buffer : Buffer_Ptr)
- is
- J : Integer;
- X : Integer_Address := +T;
- Next : Buf_Range renames Buffer.Next;
- Buf : Buf_Array renames Buffer.Chars;
- First : constant Integer := Next;
- Wdth : Integer := Width;
-
- begin
- if Wdth > Buf'Last - Next then
- Wdth := Buf'Last - Next;
- end if;
-
- J := Next + (Wdth - 1);
-
- if X = 0 then
- Buf (J) := '0';
-
- else
- while X > 0 loop
- Buf (J) := Hex_Digits (X rem 16);
- J := J - 1;
- X := X / 16;
-
- -- Check for overflow
-
- if J < First and then X > 0 then
- Buf (J + 1) := '*';
- exit;
- end if;
+ if T.Open_Accepts /= null then
+ Put (", accepting:");
+ for J in T.Open_Accepts'Range loop
+ Put (T.Open_Accepts (J).S'Img);
end loop;
- end if;
-
- Next := Next + Wdth;
- end Put;
- procedure Put
- (N : Integer_Address;
- Width : Integer;
- Buffer : Buffer_Ptr)
- is
- J : Integer;
- X : Integer_Address := N;
- Next : Buf_Range renames Buffer.Next;
- Buf : Buf_Array renames Buffer.Chars;
- First : constant Integer := Next;
- Wdth : Integer := Width;
-
- begin
- if Wdth > Buf'Last - Next then
- Wdth := Buf'Last - Next;
+ if T.Terminate_Alternative then
+ Put (" or terminate");
+ end if;
end if;
- J := Next + (Wdth - 1);
-
- if N = 0 then
- Buf (J) := '0';
-
- else
- while X > 0 loop
- Buf (J) := Hex_Digits (X rem 10);
- J := J - 1;
- X := X / 10;
-
- -- Check for overflow
-
- if J < First and then X > 0 then
- Buf (J + 1) := '*';
- exit;
- end if;
- end loop;
+ if T.User_State /= 0 then
+ Put (", state:" & T.User_State'Img);
end if;
- Next := Next + Wdth;
- end Put;
+ Put_Line;
+ end Print_Task_Info;
- procedure Put
- (S : String;
- Width : Integer;
- Buffer : Buffer_Ptr)
- is
- Next : Buf_Range renames Buffer.Next;
- Buf : Buf_Array renames Buffer.Chars;
- Bound : constant Integer := Integer'Min (Next + Width, Buf'Last);
- J : Integer := Next;
+ ---------
+ -- Put --
+ ---------
+ procedure Put (S : String) is
begin
- for K in S'Range loop
-
- -- Check overflow
-
- if J >= Bound then
- Buf (J - 1) := '*';
- exit;
- end if;
-
- Buf (J) := S (K);
- J := J + 1;
- end loop;
-
- Next := Bound;
+ write (2, S, S'Length);
end Put;
- procedure Put
- (C : Character;
- Buffer : Buffer_Ptr)
- is
- Next : Buf_Range renames Buffer.Next;
- Buf : Buf_Array renames Buffer.Chars;
+ --------------
+ -- Put_Line --
+ --------------
+ procedure Put_Line (S : String := "") is
begin
- if Next >= Buf'Last then
- Buf (Next) := '*';
- else Buf (Next) := C;
- Next := Next + 1;
- end if;
- end Put;
+ write (2, S & ASCII.LF, S'Length + 1);
+ end Put_Line;
----------------------
-- Resume_All_Tasks --
----------------------
procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
- C : ST.Task_ID;
- R : Boolean;
+ C : Task_ID;
+ Dummy : Boolean;
+ pragma Unreferenced (Dummy);
begin
STPO.Lock_RTS;
C := All_Tasks_List;
while C /= null loop
- R := STPO.Resume_Task (C, Thread_Self);
+ Dummy := STPO.Resume_Task (C, Thread_Self);
C := C.Common.All_Tasks_Link;
end loop;
STPO.Unlock_RTS;
end Resume_All_Tasks;
- ----------
- -- Self --
- ----------
-
- function Self return Task_ID is
- begin
- return STPO.Self;
- end Self;
-
---------------
-- Set_Trace --
---------------
procedure Set_Trace
(Flag : Character;
- Value : Boolean := True)
- is
+ Value : Boolean := True) is
begin
Trace_On (Flag) := Value;
end Set_Trace;
@@ -526,56 +225,26 @@ package body System.Tasking.Debug is
-- Set_User_State --
--------------------
- procedure Set_User_State (Value : Integer) is
+ procedure Set_User_State (Value : Long_Integer) is
begin
STPO.Self.User_State := Value;
end Set_User_State;
- -----------
- -- Space --
- -----------
-
- procedure Space (Buffer : Buffer_Ptr) is
- Next : Buf_Range renames Buffer.Next;
- Buf : Buf_Array renames Buffer.Chars;
-
- begin
- if Next >= Buf'Last then
- Buf (Next) := '*';
- else
- Next := Next + 1;
- end if;
- end Space;
-
- procedure Space
- (N : Integer;
- Buffer : Buffer_Ptr)
- is
- Next : Buf_Range renames Buffer.Next;
- Buf : Buf_Array renames Buffer.Chars;
-
- begin
- if Next + N > Buf'Last then
- Buf (Next) := '*';
- else
- Next := Next + N;
- end if;
- end Space;
-
-----------------------
-- Suspend_All_Tasks --
-----------------------
procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is
- C : ST.Task_ID;
- R : Boolean;
+ C : Task_ID;
+ Dummy : Boolean;
+ pragma Unreferenced (Dummy);
begin
STPO.Lock_RTS;
C := All_Tasks_List;
while C /= null loop
- R := STPO.Suspend_Task (C, Thread_Self);
+ Dummy := STPO.Suspend_Task (C, Thread_Self);
C := C.Common.All_Tasks_Link;
end loop;
@@ -609,95 +278,23 @@ package body System.Tasking.Debug is
-----------
procedure Trace
- (Self_ID : ST.Task_ID;
+ (Self_Id : Task_ID;
Msg : String;
- Other_ID : ST.Task_ID;
- Flag : Character)
- is
- Buf : aliased Buffer;
- use type System.Task_Info.Task_Image_Type;
-
+ Flag : Character;
+ Other_Id : Task_ID := null) is
begin
if Trace_On (Flag) then
- Clear (Buf'Unchecked_Access);
- Put (Self_ID, Hex_Address_Width, Buf'Unchecked_Access);
- Put (':', Buf'Unchecked_Access);
- Put (Flag, Buf'Unchecked_Access);
- Put (':', Buf'Unchecked_Access);
- Put
- (Integer_Address (Self_ID.Serial_Number),
- 4, Buf'Unchecked_Access);
- Space (Buf'Unchecked_Access);
-
- if Self_ID.Common.Task_Image = null then
- Put ("", 15, Buf'Unchecked_Access);
- else
- Put (Self_ID.Common.Task_Image.all, 15, Buf'Unchecked_Access);
- end if;
-
- Space (Buf'Unchecked_Access);
+ Put (To_Integer (Self_Id)'Img &
+ ':' & Flag & ':' &
+ Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len) &
+ ':');
- if Other_ID /= null then
- Put
- (Integer_Address (Other_ID.Serial_Number),
- 4, Buf'Unchecked_Access);
- Space (Buf'Unchecked_Access);
+ if Other_Id /= null then
+ Put (To_Integer (Other_Id)'Img & ':');
end if;
- Put (Msg, Buf.Chars'Last - Buf.Next + 1, Buf'Unchecked_Access);
- Write_Buf (Buf'Unchecked_Access);
+ Put_Line (Msg);
end if;
end Trace;
- procedure Trace
- (Self_ID : ST.Task_ID;
- Msg : String;
- Flag : Character)
- is
- begin
- Trace (Self_ID, Msg, null, Flag);
- end Trace;
-
- procedure Trace
- (Msg : String;
- Flag : Character)
- is
- Self_ID : constant ST.Task_ID := STPO.Self;
-
- begin
- Trace (Self_ID, Msg, null, Flag);
- end Trace;
-
- procedure Trace
- (Msg : String;
- Other_ID : ST.Task_ID;
- Flag : Character)
- is
- pragma Warnings (Off, Other_ID);
-
- Self_ID : constant ST.Task_ID := STPO.Self;
-
- begin
- Trace (Self_ID, Msg, null, Flag);
- end Trace;
-
- ---------------
- -- Write_Buf --
- ---------------
-
- procedure Write_Buf (Buffer : Buffer_Ptr) is
- Next : Buf_Range renames Buffer.Next;
- Buf : Buf_Array renames Buffer.Chars;
-
- procedure put_char (C : Integer);
- pragma Import (C, put_char, "put_char");
-
- begin
- for J in 1 .. Next - 1 loop
- put_char (Character'Pos (Buf (J)));
- end loop;
-
- put_char (Character'Pos (ASCII.LF));
- end Write_Buf;
-
end System.Tasking.Debug;
diff --git a/gcc/ada/s-tasdeb.ads b/gcc/ada/s-tasdeb.ads
index a98575a170c..fa886e7366f 100644
--- a/gcc/ada/s-tasdeb.ads
+++ b/gcc/ada/s-tasdeb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2002, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,150 +27,91 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This package encapsulates all direct interfaces to task debugging services
--- that are needed by gdb with gnat mode (1.17 and higher)
+-- that are needed by gdb with gnat mode.
-with Interfaces.C;
with System.Tasking;
with System.OS_Interface;
package System.Tasking.Debug is
- subtype int is Interfaces.C.int;
- subtype unsigned_long is Interfaces.C.unsigned_long;
-
- package ST renames System.Tasking;
-
- Known_Tasks : array (0 .. 999) of Task_ID;
- -- Global array of tasks read by gdb, and updated by
- -- Create_Task and Finalize_TCB
-
- procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id);
- -- This procedure is used to notify VxGdb of task's creation.
- -- It must be called by the task's creator.
-
- procedure Task_Termination_Hook;
- -- This procedure is used to notify VxGdb of task's termination.
-
- function Self return Task_ID;
- -- return system ID of current task
+ ------------------------------------------
+ -- Application-level debugging routines --
+ ------------------------------------------
procedure List_Tasks;
-- Print a list of all the known Ada tasks with abbreviated state
- -- information, one-per-line, to the standard output file
+ -- information, one-per-line, to the standard error file.
procedure Print_Current_Task;
- procedure Print_Task_Info_Header;
+ -- Write information about current task, in hexadecimal, as one line, to
+ -- the standard error file.
+
procedure Print_Task_Info (T : Task_ID);
- -- Write TASK_ID of current task, in hexadecimal, as one line, to
- -- the standard output file
- --
- -- Beware that Print_Current_Task may print garbage during an early
- -- stage of activation. There is a small window where a task is just
- -- initializing itself and has not yet recorded its own task Id.
- --
- -- Beware that Print_Current_Task will either not work at all or print
- -- garbage if it has interrupted a thread of control that does not
- -- correspond to any Ada task. For example, this is could happen if
- -- the debugger interrupts a signal handler that is using an alternate
- -- stack, or interrupts the dispatcher in the underlying thread
- -- implementation.
-
- procedure Set_User_State (Value : Integer);
-
- procedure Print_Accept_Info (T : Task_ID);
+ -- Similar to Print_Current_Task, for a given task.
- procedure Trace
- (Self_ID : Task_ID;
- Msg : String;
- Other_ID : Task_ID;
- Flag : Character);
+ procedure Set_User_State (Value : Long_Integer);
+ -- Set user state value in the current task.
+ -- This state will be displayed when calling List_Tasks or
+ -- Print_Current_Task. It is useful for setting task specific state.
- procedure Trace
- (Self_ID : Task_ID;
- Msg : String;
- Flag : Character);
+ function Get_User_State return Long_Integer;
+ -- Return the user state for the current task.
- procedure Trace
- (Msg : String;
- Flag : Character);
+ -------------------------
+ -- General GDB support --
+ -------------------------
- procedure Trace
- (Msg : String;
- Other_ID : Task_ID;
- Flag : Character);
+ Known_Tasks : array (0 .. 999) of Task_ID;
+ -- Global array of tasks read by gdb, and updated by
+ -- Create_Task and Finalize_TCB
- procedure Set_Trace
- (Flag : Character;
- Value : Boolean := True);
+ ----------------------------------
+ -- VxWorks specific GDB support --
+ ----------------------------------
+
+ -- Although the following routines are implemented in a target independent
+ -- manner, only VxWorks currently uses them.
- function Image (T : Task_ID) return String;
+ procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id);
+ -- This procedure is used to notify GDB of task's creation.
+ -- It must be called by the task's creator.
+
+ procedure Task_Termination_Hook;
+ -- This procedure is used to notify GDB of task's termination.
procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id);
-- Suspend all the tasks except the one whose associated thread is
-- Thread_Self by traversing All_Tasks_Lists and calling
- -- System.Task_Primitives.Operations.Suspend_Task
- -- Such functionality is needed by gdb on some targets (e.g VxWorks)
- -- Warning: for efficiency purposes, there is no locking.
+ -- System.Task_Primitives.Operations.Suspend_Task.
procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id);
-- Resume all the tasks except the one whose associated thread is
-- Thread_Self by traversing All_Tasks_Lists and calling
- -- System.Task_Primitives.Operations.Continue_Task
- -- Such functionality is needed by gdb on some targets (e.g VxWorks)
- -- Warning: for efficiency purposes, there is no locking.
+ -- System.Task_Primitives.Operations.Continue_Task.
-end System.Tasking.Debug;
+ -------------------------------
+ -- Run-time tracing routines --
+ -------------------------------
------------------------------
--- Use of These Functions --
------------------------------
-
--- Calling complicated functions from the debugger is generally pretty
--- risky, especially in a multithreaded program.
-
--- The debugger may interrupt something that is not an Ada task,
--- within the thread implementation, and which is not async-safe.
-
--- For example, under Solaris, it can interrupt code in "_dynamiclwps",
--- which seems to serve as dispatcher when all the user threads are
--- suspended. By experience, we have found that one cannot safely
--- do certain things, apparently including calls to thread primitives
--- from the debugger if the debugger has interrupted at one of these
--- unsafe points. In general, if you interrupt a running program
--- asynchronously (e.g. via control-C), it will not be safe to
--- call the subprograms in this package.
-
------------------
--- Future work --
------------------
-
--- It would be nice to be able to tell whether execution has been
--- interrupted in an Ada task. A heuristic way of checking this would
--- be if we added to the Ada TCB a component that always contains a
--- constant value that is unlikely to occur accidentally in code or
--- data. We could then check this in the debugger-callable subprograms,
--- and simply return an error code if it looks unsafe to proceed.
-
--- ???
--- Recently we have added such a marker as a local variable of the
--- task-wrapper routine. This allows Self to generate a fake ATCB for
--- non-Ada threads of control. Given this capability, it is probably
--- time to revisit the issue above.
-
--- DEADLOCK
-
--- We follow a simple rule here to avoid deadlock:
-
--- We do not use any locks in functions called by gdb, and we do not
--- traverse linked lists.
---
--- The use of an array (Known_Tasks) has many advantages:
-
--- - Easy and fast to examine;
--- - No risk of dangling references (to the next element) when traversing
--- the array.
+ procedure Trace
+ (Self_Id : Task_ID;
+ Msg : String;
+ Flag : Character;
+ Other_Id : Task_ID := null);
+ -- If traces for Flag are enabled, display on Standard_Error a given
+ -- message for the current task. Other_Id is an optional second task id
+ -- to display.
+
+ procedure Set_Trace
+ (Flag : Character;
+ Value : Boolean := True);
+ -- Enable or disable tracing for Flag.
+ -- By default, flags in the range 'A' .. 'Z' are disabled, others are
+ -- enabled.
+
+end System.Tasking.Debug;
diff --git a/gcc/ada/s-tasinf.adb b/gcc/ada/s-tasinf.adb
index 8ce2523b2f7..86aa5a4fa7e 100644
--- a/gcc/ada/s-tasinf.adb
+++ b/gcc/ada/s-tasinf.adb
@@ -7,7 +7,7 @@
-- S p e c --
-- (Compiler Interface) --
-- --
--- Copyright (C) 1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/s-tasinf.ads b/gcc/ada/s-tasinf.ads
index 4ea77e46254..18b6ce6c3f3 100644
--- a/gcc/ada/s-tasinf.ads
+++ b/gcc/ada/s-tasinf.ads
@@ -5,9 +5,8 @@
-- S Y S T E M . T A S K _ I N F O --
-- --
-- S p e c --
--- (Compiler Interface) --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -33,16 +32,18 @@
------------------------------------------------------------------------------
-- This package contains the definitions and routines associated with the
--- implementation of the Task_Info pragma. It is specialized appropriately
--- for targets that make use of this pragma.
+-- implementation and use of the Task_Info pragma. It is specialized
+-- appropriately for targets that make use of this pragma.
-- Note: the compiler generates direct calls to this interface, via Rtsfind.
-- Any changes to this interface may require corresponding compiler changes.
-with Unchecked_Deallocation;
+-- This unit may be used directly from an application program by providing
+-- an appropriate WITH, and the interface can be expected to remain stable.
+
package System.Task_Info is
-pragma Elaborate_Body;
--- To ensure that a body is allowed
+ pragma Elaborate_Body;
+ -- To ensure that a body is allowed
-----------------------------------------
-- Implementation of Task_Info Feature --
@@ -86,13 +87,6 @@ pragma Elaborate_Body;
-- implementations, but it must be a type that can be used as a
-- discriminant (i.e. a scalar or access type).
- type Task_Image_Type is access String;
- -- Used to generate a meaningful identifier for tasks that are variables
- -- and components of variables.
-
- procedure Free_Task_Image is new
- Unchecked_Deallocation (String, Task_Image_Type);
-
Unspecified_Task_Info : constant Task_Info_Type := Default_Scope;
-- Value passed to task in the absence of a Task_Info pragma
diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb
index badf009b96e..5a0d1074972 100644
--- a/gcc/ada/s-tasini.adb
+++ b/gcc/ada/s-tasini.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -124,10 +124,10 @@ package body System.Tasking.Initialization is
-- Get/Set the address for storing the current task's machine state
function Get_Current_Excep return SSL.EOA;
- -- Comments needed???
+ -- Task-safe version of SSL.Get_Current_Excep
procedure Timed_Delay_T (Time : Duration; Mode : Integer);
- -- Comments needed???
+ -- Task-safe version of SSL.Timed_Delay
function Get_Stack_Info return Stack_Checking.Stack_Access;
-- Get access to the current task's Stack_Info
@@ -151,6 +151,13 @@ package body System.Tasking.Initialization is
-- Tasking Initialization --
----------------------------
+ procedure Gnat_Install_Locks (Lock, Unlock : SSL.No_Param_Proc);
+ pragma Import (C, Gnat_Install_Locks, "__gnatlib_install_locks");
+ -- Used by Init_RTS to install procedure Lock and Unlock for the
+ -- thread locking. This has no effect on GCC 2. For GCC 3,
+ -- it has an effect only if gcc is configured with
+ -- --enable_threads=gnat.
+
procedure Init_RTS;
-- This procedure completes the initialization of the GNARL. The first
-- part of the initialization is done in the body of System.Tasking.
@@ -422,6 +429,10 @@ package body System.Tasking.Initialization is
SSL.Set_Jmpbuf_Address (SSL.Get_Jmpbuf_Address_NT);
SSL.Set_Machine_State_Addr (SSL.Get_Machine_State_Addr_NT);
+ -- Install tasking locks in the GCC runtime.
+
+ Gnat_Install_Locks (Task_Lock'Access, Task_Unlock'Access);
+
-- Abortion is deferred in a new ATCB, so we need to undefer abortion
-- at this stage to make the environment task abortable.
@@ -481,8 +492,8 @@ package body System.Tasking.Initialization is
procedure Locked_Abort_To_Level
(Self_ID : Task_ID;
T : Task_ID;
- L : ATC_Level) is
-
+ L : ATC_Level)
+ is
begin
if not T.Aborting and then T /= Self_ID then
case T.Common.State is
@@ -582,6 +593,7 @@ package body System.Tasking.Initialization is
procedure Poll_Base_Priority_Change (Self_ID : Task_ID) is
begin
if Dynamic_Priority_Support and then Self_ID.Pending_Priority_Change then
+
-- Check for ceiling violations ???
Self_ID.Pending_Priority_Change := False;
@@ -630,7 +642,7 @@ package body System.Tasking.Initialization is
begin
pragma Debug
- (Debug.Trace ("Remove_From_All_Tasks_List", 'C'));
+ (Debug.Trace (Self, "Remove_From_All_Tasks_List", 'C'));
Previous := Null_Task;
C := All_Tasks_List;
@@ -678,14 +690,10 @@ package body System.Tasking.Initialization is
---------------
function Task_Name return String is
- use System.Task_Info;
+ Self_Id : constant Task_ID := STPO.Self;
begin
- if STPO.Self.Common.Task_Image /= null then
- return STPO.Self.Common.Task_Image.all;
- else
- return "";
- end if;
+ return Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len);
end Task_Name;
-----------------
@@ -786,6 +794,7 @@ package body System.Tasking.Initialization is
procedure Undefer_Abortion is
Self_ID : Task_ID;
+
begin
if No_Abort and then not Dynamic_Priority_Support then
return;
@@ -881,9 +890,10 @@ package body System.Tasking.Initialization is
New_State : Entry_Call_State)
is
Caller : constant Task_ID := Entry_Call.Self;
+
begin
pragma Debug (Debug.Trace
- (Self_ID, "Wakeup_Entry_Caller", Caller, 'E'));
+ (Self_ID, "Wakeup_Entry_Caller", 'E', Caller));
pragma Assert (New_State = Done or else New_State = Cancelled);
pragma Assert
@@ -911,43 +921,38 @@ package body System.Tasking.Initialization is
----------------------
function Get_Current_Excep return SSL.EOA is
- Me : constant Task_ID := STPO.Self;
begin
- return Me.Common.Compiler_Data.Current_Excep'Access;
+ return STPO.Self.Common.Compiler_Data.Current_Excep'Access;
end Get_Current_Excep;
function Get_Exc_Stack_Addr return Address is
- Me : constant Task_ID := STPO.Self;
begin
- return Me.Common.Compiler_Data.Exc_Stack_Addr;
+ return STPO.Self.Common.Compiler_Data.Exc_Stack_Addr;
end Get_Exc_Stack_Addr;
function Get_Jmpbuf_Address return Address is
- Me : constant Task_ID := STPO.Self;
begin
- return Me.Common.Compiler_Data.Jmpbuf_Address;
+ return STPO.Self.Common.Compiler_Data.Jmpbuf_Address;
end Get_Jmpbuf_Address;
function Get_Machine_State_Addr return Address is
- Me : constant Task_ID := STPO.Self;
begin
- return Me.Common.Compiler_Data.Machine_State_Addr;
+ return STPO.Self.Common.Compiler_Data.Machine_State_Addr;
end Get_Machine_State_Addr;
function Get_Sec_Stack_Addr return Address is
- Me : constant Task_ID := STPO.Self;
begin
- return Me.Common.Compiler_Data.Sec_Stack_Addr;
+ return STPO.Self.Common.Compiler_Data.Sec_Stack_Addr;
end Get_Sec_Stack_Addr;
function Get_Stack_Info return Stack_Checking.Stack_Access is
- Me : constant Task_ID := STPO.Self;
begin
- return Me.Common.Compiler_Data.Pri_Stack_Info'Access;
+ return STPO.Self.Common.Compiler_Data.Pri_Stack_Info'Access;
end Get_Stack_Info;
procedure Set_Exc_Stack_Addr (Self_ID : Address; Addr : Address) is
Me : Task_ID := To_Task_Id (Self_ID);
+
begin
if Me = Null_Task then
Me := STPO.Self;
@@ -957,21 +962,18 @@ package body System.Tasking.Initialization is
end Set_Exc_Stack_Addr;
procedure Set_Jmpbuf_Address (Addr : Address) is
- Me : Task_ID := STPO.Self;
begin
- Me.Common.Compiler_Data.Jmpbuf_Address := Addr;
+ STPO.Self.Common.Compiler_Data.Jmpbuf_Address := Addr;
end Set_Jmpbuf_Address;
procedure Set_Machine_State_Addr (Addr : Address) is
- Me : Task_ID := STPO.Self;
begin
- Me.Common.Compiler_Data.Machine_State_Addr := Addr;
+ STPO.Self.Common.Compiler_Data.Machine_State_Addr := Addr;
end Set_Machine_State_Addr;
procedure Set_Sec_Stack_Addr (Addr : Address) is
- Me : Task_ID := STPO.Self;
begin
- Me.Common.Compiler_Data.Sec_Stack_Addr := Addr;
+ STPO.Self.Common.Compiler_Data.Sec_Stack_Addr := Addr;
end Set_Sec_Stack_Addr;
procedure Timed_Delay_T (Time : Duration; Mode : Integer) is
@@ -990,12 +992,14 @@ package body System.Tasking.Initialization is
procedure Finalize_Attributes (T : Task_ID) is
pragma Warnings (Off, T);
+
begin
null;
end Finalize_Attributes;
procedure Initialize_Attributes (T : Task_ID) is
pragma Warnings (Off, T);
+
begin
null;
end Initialize_Attributes;
diff --git a/gcc/ada/s-tasini.ads b/gcc/ada/s-tasini.ads
index 2b5c39e4c98..9a52aacd143 100644
--- a/gcc/ada/s-tasini.ads
+++ b/gcc/ada/s-tasini.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb
index ba34a69f384..84dafe76123 100644
--- a/gcc/ada/s-taskin.adb
+++ b/gcc/ada/s-taskin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2001 Florida State University --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -123,11 +122,14 @@ package body System.Tasking is
All_Tasks_List := T;
end Initialize_ATCB;
- Main_Task_Image : aliased String := "main_task";
- -- Declare a global variable to avoid allocating dynamic memory.
+ Main_Task_Image : String := "main_task";
+ -- Image of environment task.
- Main_Priority : Priority;
+ Main_Priority : Integer;
pragma Import (C, Main_Priority, "__gl_main_priority");
+ -- Priority for main task. Note that this is of type Integer, not
+ -- Priority, because we use the value -1 to indicate the default
+ -- main priority, and that is of course not in Priority'range.
----------------------------
-- Tasking Initialization --
@@ -154,7 +156,7 @@ begin
if Main_Priority = Unspecified_Priority then
Base_Priority := Default_Priority;
else
- Base_Priority := Main_Priority;
+ Base_Priority := Priority (Main_Priority);
end if;
Success := True;
@@ -167,7 +169,8 @@ begin
STPO.Initialize (T);
STPO.Set_Priority (T, T.Common.Base_Priority);
T.Common.State := Runnable;
- T.Common.Task_Image := Main_Task_Image'Unrestricted_Access;
+ T.Common.Task_Image_Len := Main_Task_Image'Length;
+ T.Common.Task_Image (Main_Task_Image'Range) := Main_Task_Image;
-- Only initialize the first element since others are not relevant
-- in ravenscar mode. Rest of the initialization is done in Init_RTS.
diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads
index 6210a26a0ba..04a7657bc68 100644
--- a/gcc/ada/s-taskin.ads
+++ b/gcc/ada/s-taskin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -43,7 +43,7 @@ with System.Parameters;
-- used for Size_Type
with System.Task_Info;
--- used for Task_Info_Type, Task_Image_Type
+-- used for Task_Info_Type
with System.Soft_Links;
-- used for TSD
@@ -287,12 +287,12 @@ package System.Tasking is
-- State >= Done, in which case it may or may not be still Onqueue.
-- Please do not modify the order of the values, without checking
- -- all uses of this type. We rely on partial "monotonicity" of
+ -- all uses of this type. We rely on partial "monotonicity" of
-- Entry_Call_Record.State to avoid locking when we access this
- -- value for certain tests. In particular:
+ -- value for certain tests. In particular:
-- 1) Once State >= Done, we can rely that the call has been
- -- completed. If State >= Done, it will not
+ -- completed. If State >= Done, it will not
-- change until the task does another entry call at this level.
-- 2) Once State >= Was_Abortable, we can rely that the call has
@@ -371,7 +371,7 @@ package System.Tasking is
-- Note: The order of the fields is important to implement efficiently
-- tasking support under gdb.
-- Currently gdb relies on the order of the State, Parent, Base_Priority,
- -- Task_Image, Call and LL fields.
+ -- Task_Image, Task_Image_Len, Call and LL fields.
----------------------------------------------------------------------
-- Common ATCB section --
@@ -422,10 +422,13 @@ package System.Tasking is
-- accepts an entry or when Created activates, at which points Self is
-- suspended.
- Task_Image : System.Task_Info.Task_Image_Type;
- -- holds an access to string that provides a readable id for task,
+ Task_Image : String (1 .. 32);
+ -- Hold a string that provides a readable id for task,
-- built from the variable of which it is a value or component.
+ Task_Image_Len : Natural;
+ -- Actual length of Task_Image.
+
Call : Entry_Call_Link;
-- The entry call that has been accepted by this task.
-- Protection: Self.L. Self will modify this field
@@ -440,8 +443,8 @@ package System.Tasking is
-- takes care of all of its synchronization.
Task_Arg : System.Address;
- -- The argument to task procedure. Currently unused; this will
- -- provide a handle for discriminant information.
+ -- The argument to task procedure. Provide a handle for discriminant
+ -- information.
-- Protection: Part of the synchronization between Self and
-- Activator. Activator writes it, once, before Self starts
-- executing. Thereafter, Self only reads it.
@@ -733,20 +736,20 @@ package System.Tasking is
type Entry_Call_Array is array (ATC_Level_Index) of
aliased Entry_Call_Record;
- D_I_Count : constant := 2;
- -- This constant may be adjusted, to allow more Address-sized
- -- attributes to be stored directly in the task control block.
-
- subtype Direct_Index is Integer range 0 .. D_I_Count - 1;
+ type Direct_Index is range 0 .. Parameters.Default_Attribute_Count;
+ subtype Direct_Index_Range is Direct_Index range 1 .. Direct_Index'Last;
-- Attributes with indices in this range are stored directly in
- -- the task control block. Such attributes must be Address-sized.
+ -- the task control block. Such attributes must be Address-sized.
-- Other attributes will be held in dynamically allocated records
-- chained off of the task control block.
+ type Direct_Attribute_Element is mod Memory_Size;
+ pragma Atomic (Direct_Attribute_Element);
+
type Direct_Attribute_Array is
- array (Direct_Index) of aliased System.Address;
+ array (Direct_Index_Range) of aliased Direct_Attribute_Element;
- type Direct_Index_Vector is mod 2 ** D_I_Count;
+ type Direct_Index_Vector is mod 2 ** Parameters.Default_Attribute_Count;
-- This is a bit-vector type, used to store information about
-- the usage of the direct attribute fields.
@@ -831,7 +834,7 @@ package System.Tasking is
-- signal (and resulting abortion exception) are not handled any more.
-- In other words, the flag prevents a race between multiple aborters
-- and the abortee.
- -- Protection: Self.L.
+ -- Protection: protected by atomic access.
ATC_Hack : Boolean := False;
pragma Atomic (ATC_Hack);
@@ -856,7 +859,7 @@ package System.Tasking is
Pending_Action : Boolean := False;
-- Unified flag indicating some action needs to be take when abort
- -- next becomes undeferred. Currently set if:
+ -- next becomes undeferred. Currently set if:
-- . Pending_Priority_Change is set
-- . Pending_ATC_Level is changed
-- . Requeue involving POs
@@ -919,10 +922,9 @@ package System.Tasking is
Known_Tasks_Index : Integer := -1;
-- Index in the System.Tasking.Debug.Known_Tasks array.
- User_State : Integer := 0;
- -- user-writeable location, for use in debugging tasks;
- -- debugger can display this value to show where the task currently
- -- is, in user terms
+ User_State : Long_Integer := 0;
+ -- User-writeable location, for use in debugging tasks;
+ -- also provides a simple task specific data.
Direct_Attributes : Direct_Attribute_Array;
-- For task attributes that have same size as Address
@@ -939,7 +941,6 @@ package System.Tasking is
-- Protection: Self.L. Once a task has set Self.Stage to Completing, it
-- has exclusive access to this field.
end record;
- pragma Volatile (Ada_Task_Control_Block);
---------------------
-- Initialize_ATCB --
@@ -969,7 +970,7 @@ private
pragma Volatile (Activation_Chain);
-- Activation_chain is an in-out parameter of initialization procedures
- -- and it must be passed by reference because the init_proc may terminate
+ -- and it must be passed by reference because the init proc may terminate
-- abnormally after creating task components, and these must be properly
-- registered for removal (Expunge_Unactivated_Tasks).
diff --git a/gcc/ada/s-tasque.adb b/gcc/ada/s-tasque.adb
index 092de11f1f2..e96bfeca061 100644
--- a/gcc/ada/s-tasque.adb
+++ b/gcc/ada/s-tasque.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. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -477,16 +477,13 @@ package body System.Tasking.Queuing is
Temp_Call : Entry_Call_Link;
Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning
- -- ??? should add comment as to why Entry_Index is always initialized
-
begin
Entry_Call := null;
begin
- if Priority_Queuing then
-
- -- Priority queuing
+ -- Priority queuing case
+ if Priority_Queuing then
for J in Object.Entry_Queues'Range loop
Temp_Call := Head (Object.Entry_Queues (J));
@@ -497,8 +494,8 @@ package body System.Tasking.Queuing is
(Object.Compiler_Info, J)).
Barrier (Object.Compiler_Info, J)
then
- if (Entry_Call = null or else
- Entry_Call.Prio < Temp_Call.Prio)
+ if Entry_Call = null
+ or else Entry_Call.Prio < Temp_Call.Prio
then
Entry_Call := Temp_Call;
Entry_Index := J;
@@ -506,9 +503,9 @@ package body System.Tasking.Queuing is
end if;
end loop;
- else
- -- FIFO queuing
+ -- FIFO queueing case
+ else
for J in Object.Entry_Queues'Range loop
Temp_Call := Head (Object.Entry_Queues (J));
diff --git a/gcc/ada/s-tasque.ads b/gcc/ada/s-tasque.ads
index d9d66ca5d97..91538a2849f 100644
--- a/gcc/ada/s-tasque.ads
+++ b/gcc/ada/s-tasque.ads
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb
index 58ead84f6b3..67e437d6458 100644
--- a/gcc/ada/s-tasren.adb
+++ b/gcc/ada/s-tasren.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,15 +26,15 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions;
-- Used for Exception_ID
-- Null_Id
--- Save_Occurrence
+-- Transfer_Occurrence
-- Raise_Exception
with System.Task_Primitives.Operations;
@@ -159,6 +159,7 @@ package body System.Tasking.Rendezvous is
Rendezvous_Successful : out Boolean);
pragma Inline (Call_Synchronous);
-- This call is used to make a simple or conditional entry call.
+ -- Called from Call_Simple and Task_Entry_Call.
procedure Setup_For_Rendezvous_With_Body
(Entry_Call : Entry_Call_Link;
@@ -166,14 +167,10 @@ package body System.Tasking.Rendezvous is
pragma Inline (Setup_For_Rendezvous_With_Body);
-- Call this only with abort deferred and holding lock of Acceptor.
-- When a rendezvous selected (ready for rendezvous) we need to save
- -- privious caller and adjust the priority. Also we need to make
+ -- previous caller and adjust the priority. Also we need to make
-- this call not Abortable (Cancellable) since the rendezvous has
-- already been started.
- function Is_Entry_Open (T : Task_ID; E : Task_Entry_Index) return Boolean;
- pragma Inline (Is_Entry_Open);
- -- Call this only with abort deferred and holding lock of T.
-
procedure Wait_For_Call (Self_Id : Task_ID);
pragma Inline (Wait_For_Call);
-- Call this only with abort deferred and holding lock of Self_Id.
@@ -371,8 +368,8 @@ package body System.Tasking.Rendezvous is
procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_ID) is
Caller : constant Task_ID := Call.Self;
- Caller_Prio : System.Any_Priority := Get_Priority (Caller);
- Acceptor_Prio : System.Any_Priority := Get_Priority (Acceptor);
+ Caller_Prio : constant System.Any_Priority := Get_Priority (Caller);
+ Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor);
begin
if Caller_Prio > Acceptor_Prio then
@@ -403,8 +400,6 @@ package body System.Tasking.Rendezvous is
-- Call_Synchronous --
----------------------
- -- Called from Call_Simple and Task_Entry_Call.
-
procedure Call_Synchronous
(Acceptor : Task_ID;
E : Task_Entry_Index;
@@ -556,6 +551,11 @@ package body System.Tasking.Rendezvous is
procedure Internal_Reraise;
pragma Import (C, Internal_Reraise, "__gnat_reraise");
+ procedure Transfer_Occurrence
+ (Target : Ada.Exceptions.Exception_Occurrence_Access;
+ Source : Ada.Exceptions.Exception_Occurrence);
+ pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");
+
use type STPE.Protection_Entries_Access;
begin
@@ -637,7 +637,7 @@ package body System.Tasking.Rendezvous is
(Self_Id, Entry_Call, Entry_Call.Requeue_With_Abort)
then
if Single_Lock then
- Lock_RTS;
+ Unlock_RTS;
end if;
Initialization.Undefer_Abort (Self_Id);
@@ -700,8 +700,8 @@ package body System.Tasking.Rendezvous is
-- Done with Caller locked to make sure that Wakeup is not lost.
if Ex /= Ada.Exceptions.Null_Id then
- Ada.Exceptions.Save_Occurrence
- (Caller.Common.Compiler_Data.Current_Excep,
+ Transfer_Occurrence
+ (Caller.Common.Compiler_Data.Current_Excep'Access,
Self_Id.Common.Compiler_Data.Current_Excep);
end if;
@@ -728,30 +728,6 @@ package body System.Tasking.Rendezvous is
-- failure of requeue?
end Exceptional_Complete_Rendezvous;
- -------------------
- -- Is_Entry_Open --
- -------------------
-
- -- Call this only with abort deferred and holding lock of T.
-
- function Is_Entry_Open (T : Task_ID; E : Task_Entry_Index) return Boolean is
- begin
- pragma Assert (T.Open_Accepts /= null);
-
- if T.Open_Accepts /= null then
- for J in T.Open_Accepts'Range loop
-
- pragma Assert (J > 0);
-
- if E = T.Open_Accepts (J).S then
- return True;
- end if;
- end loop;
- end if;
-
- return False;
- end Is_Entry_Open;
-
-------------------------------------
-- Requeue_Protected_To_Task_Entry --
-------------------------------------
@@ -955,25 +931,16 @@ package body System.Tasking.Rendezvous is
Self_Id.Open_Accepts := Open_Accepts;
Self_Id.Common.State := Acceptor_Sleep;
- STPO.Unlock (Self_Id);
-- Notify ancestors that this task is on a terminate alternative.
+ STPO.Unlock (Self_Id);
Utilities.Make_Passive (Self_Id, Task_Completed => False);
-
- -- Wait for normal entry call or termination
-
- pragma Assert (Self_Id.ATC_Nesting_Level = 1);
-
STPO.Write_Lock (Self_Id);
- loop
- Initialization.Poll_Base_Priority_Change (Self_Id);
- exit when Self_Id.Open_Accepts = null;
- Sleep (Self_Id, Acceptor_Sleep);
- end loop;
+ -- Wait for normal entry call or termination
- Self_Id.Common.State := Runnable;
+ Wait_For_Call (Self_Id);
pragma Assert (Self_Id.Open_Accepts = null);
@@ -1066,8 +1033,6 @@ package body System.Tasking.Rendezvous is
-- Setup_For_Rendezvous_With_Body --
------------------------------------
- -- Call this only with abort deferred and holding lock of Acceptor.
-
procedure Setup_For_Rendezvous_With_Body
(Entry_Call : Entry_Call_Link;
Acceptor : Task_ID) is
@@ -1558,6 +1523,33 @@ package body System.Tasking.Rendezvous is
-- Wait for a normal call and a pending action until the
-- Wakeup_Time is reached.
+ -- Try to remove calls to Sleep in the loop below by letting the
+ -- caller a chance of getting ready immediately, using Unlock &
+ -- Yield.
+ -- See similar action in Wait_For_Completion & Wait_For_Call.
+
+ if Single_Lock then
+ Unlock_RTS;
+ else
+ Unlock (Self_Id);
+ end if;
+
+ if Self_Id.Open_Accepts /= null then
+ Yield;
+ end if;
+
+ if Single_Lock then
+ Lock_RTS;
+ else
+ Write_Lock (Self_Id);
+ end if;
+
+ -- Check if this task has been aborted while the lock was released
+
+ if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
+ Self_Id.Open_Accepts := null;
+ end if;
+
Self_Id.Common.State := Acceptor_Sleep;
loop
@@ -1758,11 +1750,34 @@ package body System.Tasking.Rendezvous is
-- Wait_For_Call --
-------------------
- -- Call this only with abort deferred and holding lock of Self_Id.
- -- Wait for normal call and a pending action.
-
procedure Wait_For_Call (Self_Id : Task_ID) is
begin
+ -- Try to remove calls to Sleep in the loop below by letting the caller
+ -- a chance of getting ready immediately, using Unlock & Yield.
+ -- See similar action in Wait_For_Completion & Selective_Wait.
+
+ if Single_Lock then
+ Unlock_RTS;
+ else
+ Unlock (Self_Id);
+ end if;
+
+ if Self_Id.Open_Accepts /= null then
+ Yield;
+ end if;
+
+ if Single_Lock then
+ Lock_RTS;
+ else
+ Write_Lock (Self_Id);
+ end if;
+
+ -- Check if this task has been aborted while the lock was released.
+
+ if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then
+ Self_Id.Open_Accepts := null;
+ end if;
+
Self_Id.Common.State := Acceptor_Sleep;
loop
diff --git a/gcc/ada/s-tasren.ads b/gcc/ada/s-tasren.ads
index 62dfedf458c..5cf8d733577 100644
--- a/gcc/ada/s-tasren.ads
+++ b/gcc/ada/s-tasren.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-tasres.ads b/gcc/ada/s-tasres.ads
index ab178857a87..85cc88b986c 100644
--- a/gcc/ada/s-tasres.ads
+++ b/gcc/ada/s-tasres.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb
index 6e73cde6b80..8fc01030702 100644
--- a/gcc/ada/s-tassta.adb
+++ b/gcc/ada/s-tassta.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. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -39,7 +39,6 @@ with Ada.Exceptions;
-- used for Raise_Exception
with System.Tasking.Debug;
-pragma Warnings (Off, System.Tasking.Debug);
-- used for enabling tasking facilities with gdb
with System.Address_Image;
@@ -52,7 +51,6 @@ with System.Parameters;
with System.Task_Info;
-- used for Task_Info_Type
--- Task_Image_Type
with System.Task_Primitives.Operations;
-- used for Finalize_Lock
@@ -99,9 +97,6 @@ with System.OS_Primitives;
with System.Finalization_Implementation;
-- Used for System.Finalization_Implementation.Finalize_Global_List
-with Interfaces.C;
--- Used for type Unsigned.
-
with System.Secondary_Stack;
-- used for SS_Init;
@@ -135,11 +130,9 @@ package body System.Tasking.Stages is
-- Local Subprograms --
-----------------------
- procedure Notify_Exception
- (Self_Id : Task_ID;
- Excep : Exception_Occurrence);
- -- This procedure will output the task ID and the exception information,
- -- including traceback if available.
+ procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_ID);
+ -- This procedure outputs the task specific message for exception
+ -- tracing purposes.
procedure Task_Wrapper (Self_ID : Task_ID);
-- This is the procedure that is called by the GNULL from the
@@ -184,10 +177,6 @@ package body System.Tasking.Stages is
-- Different code is used at master completion, in Terminate_Dependents,
-- due to a need for tighter synchronization with the master.
- procedure Terminate_Task (Self_ID : Task_ID);
- -- Terminate the calling task.
- -- This should only be called by the Task_Wrapper procedure.
-
----------------------
-- Abort_Dependents --
----------------------
@@ -339,10 +328,10 @@ package body System.Tasking.Stages is
(C.Common.Compiler_Data.Pri_Stack_Info.Size),
Activate_Prio, Success);
- -- There would be a race between the created task and
- -- the creator to do the following initialization,
- -- if we did not have a Lock/Unlock_RTS pair
- -- in the task wrapper, to prevent it from racing ahead.
+ -- There would be a race between the created task and the
+ -- creator to do the following initialization, if we did not
+ -- have a Lock/Unlock_RTS pair in the task wrapper to prevent
+ -- it from racing ahead.
if Success then
C.Common.State := Runnable;
@@ -404,9 +393,8 @@ package body System.Tasking.Stages is
C := P;
end loop;
- -- Wait for the activated tasks to complete activation.
- -- It is unsafe to abort any of these tasks until the count goes to
- -- zero.
+ -- Wait for the activated tasks to complete activation. It is
+ -- unsafe to abort any of these tasks until the count goes to zero.
loop
Initialization.Poll_Base_Priority_Change (Self_ID);
@@ -421,7 +409,7 @@ package body System.Tasking.Stages is
Unlock_RTS;
end if;
- -- Remove the tasks from the chain.
+ -- Remove the tasks from the chain
Chain_Access.T_ID := null;
Initialization.Undefer_Abort_Nestable (Self_ID);
@@ -467,7 +455,7 @@ package body System.Tasking.Stages is
---------------------
procedure Complete_Master is
- Self_ID : Task_ID := STPO.Self;
+ Self_ID : constant Task_ID := STPO.Self;
begin
pragma Assert (Self_ID.Deferral_Level > 0);
@@ -479,7 +467,7 @@ package body System.Tasking.Stages is
-- Complete_Task --
-------------------
- -- See comments on Vulnerable_Complete_Task for details.
+ -- See comments on Vulnerable_Complete_Task for details
procedure Complete_Task is
Self_ID : constant Task_ID := STPO.Self;
@@ -488,8 +476,8 @@ package body System.Tasking.Stages is
Vulnerable_Complete_Task (Self_ID);
- -- All of our dependents have terminated.
- -- Never undefer abort again!
+ -- All of our dependents have terminated. Never undefer abort again!
+
end Complete_Task;
-----------------
@@ -509,13 +497,14 @@ package body System.Tasking.Stages is
Discriminants : System.Address;
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
- Task_Image : System.Task_Info.Task_Image_Type;
+ Task_Image : String;
Created_Task : out Task_ID)
is
T, P : Task_ID;
Self_ID : constant Task_ID := STPO.Self;
Success : Boolean;
Base_Priority : System.Any_Priority;
+ Len : Natural;
begin
pragma Debug
@@ -527,7 +516,7 @@ package body System.Tasking.Stages is
Base_Priority := System.Any_Priority (Priority);
end if;
- -- Find parent P of new Task, via master level number.
+ -- Find parent P of new Task, via master level number
P := Self_ID;
@@ -595,7 +584,29 @@ package body System.Tasking.Stages is
T.Entry_Calls (L).Level := L;
end loop;
- T.Common.Task_Image := Task_Image;
+ if Task_Image'Length = 0 then
+ T.Common.Task_Image_Len := 0;
+ else
+ Len := 1;
+ T.Common.Task_Image (1) := Task_Image (Task_Image'First);
+
+ for J in Task_Image'First + 1 .. Task_Image'Last loop
+
+ -- Remove unwanted blank space generated by 'Image
+
+ if Task_Image (J) /= ' '
+ or else Task_Image (J - 1) /= '('
+ then
+ Len := Len + 1;
+ T.Common.Task_Image (Len) := Task_Image (J);
+
+ exit when Len = T.Common.Task_Image'Last;
+ end if;
+ end loop;
+
+ T.Common.Task_Image_Len := Len;
+ end if;
+
Unlock (Self_ID);
Unlock_RTS;
@@ -655,6 +666,7 @@ package body System.Tasking.Stages is
-- ???
-- Experimentation has shown that abort is sometimes (but not
-- always) already deferred when this is called.
+
-- That may indicate an error. Find out what is going on.
C := Chain.T_ID;
@@ -742,10 +754,9 @@ package body System.Tasking.Stages is
Unlock_RTS;
end if;
- -- We need to explicitly wait for the task to be
- -- terminated here because on true concurrent system, we
- -- may end this procedure before the tasks are really
- -- terminated.
+ -- We need to explicitely wait for the task to be terminated here
+ -- because on true concurrent system, we may end this procedure
+ -- before the tasks are really terminated.
Write_Lock (Self_ID);
@@ -774,7 +785,7 @@ package body System.Tasking.Stages is
Unlock_RTS;
end if;
- -- Complete the environment task.
+ -- Complete the environment task
Vulnerable_Complete_Task (Self_ID);
@@ -807,14 +818,11 @@ package body System.Tasking.Stages is
begin
if T.Common.State = Terminated then
+
-- It is not safe to call Abort_Defer or Write_Lock at this stage
Initialization.Task_Lock (Self_Id);
- if T.Common.Task_Image /= null then
- Free_Task_Image (T.Common.Task_Image);
- end if;
-
Lock_RTS;
Initialization.Remove_From_All_Tasks_List (T);
Unlock_RTS;
@@ -832,43 +840,6 @@ package body System.Tasking.Stages is
end if;
end Free_Task;
- ----------------------
- -- Notify_Exception --
- ----------------------
-
- procedure Notify_Exception
- (Self_Id : Task_ID;
- Excep : Exception_Occurrence)
- is
- procedure To_Stderr (S : String);
- pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
-
- use System.Task_Info;
- use System.Soft_Links;
-
- function To_Address is new
- Unchecked_Conversion (Task_ID, System.Address);
-
- function Tailored_Exception_Information
- (E : Exception_Occurrence) return String;
- pragma Import
- (Ada, Tailored_Exception_Information,
- "__gnat_tailored_exception_information");
-
- begin
- To_Stderr ("task ");
-
- if Self_Id.Common.Task_Image /= null then
- To_Stderr (Self_Id.Common.Task_Image.all);
- To_Stderr ("_");
- end if;
-
- To_Stderr (System.Address_Image (To_Address (Self_Id)));
- To_Stderr (" terminated by unhandled exception");
- To_Stderr ((1 => ASCII.LF));
- To_Stderr (Tailored_Exception_Information (Excep));
- end Notify_Exception;
-
------------------
-- Task_Wrapper --
------------------
@@ -880,36 +851,13 @@ package body System.Tasking.Stages is
-- data. Task finalization is done by Complete_Task, which is called from
-- an at-end handler that the compiler generates.
- -- The variable ID in the task wrapper is used to implement the Self
- -- function on targets where there is a fast way to find the stack base
- -- of the current thread, since it should be at a fixed offset from the
- -- stack base.
-
- -- The variable Magic_Number is also used in such implementations
- -- of Self, to check whether the current task is an Ada task, as
- -- compared to other-language threads.
-
- -- Both act as constants, once initialized, but need to be marked as
- -- volatile or aliased to prevent the compiler from optimizing away the
- -- storage. See System.Task_Primitives.Operations.Self for more info.
-
procedure Task_Wrapper (Self_ID : Task_ID) is
- ID : Task_ID := Self_ID;
- pragma Volatile (ID);
- -- Do not delete this variable.
- -- In some targets, we need this variable to implement a fast Self.
-
- Magic_Number : Interfaces.C.unsigned := 16#ADAADAAD#;
- pragma Volatile (Magic_Number);
- -- We use this to verify that we are looking at an Ada task,
- -- inside of System.Task_Primitives.Operations.Self.
-
use type System.Parameters.Size_Type;
use type SSE.Storage_Offset;
use System.Standard_Library;
Secondary_Stack : aliased SSE.Storage_Array
- (1 .. ID.Common.Compiler_Data.Pri_Stack_Info.Size *
+ (1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
SSE.Storage_Offset (Parameters.Sec_Stack_Ratio) / 100);
Secondary_Stack_Address : System.Address := Secondary_Stack'Address;
@@ -917,63 +865,83 @@ package body System.Tasking.Stages is
pragma Assert (Self_ID.Deferral_Level = 1);
if not Parameters.Sec_Stack_Dynamic then
- ID.Common.Compiler_Data.Sec_Stack_Addr := Secondary_Stack'Address;
+ Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
+ Secondary_Stack'Address;
SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
end if;
- -- Set the guard page at the bottom of the stack.
- -- The call to unprotect the page is done in Terminate_Task
+ -- Set the guard page at the bottom of the stack. The call to
+ -- unprotect the page is done in Terminate_Task
Stack_Guard (Self_ID, True);
- -- Initialize low-level TCB components, that
- -- cannot be initialized by the creator.
- -- Enter_Task sets Self_ID.Known_Tasks_Index
- -- and Self_ID.LL.Thread
+ -- Initialize low-level TCB components, that cannot be initialized
+ -- by the creator. Enter_Task sets Self_ID.Known_Tasks_Index and
+ -- also Self_ID.LL.Thread
Enter_Task (Self_ID);
-- We lock RTS_Lock to wait for activator to finish activating
-- the rest of the chain, so that everyone in the chain comes out
-- in priority order.
+
-- This also protects the value of
- -- Self_ID.Common.Activator.Common.Wait_Count.
+ -- Self_ID.Common.Activator.Common.Wait_Count.
Lock_RTS;
Unlock_RTS;
begin
-- We are separating the following portion of the code in order to
- -- place the exception handlers in a different block.
- -- In this way we do not call Set_Jmpbuf_Address (which needs
- -- Self) before we set Self in Enter_Task
+ -- place the exception handlers in a different block. In this way,
+ -- we do not call Set_Jmpbuf_Address (which needs Self) before we
+ -- set Self in Enter_Task
- -- Call the task body procedure.
+ -- Call the task body procedure
-- The task body is called with abort still deferred. That
-- eliminates a dangerous window, for which we had to patch-up in
-- Terminate_Task.
+
-- During the expansion of the task body, we insert an RTS-call
-- to Abort_Undefer, at the first point where abort should be
-- allowed.
Self_ID.Common.Task_Entry_Point (Self_ID.Common.Task_Arg);
- Terminate_Task (Self_ID);
+ Initialization.Defer_Abort_Nestable (Self_ID);
exception
+ -- We can't call Terminate_Task in the exception handlers below,
+ -- since there may be (e.g. in the case of GCC exception handling)
+ -- clean ups associated with the exception handler that need to
+ -- access task specific data.
+
+ -- Defer abortion so that this task can't be aborted while exiting
+
when Standard'Abort_Signal =>
- Terminate_Task (Self_ID);
+ Initialization.Defer_Abort_Nestable (Self_ID);
when others =>
-- ??? Using an E : others here causes CD2C11A to fail on
-- DEC Unix, see 7925-005.
+ Initialization.Defer_Abort_Nestable (Self_ID);
+
+ -- Perform the task specific exception tracing duty. We handle
+ -- these outputs here and not in the common notification routine
+ -- because we need access to tasking related data and we don't
+ -- want to drag dependencies against tasking related units in the
+ -- the common notification units. Additionally, no trace is ever
+ -- triggered from the common routine for the Unhandled_Raise case
+ -- in tasks, since an exception never appears unhandled in this
+ -- context because of this handler.
+
if Exception_Trace = Unhandled_Raise then
- Notify_Exception (Self_ID, SSL.Get_Current_Excep.all.all);
+ Trace_Unhandled_Exception_In_Task (Self_ID);
end if;
-
- Terminate_Task (Self_ID);
end;
+
+ Terminate_Task (Self_ID);
end Task_Wrapper;
--------------------
@@ -985,12 +953,11 @@ package body System.Tasking.Stages is
-- try to deallocate the ATCB out from under the current task WHILE IT IS
-- STILL EXECUTING.
- -- To avoid this, the parent task must be blocked up to the last thing
- -- done before the call to Exit_Task. The trouble is that we have another
- -- step that we also want to postpone to the very end, i.e., calling
- -- SSL.Destroy_TSD. We have to postpone that until the end because
- -- compiler-generated code is likely to try to access that data at just
- -- about any point.
+ -- To avoid this, the parent task must be blocked up to the latest
+ -- statement executed. The trouble is that we have another step that we
+ -- also want to postpone to the very end, i.e., calling SSL.Destroy_TSD.
+ -- We have to postpone that until the end because compiler-generated code
+ -- is likely to try to access that data at just about any point.
-- We can't call Destroy_TSD while we are holding any other locks, because
-- it locks Global_Task_Lock, and our deadlock prevention rules require
@@ -1008,8 +975,11 @@ package body System.Tasking.Stages is
procedure Terminate_Task (Self_ID : Task_ID) is
Environment_Task : constant Task_ID := STPO.Environment_Task;
+ Master_of_Task : Integer;
begin
+ Debug.Task_Termination_Hook;
+
if Runtime_Traces then
Send_Trace_Info (T_Terminate);
end if;
@@ -1029,10 +999,12 @@ package body System.Tasking.Stages is
Lock_RTS;
end if;
+ Master_of_Task := Self_ID.Master_of_Task;
+
-- Check if the current task is an independent task
-- If so, decrement the Independent_Task_Count value.
- if Self_ID.Master_of_Task = 2 then
+ if Master_of_Task = 2 then
if Single_Lock then
Utilities.Independent_Task_Count :=
Utilities.Independent_Task_Count - 1;
@@ -1045,7 +1017,7 @@ package body System.Tasking.Stages is
end if;
end if;
- -- Unprotect the guard page if needed.
+ -- Unprotect the guard page if needed
Stack_Guard (Self_ID, False);
@@ -1064,7 +1036,9 @@ package body System.Tasking.Stages is
-- past this point, this thread must assume that the ATCB
-- has been deallocated. It should not be accessed again.
- STPO.Exit_Task;
+ if Master_of_Task > 0 then
+ STPO.Exit_Task;
+ end if;
end Terminate_Task;
----------------
@@ -1072,8 +1046,8 @@ package body System.Tasking.Stages is
----------------
function Terminated (T : Task_ID) return Boolean is
+ Self_ID : constant Task_ID := STPO.Self;
Result : Boolean;
- Self_ID : Task_ID := STPO.Self;
begin
Initialization.Defer_Abort_Nestable (Self_ID);
@@ -1094,6 +1068,49 @@ package body System.Tasking.Stages is
return Result;
end Terminated;
+ ----------------------------------------
+ -- Trace_Unhandled_Exception_In_Task --
+ ----------------------------------------
+
+ procedure Trace_Unhandled_Exception_In_Task (Self_Id : Task_ID) is
+ procedure To_Stderr (S : String);
+ pragma Import (Ada, To_Stderr, "__gnat_to_stderr");
+
+ use System.Task_Info;
+ use System.Soft_Links;
+ use System.Standard_Library;
+
+ function To_Address is new
+ Unchecked_Conversion (Task_ID, System.Address);
+
+ function Tailored_Exception_Information
+ (E : Exception_Occurrence) return String;
+ pragma Import
+ (Ada, Tailored_Exception_Information,
+ "__gnat_tailored_exception_information");
+
+ Excep : Exception_Occurrence_Access := SSL.Get_Current_Excep.all;
+
+ begin
+ -- This procedure is called by the task outermost handler in
+ -- Task_Wrapper below, so only once the task stack has been fully
+ -- unwound. The common notification routine has been called at the
+ -- raise point already.
+
+ To_Stderr ("task ");
+
+ if Self_Id.Common.Task_Image_Len /= 0 then
+ To_Stderr
+ (Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len));
+ To_Stderr ("_");
+ end if;
+
+ To_Stderr (System.Address_Image (To_Address (Self_Id)));
+ To_Stderr (" terminated by unhandled exception");
+ To_Stderr ((1 => ASCII.LF));
+ To_Stderr (Tailored_Exception_Information (Excep.all));
+ end Trace_Unhandled_Exception_In_Task;
+
------------------------------------
-- Vulnerable_Complete_Activation --
------------------------------------
@@ -1114,14 +1131,13 @@ package body System.Tasking.Stages is
pragma Assert (Self_ID.Common.Activator /= null);
- -- Remove dangling reference to Activator,
- -- since a task may outlive its activator.
+ -- Remove dangling reference to Activator, since a task may
+ -- outlive its activator.
Self_ID.Common.Activator := null;
- -- Wake up the activator, if it is waiting for a chain
- -- of tasks to activate, and we are the last in the chain
- -- to complete activation
+ -- Wake up the activator, if it is waiting for a chain of tasks to
+ -- activate, and we are the last in the chain to complete activation.
if Activator.Common.State = Activator_Sleep then
Activator.Common.Wait_Count := Activator.Common.Wait_Count - 1;
@@ -1131,10 +1147,10 @@ package body System.Tasking.Stages is
end if;
end if;
- -- The activator raises a Tasking_Error if any task
- -- it is activating is completed before the activation is
- -- done. However, if the reason for the task completion is
- -- an abortion, we do not raise an exception. ARM 9.2(5).
+ -- The activator raises a Tasking_Error if any task it is activating
+ -- is completed before the activation is done. However, if the reason
+ -- for the task completion is an abortion, we do not raise an exception.
+ -- See RM 9.2(5).
if not Self_ID.Callable and then Self_ID.Pending_ATC_Level /= 0 then
Activator.Common.Activation_Failed := True;
@@ -1161,7 +1177,7 @@ package body System.Tasking.Stages is
procedure Vulnerable_Complete_Master (Self_ID : Task_ID) is
C : Task_ID;
P : Task_ID;
- CM : Master_Level := Self_ID.Master_Within;
+ CM : constant Master_Level := Self_ID.Master_Within;
T : aliased Task_ID;
To_Be_Freed : Task_ID;
@@ -1455,7 +1471,7 @@ package body System.Tasking.Stages is
if T.Interrupt_Entry and Interrupt_Manager_ID /= null then
declare
- Detach_Interrupt_Entries_Index : Task_Entry_Index := 1;
+ Detach_Interrupt_Entries_Index : constant Task_Entry_Index := 1;
-- Corresponds to the entry index of System.Interrupts.
-- Interrupt_Manager.Detach_Interrupt_Entries.
-- Be sure to update this value when changing
@@ -1592,8 +1608,7 @@ package body System.Tasking.Stages is
procedure Vulnerable_Free_Task (T : Task_ID) is
begin
- pragma Debug
- (Debug.Trace ("Vulnerable_Free_Task", T, 'C'));
+ pragma Debug (Debug.Trace (Self, "Vulnerable_Free_Task", 'C', T));
if Single_Lock then
Lock_RTS;
@@ -1607,15 +1622,12 @@ package body System.Tasking.Stages is
Unlock_RTS;
end if;
- if T.Common.Task_Image /= null then
- Free_Task_Image (T.Common.Task_Image);
- end if;
-
System.Task_Primitives.Operations.Finalize_TCB (T);
end Vulnerable_Free_Task;
begin
-- Establish the Adafinal softlink.
+
-- This is not done inside the central RTS initialization routine
-- to avoid with-ing this package from System.Tasking.Initialization.
diff --git a/gcc/ada/s-tassta.ads b/gcc/ada/s-tassta.ads
index 92084f09713..25018389891 100644
--- a/gcc/ada/s-tassta.ads
+++ b/gcc/ada/s-tassta.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1999, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -50,24 +50,24 @@ package System.Tasking.Stages is
pragma Elaborate_Body;
-- The compiler will expand in the GNAT tree the following construct:
- --
+
-- task type T (Discr : Integer);
- --
+
-- task body T is
-- ...declarations, possibly some controlled...
-- begin
-- ...B...;
-- end T;
- --
+
-- T1 : T (1);
- --
+
-- as follows:
- --
+
-- enter_master.all;
- --
+
-- _chain : aliased activation_chain;
- -- _init_proc (_chain);
- --
+ -- activation_chainIP (_chain);
+
-- task type t (discr : integer);
-- tE : aliased boolean := false;
-- tZ : size_type := unspecified_size;
@@ -76,7 +76,7 @@ package System.Tasking.Stages is
-- end record;
-- procedure tB (_task : access tV);
-- freeze tV [
- -- procedure _init_proc (_init : in out tV; _master : master_id;
+ -- procedure tVIP (_init : in out tV; _master : master_id;
-- _chain : in out activation_chain; _task_id : in task_image_type;
-- discr : integer) is
-- begin
@@ -88,12 +88,12 @@ package System.Tasking.Stages is
-- _init'address, tE'unchecked_access, _chain, _task_id, _init.
-- _task_id);
-- return;
- -- end _init_proc;
+ -- end tVIP;
-- ]
- --
+
-- procedure tB (_task : access tV) is
-- discr : integer renames _task.discr;
- --
+
-- procedure _clean is
-- begin
-- abort_defer.all;
@@ -111,13 +111,13 @@ package System.Tasking.Stages is
-- at end
-- _clean;
-- end tB;
- --
+
-- tE := true;
-- t1 : t (1);
- -- master : constant master_id := current_master.all;
- -- t1I : task_image_type := new string'"t1";
- -- _init_proc (t1, _master, _chain, t1I, 1);
- --
+ -- _master : constant master_id := current_master.all;
+ -- t1S : task_image_type := new string'"t1";
+ -- task_image_typeIP (t1, _master, _chain, t1S, 1);
+
-- activate_tasks (_chain'unchecked_access);
procedure Abort_Tasks (Tasks : Task_List);
@@ -176,7 +176,7 @@ package System.Tasking.Stages is
Discriminants : System.Address;
Elaborated : Access_Boolean;
Chain : in out Activation_Chain;
- Task_Image : System.Task_Info.Task_Image_Type;
+ Task_Image : String;
Created_Task : out Task_ID);
-- Compiler interface only. Do not call from within the RTS.
-- This must be called to create a new task.
@@ -191,12 +191,12 @@ package System.Tasking.Stages is
-- are those of the task to create. This parameter should be passed as
-- the single argument to State.
-- Elaborated is a pointer to a Boolean that must be set to true on exit
- -- if the task could be successfully elaborated.
+ -- if the task could be sucessfully elaborated.
-- Chain is a linked list of task that needs to be created. On exit,
-- Created_Task.Activation_Link will be Chain.T_ID, and Chain.T_ID
-- will be Created_Task (e.g the created task will be linked at the front
-- of Chain).
- -- Task_Image is a pointer to a string created by the compiler that the
+ -- Task_Image is a string created by the compiler that the
-- run time can store to ease the debugging and the
-- Ada.Task_Identification facility.
-- Created_Task is the resulting task.
@@ -214,7 +214,7 @@ package System.Tasking.Stages is
-- declared.
procedure Expunge_Unactivated_Tasks (Chain : in out Activation_Chain);
- -- Compiler interface only. Do not call from within the RTS.
+ -- Compiler interface only. Do not call from within the RTS.
-- This must be called by the compiler-generated code for an allocator if
-- the allocated object contains tasks, if the allocator exits without
-- calling Activate_Tasks for a given activation chains, as can happen if
@@ -268,4 +268,9 @@ package System.Tasking.Stages is
-- code expansion:
-- terminated (t1._task_id)
+ procedure Terminate_Task (Self_ID : Task_ID);
+ -- Terminate the calling task.
+ -- This should only be called by the Task_Wrapper procedure, and to
+ -- deallocate storage associate with foreign tasks.
+
end System.Tasking.Stages;
diff --git a/gcc/ada/s-tasuti.adb b/gcc/ada/s-tasuti.adb
index 8b4bcfa6a66..37e6b44901d 100644
--- a/gcc/ada/s-tasuti.adb
+++ b/gcc/ada/s-tasuti.adb
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -181,10 +181,16 @@ package body System.Tasking.Utilities is
procedure Cancel_Queued_Entry_Calls (T : Task_ID) is
Next_Entry_Call : Entry_Call_Link;
Entry_Call : Entry_Call_Link;
- Caller : Task_ID;
- Level : Integer;
Self_Id : constant Task_ID := STPO.Self;
+ Caller : Task_ID;
+ pragma Unreferenced (Caller);
+ -- Should this be removed ???
+
+ Level : Integer;
+ pragma Unreferenced (Level);
+ -- Should this be removed ???
+
begin
pragma Assert (T = Self or else T.Common.State = Terminated);
@@ -192,6 +198,7 @@ package body System.Tasking.Utilities is
Queuing.Dequeue_Head (T.Entry_Queues (J), Entry_Call);
while Entry_Call /= null loop
+
-- Leave Entry_Call.Done = False, since this is cancelled
Caller := Entry_Call.Self;
@@ -260,6 +267,7 @@ package body System.Tasking.Utilities is
Environment_Task : constant Task_ID := STPO.Environment_Task;
Parent : constant Task_ID := Self_Id.Common.Parent;
Parent_Needs_Updating : Boolean := False;
+ Master_of_Task : Integer;
begin
if Self_Id.Known_Tasks_Index /= -1 then
@@ -278,6 +286,7 @@ package body System.Tasking.Utilities is
pragma Assert (Parent = Environment_Task
or else Self_Id.Master_of_Task = Library_Task_Level);
+ Master_of_Task := Self_Id.Master_of_Task;
Self_Id.Master_of_Task := Independent_Task_Level;
-- The run time assumes that the parent of an independent task is the
@@ -313,6 +322,18 @@ package body System.Tasking.Utilities is
Unlock (Parent);
end if;
+ -- In case the environment task is already waiting for children to
+ -- complete.
+ -- ??? There may be a race condition if the environment task was not in
+ -- master completion sleep when this task was created, but now is
+
+ if Environment_Task.Common.State = Master_Completion_Sleep and then
+ Master_of_Task = Environment_Task.Master_Within
+ then
+ Environment_Task.Common.Wait_Count :=
+ Environment_Task.Common.Wait_Count - 1;
+ end if;
+
Unlock (Environment_Task);
if Single_Lock then
diff --git a/gcc/ada/s-tasuti.ads b/gcc/ada/s-tasuti.ads
index 712f68c37c3..dfdd274fd3b 100644
--- a/gcc/ada/s-tasuti.ads
+++ b/gcc/ada/s-tasuti.ads
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-tataat.adb b/gcc/ada/s-tataat.adb
index d417da50e76..120fa21f544 100644
--- a/gcc/ada/s-tataat.adb
+++ b/gcc/ada/s-tataat.adb
@@ -6,7 +6,8 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2001 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,8 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -148,7 +149,8 @@ package body System.Tasking.Task_Attributes is
Undefer_Abortion;
exception
- when others => null;
+ when others =>
+ null;
pragma Assert (False,
"Exception in task attribute instance finalization");
end Finalize;
@@ -175,7 +177,8 @@ package body System.Tasking.Task_Attributes is
T.Indirect_Attributes := null;
exception
- when others => null;
+ when others =>
+ null;
pragma Assert (False,
"Exception in per-task attributes finalization");
end Finalize_Attributes;
@@ -185,12 +188,11 @@ package body System.Tasking.Task_Attributes is
---------------------------
-- This is to be called by System.Tasking.Stages.Create_Task.
- -- It relies on their being no concurrent access to this TCB,
- -- so it does not defer abortion nor lock T.L.
procedure Initialize_Attributes (T : Task_ID) is
P : Access_Instance;
begin
+ Defer_Abortion;
Lock_RTS;
-- Initialize all the direct-access attributes of this task.
@@ -200,16 +202,19 @@ package body System.Tasking.Task_Attributes is
while P /= null loop
if P.Index /= 0 then
T.Direct_Attributes (P.Index) :=
- System.Storage_Elements.To_Address (P.Initial_Value);
+ Direct_Attribute_Element
+ (System.Storage_Elements.To_Address (P.Initial_Value));
end if;
P := P.Next;
end loop;
Unlock_RTS;
+ Undefer_Abortion;
exception
- when others => null;
+ when others =>
+ null;
pragma Assert (False);
end Initialize_Attributes;
diff --git a/gcc/ada/s-tataat.ads b/gcc/ada/s-tataat.ads
index 3ed63ac090d..8893cdacf46 100644
--- a/gcc/ada/s-tataat.ads
+++ b/gcc/ada/s-tataat.ads
@@ -6,7 +6,8 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2002 Florida State University --
+-- Copyright (C) 1991-1994, Florida State University --
+-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,8 +27,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -94,6 +95,11 @@ package System.Tasking.Task_Attributes is
-- The generic formal type, may be controlled
end record;
+ for Dummy_Wrapper'Alignment use Standard'Maximum_Alignment;
+ -- A number of unchecked conversions involving Dummy_Wrapper_Access
+ -- sources are performed in other units (e.g. Ada.Task_Attributes).
+ -- Ensure that the designated object is always strictly enough aligned.
+
In_Use : Direct_Index_Vector := 0;
-- is True for direct indices that are already used.
diff --git a/gcc/ada/s-thread.adb b/gcc/ada/s-thread.adb
new file mode 100644
index 00000000000..0f3a90c1a08
--- /dev/null
+++ b/gcc/ada/s-thread.adb
@@ -0,0 +1,101 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T H R E A D S --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the VxWorks/Cert version of this package
+
+with Unchecked_Conversion;
+
+package body System.Threads is
+
+ Current_ATSD : aliased System.Address := System.Null_Address;
+ pragma Export (C, Current_ATSD, "__gnat_current_atsd");
+
+ function From_Address is
+ new Unchecked_Conversion (Address, ATSD_Access);
+
+ -----------------------
+ -- Get_Current_Excep --
+ -----------------------
+
+ function Get_Current_Excep return EOA is
+ CTSD : ATSD_Access := From_Address (Current_ATSD);
+ begin
+ pragma Assert (Current_ATSD /= System.Null_Address);
+ return CTSD.Current_Excep'Access;
+ end Get_Current_Excep;
+
+ ------------------------
+ -- Get_Jmpbuf_Address --
+ ------------------------
+
+ function Get_Jmpbuf_Address return Address is
+ CTSD : ATSD_Access := From_Address (Current_ATSD);
+ begin
+ pragma Assert (Current_ATSD /= System.Null_Address);
+ return CTSD.Jmpbuf_Address;
+ end Get_Jmpbuf_Address;
+
+ ------------------------
+ -- Get_Sec_Stack_Addr --
+ ------------------------
+
+ function Get_Sec_Stack_Addr return Address is
+ CTSD : ATSD_Access := From_Address (Current_ATSD);
+ begin
+ pragma Assert (Current_ATSD /= System.Null_Address);
+ return CTSD.Sec_Stack_Addr;
+ end Get_Sec_Stack_Addr;
+
+ ------------------------
+ -- Set_Jmpbuf_Address --
+ ------------------------
+
+ procedure Set_Jmpbuf_Address (Addr : Address) is
+ CTSD : ATSD_Access := From_Address (Current_ATSD);
+ begin
+ pragma Assert (Current_ATSD /= System.Null_Address);
+ CTSD.Jmpbuf_Address := Addr;
+ end Set_Jmpbuf_Address;
+
+ ------------------------
+ -- Set_Sec_Stack_Addr --
+ ------------------------
+
+ procedure Set_Sec_Stack_Addr (Addr : Address) is
+ CTSD : ATSD_Access := From_Address (Current_ATSD);
+ begin
+ pragma Assert (Current_ATSD /= System.Null_Address);
+ CTSD.Sec_Stack_Addr := Addr;
+ end Set_Sec_Stack_Addr;
+
+end System.Threads;
diff --git a/gcc/ada/s-thread.ads b/gcc/ada/s-thread.ads
new file mode 100644
index 00000000000..6bf6aafb568
--- /dev/null
+++ b/gcc/ada/s-thread.ads
@@ -0,0 +1,93 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y S T E M . T H R E A D S --
+-- --
+-- S p e c --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides facilities to register a thread to the runtime,
+-- and allocate its task specific datas.
+
+with Ada.Exceptions;
+
+package System.Threads is
+
+ subtype EO is Ada.Exceptions.Exception_Occurrence;
+
+ subtype EOA is Ada.Exceptions.Exception_Occurrence_Access;
+
+ type ATSD is limited private;
+ -- Type of the Ada thread specific data. It contains datas needed
+ -- by the GNAT runtime.
+
+ type ATSD_Access is access ATSD;
+
+ -- Get/Set for the attributes of the current thread.
+
+ function Get_Jmpbuf_Address return Address;
+ pragma Inline (Get_Jmpbuf_Address);
+
+ procedure Set_Jmpbuf_Address (Addr : Address);
+ pragma Inline (Get_Jmpbuf_Address);
+
+ function Get_Sec_Stack_Addr return Address;
+ pragma Inline (Get_Sec_Stack_Addr);
+
+ procedure Set_Sec_Stack_Addr (Addr : Address);
+ pragma Inline (Set_Sec_Stack_Addr);
+
+ function Get_Current_Excep return EOA;
+ pragma Inline (Get_Current_Excep);
+
+private
+
+ ------------------------
+ -- Task Specific Data --
+ ------------------------
+
+ type ATSD is limited record
+ Jmpbuf_Address : Address := Null_Address;
+ -- Address of jump buffer used to store the address of the
+ -- current longjmp/setjmp buffer for exception management.
+ -- These buffers are threaded into a stack, and the address
+ -- here is the top of the stack. A null address means that
+ -- no exception handler is currently active.
+
+ Sec_Stack_Addr : Address := Null_Address;
+ -- Address of currently allocated secondary stack
+
+ Current_Excep : aliased EO;
+ -- Exception occurrence that contains the information for the
+ -- current exception. Note that any exception in the same task
+ -- destroys this information, so the data in this variable must
+ -- be copied out before another exception can occur.
+
+ end record;
+
+end System.Threads;
diff --git a/gcc/ada/s-tpae65.adb b/gcc/ada/s-tpae65.adb
new file mode 100644
index 00000000000..b0438b00fa3
--- /dev/null
+++ b/gcc/ada/s-tpae65.adb
@@ -0,0 +1,87 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . A E _ 6 5 3 --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2003, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Export certain tasking-related routines for use by Interfaces.Vthreads
+
+with Interfaces.C;
+package body System.Task_Primitives.Ae_653 is
+
+ -------------------
+ -- ATCB_Key_Addr --
+ -------------------
+
+ function ATCB_Key_Addr return Address_Access is
+ Key_Addr : Address_Access;
+ pragma Import (Ada, Key_Addr, "__gnat_ATCB_key_addr");
+ -- Done this way to minimize impact on other targets. This
+ -- implementation is temporary, and specific to AE653
+ begin
+ return Key_Addr;
+ end ATCB_Key_Addr;
+
+ --------------------------
+ -- Set_Current_Priority --
+ --------------------------
+
+ procedure Set_Current_Priority
+ (T : System.Tasking.Task_ID;
+ Prio : System.Priority)
+ is
+ begin
+ T.Common.Current_Priority := Prio;
+ end Set_Current_Priority;
+
+ ---------------------
+ -- Set_Task_Thread --
+ ---------------------
+
+ procedure Set_Task_Thread
+ (T : System.Tasking.Task_ID;
+ Thread : System.OS_Interface.Thread_Id)
+ is
+ use System.OS_Interface;
+ use System.Tasking;
+ use type Interfaces.C.int;
+ Result : STATUS;
+ begin
+ T.Common.LL.Thread := Thread;
+ if taskVarGet (Thread, ATCB_Key_Addr) = ERROR then
+ Result := taskVarAdd (Thread, ATCB_Key_Addr);
+ pragma Assert (Result = OK);
+ end if;
+
+ Result := taskVarSet (Thread, ATCB_Key_Addr, To_Address (T));
+ pragma Assert (Result = OK);
+ end Set_Task_Thread;
+
+end System.Task_Primitives.Ae_653;
diff --git a/gcc/ada/5qosinte.adb b/gcc/ada/s-tpae65.ads
index 59d34acd4c8..641f17187d8 100644
--- a/gcc/ada/5qosinte.adb
+++ b/gcc/ada/s-tpae65.ads
@@ -2,11 +2,11 @@
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- S Y S T E M . O S _ I N T E R F A C E --
+-- S Y S T E M . T A S K _ P R I M I T I V E S . A E _ 6 5 3 --
-- --
--- B o d y --
+-- S p e c --
-- --
--- Copyright (C) 1991-2001 Florida State University --
+-- Copyright (C) 2002-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,23 +26,29 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
--- RT GNU/Linux version.
+-- Export certain tasking-related routines for use by Interfaces.Vthreads
--- This package encapsulates all direct interfaces to OS services
--- that are needed by children of System.
+with System.Tasking;
+with System.OS_Interface;
+package System.Task_Primitives.Ae_653 is
+ type Address_Access is access System.Address;
-pragma Polling (Off);
--- Turn off polling, we do not want ATC polling to take place during
--- tasking operations. It causes infinite loops and other problems.
+ function ATCB_Key_Addr return Address_Access;
+ pragma Inline (ATCB_Key_Addr);
+ -- Address of ATCB_Key taskvar
-package body System.OS_Interface is
+ procedure Set_Current_Priority
+ (T : System.Tasking.Task_ID; Prio : System.Priority);
+ -- Set priority
- type Require_Body is new Integer;
+ procedure Set_Task_Thread
+ (T : System.Tasking.Task_ID;
+ Thread : System.OS_Interface.Thread_Id);
+ -- Set "Thread" as the underlying OS thread implementing "T"
-end System.OS_Interface;
+end System.Task_Primitives.Ae_653;
diff --git a/gcc/ada/s-tpinop.adb b/gcc/ada/s-tpinop.adb
index ac5bda3f8c4..05c44405c1f 100644
--- a/gcc/ada/s-tpinop.adb
+++ b/gcc/ada/s-tpinop.adb
@@ -28,7 +28,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-tpinop.ads b/gcc/ada/s-tpinop.ads
index 763641e4aea..4c96ca28e0a 100644
--- a/gcc/ada/s-tpinop.ads
+++ b/gcc/ada/s-tpinop.ads
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb
index 8e90a9dc490..45ef97fb244 100644
--- a/gcc/ada/s-tpoben.adb
+++ b/gcc/ada/s-tpoben.adb
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads
index cd3fd57aa04..5bef440590d 100644
--- a/gcc/ada/s-tpoben.ads
+++ b/gcc/ada/s-tpoben.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -110,7 +110,6 @@ package System.Tasking.Protected_Objects.Entries is
Find_Body_Index : Find_Body_Index_Access;
Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries);
end record;
- pragma Volatile (Protection_Entries);
-- No default initial values for this type, since call records
-- will need to be re-initialized before every use.
@@ -119,9 +118,6 @@ package System.Tasking.Protected_Objects.Entries is
-- See comments in s-tassta.adb about the implicit call to Current_Master
-- generated by this declaration.
- function To_Protection_Entries is new Unchecked_Conversion
- (Protection_Access, Protection_Entries_Access);
-
function To_Address is
new Unchecked_Conversion (Protection_Entries_Access, System.Address);
function To_Protection is
diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb
index 36e60b1b212..275f872de9a 100644
--- a/gcc/ada/s-tpobop.adb
+++ b/gcc/ada/s-tpobop.adb
@@ -2,12 +2,11 @@
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- S Y S T E M . T A S K I N G . P R O T E C T E D _ O B J E C T S . --
--- O P E R A T I O N S --
+-- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS --
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2003, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -142,7 +141,7 @@ package body System.Tasking.Protected_Objects.Operations is
-- declare
-- X : protected_entry_index := 1;
-- B80b : communication_block;
- -- _init_proc (B80b);
+ -- communication_blockIP (B80b);
-- begin
-- begin
-- A79b : label
@@ -616,7 +615,7 @@ package body System.Tasking.Protected_Objects.Operations is
-- declare
-- X : protected_entry_index := 1;
-- B85b : communication_block;
- -- _init_proc (B85b);
+ -- communication_blockIP (B85b);
-- begin
-- protected_entry_call (rTV!(r)._object'unchecked_access, X,
-- null_address, conditional_call, B85b, objectF => 0);
@@ -1040,7 +1039,8 @@ package body System.Tasking.Protected_Objects.Operations is
(Entry_Call : Entry_Call_Link;
With_Abort : Boolean)
is
- Old : Entry_Call_State := Entry_Call.State;
+ Old : constant Entry_Call_State := Entry_Call.State;
+
begin
pragma Assert (Old < Done);
diff --git a/gcc/ada/s-tpobop.ads b/gcc/ada/s-tpobop.ads
index c1498c63ade..a4748ac0845 100644
--- a/gcc/ada/s-tpobop.ads
+++ b/gcc/ada/s-tpobop.ads
@@ -28,7 +28,7 @@
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
diff --git a/gcc/ada/s-tporft.adb b/gcc/ada/s-tporft.adb
new file mode 100644
index 00000000000..b735b1145d9
--- /dev/null
+++ b/gcc/ada/s-tporft.adb
@@ -0,0 +1,104 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.REGISTER_FOREIGN_THREAD --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002-2003, Free Software Foundation, Inc. --
+-- --
+-- GNARL is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNARL; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Task_Info;
+-- Use for Unspecified_Task_Info
+
+with System.Soft_Links;
+-- used to initialize TSD for a C thread, in function Self
+
+separate (System.Task_Primitives.Operations)
+function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID is
+ Local_ATCB : aliased Ada_Task_Control_Block (0);
+ Self_Id : Task_ID;
+ Succeeded : Boolean;
+
+ use type Interfaces.C.unsigned;
+
+begin
+ -- This section is tricky. We must not call anything that might require
+ -- an ATCB, until the new ATCB is in place. In order to get an ATCB
+ -- immediately, we fake one, so that it is then possible to e.g allocate
+ -- memory (which might require accessing self).
+
+ -- Record this as the Task_ID for the thread
+
+ Local_ATCB.Common.LL.Thread := Thread;
+ Local_ATCB.Common.Current_Priority := System.Priority'First;
+ Specific.Set (Local_ATCB'Unchecked_Access);
+
+ -- It is now safe to use an allocator
+
+ Self_Id := new Ada_Task_Control_Block (0);
+
+ -- Finish initialization
+
+ System.Tasking.Initialize_ATCB
+ (Self_Id, null, Null_Address, Null_Task,
+ Foreign_Task_Elaborated'Access,
+ System.Priority'First, Task_Info.Unspecified_Task_Info, 0, Self_Id,
+ Succeeded);
+ pragma Assert (Succeeded);
+
+ Self_Id.Master_of_Task := 0;
+ Self_Id.Master_Within := Self_Id.Master_of_Task + 1;
+
+ for L in Self_Id.Entry_Calls'Range loop
+ Self_Id.Entry_Calls (L).Self := Self_Id;
+ Self_Id.Entry_Calls (L).Level := L;
+ end loop;
+
+ Self_Id.Common.State := Runnable;
+ Self_Id.Awake_Count := 1;
+
+ -- Since this is not an ordinary Ada task, we will start out undeferred
+
+ Self_Id.Deferral_Level := 0;
+
+ System.Soft_Links.Create_TSD (Self_Id.Common.Compiler_Data);
+
+ -- ???
+ -- The following call is commented out to avoid dependence on
+ -- the System.Tasking.Initialization package.
+ -- It seems that if we want Ada.Task_Attributes to work correctly
+ -- for C threads we will need to raise the visibility of this soft
+ -- link to System.Soft_Links.
+ -- We are putting that off until this new functionality is otherwise
+ -- stable.
+
+ -- System.Tasking.Initialization.Initialize_Attributes_Link.all (T);
+
+ Enter_Task (Self_Id);
+
+ return Self_Id;
+end Register_Foreign_Thread;
diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb
index df132a544ea..3eaec425e91 100644
--- a/gcc/ada/s-tposen.adb
+++ b/gcc/ada/s-tposen.adb
@@ -26,8 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -444,7 +444,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
function Protected_Count_Entry (Object : Protection_Entry) return Natural is
begin
- if Object.Call_In_Progress /= null then
+ if Object.Entry_Queue /= null then
return 1;
else
return 0;
@@ -519,13 +519,12 @@ package body System.Tasking.Protected_Objects.Single_Entry is
Self_Id : constant Task_ID := STPO.Self;
Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
Caller : Task_ID;
- Barrier_Value : Boolean;
begin
if Entry_Call /= null then
- Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1);
+ if Object.Entry_Body.Barrier (Object.Compiler_Info, 1) then
+ Object.Entry_Queue := null;
- if Barrier_Value then
if Object.Call_In_Progress /= null then
-- This violates the No_Entry_Queue restriction, send
-- Program_Error to the caller.
diff --git a/gcc/ada/s-tposen.ads b/gcc/ada/s-tposen.ads
index d5f48785fcd..cb581ff34b0 100644
--- a/gcc/ada/s-tposen.ads
+++ b/gcc/ada/s-tposen.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1991-2001 Florida State University --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,9 +26,8 @@
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
--- GNARL was developed by the GNARL team at Florida State University. It is --
--- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
--- State University (http://www.gnat.com). --
+-- GNARL was developed by the GNARL team at Florida State University. --
+-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
@@ -65,30 +64,30 @@ package System.Tasking.Protected_Objects.Single_Entry is
---------------------------------
-- The compiler will expand in the GNAT tree the following construct:
- --
+
-- protected PO is
-- entry E;
-- procedure P;
-- private
-- Open : Boolean := False;
-- end PO;
- --
+
-- protected body PO is
-- entry E when Open is
-- ...variable declarations...
-- begin
-- ...B...
-- end E;
- --
+
-- procedure P is
-- ...variable declarations...
-- begin
-- ...C...
-- end P;
-- end PO;
- --
+
-- as follows:
- --
+
-- protected type poT is
-- entry e;
-- procedure p;
@@ -109,19 +108,19 @@ package System.Tasking.Protected_Objects.Single_Entry is
-- barrier => poPT__B2s'unrestricted_access,
-- action => poPT__E1s'unrestricted_access);
-- freeze poTV [
- -- procedure _init_proc (_init : in out poTV) is
+ -- procedure poTVIP (_init : in out poTV) is
-- begin
-- _init.open := false;
- -- _init_proc (_init._object);
+ -- object-init-proc (_init._object);
-- initialize_protection_entry (_init._object'unchecked_access,
-- unspecified_priority, _init'address, poTA'
-- unrestricted_access);
-- return;
- -- end _init_proc;
+ -- end poTVIP;
-- ]
-- po : poT;
- -- _init_proc (poTV!(po));
- --
+ -- poTVIP (poTV!(po));
+
-- function poPT__B2s (O : address; E : protected_entry_index) return
-- boolean is
-- type poTVP is access poTV;
@@ -131,7 +130,7 @@ package System.Tasking.Protected_Objects.Single_Entry is
-- begin
-- return open;
-- end poPT__B2s;
- --
+
-- procedure poPT__E1s (O : address; P : address; E :
-- protected_entry_index) is
-- type poTVP is access poTV;
@@ -152,7 +151,7 @@ package System.Tasking.Protected_Objects.Single_Entry is
-- unchecked_access, get_gnat_exception);
-- return;
-- end poPT__E1s;
- --
+
-- procedure poPT__pN (_object : in out poTV) is
-- poR : protection_entry renames _object._object;
-- openP : boolean renames _object.open;
@@ -161,7 +160,7 @@ package System.Tasking.Protected_Objects.Single_Entry is
-- ...C...
-- return;
-- end poPT__pN;
- --
+
-- procedure poPT__pP (_object : in out poTV) is
-- procedure _clean is
-- begin
@@ -284,9 +283,5 @@ private
Entry_Body : Entry_Body_Access;
Entry_Queue : Entry_Call_Link;
end record;
- pragma Volatile (Protection_Entry);
- for Protection_Entry'Alignment use Standard'Maximum_Alignment;
- -- Use maximum alignement so that one can convert a protection_entry_access
- -- to a task_id.
end System.Tasking.Protected_Objects.Single_Entry;
diff --git a/gcc/ada/s-traceb.adb b/gcc/ada/s-traceb.adb
index 94cc6ff22c1..1778f7931bb 100644
--- a/gcc/ada/s-traceb.adb
+++ b/gcc/ada/s-traceb.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-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- --
@@ -33,6 +33,9 @@
-- This is the default version of this package
+-- Note: this unit must be compiled using -fno-optimize-sibling-calls.
+-- See comment below in body of Call_Chain for details on the reason.
+
package body System.Traceback is
------------------
@@ -59,19 +62,32 @@ package body System.Traceback is
(Traceback : System.Address;
Len : Integer;
Exclude_Min : System.Address;
- Exclude_Max : System.Address)
+ Exclude_Max : System.Address;
+ Skip_Frames : Integer)
return Integer;
pragma Import (C, Backtrace, "__gnat_backtrace");
procedure Call_Chain
- (Traceback : System.Address;
- Max_Len : Natural;
- Len : out Natural;
- Exclude_Min,
- Exclude_Max : System.Address := System.Null_Address)
+ (Traceback : System.Address;
+ Max_Len : Natural;
+ Len : out Natural;
+ Exclude_Min : System.Address := System.Null_Address;
+ Exclude_Max : System.Address := System.Null_Address;
+ Skip_Frames : Natural := 1)
is
begin
- Len := Backtrace (Traceback, Max_Len, Exclude_Min, Exclude_Max);
+ -- Note: Backtrace relies on the following call actually creating a
+ -- stack frame. To ensure that this is the case, it is essential to
+ -- compile this unit without sibling call optimization.
+
+ -- We want the underlying engine to skip its own frame plus the
+ -- ones we have been requested to skip ourselves.
+
+ Len := Backtrace (Traceback => Traceback,
+ Len => Max_Len,
+ Exclude_Min => Exclude_Min,
+ Exclude_Max => Exclude_Max,
+ Skip_Frames => Skip_Frames + 1);
end Call_Chain;
end System.Traceback;
diff --git a/gcc/ada/s-traceb.ads b/gcc/ada/s-traceb.ads
index 1f69c2dd8aa..10ec5af515c 100644
--- a/gcc/ada/s-traceb.ads
+++ b/gcc/ada/s-traceb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-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- --
@@ -51,7 +51,8 @@ package System.Traceback is
Max_Len : Natural;
Len : out Natural;
Exclude_Min : System.Address := System.Null_Address;
- Exclude_Max : System.Address := System.Null_Address);
+ Exclude_Max : System.Address := System.Null_Address;
+ Skip_Frames : Natural := 1);
-- Store up to Max_Len code locations in Traceback, corresponding to
-- the current call chain.
--
@@ -68,6 +69,12 @@ package System.Traceback is
-- Exclude_Min/Exclude_Max, if non null, provide a range of addresses
-- to ignore from the computation of the traceback.
--
+ -- Skip_Frames says how many of the most recent calls should at least
+ -- be excluded from the result, regardless of the exclusion bounds and
+ -- starting with this procedure itself: 1 means exclude the frame for
+ -- this procedure, 2 means 1 + exclude the frame for this procedure's
+ -- caller, ...
+ --
-- On return, the Traceback array is filled in, and Len indicates
-- the number of stored entries. The first entry is the most recent
-- call, and the last entry is the highest level call.
diff --git a/gcc/ada/s-traent.adb b/gcc/ada/s-traent.adb
new file mode 100644
index 00000000000..a1437146ea1
--- /dev/null
+++ b/gcc/ada/s-traent.adb
@@ -0,0 +1,59 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E B A C K _ E N T R I E S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+
+package body System.Traceback_Entries is
+
+ ------------
+ -- PC_For --
+ ------------
+
+ function PC_For (TB_Entry : Traceback_Entry) return System.Address is
+ begin
+ return TB_Entry;
+ end PC_For;
+
+ ------------------
+ -- TB_Entry_For --
+ ------------------
+
+ function TB_Entry_For (PC : System.Address) return Traceback_Entry is
+ begin
+ return PC;
+ end TB_Entry_For;
+
+end System.Traceback_Entries;
diff --git a/gcc/ada/s-traent.ads b/gcc/ada/s-traent.ads
new file mode 100644
index 00000000000..d0c0865561a
--- /dev/null
+++ b/gcc/ada/s-traent.ads
@@ -0,0 +1,62 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . T R A C E B A C K _ E N T R I E S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- --
+-- This specification is derived from the Ada Reference Manual for use with --
+-- GNAT. The copyright notice above, and the license provisions that follow --
+-- apply solely to the contents of the part following the private keyword. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package offers an abstraction of what is stored in traceback arrays
+-- for call-chain computation purposes. By default, as defined in this
+-- version of the package, an entry is a mere code location representing the
+-- address of a call instruction part of the call-chain.
+
+package System.Traceback_Entries is
+
+ subtype Traceback_Entry is System.Address;
+ -- This subtype defines what each traceback array entry contains.
+
+ Null_TB_Entry : constant Traceback_Entry := System.Null_Address;
+ -- This is the value to be used when initializing an entry.
+
+ function PC_For (TB_Entry : Traceback_Entry) return System.Address;
+ pragma Inline (PC_For);
+ -- Returns the address of the call instruction associated with the
+ -- provided entry.
+
+ function TB_Entry_For (PC : System.Address) return Traceback_Entry;
+ pragma Inline (TB_Entry_For);
+ -- Returns an entry representing a frame for a call instruction at PC.
+
+end System.Traceback_Entries;
+
+
diff --git a/gcc/ada/s-unstyp.ads b/gcc/ada/s-unstyp.ads
index 7ed1033553c..5edeeb83412 100644
--- a/gcc/ada/s-unstyp.ads
+++ b/gcc/ada/s-unstyp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -33,7 +33,7 @@
-- This package contains definitions of standard unsigned types that
-- correspond in size to the standard signed types declared in Standard.
--- and (unlike the types in Interfaces have corresponding names). It
+-- and (unlike the types in Interfaces) have corresponding names. It
-- also contains some related definitions for other specialized types
-- used by the compiler in connection with packed array types.
@@ -55,6 +55,7 @@ pragma Pure (Unsigned_Types);
type Packed_Bytes1 is array (Natural range <>) of Packed_Byte;
for Packed_Bytes1'Alignment use 1;
+ for Packed_Bytes1'Component_Size use Packed_Byte'Size;
-- This is the type used to implement packed arrays where no alignment
-- is required. This includes the cases of 1,2,4 (where we use direct
-- masking operations), and all odd component sizes (where the clusters
diff --git a/gcc/ada/s-vaflop.ads b/gcc/ada/s-vaflop.ads
index 529e0ef8c55..018ae65eb7f 100644
--- a/gcc/ada/s-vaflop.ads
+++ b/gcc/ada/s-vaflop.ads
@@ -162,7 +162,7 @@ package System.Vax_Float_Operations is
-- These routines return a decimal C string image of their argument.
-- They are provided for implicit use by the debugger, in response to
-- the special encoding used for Vax floating-point types (see Exp_Dbug
- -- for details). They supersede the above Debug_Output_D/F/G routines
+ -- for details). They supercede the above Debug_Output_D/F/G routines
-- which didn't work properly with GDBTK.
procedure pd (Arg : D);
diff --git a/gcc/ada/s-valrea.adb b/gcc/ada/s-valrea.adb
index 7d93472a538..28f687e8ca2 100644
--- a/gcc/ada/s-valrea.adb
+++ b/gcc/ada/s-valrea.adb
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 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- --
@@ -81,6 +81,17 @@ package body System.Val_Real is
After_Point : Natural := 0;
-- Set to 1 after the point
+ Num_Saved_Zeroes : Natural := 0;
+ -- This counts zeroes after the decimal point. A non-zero value means
+ -- that this number of previously scanned digits are zero. if the end
+ -- of the number is reached, these zeroes are simply discarded, which
+ -- ensures that trailing zeroes after the point never affect the value
+ -- (which might otherwise happen as a result of rounding). With this
+ -- processing in place, we can ensure that, for example, we get the
+ -- same exact result from 1.0E+49 and 1.0000000E+49. This is not
+ -- necessarily required in a case like this where the result is not
+ -- a machine number, but it is certainly a desirable behavior.
+
procedure Scanf;
-- Scans integer literal value starting at current character position.
-- For each digit encountered, Uval is multiplied by 10.0, and the new
@@ -96,9 +107,36 @@ package body System.Val_Real is
begin
loop
Digit := Character'Pos (Str (P)) - Character'Pos ('0');
- Uval := Uval * 10.0 + Long_Long_Float (Digit);
P := P + 1;
- Scale := Scale - After_Point;
+
+ -- Save up trailing zeroes after the decimal point
+
+ if Digit = 0 and After_Point = 1 then
+ Num_Saved_Zeroes := Num_Saved_Zeroes + 1;
+
+ -- Here for a non-zero digit
+
+ else
+ -- First deal with any previously saved zeroes
+
+ if Num_Saved_Zeroes /= 0 then
+ while Num_Saved_Zeroes > Maxpow loop
+ Uval := Uval * Powten (Maxpow);
+ Num_Saved_Zeroes := Num_Saved_Zeroes - Maxpow;
+ Scale := Scale - Maxpow;
+ end loop;
+
+ Uval := Uval * Powten (Num_Saved_Zeroes);
+ Scale := Scale - Num_Saved_Zeroes;
+
+ Num_Saved_Zeroes := 0;
+ end if;
+
+ -- Accumulate new digit
+
+ Uval := Uval * 10.0 + Long_Long_Float (Digit);
+ Scale := Scale - After_Point;
+ end if;
-- Done if end of input field
@@ -197,16 +235,36 @@ package body System.Val_Real is
raise Constraint_Error;
end if;
- P := P + 1;
- Fdigit := Long_Long_Float (Digit);
+ -- Save up trailing zeroes after the decimal point
+
+ if Digit = 0 and After_Point = 1 then
+ Num_Saved_Zeroes := Num_Saved_Zeroes + 1;
+
+ -- Here for a non-zero digit
- if Fdigit >= Base then
- Bad_Base := True;
else
- Scale := Scale - After_Point;
- Uval := Uval * Base + Fdigit;
+ -- First deal with any previously saved zeroes
+
+ if Num_Saved_Zeroes /= 0 then
+ Uval := Uval * Base ** Num_Saved_Zeroes;
+ Scale := Scale - Num_Saved_Zeroes;
+ Num_Saved_Zeroes := 0;
+ end if;
+
+ -- Now accumulate the new digit
+
+ Fdigit := Long_Long_Float (Digit);
+
+ if Fdigit >= Base then
+ Bad_Base := True;
+ else
+ Scale := Scale - After_Point;
+ Uval := Uval * Base + Fdigit;
+ end if;
end if;
+ P := P + 1;
+
if P > Max then
raise Constraint_Error;
@@ -276,7 +334,6 @@ package body System.Val_Real is
-- For base 10, use power of ten table, repeatedly if necessary.
elsif Scale > 0 then
-
while Scale > Maxpow loop
Uval := Uval * Powten (Maxpow);
Scale := Scale - Maxpow;
@@ -287,7 +344,6 @@ package body System.Val_Real is
end if;
elsif Scale < 0 then
-
while (-Scale) > Maxpow loop
Uval := Uval / Powten (Maxpow);
Scale := Scale + Maxpow;
diff --git a/gcc/ada/s-valuti.adb b/gcc/ada/s-valuti.adb
index dede3366081..6101d1af92e 100644
--- a/gcc/ada/s-valuti.adb
+++ b/gcc/ada/s-valuti.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,7 +31,7 @@
-- --
------------------------------------------------------------------------------
-with GNAT.Case_Util; use GNAT.Case_Util;
+with System.Case_Util; use System.Case_Util;
package body System.Val_Util is
diff --git a/gcc/ada/s-veboop.adb b/gcc/ada/s-veboop.adb
new file mode 100644
index 00000000000..ddbb376a89a
--- /dev/null
+++ b/gcc/ada/s-veboop.adb
@@ -0,0 +1,121 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V E C T O R S . B O O L E A N _ O P E R A T I O N S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+package body System.Vectors.Boolean_Operations is
+
+ type Boolean_Array is array (Integer range <>) of Boolean;
+ pragma Assert (Boolean_Array'Component_Size = 8);
+ -- Unfortunately Boolean_Array'Component_Size is not a compile-time-known
+ -- value, so assume it is 8 in order to be able to determine True_Val at
+ -- compile time.
+
+ -- NOTE: The boolean literals must be qualified here to avoid visibility
+ -- anomalies when this package is compiled through Rtsfind, in a context
+ -- that includes a user-defined type derived from boolean.
+
+ True_Val : constant Vector := Standard.True'Enum_Rep
+ + Standard.True'Enum_Rep * 2**8
+ + Standard.True'Enum_Rep * 2**(8 * 2)
+ + Standard.True'Enum_Rep * 2**(8 * 3)
+ + Standard.True'Enum_Rep * 2**(8 * 4)
+ + Standard.True'Enum_Rep * 2**(8 * 5)
+ + Standard.True'Enum_Rep * 2**(8 * 6)
+ + Standard.True'Enum_Rep * 2**(8 * 7);
+ -- This constant represents the bits to be flipped to perform a logical
+ -- "not" on a vector of booleans, independent of the actual
+ -- representation of True.
+
+ -- The representations of (False, True) are assumed to be zero/one and
+ -- the maximum number of unpacked booleans per Vector is assumed to be 8.
+
+ pragma Assert (Standard.False'Enum_Rep = 0);
+ pragma Assert (Standard.True'Enum_Rep = 1);
+ pragma Assert (Vector'Size / Storage_Unit <= 8);
+
+ -- The reason we need to do these gymnastics is that no call to
+ -- Unchecked_Conversion can be made at the library level since this
+ -- unit is pure. Also a conversion from the array type to the Vector type
+ -- inside the body of "not" is inefficient because of alignment issues.
+
+ -----------
+ -- "not" --
+ -----------
+
+ function "not" (Item : Vectors.Vector) return Vectors.Vector is
+ begin
+ return Item xor True_Val;
+ end "not";
+
+ ----------
+ -- Nand --
+ ----------
+
+ function Nand (Left, Right : Boolean) return Boolean is
+ begin
+ return not (Left and Right);
+ end Nand;
+
+ function Nand (Left, Right : Vectors.Vector) return Vectors.Vector is
+ begin
+ return not (Left and Right);
+ end Nand;
+
+ ---------
+ -- Nor --
+ ---------
+
+ function Nor (Left, Right : Boolean) return Boolean is
+ begin
+ return not (Left or Right);
+ end Nor;
+
+ function Nor (Left, Right : Vectors.Vector) return Vectors.Vector is
+ begin
+ return not (Left or Right);
+ end Nor;
+
+ ----------
+ -- Nxor --
+ ----------
+
+ function Nxor (Left, Right : Boolean) return Boolean is
+ begin
+ return not (Left xor Right);
+ end Nxor;
+
+ function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector is
+ begin
+ return not (Left xor Right);
+ end Nxor;
+
+end System.Vectors.Boolean_Operations;
diff --git a/gcc/ada/s-veboop.ads b/gcc/ada/s-veboop.ads
new file mode 100644
index 00000000000..2c86527977e
--- /dev/null
+++ b/gcc/ada/s-veboop.ads
@@ -0,0 +1,68 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V E C T O R S . B O O L E A N _ O P E R A T I O N S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains functions for runtime operations on boolean vectors
+
+package System.Vectors.Boolean_Operations is
+pragma Pure (Boolean_Operations);
+
+ -- Although in general the boolean operations on arrays of booleans are
+ -- identical to operations on arrays of unsigned words of the same size,
+ -- for the "not" operator this is not the case as False is typically
+ -- represented by 0 and true by 1.
+
+ function "not" (Item : Vectors.Vector) return Vectors.Vector;
+
+ -- The three boolean operations "nand", "nor" and "nxor" are needed
+ -- for cases where the compiler moves boolean array operations into
+ -- the body of the loop that iterates over the array elements.
+
+ -- Note the following equivalences:
+ -- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
+ -- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
+ -- (not X) xor (not Y) = X xor Y
+ -- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
+
+ function Nand (Left, Right : Boolean) return Boolean;
+ function Nor (Left, Right : Boolean) return Boolean;
+ function Nxor (Left, Right : Boolean) return Boolean;
+
+ function Nand (Left, Right : Vectors.Vector) return Vectors.Vector;
+ function Nor (Left, Right : Vectors.Vector) return Vectors.Vector;
+ function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector;
+
+ pragma Inline_Always ("not");
+ pragma Inline_Always (Nand);
+ pragma Inline_Always (Nor);
+ pragma Inline_Always (Nxor);
+end System.Vectors.Boolean_Operations;
diff --git a/gcc/ada/s-vector.ads b/gcc/ada/s-vector.ads
new file mode 100644
index 00000000000..67d5cdb7716
--- /dev/null
+++ b/gcc/ada/s-vector.ads
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+-- --
+-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . V E C T O R S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package defines a datatype which is most efficient for performing
+-- logical operations on large arrays. See System.Generic_Vector_Operations.
+
+-- In the future this package may also define operations such as element-wise
+-- addition, subtraction, multiplication, minimum and maximum of vector-sized
+-- packed arrays of Unsigned_8, Unsigned_16 and Unsigned_32 values. These
+-- operations could be implemented as system intrinsics on platforms with
+-- direct processor support for them.
+
+package System.Vectors is
+pragma Pure (Vectors);
+
+ type Vector is mod 2**System.Word_Size;
+ for Vector'Alignment use Integer'Min
+ (Standard'Maximum_Alignment, System.Word_Size / System.Storage_Unit);
+ for Vector'Size use System.Word_Size;
+
+end System.Vectors;
diff --git a/gcc/ada/s-vercon.adb b/gcc/ada/s-vercon.adb
index 65f5854ca4b..bc658f69a44 100644
--- a/gcc/ada/s-vercon.adb
+++ b/gcc/ada/s-vercon.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -44,7 +44,8 @@ package body System.Version_Control is
is
S : Version_String;
D : Unsigned := V;
- H : array (Unsigned range 0 .. 15) of Character := "0123456789abcdef";
+ H : constant array (Unsigned range 0 .. 15) of Character :=
+ "0123456789abcdef";
begin
for J in reverse 1 .. 8 loop
diff --git a/gcc/ada/s-vmexta.adb b/gcc/ada/s-vmexta.adb
index 2d144674130..b61955fb5d3 100644
--- a/gcc/ada/s-vmexta.adb
+++ b/gcc/ada/s-vmexta.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,8 +33,8 @@
-- This is an Alpha/VMS package.
-with GNAT.HTable;
-pragma Elaborate_All (GNAT.HTable);
+with System.HTable;
+pragma Elaborate_All (System.HTable);
package body System.VMS_Exception_Table is
@@ -64,7 +64,7 @@ package body System.VMS_Exception_Table is
function Hash (F : Natural) return HTable_Headers;
function Get_Key (T : Exception_Code_Data_Ptr) return Natural;
- package Exception_Code_HTable is new GNAT.HTable.Static_HTable (
+ package Exception_Code_HTable is new System.HTable.Static_HTable (
Header_Num => HTable_Headers,
Element => Exception_Code_Data,
Elmt_Ptr => Exception_Code_Data_Ptr,
@@ -128,11 +128,10 @@ package body System.VMS_Exception_Table is
----------------------------
procedure Register_VMS_Exception (Code : Integer) is
+ Excode : constant Integer := (Code / 8) * 8;
-- Mask off lower 3 bits which are the severity
- Excode : Integer := (Code / 8) * 8;
begin
-
-- This allocates an empty exception that gets filled in by
-- __gnat_error_handler when the exception is raised. Allocating
-- it here prevents having to allocate it each time the exception
@@ -142,7 +141,14 @@ package body System.VMS_Exception_Table is
Exception_Code_HTable.Set
(new Exception_Code_Data'
(Excode,
- new Exception_Data'(False, 'V', 0, null, null, 0),
+ new Exception_Data'
+ (Not_Handled_By_Others => False,
+ Lang => 'V',
+ Name_Length => 0,
+ Full_Name => null,
+ HTable_Ptr => null,
+ Import_Code => 0,
+ Raise_Hook => null),
null));
end if;
end Register_VMS_Exception;
diff --git a/gcc/ada/s-wchcnv.ads b/gcc/ada/s-wchcnv.ads
index 38ca113a6b2..65180ca2a57 100644
--- a/gcc/ada/s-wchcnv.ads
+++ b/gcc/ada/s-wchcnv.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 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,6 +35,9 @@
-- sequences of Character and Wide_Character. All access to wide character
-- sequences is isolated in this unit.
+-- This unit may be used directly from an application program by providing
+-- an appropriate WITH, and the interface can be expected to remain stable.
+
with System.WCh_Con;
package System.WCh_Cnv is
diff --git a/gcc/ada/s-wchcon.ads b/gcc/ada/s-wchcon.ads
index e0665a5d22a..3c08176edf6 100644
--- a/gcc/ada/s-wchcon.ads
+++ b/gcc/ada/s-wchcon.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1998 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,6 +35,9 @@
-- wide characters in string and character constants. This is needed both
-- at compile time and at runtime (for the wide character runtime routines)
+-- This unit may be used directly from an application program by providing
+-- an appropriate WITH, and the interface can be expected to remain stable.
+
package System.WCh_Con is
pragma Pure (WCh_Con);
diff --git a/gcc/ada/s-widcha.adb b/gcc/ada/s-widcha.adb
index 21e65512541..5c407901385 100644
--- a/gcc/ada/s-widcha.adb
+++ b/gcc/ada/s-widcha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -45,7 +45,7 @@ package body System.Wid_Char is
for C in Lo .. Hi loop
declare
- S : String := Character'Image (C);
+ S : constant String := Character'Image (C);
begin
W := Natural'Max (W, S'Length);
diff --git a/gcc/ada/s-wwdcha.adb b/gcc/ada/s-wwdcha.adb
index e756b9d3610..18928fdf848 100644
--- a/gcc/ada/s-wwdcha.adb
+++ b/gcc/ada/s-wwdcha.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992,1993,1994 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -45,7 +45,7 @@ package body System.WWd_Char is
for C in Lo .. Hi loop
declare
- S : Wide_String := Character'Wide_Image (C);
+ S : constant Wide_String := Character'Wide_Image (C);
begin
W := Natural'Max (W, S'Length);
diff --git a/gcc/ada/s-wwdwch.adb b/gcc/ada/s-wwdwch.adb
index b794cd5e68b..eb9d2fb6ac4 100644
--- a/gcc/ada/s-wwdwch.adb
+++ b/gcc/ada/s-wwdwch.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2000, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -61,7 +61,8 @@ package body System.Wwd_WChar is
else
declare
- S : Wide_String := Character'Wide_Image (Character'Val (P));
+ S : constant Wide_String :=
+ Character'Wide_Image (Character'Val (P));
begin
W := Natural'Max (W, S'Length);
diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads
index 7ff80e9c5cd..1551296907e 100644
--- a/gcc/ada/scans.ads
+++ b/gcc/ada/scans.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,7 +31,9 @@
-- --
------------------------------------------------------------------------------
-with Types; use Types;
+with Types; use Types;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
package Scans is
@@ -62,7 +64,7 @@ package Scans is
Tok_Operator_Symbol, -- op symbol Name, Literal, Lit_Or_Name, Desig
- Tok_Identifier, -- identifier Name, Lit_Or_Name, Desig
+ Tok_Identifier, -- identifer Name, Lit_Or_Name, Desig
Tok_Double_Asterisk, -- **
@@ -192,6 +194,10 @@ package Scans is
Tok_Extends,
Tok_External,
+ -- The following two entries are used by the preprocessor
+ Tok_End_Of_Line,
+ Tok_Special,
+
No_Token);
-- No_Token is used for initializing Token values to indicate that
-- no value has been set yet.
@@ -378,6 +384,26 @@ package Scans is
-- initialized to True, and then reset when the version number is found.
-- We do things this way to minimize the impact on comment scanning.
+ Character_Code : Char_Code;
+ -- Valid only when Token is Tok_Char_Literal.
+
+ Real_Literal_Value : Ureal;
+ -- Valid only when Token is Tok_Real_Literal
+
+ Int_Literal_Value : Uint;
+ -- Valid only when Token = Tok_Integer_Literal;
+
+ String_Literal_Id : String_Id;
+ -- Id for currently scanned string value.
+ -- Valid only when Token = Tok_String_Literal or Tok_Operator_Symbol.
+
+ Wide_Character_Found : Boolean := False;
+ -- Set True if wide character found.
+ -- Valid only when Token = Tok_String_Literal.
+
+ Special_Character : Character;
+ -- Valid only when Token = Tok_Special
+
--------------------------------------------------------
-- Procedures for Saving and Restoring the Scan State --
--------------------------------------------------------
diff --git a/gcc/ada/scn-nlit.adb b/gcc/ada/scn-nlit.adb
deleted file mode 100644
index 0f69a9905ca..00000000000
--- a/gcc/ada/scn-nlit.adb
+++ /dev/null
@@ -1,369 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S C N . N L I T --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Uintp; use Uintp;
-with Urealp; use Urealp;
-
-separate (Scn)
-procedure Nlit is
-
- C : Character;
- -- Current source program character
-
- Base_Char : Character;
- -- Either # or : (character at start of based number)
-
- Base : Int;
- -- Value of base
-
- UI_Base : Uint;
- -- Value of base in Uint format
-
- UI_Int_Value : Uint;
- -- Value of integer scanned by Scan_Integer in Uint format
-
- UI_Num_Value : Uint;
- -- Value of integer in numeric value being scanned
-
- Scale : Int;
- -- Scale value for real literal
-
- UI_Scale : Uint;
- -- Scale in Uint format
-
- Exponent_Is_Negative : Boolean;
- -- Set true for negative exponent
-
- Extended_Digit_Value : Int;
- -- Extended digit value
-
- Point_Scanned : Boolean;
- -- Flag for decimal point scanned in numeric literal
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Error_Digit_Expected;
- -- Signal error of bad digit, Scan_Ptr points to the location at which
- -- the digit was expected on input, and is unchanged on return.
-
- procedure Scan_Integer;
- -- Procedure to scan integer literal. On entry, Scan_Ptr points to a
- -- digit, on exit Scan_Ptr points past the last character of the integer.
- -- For each digit encountered, UI_Int_Value is multiplied by 10, and the
- -- value of the digit added to the result. In addition, the value in
- -- Scale is decremented by one for each actual digit scanned.
-
- --------------------------
- -- Error_Digit_Expected --
- --------------------------
-
- procedure Error_Digit_Expected is
- begin
- Error_Msg_S ("digit expected");
- end Error_Digit_Expected;
-
- -------------------
- -- Scan_Integer --
- -------------------
-
- procedure Scan_Integer is
- C : Character;
- -- Next character scanned
-
- begin
- C := Source (Scan_Ptr);
-
- -- Loop through digits (allowing underlines)
-
- loop
- Accumulate_Checksum (C);
- UI_Int_Value :=
- UI_Int_Value * 10 + (Character'Pos (C) - Character'Pos ('0'));
- Scan_Ptr := Scan_Ptr + 1;
- Scale := Scale - 1;
- C := Source (Scan_Ptr);
-
- if C = '_' then
- Accumulate_Checksum ('_');
-
- loop
- Scan_Ptr := Scan_Ptr + 1;
- C := Source (Scan_Ptr);
- exit when C /= '_';
- Error_No_Double_Underline;
- end loop;
-
- if C not in '0' .. '9' then
- Error_Digit_Expected;
- exit;
- end if;
-
- else
- exit when C not in '0' .. '9';
- end if;
- end loop;
-
- end Scan_Integer;
-
-----------------------------------
--- Start of Processing for Nlit --
-----------------------------------
-
-begin
- Base := 10;
- UI_Base := Uint_10;
- UI_Int_Value := Uint_0;
- Scale := 0;
- Scan_Integer;
- Scale := 0;
- Point_Scanned := False;
- UI_Num_Value := UI_Int_Value;
-
- -- Various possibilities now for continuing the literal are
- -- period, E/e (for exponent), or :/# (for based literal).
-
- Scale := 0;
- C := Source (Scan_Ptr);
-
- if C = '.' then
-
- -- Scan out point, but do not scan past .. which is a range sequence,
- -- and must not be eaten up scanning a numeric literal.
-
- while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop
- Accumulate_Checksum ('.');
-
- if Point_Scanned then
- Error_Msg_S ("duplicate point ignored");
- end if;
-
- Point_Scanned := True;
- Scan_Ptr := Scan_Ptr + 1;
- C := Source (Scan_Ptr);
-
- if C not in '0' .. '9' then
- Error_Msg ("real literal cannot end with point", Scan_Ptr - 1);
- else
- Scan_Integer;
- UI_Num_Value := UI_Int_Value;
- end if;
- end loop;
-
- -- Based literal case. The base is the value we already scanned.
- -- In the case of colon, we insist that the following character
- -- is indeed an extended digit or a period. This catches a number
- -- of common errors, as well as catching the well known tricky
- -- bug otherwise arising from "x : integer range 1 .. 10:= 6;"
-
- elsif C = '#'
- or else (C = ':' and then
- (Source (Scan_Ptr + 1) = '.'
- or else
- Source (Scan_Ptr + 1) in '0' .. '9'
- or else
- Source (Scan_Ptr + 1) in 'A' .. 'Z'
- or else
- Source (Scan_Ptr + 1) in 'a' .. 'z'))
- then
- Accumulate_Checksum (C);
- Base_Char := C;
- UI_Base := UI_Int_Value;
-
- if UI_Base < 2 or else UI_Base > 16 then
- Error_Msg_SC ("base not 2-16");
- UI_Base := Uint_16;
- end if;
-
- Base := UI_To_Int (UI_Base);
- Scan_Ptr := Scan_Ptr + 1;
-
- -- Scan out extended integer [. integer]
-
- C := Source (Scan_Ptr);
- UI_Int_Value := Uint_0;
- Scale := 0;
-
- loop
- if C in '0' .. '9' then
- Accumulate_Checksum (C);
- Extended_Digit_Value :=
- Int'(Character'Pos (C)) - Int'(Character'Pos ('0'));
-
- elsif C in 'A' .. 'F' then
- Accumulate_Checksum (Character'Val (Character'Pos (C) + 32));
- Extended_Digit_Value :=
- Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10;
-
- elsif C in 'a' .. 'f' then
- Accumulate_Checksum (C);
- Extended_Digit_Value :=
- Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10;
-
- else
- Error_Msg_S ("extended digit expected");
- exit;
- end if;
-
- if Extended_Digit_Value >= Base then
- Error_Msg_S ("digit >= base");
- end if;
-
- UI_Int_Value := UI_Int_Value * UI_Base + Extended_Digit_Value;
- Scale := Scale - 1;
- Scan_Ptr := Scan_Ptr + 1;
- C := Source (Scan_Ptr);
-
- if C = '_' then
- loop
- Accumulate_Checksum ('_');
- Scan_Ptr := Scan_Ptr + 1;
- C := Source (Scan_Ptr);
- exit when C /= '_';
- Error_No_Double_Underline;
- end loop;
-
- elsif C = '.' then
- Accumulate_Checksum ('.');
-
- if Point_Scanned then
- Error_Msg_S ("duplicate point ignored");
- end if;
-
- Scan_Ptr := Scan_Ptr + 1;
- C := Source (Scan_Ptr);
- Point_Scanned := True;
- Scale := 0;
-
- elsif C = Base_Char then
- Accumulate_Checksum (C);
- Scan_Ptr := Scan_Ptr + 1;
- exit;
-
- elsif C = '#' or else C = ':' then
- Error_Msg_S ("based number delimiters must match");
- Scan_Ptr := Scan_Ptr + 1;
- exit;
-
- elsif not Identifier_Char (C) then
- if Base_Char = '#' then
- Error_Msg_S ("missing '#");
- else
- Error_Msg_S ("missing ':");
- end if;
-
- exit;
- end if;
-
- end loop;
-
- UI_Num_Value := UI_Int_Value;
- end if;
-
- -- Scan out exponent
-
- if not Point_Scanned then
- Scale := 0;
- UI_Scale := Uint_0;
- else
- UI_Scale := UI_From_Int (Scale);
- end if;
-
- if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then
- Accumulate_Checksum ('e');
- Scan_Ptr := Scan_Ptr + 1;
- Exponent_Is_Negative := False;
-
- if Source (Scan_Ptr) = '+' then
- Accumulate_Checksum ('+');
- Scan_Ptr := Scan_Ptr + 1;
-
- elsif Source (Scan_Ptr) = '-' then
- Accumulate_Checksum ('-');
-
- if not Point_Scanned then
- Error_Msg_S ("negative exponent not allowed for integer literal");
- else
- Exponent_Is_Negative := True;
- end if;
-
- Scan_Ptr := Scan_Ptr + 1;
- end if;
-
- UI_Int_Value := Uint_0;
-
- if Source (Scan_Ptr) in '0' .. '9' then
- Scan_Integer;
- else
- Error_Digit_Expected;
- end if;
-
- if Exponent_Is_Negative then
- UI_Scale := UI_Scale - UI_Int_Value;
- else
- UI_Scale := UI_Scale + UI_Int_Value;
- end if;
- end if;
-
- -- Case of real literal to be returned
-
- if Point_Scanned then
- Token := Tok_Real_Literal;
- Token_Node := New_Node (N_Real_Literal, Token_Ptr);
- Set_Realval (Token_Node,
- UR_From_Components (
- Num => UI_Num_Value,
- Den => -UI_Scale,
- Rbase => Base));
-
- -- Case of integer literal to be returned
-
- else
- Token := Tok_Integer_Literal;
- Token_Node := New_Node (N_Integer_Literal, Token_Ptr);
-
- if UI_Scale = 0 then
- Set_Intval (Token_Node, UI_Num_Value);
-
- -- Avoid doing possibly expensive calculations in cases like
- -- parsing 163E800_000# when semantics will not be done anyway.
- -- This is especially useful when parsing garbled input.
-
- elsif Operating_Mode /= Check_Syntax
- and then (Serious_Errors_Detected = 0 or else Try_Semantics)
- then
- Set_Intval (Token_Node, UI_Num_Value * UI_Base ** UI_Scale);
-
- else
- Set_Intval (Token_Node, No_Uint);
- end if;
-
- end if;
-
- return;
-
-end Nlit;
diff --git a/gcc/ada/scn-slit.adb b/gcc/ada/scn-slit.adb
deleted file mode 100644
index e1ded875893..00000000000
--- a/gcc/ada/scn-slit.adb
+++ /dev/null
@@ -1,371 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S C N . S L I T --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Stringt; use Stringt;
-
-separate (Scn)
-procedure Slit is
-
- Delimiter : Character;
- -- Delimiter (first character of string)
-
- C : Character;
- -- Current source program character
-
- Code : Char_Code;
- -- Current character code value
-
- Err : Boolean;
- -- Error flag for Scan_Wide call
-
- String_Literal_Id : String_Id;
- -- Id for currently scanned string value
-
- Wide_Character_Found : Boolean := False;
- -- Set True if wide character found
-
- procedure Error_Bad_String_Char;
- -- Signal bad character in string/character literal. On entry Scan_Ptr
- -- points to the improper character encountered during the scan. Scan_Ptr
- -- is not modified, so it still points to the bad character on return.
-
- procedure Error_Unterminated_String;
- -- Procedure called if a line terminator character is encountered during
- -- scanning a string, meaning that the string is not properly terminated.
-
- procedure Set_String;
- -- Procedure used to distinguish between string and operator symbol.
- -- On entry the string has been scanned out, and its characters start
- -- at Token_Ptr and end one character before Scan_Ptr. On exit Token
- -- is set to Tok_String_Literal or Tok_Operator_Symbol as appropriate,
- -- and Token_Node is appropriately initialized. In addition, in the
- -- operator symbol case, Token_Name is appropriately set.
-
- ---------------------------
- -- Error_Bad_String_Char --
- ---------------------------
-
- procedure Error_Bad_String_Char is
- C : constant Character := Source (Scan_Ptr);
-
- begin
- if C = HT then
- Error_Msg_S ("horizontal tab not allowed in string");
-
- elsif C = VT or else C = FF then
- Error_Msg_S ("format effector not allowed in string");
-
- elsif C in Upper_Half_Character then
- Error_Msg_S ("(Ada 83) upper half character not allowed");
-
- else
- Error_Msg_S ("control character not allowed in string");
- end if;
- end Error_Bad_String_Char;
-
- -------------------------------
- -- Error_Unterminated_String --
- -------------------------------
-
- procedure Error_Unterminated_String is
- begin
- -- An interesting little refinement. Consider the following examples:
-
- -- A := "this is an unterminated string;
- -- A := "this is an unterminated string &
- -- P(A, "this is a parameter that didn't get terminated);
-
- -- We fiddle a little to do slightly better placement in these cases
- -- also if there is white space at the end of the line we place the
- -- flag at the start of this white space, not at the end. Note that
- -- we only have to test for blanks, since tabs aren't allowed in
- -- strings in the first place and would have caused an error message.
-
- -- Two more cases that we treat specially are:
-
- -- A := "this string uses the wrong terminator'
- -- A := "this string uses the wrong terminator' &
-
- -- In these cases we give a different error message as well
-
- -- We actually reposition the scan pointer to the point where we
- -- place the flag in these cases, since it seems a better bet on
- -- the original intention.
-
- while Source (Scan_Ptr - 1) = ' '
- or else Source (Scan_Ptr - 1) = '&'
- loop
- Scan_Ptr := Scan_Ptr - 1;
- Unstore_String_Char;
- end loop;
-
- -- Check for case of incorrect string terminator, but single quote is
- -- not considered incorrect if the opening terminator misused a single
- -- quote (error message already given).
-
- if Delimiter /= '''
- and then Source (Scan_Ptr - 1) = '''
- then
- Unstore_String_Char;
- Error_Msg ("incorrect string terminator character", Scan_Ptr - 1);
- return;
- end if;
-
- if Source (Scan_Ptr - 1) = ';' then
- Scan_Ptr := Scan_Ptr - 1;
- Unstore_String_Char;
-
- if Source (Scan_Ptr - 1) = ')' then
- Scan_Ptr := Scan_Ptr - 1;
- Unstore_String_Char;
- end if;
- end if;
-
- Error_Msg_S ("missing string quote");
- end Error_Unterminated_String;
-
- ----------------
- -- Set_String --
- ----------------
-
- procedure Set_String is
- Slen : Int := Int (Scan_Ptr - Token_Ptr - 2);
- C1 : Character;
- C2 : Character;
- C3 : Character;
-
- begin
- -- Token_Name is currently set to Error_Name. The following section of
- -- code resets Token_Name to the proper Name_Op_xx value if the string
- -- is a valid operator symbol, otherwise it is left set to Error_Name.
-
- if Slen = 1 then
- C1 := Source (Token_Ptr + 1);
-
- case C1 is
- when '=' =>
- Token_Name := Name_Op_Eq;
-
- when '>' =>
- Token_Name := Name_Op_Gt;
-
- when '<' =>
- Token_Name := Name_Op_Lt;
-
- when '+' =>
- Token_Name := Name_Op_Add;
-
- when '-' =>
- Token_Name := Name_Op_Subtract;
-
- when '&' =>
- Token_Name := Name_Op_Concat;
-
- when '*' =>
- Token_Name := Name_Op_Multiply;
-
- when '/' =>
- Token_Name := Name_Op_Divide;
-
- when others =>
- null;
- end case;
-
- elsif Slen = 2 then
- C1 := Source (Token_Ptr + 1);
- C2 := Source (Token_Ptr + 2);
-
- if C1 = '*' and then C2 = '*' then
- Token_Name := Name_Op_Expon;
-
- elsif C2 = '=' then
-
- if C1 = '/' then
- Token_Name := Name_Op_Ne;
- elsif C1 = '<' then
- Token_Name := Name_Op_Le;
- elsif C1 = '>' then
- Token_Name := Name_Op_Ge;
- end if;
-
- elsif (C1 = 'O' or else C1 = 'o') and then -- OR
- (C2 = 'R' or else C2 = 'r')
- then
- Token_Name := Name_Op_Or;
- end if;
-
- elsif Slen = 3 then
- C1 := Source (Token_Ptr + 1);
- C2 := Source (Token_Ptr + 2);
- C3 := Source (Token_Ptr + 3);
-
- if (C1 = 'A' or else C1 = 'a') and then -- AND
- (C2 = 'N' or else C2 = 'n') and then
- (C3 = 'D' or else C3 = 'd')
- then
- Token_Name := Name_Op_And;
-
- elsif (C1 = 'A' or else C1 = 'a') and then -- ABS
- (C2 = 'B' or else C2 = 'b') and then
- (C3 = 'S' or else C3 = 's')
- then
- Token_Name := Name_Op_Abs;
-
- elsif (C1 = 'M' or else C1 = 'm') and then -- MOD
- (C2 = 'O' or else C2 = 'o') and then
- (C3 = 'D' or else C3 = 'd')
- then
- Token_Name := Name_Op_Mod;
-
- elsif (C1 = 'N' or else C1 = 'n') and then -- NOT
- (C2 = 'O' or else C2 = 'o') and then
- (C3 = 'T' or else C3 = 't')
- then
- Token_Name := Name_Op_Not;
-
- elsif (C1 = 'R' or else C1 = 'r') and then -- REM
- (C2 = 'E' or else C2 = 'e') and then
- (C3 = 'M' or else C3 = 'm')
- then
- Token_Name := Name_Op_Rem;
-
- elsif (C1 = 'X' or else C1 = 'x') and then -- XOR
- (C2 = 'O' or else C2 = 'o') and then
- (C3 = 'R' or else C3 = 'r')
- then
- Token_Name := Name_Op_Xor;
- end if;
-
- end if;
-
- -- If it is an operator symbol, then Token_Name is set. If it is some
- -- other string value, then Token_Name still contains Error_Name.
-
- if Token_Name = Error_Name then
- Token := Tok_String_Literal;
- Token_Node := New_Node (N_String_Literal, Token_Ptr);
- Set_Has_Wide_Character (Token_Node, Wide_Character_Found);
-
- else
- Token := Tok_Operator_Symbol;
- Token_Node := New_Node (N_Operator_Symbol, Token_Ptr);
- Set_Chars (Token_Node, Token_Name);
- end if;
-
- Set_Strval (Token_Node, String_Literal_Id);
-
- end Set_String;
-
-----------
--- Slit --
-----------
-
-begin
- -- On entry, Scan_Ptr points to the opening character of the string which
- -- is either a percent, double quote, or apostrophe (single quote). The
- -- latter case is an error detected by the character literal circuit.
-
- Delimiter := Source (Scan_Ptr);
- Accumulate_Checksum (Delimiter);
- Start_String;
- Scan_Ptr := Scan_Ptr + 1;
-
- -- Loop to scan out characters of string literal
-
- loop
- C := Source (Scan_Ptr);
-
- if C = Delimiter then
- Accumulate_Checksum (C);
- Scan_Ptr := Scan_Ptr + 1;
- exit when Source (Scan_Ptr) /= Delimiter;
- Code := Get_Char_Code (C);
- Accumulate_Checksum (C);
- Scan_Ptr := Scan_Ptr + 1;
-
- else
- if C = '"' and then Delimiter = '%' then
- Error_Msg_S ("quote not allowed in percent delimited string");
- Code := Get_Char_Code (C);
- Scan_Ptr := Scan_Ptr + 1;
-
- elsif (C = ESC
- and then
- Wide_Character_Encoding_Method in WC_ESC_Encoding_Method)
- or else
- (C in Upper_Half_Character
- and then
- Upper_Half_Encoding)
- or else
- (C = '['
- and then
- Source (Scan_Ptr + 1) = '"'
- and then
- Identifier_Char (Source (Scan_Ptr + 2)))
- then
- Scan_Wide (Source, Scan_Ptr, Code, Err);
- Accumulate_Checksum (Code);
-
- if Err then
- Error_Illegal_Wide_Character;
- Code := Get_Char_Code (' ');
- end if;
-
- else
- Accumulate_Checksum (C);
-
- if C not in Graphic_Character then
- if C in Line_Terminator then
- Error_Unterminated_String;
- exit;
-
- elsif C in Upper_Half_Character then
- if Ada_83 then
- Error_Bad_String_Char;
- end if;
-
- else
- Error_Bad_String_Char;
- end if;
- end if;
-
- Code := Get_Char_Code (C);
- Scan_Ptr := Scan_Ptr + 1;
- end if;
- end if;
-
- Store_String_Char (Code);
-
- if not In_Character_Range (Code) then
- Wide_Character_Found := True;
- end if;
- end loop;
-
- String_Literal_Id := End_String;
- Set_String;
- return;
-
-end Slit;
diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb
index cc793d59d30..91908d3667d 100644
--- a/gcc/ada/scn.adb
+++ b/gcc/ada/scn.adb
@@ -26,56 +26,22 @@
with Atree; use Atree;
with Csets; use Csets;
-with Errout; use Errout;
-with Hostparm; use Hostparm;
+with Hostparm;
with Namet; use Namet;
with Opt; use Opt;
with Scans; use Scans;
-with Sinput; use Sinput;
with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Style;
-with Widechar; use Widechar;
-
-with System.CRC32;
-with System.WCh_Con; use System.WCh_Con;
+with Sinput; use Sinput;
package body Scn is
use ASCII;
- -- Make control characters visible
Used_As_Identifier : array (Token_Type) of Boolean;
-- Flags set True if a given keyword is used as an identifier (used to
-- make sure that we only post an error message for incorrect use of a
-- keyword as an identifier once for a given keyword).
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Accumulate_Checksum (C : Character);
- pragma Inline (Accumulate_Checksum);
- -- This routine accumulates the checksum given character C. During the
- -- scanning of a source file, this routine is called with every character
- -- in the source, excluding blanks, and all control characters (except
- -- that ESC is included in the checksum). Upper case letters not in string
- -- literals are folded by the caller. See Sinput spec for the documentation
- -- of the checksum algorithm. Note: checksum values are only used if we
- -- generate code, so it is not necessary to worry about making the right
- -- sequence of calls in any error situation.
-
- procedure Accumulate_Checksum (C : Char_Code);
- pragma Inline (Accumulate_Checksum);
- -- This version is identical, except that the argument, C, is a character
- -- code value instead of a character. This is used when wide characters
- -- are scanned. We use the character code rather than the ASCII characters
- -- so that the checksum is independent of wide character encoding method.
-
- procedure Initialize_Checksum;
- pragma Inline (Initialize_Checksum);
- -- Initialize checksum value
-
procedure Check_End_Of_Line;
-- Called when end of line encountered. Checks that line is not
-- too long, and that other style checks for the end of line are met.
@@ -85,67 +51,47 @@ package body Scn is
-- header with a proper license statement. Returns GPL, Unrestricted,
-- or Modified_GPL depending on header. If none of these, returns Unknown.
- function Double_Char_Token (C : Character) return Boolean;
- -- This function is used for double character tokens like := or <>. It
- -- checks if the character following Source (Scan_Ptr) is C, and if so
- -- bumps Scan_Ptr past the pair of characters and returns True. A space
- -- between the two characters is also recognized with an appropriate
- -- error message being issued. If C is not present, False is returned.
- -- Note that Double_Char_Token can only be used for tokens defined in
- -- the Ada syntax (it's use for error cases like && is not appropriate
- -- since we do not want a junk message for a case like &-space-&).
-
- procedure Error_Illegal_Character;
- -- Give illegal character error, Scan_Ptr points to character. On return,
- -- Scan_Ptr is bumped past the illegal character.
-
- procedure Error_Illegal_Wide_Character;
- -- Give illegal wide character message. On return, Scan_Ptr is bumped
- -- past the illegal character, which may still leave us pointing to
- -- junk, not much we can do if the escape sequence is messed up!
-
procedure Error_Long_Line;
-- Signal error of excessively long line
- procedure Error_No_Double_Underline;
- -- Signal error of double underline character
-
- procedure Nlit;
- -- This is the procedure for scanning out numeric literals. On entry,
- -- Scan_Ptr points to the digit that starts the numeric literal (the
- -- checksum for this character has not been accumulated yet). On return
- -- Scan_Ptr points past the last character of the numeric literal, Token
- -- and Token_Node are set appropriately, and the checksum is updated.
-
- function Set_Start_Column return Column_Number;
- -- This routine is called with Scan_Ptr pointing to the first character
- -- of a line. On exit, Scan_Ptr is advanced to the first non-blank
- -- character of this line (or to the terminating format effector if the
- -- line contains no non-blank characters), and the returned result is the
- -- column number of this non-blank character (zero origin), which is the
- -- value to be stored in the Start_Column scan variable.
-
- procedure Slit;
- -- This is the procedure for scanning out string literals. On entry,
- -- Scan_Ptr points to the opening string quote (the checksum for this
- -- character has not been accumulated yet). On return Scan_Ptr points
- -- past the closing quote of the string literal, Token and Token_Node
- -- are set appropriately, and the checksum is upated.
-
- -------------------------
- -- Accumulate_Checksum --
- -------------------------
-
- procedure Accumulate_Checksum (C : Character) is
- begin
- System.CRC32.Update (System.CRC32.CRC32 (Checksum), C);
- end Accumulate_Checksum;
+ ---------------
+ -- Post_Scan --
+ ---------------
- procedure Accumulate_Checksum (C : Char_Code) is
+ procedure Post_Scan is
begin
- Accumulate_Checksum (Character'Val (C / 256));
- Accumulate_Checksum (Character'Val (C mod 256));
- end Accumulate_Checksum;
+ case Token is
+ when Tok_Char_Literal =>
+ Token_Node := New_Node (N_Character_Literal, Token_Ptr);
+ Set_Char_Literal_Value (Token_Node, Character_Code);
+ Set_Chars (Token_Node, Token_Name);
+
+ when Tok_Identifier =>
+ Token_Node := New_Node (N_Identifier, Token_Ptr);
+ Set_Chars (Token_Node, Token_Name);
+
+ when Tok_Real_Literal =>
+ Token_Node := New_Node (N_Real_Literal, Token_Ptr);
+ Set_Realval (Token_Node, Real_Literal_Value);
+
+ when Tok_Integer_Literal =>
+ Token_Node := New_Node (N_Integer_Literal, Token_Ptr);
+ Set_Intval (Token_Node, Int_Literal_Value);
+
+ when Tok_String_Literal =>
+ Token_Node := New_Node (N_String_Literal, Token_Ptr);
+ Set_Has_Wide_Character (Token_Node, Wide_Character_Found);
+ Set_Strval (Token_Node, String_Literal_Id);
+
+ when Tok_Operator_Symbol =>
+ Token_Node := New_Node (N_Operator_Symbol, Token_Ptr);
+ Set_Chars (Token_Node, Token_Name);
+ Set_Strval (Token_Node, String_Literal_Id);
+
+ when others =>
+ null;
+ end case;
+ end Post_Scan;
-----------------------
-- Check_End_Of_Line --
@@ -275,7 +221,7 @@ package body Scn is
if Physical then
Current_Line_Start := Scan_Ptr;
- Start_Column := Set_Start_Column;
+ Start_Column := Scanner.Set_Start_Column;
First_Non_Blank_Location := Scan_Ptr;
end if;
end;
@@ -288,61 +234,9 @@ package body Scn is
function Determine_Token_Casing return Casing_Type is
begin
- return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1));
+ return Scanner.Determine_Token_Casing;
end Determine_Token_Casing;
- -----------------------
- -- Double_Char_Token --
- -----------------------
-
- function Double_Char_Token (C : Character) return Boolean is
- begin
- if Source (Scan_Ptr + 1) = C then
- Accumulate_Checksum (C);
- Scan_Ptr := Scan_Ptr + 2;
- return True;
-
- elsif Source (Scan_Ptr + 1) = ' '
- and then Source (Scan_Ptr + 2) = C
- then
- Scan_Ptr := Scan_Ptr + 1;
- Error_Msg_S ("no space allowed here");
- Scan_Ptr := Scan_Ptr + 2;
- return True;
-
- else
- return False;
- end if;
- end Double_Char_Token;
-
- -----------------------------
- -- Error_Illegal_Character --
- -----------------------------
-
- procedure Error_Illegal_Character is
- begin
- Error_Msg_S ("illegal character");
- Scan_Ptr := Scan_Ptr + 1;
- end Error_Illegal_Character;
-
- ----------------------------------
- -- Error_Illegal_Wide_Character --
- ----------------------------------
-
- procedure Error_Illegal_Wide_Character is
- begin
- if OpenVMS then
- Error_Msg_S
- ("illegal wide character, check " &
- "'/'W'I'D'E'_'C'H'A'R'A'C'T'E'R'_'E'N'C'O'D'I'N'G qualifer");
- else
- Error_Msg_S
- ("illegal wide character, check -gnatW switch");
- end if;
-
- Scan_Ptr := Scan_Ptr + 1;
- end Error_Illegal_Wide_Character;
-
---------------------
-- Error_Long_Line --
---------------------
@@ -354,24 +248,6 @@ package body Scn is
Current_Line_Start + Hostparm.Max_Line_Length);
end Error_Long_Line;
- -------------------------------
- -- Error_No_Double_Underline --
- -------------------------------
-
- procedure Error_No_Double_Underline is
- begin
- Error_Msg_S ("two consecutive underlines not permitted");
- end Error_No_Double_Underline;
-
- -------------------------
- -- Initialize_Checksum --
- -------------------------
-
- procedure Initialize_Checksum is
- begin
- System.CRC32.Initialize (System.CRC32.CRC32 (Checksum));
- end Initialize_Checksum;
-
------------------------
-- Initialize_Scanner --
------------------------
@@ -383,95 +259,7 @@ package body Scn is
GNAT_Hedr : constant Text_Buffer (1 .. 78) := (others => '-');
begin
- -- Set up Token_Type values in Names Table entries for reserved keywords
- -- We use the Pos value of the Token_Type value. Note we are relying on
- -- the fact that Token_Type'Val (0) is not a reserved word!
-
- Set_Name_Table_Byte (Name_Abort, Token_Type'Pos (Tok_Abort));
- Set_Name_Table_Byte (Name_Abs, Token_Type'Pos (Tok_Abs));
- Set_Name_Table_Byte (Name_Abstract, Token_Type'Pos (Tok_Abstract));
- Set_Name_Table_Byte (Name_Accept, Token_Type'Pos (Tok_Accept));
- Set_Name_Table_Byte (Name_Access, Token_Type'Pos (Tok_Access));
- Set_Name_Table_Byte (Name_And, Token_Type'Pos (Tok_And));
- Set_Name_Table_Byte (Name_Aliased, Token_Type'Pos (Tok_Aliased));
- Set_Name_Table_Byte (Name_All, Token_Type'Pos (Tok_All));
- Set_Name_Table_Byte (Name_Array, Token_Type'Pos (Tok_Array));
- Set_Name_Table_Byte (Name_At, Token_Type'Pos (Tok_At));
- Set_Name_Table_Byte (Name_Begin, Token_Type'Pos (Tok_Begin));
- Set_Name_Table_Byte (Name_Body, Token_Type'Pos (Tok_Body));
- Set_Name_Table_Byte (Name_Case, Token_Type'Pos (Tok_Case));
- Set_Name_Table_Byte (Name_Constant, Token_Type'Pos (Tok_Constant));
- Set_Name_Table_Byte (Name_Declare, Token_Type'Pos (Tok_Declare));
- Set_Name_Table_Byte (Name_Delay, Token_Type'Pos (Tok_Delay));
- Set_Name_Table_Byte (Name_Delta, Token_Type'Pos (Tok_Delta));
- Set_Name_Table_Byte (Name_Digits, Token_Type'Pos (Tok_Digits));
- Set_Name_Table_Byte (Name_Do, Token_Type'Pos (Tok_Do));
- Set_Name_Table_Byte (Name_Else, Token_Type'Pos (Tok_Else));
- Set_Name_Table_Byte (Name_Elsif, Token_Type'Pos (Tok_Elsif));
- Set_Name_Table_Byte (Name_End, Token_Type'Pos (Tok_End));
- Set_Name_Table_Byte (Name_Entry, Token_Type'Pos (Tok_Entry));
- Set_Name_Table_Byte (Name_Exception, Token_Type'Pos (Tok_Exception));
- Set_Name_Table_Byte (Name_Exit, Token_Type'Pos (Tok_Exit));
- Set_Name_Table_Byte (Name_For, Token_Type'Pos (Tok_For));
- Set_Name_Table_Byte (Name_Function, Token_Type'Pos (Tok_Function));
- Set_Name_Table_Byte (Name_Generic, Token_Type'Pos (Tok_Generic));
- Set_Name_Table_Byte (Name_Goto, Token_Type'Pos (Tok_Goto));
- Set_Name_Table_Byte (Name_If, Token_Type'Pos (Tok_If));
- Set_Name_Table_Byte (Name_In, Token_Type'Pos (Tok_In));
- Set_Name_Table_Byte (Name_Is, Token_Type'Pos (Tok_Is));
- Set_Name_Table_Byte (Name_Limited, Token_Type'Pos (Tok_Limited));
- Set_Name_Table_Byte (Name_Loop, Token_Type'Pos (Tok_Loop));
- Set_Name_Table_Byte (Name_Mod, Token_Type'Pos (Tok_Mod));
- Set_Name_Table_Byte (Name_New, Token_Type'Pos (Tok_New));
- Set_Name_Table_Byte (Name_Not, Token_Type'Pos (Tok_Not));
- Set_Name_Table_Byte (Name_Null, Token_Type'Pos (Tok_Null));
- Set_Name_Table_Byte (Name_Of, Token_Type'Pos (Tok_Of));
- Set_Name_Table_Byte (Name_Or, Token_Type'Pos (Tok_Or));
- Set_Name_Table_Byte (Name_Others, Token_Type'Pos (Tok_Others));
- Set_Name_Table_Byte (Name_Out, Token_Type'Pos (Tok_Out));
- Set_Name_Table_Byte (Name_Package, Token_Type'Pos (Tok_Package));
- Set_Name_Table_Byte (Name_Pragma, Token_Type'Pos (Tok_Pragma));
- Set_Name_Table_Byte (Name_Private, Token_Type'Pos (Tok_Private));
- Set_Name_Table_Byte (Name_Procedure, Token_Type'Pos (Tok_Procedure));
- Set_Name_Table_Byte (Name_Protected, Token_Type'Pos (Tok_Protected));
- Set_Name_Table_Byte (Name_Raise, Token_Type'Pos (Tok_Raise));
- Set_Name_Table_Byte (Name_Range, Token_Type'Pos (Tok_Range));
- Set_Name_Table_Byte (Name_Record, Token_Type'Pos (Tok_Record));
- Set_Name_Table_Byte (Name_Rem, Token_Type'Pos (Tok_Rem));
- Set_Name_Table_Byte (Name_Renames, Token_Type'Pos (Tok_Renames));
- Set_Name_Table_Byte (Name_Requeue, Token_Type'Pos (Tok_Requeue));
- Set_Name_Table_Byte (Name_Return, Token_Type'Pos (Tok_Return));
- Set_Name_Table_Byte (Name_Reverse, Token_Type'Pos (Tok_Reverse));
- Set_Name_Table_Byte (Name_Select, Token_Type'Pos (Tok_Select));
- Set_Name_Table_Byte (Name_Separate, Token_Type'Pos (Tok_Separate));
- Set_Name_Table_Byte (Name_Subtype, Token_Type'Pos (Tok_Subtype));
- Set_Name_Table_Byte (Name_Tagged, Token_Type'Pos (Tok_Tagged));
- Set_Name_Table_Byte (Name_Task, Token_Type'Pos (Tok_Task));
- Set_Name_Table_Byte (Name_Terminate, Token_Type'Pos (Tok_Terminate));
- Set_Name_Table_Byte (Name_Then, Token_Type'Pos (Tok_Then));
- Set_Name_Table_Byte (Name_Type, Token_Type'Pos (Tok_Type));
- Set_Name_Table_Byte (Name_Until, Token_Type'Pos (Tok_Until));
- Set_Name_Table_Byte (Name_Use, Token_Type'Pos (Tok_Use));
- Set_Name_Table_Byte (Name_When, Token_Type'Pos (Tok_When));
- Set_Name_Table_Byte (Name_While, Token_Type'Pos (Tok_While));
- Set_Name_Table_Byte (Name_With, Token_Type'Pos (Tok_With));
- Set_Name_Table_Byte (Name_Xor, Token_Type'Pos (Tok_Xor));
-
- -- Initialize scan control variables
-
- Current_Source_File := Index;
- Source := Source_Text (Current_Source_File);
- Current_Source_Unit := Unit;
- Scan_Ptr := Source_First (Current_Source_File);
- Token := No_Token;
- Token_Ptr := Scan_Ptr;
- Current_Line_Start := Scan_Ptr;
- Token_Node := Empty;
- Token_Name := No_Name;
- Start_Column := Set_Start_Column;
- First_Non_Blank_Location := Scan_Ptr;
-
- Initialize_Checksum;
+ Scanner.Initialize_Scanner (Unit, Index);
-- Set default for Comes_From_Source. All nodes built now until we
-- reenter the analyzer will have Comes_From_Source set to True
@@ -486,989 +274,19 @@ package body Scn is
Set_License (Current_Source_File, Determine_License);
end if;
- -- Scan initial token (note this initializes Prev_Token, Prev_Token_Ptr)
+ -- Because of the License stuff above, Scng.Initialize_Scanner cannot
+ -- call Scan. Scan initial token (note this initializes Prev_Token,
+ -- Prev_Token_Ptr).
Scan;
- -- Clear flags for reserved words used as identifiers
+ -- Clear flags for reserved words used as indentifiers
for J in Token_Type loop
Used_As_Identifier (J) := False;
end loop;
-
end Initialize_Scanner;
- ----------
- -- Nlit --
- ----------
-
- procedure Nlit is separate;
-
- ----------
- -- Scan --
- ----------
-
- procedure Scan is
- begin
- Prev_Token := Token;
- Prev_Token_Ptr := Token_Ptr;
- Token_Name := Error_Name;
-
- -- The following loop runs more than once only if a format effector
- -- (tab, vertical tab, form feed, line feed, carriage return) is
- -- encountered and skipped, or some error situation, such as an
- -- illegal character, is encountered.
-
- loop
- -- Skip past blanks, loop is opened up for speed
-
- while Source (Scan_Ptr) = ' ' loop
-
- if Source (Scan_Ptr + 1) /= ' ' then
- Scan_Ptr := Scan_Ptr + 1;
- exit;
- end if;
-
- if Source (Scan_Ptr + 2) /= ' ' then
- Scan_Ptr := Scan_Ptr + 2;
- exit;
- end if;
-
- if Source (Scan_Ptr + 3) /= ' ' then
- Scan_Ptr := Scan_Ptr + 3;
- exit;
- end if;
-
- if Source (Scan_Ptr + 4) /= ' ' then
- Scan_Ptr := Scan_Ptr + 4;
- exit;
- end if;
-
- if Source (Scan_Ptr + 5) /= ' ' then
- Scan_Ptr := Scan_Ptr + 5;
- exit;
- end if;
-
- if Source (Scan_Ptr + 6) /= ' ' then
- Scan_Ptr := Scan_Ptr + 6;
- exit;
- end if;
-
- if Source (Scan_Ptr + 7) /= ' ' then
- Scan_Ptr := Scan_Ptr + 7;
- exit;
- end if;
-
- Scan_Ptr := Scan_Ptr + 8;
- end loop;
-
- -- We are now at a non-blank character, which is the first character
- -- of the token we will scan, and hence the value of Token_Ptr.
-
- Token_Ptr := Scan_Ptr;
-
- -- Here begins the main case statement which transfers control on
- -- the basis of the non-blank character we have encountered.
-
- case Source (Scan_Ptr) is
-
- -- Line terminator characters
-
- when CR | LF | FF | VT => Line_Terminator_Case : begin
-
- -- Check line too long
-
- Check_End_Of_Line;
-
- declare
- Physical : Boolean;
-
- begin
- Skip_Line_Terminators (Scan_Ptr, Physical);
-
- -- If we are at start of physical line, update scan pointers
- -- to reflect the start of the new line.
-
- if Physical then
- Current_Line_Start := Scan_Ptr;
- Start_Column := Set_Start_Column;
- First_Non_Blank_Location := Scan_Ptr;
- end if;
- end;
- end Line_Terminator_Case;
-
- -- Horizontal tab, just skip past it
-
- when HT =>
- if Style_Check then Style.Check_HT; end if;
- Scan_Ptr := Scan_Ptr + 1;
-
- -- End of file character, treated as an end of file only if it
- -- is the last character in the buffer, otherwise it is ignored.
-
- when EOF =>
- if Scan_Ptr = Source_Last (Current_Source_File) then
- Check_End_Of_Line;
- Token := Tok_EOF;
- return;
-
- else
- Scan_Ptr := Scan_Ptr + 1;
- end if;
-
- -- Ampersand
-
- when '&' =>
- Accumulate_Checksum ('&');
-
- if Source (Scan_Ptr + 1) = '&' then
- Error_Msg_S ("'&'& should be `AND THEN`");
- Scan_Ptr := Scan_Ptr + 2;
- Token := Tok_And;
- return;
-
- else
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Ampersand;
- return;
- end if;
-
- -- Asterisk (can be multiplication operator or double asterisk
- -- which is the exponentiation compound delimtier).
-
- when '*' =>
- Accumulate_Checksum ('*');
-
- if Source (Scan_Ptr + 1) = '*' then
- Accumulate_Checksum ('*');
- Scan_Ptr := Scan_Ptr + 2;
- Token := Tok_Double_Asterisk;
- return;
-
- else
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Asterisk;
- return;
- end if;
-
- -- Colon, which can either be an isolated colon, or part of an
- -- assignment compound delimiter.
-
- when ':' =>
- Accumulate_Checksum (':');
-
- if Double_Char_Token ('=') then
- Token := Tok_Colon_Equal;
- if Style_Check then Style.Check_Colon_Equal; end if;
- return;
-
- elsif Source (Scan_Ptr + 1) = '-'
- and then Source (Scan_Ptr + 2) /= '-'
- then
- Token := Tok_Colon_Equal;
- Error_Msg (":- should be :=", Scan_Ptr);
- Scan_Ptr := Scan_Ptr + 2;
- return;
-
- else
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Colon;
- if Style_Check then Style.Check_Colon; end if;
- return;
- end if;
-
- -- Left parenthesis
-
- when '(' =>
- Accumulate_Checksum ('(');
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Left_Paren;
- if Style_Check then Style.Check_Left_Paren; end if;
- return;
-
- -- Left bracket
-
- when '[' =>
- if Source (Scan_Ptr + 1) = '"' then
- Name_Len := 0;
- goto Scan_Identifier;
-
- else
- Error_Msg_S ("illegal character, replaced by ""(""");
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Left_Paren;
- return;
- end if;
-
- -- Left brace
-
- when '{' =>
- Error_Msg_S ("illegal character, replaced by ""(""");
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Left_Paren;
- return;
-
- -- Comma
-
- when ',' =>
- Accumulate_Checksum (',');
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Comma;
- if Style_Check then Style.Check_Comma; end if;
- return;
-
- -- Dot, which is either an isolated period, or part of a double
- -- dot compound delimiter sequence. We also check for the case of
- -- a digit following the period, to give a better error message.
-
- when '.' =>
- Accumulate_Checksum ('.');
-
- if Double_Char_Token ('.') then
- Token := Tok_Dot_Dot;
- if Style_Check then Style.Check_Dot_Dot; end if;
- return;
-
- elsif Source (Scan_Ptr + 1) in '0' .. '9' then
- Error_Msg_S ("numeric literal cannot start with point");
- Scan_Ptr := Scan_Ptr + 1;
-
- else
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Dot;
- return;
- end if;
-
- -- Equal, which can either be an equality operator, or part of the
- -- arrow (=>) compound delimiter.
-
- when '=' =>
- Accumulate_Checksum ('=');
-
- if Double_Char_Token ('>') then
- Token := Tok_Arrow;
- if Style_Check then Style.Check_Arrow; end if;
- return;
-
- elsif Source (Scan_Ptr + 1) = '=' then
- Error_Msg_S ("== should be =");
- Scan_Ptr := Scan_Ptr + 1;
- end if;
-
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Equal;
- return;
-
- -- Greater than, which can be a greater than operator, greater than
- -- or equal operator, or first character of a right label bracket.
-
- when '>' =>
- Accumulate_Checksum ('>');
-
- if Double_Char_Token ('=') then
- Token := Tok_Greater_Equal;
- return;
-
- elsif Double_Char_Token ('>') then
- Token := Tok_Greater_Greater;
- return;
-
- else
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Greater;
- return;
- end if;
-
- -- Less than, which can be a less than operator, less than or equal
- -- operator, or the first character of a left label bracket, or the
- -- first character of a box (<>) compound delimiter.
-
- when '<' =>
- Accumulate_Checksum ('<');
-
- if Double_Char_Token ('=') then
- Token := Tok_Less_Equal;
- return;
-
- elsif Double_Char_Token ('>') then
- Token := Tok_Box;
- if Style_Check then Style.Check_Box; end if;
- return;
-
- elsif Double_Char_Token ('<') then
- Token := Tok_Less_Less;
- return;
-
- else
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Less;
- return;
- end if;
-
- -- Minus, which is either a subtraction operator, or the first
- -- character of double minus starting a comment
-
- when '-' => Minus_Case : begin
- if Source (Scan_Ptr + 1) = '>' then
- Error_Msg_S ("invalid token");
- Scan_Ptr := Scan_Ptr + 2;
- Token := Tok_Arrow;
- return;
-
- elsif Source (Scan_Ptr + 1) /= '-' then
- Accumulate_Checksum ('-');
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Minus;
- return;
-
- -- Comment
-
- else -- Source (Scan_Ptr + 1) = '-' then
- if Style_Check then Style.Check_Comment; end if;
- Scan_Ptr := Scan_Ptr + 2;
-
- -- Loop to scan comment (this loop runs more than once only if
- -- a horizontal tab or other non-graphic character is scanned)
-
- loop
- -- Scan to non graphic character (opened up for speed)
-
- loop
- exit when Source (Scan_Ptr) not in Graphic_Character;
- Scan_Ptr := Scan_Ptr + 1;
- exit when Source (Scan_Ptr) not in Graphic_Character;
- Scan_Ptr := Scan_Ptr + 1;
- exit when Source (Scan_Ptr) not in Graphic_Character;
- Scan_Ptr := Scan_Ptr + 1;
- exit when Source (Scan_Ptr) not in Graphic_Character;
- Scan_Ptr := Scan_Ptr + 1;
- exit when Source (Scan_Ptr) not in Graphic_Character;
- Scan_Ptr := Scan_Ptr + 1;
- end loop;
-
- -- Keep going if horizontal tab
-
- if Source (Scan_Ptr) = HT then
- if Style_Check then Style.Check_HT; end if;
- Scan_Ptr := Scan_Ptr + 1;
-
- -- Terminate scan of comment if line terminator
-
- elsif Source (Scan_Ptr) in Line_Terminator then
- exit;
-
- -- Terminate scan of comment if end of file encountered
- -- (embedded EOF character or real last character in file)
-
- elsif Source (Scan_Ptr) = EOF then
- exit;
-
- -- Keep going if character in 80-FF range, or is ESC. These
- -- characters are allowed in comments by RM-2.1(1), 2.7(2).
- -- They are allowed even in Ada 83 mode according to the
- -- approved AI. ESC was added to the AI in June 93.
-
- elsif Source (Scan_Ptr) in Upper_Half_Character
- or else Source (Scan_Ptr) = ESC
- then
- Scan_Ptr := Scan_Ptr + 1;
-
- -- Otherwise we have an illegal comment character
-
- else
- Error_Illegal_Character;
- end if;
-
- end loop;
-
- -- Note that we do NOT execute a return here, instead we fall
- -- through to reexecute the scan loop to look for a token.
-
- end if;
- end Minus_Case;
-
- -- Double quote or percent starting a string literal
-
- when '"' | '%' =>
- Slit;
- return;
-
- -- Apostrophe. This can either be the start of a character literal,
- -- or an isolated apostrophe used in a qualified expression or an
- -- attribute. We treat it as a character literal if it does not
- -- follow a right parenthesis, identifier, the keyword ALL or
- -- a literal. This means that we correctly treat constructs like:
-
- -- A := CHARACTER'('A');
-
- -- Note that RM-2.2(7) does not require a separator between
- -- "CHARACTER" and "'" in the above.
-
- when ''' => Char_Literal_Case : declare
- Code : Char_Code;
- Err : Boolean;
-
- begin
- Accumulate_Checksum (''');
- Scan_Ptr := Scan_Ptr + 1;
-
- -- Here is where we make the test to distinguish the cases. Treat
- -- as apostrophe if previous token is an identifier, right paren
- -- or the reserved word "all" (latter case as in A.all'Address)
- -- Also treat it as apostrophe after a literal (this catches
- -- some legitimate cases, like A."abs"'Address, and also gives
- -- better error behavior for impossible cases like 123'xxx).
-
- if Prev_Token = Tok_Identifier
- or else Prev_Token = Tok_Right_Paren
- or else Prev_Token = Tok_All
- or else Prev_Token in Token_Class_Literal
- then
- Token := Tok_Apostrophe;
- return;
-
- -- Otherwise the apostrophe starts a character literal
-
- else
- -- Case of wide character literal with ESC or [ encoding
-
- if (Source (Scan_Ptr) = ESC
- and then
- Wide_Character_Encoding_Method in WC_ESC_Encoding_Method)
- or else
- (Source (Scan_Ptr) in Upper_Half_Character
- and then
- Upper_Half_Encoding)
- or else
- (Source (Scan_Ptr) = '['
- and then
- Source (Scan_Ptr + 1) = '"')
- then
- Scan_Wide (Source, Scan_Ptr, Code, Err);
- Accumulate_Checksum (Code);
-
- if Err then
- Error_Illegal_Wide_Character;
- end if;
-
- if Source (Scan_Ptr) /= ''' then
- Error_Msg_S ("missing apostrophe");
- else
- Scan_Ptr := Scan_Ptr + 1;
- end if;
-
- -- If we do not find a closing quote in the expected place then
- -- assume that we have a misguided attempt at a string literal.
-
- -- However, if previous token is RANGE, then we return an
- -- apostrophe instead since this gives better error recovery
-
- elsif Source (Scan_Ptr + 1) /= ''' then
-
- if Prev_Token = Tok_Range then
- Token := Tok_Apostrophe;
- return;
-
- else
- Scan_Ptr := Scan_Ptr - 1;
- Error_Msg_S
- ("strings are delimited by double quote character");
- Scn.Slit;
- return;
- end if;
-
- -- Otherwise we have a (non-wide) character literal
-
- else
- Accumulate_Checksum (Source (Scan_Ptr));
-
- if Source (Scan_Ptr) not in Graphic_Character then
- if Source (Scan_Ptr) in Upper_Half_Character then
- if Ada_83 then
- Error_Illegal_Character;
- end if;
-
- else
- Error_Illegal_Character;
- end if;
- end if;
-
- Code := Get_Char_Code (Source (Scan_Ptr));
- Scan_Ptr := Scan_Ptr + 2;
- end if;
-
- -- Fall through here with Scan_Ptr updated past the closing
- -- quote, and Code set to the Char_Code value for the literal
-
- Accumulate_Checksum (''');
- Token := Tok_Char_Literal;
- Token_Node := New_Node (N_Character_Literal, Token_Ptr);
- Set_Char_Literal_Value (Token_Node, Code);
- Set_Character_Literal_Name (Code);
- Token_Name := Name_Find;
- Set_Chars (Token_Node, Token_Name);
- return;
- end if;
- end Char_Literal_Case;
-
- -- Right parenthesis
-
- when ')' =>
- Accumulate_Checksum (')');
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Right_Paren;
- if Style_Check then Style.Check_Right_Paren; end if;
- return;
-
- -- Right bracket or right brace, treated as right paren
-
- when ']' | '}' =>
- Error_Msg_S ("illegal character, replaced by "")""");
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Right_Paren;
- return;
-
- -- Slash (can be division operator or first character of not equal)
-
- when '/' =>
- Accumulate_Checksum ('/');
-
- if Double_Char_Token ('=') then
- Token := Tok_Not_Equal;
- return;
- else
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Slash;
- return;
- end if;
-
- -- Semicolon
-
- when ';' =>
- Accumulate_Checksum (';');
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Semicolon;
- if Style_Check then Style.Check_Semicolon; end if;
- return;
-
- -- Vertical bar
-
- when '|' => Vertical_Bar_Case : begin
- Accumulate_Checksum ('|');
-
- -- Special check for || to give nice message
-
- if Source (Scan_Ptr + 1) = '|' then
- Error_Msg_S ("""'|'|"" should be `OR ELSE`");
- Scan_Ptr := Scan_Ptr + 2;
- Token := Tok_Or;
- return;
-
- else
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Vertical_Bar;
- if Style_Check then Style.Check_Vertical_Bar; end if;
- return;
- end if;
- end Vertical_Bar_Case;
-
- -- Exclamation, replacement character for vertical bar
-
- when '!' => Exclamation_Case : begin
- Accumulate_Checksum ('!');
-
- if Source (Scan_Ptr + 1) = '=' then
- Error_Msg_S ("'!= should be /=");
- Scan_Ptr := Scan_Ptr + 2;
- Token := Tok_Not_Equal;
- return;
-
- else
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Vertical_Bar;
- return;
- end if;
-
- end Exclamation_Case;
-
- -- Plus
-
- when '+' => Plus_Case : begin
- Accumulate_Checksum ('+');
- Scan_Ptr := Scan_Ptr + 1;
- Token := Tok_Plus;
- return;
- end Plus_Case;
-
- -- Digits starting a numeric literal
-
- when '0' .. '9' =>
- Nlit;
-
- if Identifier_Char (Source (Scan_Ptr)) then
- Error_Msg_S
- ("delimiter required between literal and identifier");
- end if;
-
- return;
-
- -- Lower case letters
-
- when 'a' .. 'z' =>
- Name_Len := 1;
- Name_Buffer (1) := Source (Scan_Ptr);
- Accumulate_Checksum (Name_Buffer (1));
- Scan_Ptr := Scan_Ptr + 1;
- goto Scan_Identifier;
-
- -- Upper case letters
-
- when 'A' .. 'Z' =>
- Name_Len := 1;
- Name_Buffer (1) :=
- Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
- Accumulate_Checksum (Name_Buffer (1));
- Scan_Ptr := Scan_Ptr + 1;
- goto Scan_Identifier;
-
- -- Underline character
-
- when '_' =>
- Error_Msg_S ("identifier cannot start with underline");
- Name_Len := 1;
- Name_Buffer (1) := '_';
- Scan_Ptr := Scan_Ptr + 1;
- goto Scan_Identifier;
-
- -- Space (not possible, because we scanned past blanks)
-
- when ' ' =>
- raise Program_Error;
-
- -- Characters in top half of ASCII 8-bit chart
-
- when Upper_Half_Character =>
-
- -- Wide character case. Note that Scan_Identifier will issue
- -- an appropriate message if wide characters are not allowed
- -- in identifiers.
-
- if Upper_Half_Encoding then
- Name_Len := 0;
- goto Scan_Identifier;
-
- -- Otherwise we have OK Latin-1 character
-
- else
- -- Upper half characters may possibly be identifier letters
- -- but can never be digits, so Identifier_Char can be used
- -- to test for a valid start of identifier character.
-
- if Identifier_Char (Source (Scan_Ptr)) then
- Name_Len := 0;
- goto Scan_Identifier;
- else
- Error_Illegal_Character;
- end if;
- end if;
-
- when ESC =>
-
- -- ESC character, possible start of identifier if wide characters
- -- using ESC encoding are allowed in identifiers, which we can
- -- tell by looking at the Identifier_Char flag for ESC, which is
- -- only true if these conditions are met.
-
- if Identifier_Char (ESC) then
- Name_Len := 0;
- goto Scan_Identifier;
- else
- Error_Illegal_Wide_Character;
- end if;
-
- -- Invalid control characters
-
- when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | SO |
- SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
- EM | FS | GS | RS | US | DEL
- =>
- Error_Illegal_Character;
-
- -- Invalid graphic characters
-
- when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' =>
- Error_Illegal_Character;
-
- -- End switch on non-blank character
-
- end case;
-
- -- End loop past format effectors. The exit from this loop is by
- -- executing a return statement following completion of token scan
- -- (control never falls out of this loop to the code which follows)
-
- end loop;
-
- -- Identifier scanning routine. On entry, some initial characters
- -- of the identifier may have already been stored in Name_Buffer.
- -- If so, Name_Len has the number of characters stored. otherwise
- -- Name_Len is set to zero on entry.
-
- <<Scan_Identifier>>
-
- -- This loop scans as fast as possible past lower half letters
- -- and digits, which we expect to be the most common characters.
-
- loop
- if Source (Scan_Ptr) in 'a' .. 'z'
- or else Source (Scan_Ptr) in '0' .. '9'
- then
- Name_Buffer (Name_Len + 1) := Source (Scan_Ptr);
- Accumulate_Checksum (Source (Scan_Ptr));
-
- elsif Source (Scan_Ptr) in 'A' .. 'Z' then
- Name_Buffer (Name_Len + 1) :=
- Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
- Accumulate_Checksum (Name_Buffer (Name_Len + 1));
- else
- exit;
- end if;
-
- -- Open out the loop a couple of times for speed
-
- if Source (Scan_Ptr + 1) in 'a' .. 'z'
- or else Source (Scan_Ptr + 1) in '0' .. '9'
- then
- Name_Buffer (Name_Len + 2) := Source (Scan_Ptr + 1);
- Accumulate_Checksum (Source (Scan_Ptr + 1));
-
- elsif Source (Scan_Ptr + 1) in 'A' .. 'Z' then
- Name_Buffer (Name_Len + 2) :=
- Character'Val (Character'Pos (Source (Scan_Ptr + 1)) + 32);
- Accumulate_Checksum (Name_Buffer (Name_Len + 2));
-
- else
- Scan_Ptr := Scan_Ptr + 1;
- Name_Len := Name_Len + 1;
- exit;
- end if;
-
- if Source (Scan_Ptr + 2) in 'a' .. 'z'
- or else Source (Scan_Ptr + 2) in '0' .. '9'
- then
- Name_Buffer (Name_Len + 3) := Source (Scan_Ptr + 2);
- Accumulate_Checksum (Source (Scan_Ptr + 2));
-
- elsif Source (Scan_Ptr + 2) in 'A' .. 'Z' then
- Name_Buffer (Name_Len + 3) :=
- Character'Val (Character'Pos (Source (Scan_Ptr + 2)) + 32);
- Accumulate_Checksum (Name_Buffer (Name_Len + 3));
- else
- Scan_Ptr := Scan_Ptr + 2;
- Name_Len := Name_Len + 2;
- exit;
- end if;
-
- if Source (Scan_Ptr + 3) in 'a' .. 'z'
- or else Source (Scan_Ptr + 3) in '0' .. '9'
- then
- Name_Buffer (Name_Len + 4) := Source (Scan_Ptr + 3);
- Accumulate_Checksum (Source (Scan_Ptr + 3));
-
- elsif Source (Scan_Ptr + 3) in 'A' .. 'Z' then
- Name_Buffer (Name_Len + 4) :=
- Character'Val (Character'Pos (Source (Scan_Ptr + 3)) + 32);
- Accumulate_Checksum (Name_Buffer (Name_Len + 4));
-
- else
- Scan_Ptr := Scan_Ptr + 3;
- Name_Len := Name_Len + 3;
- exit;
- end if;
-
- Scan_Ptr := Scan_Ptr + 4;
- Name_Len := Name_Len + 4;
- end loop;
-
- -- If we fall through, then we have encountered either an underline
- -- character, or an extended identifier character (i.e. one from the
- -- upper half), or a wide character, or an identifier terminator.
- -- The initial test speeds us up in the most common case where we
- -- have an identifier terminator. Note that ESC is an identifier
- -- character only if a wide character encoding method that uses
- -- ESC encoding is active, so if we find an ESC character we know
- -- that we have a wide character.
-
- if Identifier_Char (Source (Scan_Ptr)) then
-
- -- Case of underline, check for error cases of double underline,
- -- and for a trailing underline character
-
- if Source (Scan_Ptr) = '_' then
- Accumulate_Checksum ('_');
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := '_';
-
- if Identifier_Char (Source (Scan_Ptr + 1)) then
- Scan_Ptr := Scan_Ptr + 1;
-
- if Source (Scan_Ptr) = '_' then
- Error_No_Double_Underline;
- end if;
-
- else
- Error_Msg_S ("identifier cannot end with underline");
- Scan_Ptr := Scan_Ptr + 1;
- end if;
-
- goto Scan_Identifier;
-
- -- Upper half character
-
- elsif Source (Scan_Ptr) in Upper_Half_Character
- and then not Upper_Half_Encoding
- then
- Accumulate_Checksum (Source (Scan_Ptr));
- Store_Encoded_Character
- (Get_Char_Code (Fold_Lower (Source (Scan_Ptr))));
- Scan_Ptr := Scan_Ptr + 1;
- goto Scan_Identifier;
-
- -- Left bracket not followed by a quote terminates an identifier.
- -- This is an error, but we don't want to give a junk error msg
- -- about wide characters in this case!
-
- elsif Source (Scan_Ptr) = '['
- and then Source (Scan_Ptr + 1) /= '"'
- then
- null;
-
- -- We know we have a wide character encoding here (the current
- -- character is either ESC, left bracket, or an upper half
- -- character depending on the encoding method).
-
- else
- -- Scan out the wide character and insert the appropriate
- -- encoding into the name table entry for the identifier.
-
- declare
- Sptr : constant Source_Ptr := Scan_Ptr;
- Code : Char_Code;
- Err : Boolean;
- Chr : Character;
-
- begin
- Scan_Wide (Source, Scan_Ptr, Code, Err);
-
- -- If error, signal error
-
- if Err then
- Error_Illegal_Wide_Character;
-
- -- If the character scanned is a normal identifier
- -- character, then we treat it that way.
-
- elsif In_Character_Range (Code)
- and then Identifier_Char (Get_Character (Code))
- then
- Chr := Get_Character (Code);
- Accumulate_Checksum (Chr);
- Store_Encoded_Character
- (Get_Char_Code (Fold_Lower (Chr)));
-
- -- Character is not normal identifier character, store
- -- it in encoded form.
-
- else
- Accumulate_Checksum (Code);
- Store_Encoded_Character (Code);
-
- -- Make sure we are allowing wide characters in
- -- identifiers. Note that we allow wide character
- -- notation for an OK identifier character. This
- -- in particular allows bracket or other notation
- -- to be used for upper half letters.
-
- if Identifier_Character_Set /= 'w' then
- Error_Msg
- ("wide character not allowed in identifier", Sptr);
- end if;
- end if;
- end;
-
- goto Scan_Identifier;
- end if;
- end if;
-
- -- Scan of identifier is complete. The identifier is stored in
- -- Name_Buffer, and Scan_Ptr points past the last character.
-
- Token_Name := Name_Find;
-
- -- Here is where we check if it was a keyword
-
- if Get_Name_Table_Byte (Token_Name) /= 0
- and then (Ada_95 or else Token_Name not in Ada_95_Reserved_Words)
- then
- Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
-
- -- Deal with possible style check for non-lower case keyword,
- -- but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords
- -- for this purpose if they appear as attribute designators.
- -- Actually we only check the first character for speed.
-
- if Style_Check
- and then Source (Token_Ptr) <= 'Z'
- and then (Prev_Token /= Tok_Apostrophe
- or else
- (Token /= Tok_Access
- and then Token /= Tok_Delta
- and then Token /= Tok_Digits
- and then Token /= Tok_Range))
- then
- Style.Non_Lower_Case_Keyword;
- end if;
-
- -- We must reset Token_Name since this is not an identifier
- -- and if we leave Token_Name set, the parser gets confused
- -- because it thinks it is dealing with an identifier instead
- -- of the corresponding keyword.
-
- Token_Name := No_Name;
- return;
-
- -- It is an identifier after all
-
- else
- Token_Node := New_Node (N_Identifier, Token_Ptr);
- Set_Chars (Token_Node, Token_Name);
- Token := Tok_Identifier;
- return;
- end if;
- end Scan;
-
- ---------------------
- -- Scan_First_Char --
- ---------------------
-
- function Scan_First_Char return Source_Ptr is
- Ptr : Source_Ptr := Current_Line_Start;
-
- begin
- loop
- if Source (Ptr) = ' ' then
- Ptr := Ptr + 1;
-
- elsif Source (Ptr) = HT then
- if Style_Check then Style.Check_HT; end if;
- Ptr := Ptr + 1;
-
- else
- return Ptr;
- end if;
- end loop;
- end Scan_First_Char;
-
------------------------------
-- Scan_Reserved_Identifier --
------------------------------
@@ -1500,91 +318,4 @@ package body Scn is
Set_Chars (Token_Node, Token_Name);
end Scan_Reserved_Identifier;
- ----------------------
- -- Set_Start_Column --
- ----------------------
-
- -- Note: it seems at first glance a little expensive to compute this value
- -- for every source line (since it is certainly not used for all source
- -- lines). On the other hand, it doesn't take much more work to skip past
- -- the initial white space on the line counting the columns than it would
- -- to scan past the white space using the standard scanning circuits.
-
- function Set_Start_Column return Column_Number is
- Start_Column : Column_Number := 0;
-
- begin
- -- Outer loop scans past horizontal tab characters
-
- Tabs_Loop : loop
-
- -- Inner loop scans past blanks as fast as possible, bumping Scan_Ptr
- -- past the blanks and adjusting Start_Column to account for them.
-
- Blanks_Loop : loop
- if Source (Scan_Ptr) = ' ' then
- if Source (Scan_Ptr + 1) = ' ' then
- if Source (Scan_Ptr + 2) = ' ' then
- if Source (Scan_Ptr + 3) = ' ' then
- if Source (Scan_Ptr + 4) = ' ' then
- if Source (Scan_Ptr + 5) = ' ' then
- if Source (Scan_Ptr + 6) = ' ' then
- Scan_Ptr := Scan_Ptr + 7;
- Start_Column := Start_Column + 7;
- else
- Scan_Ptr := Scan_Ptr + 6;
- Start_Column := Start_Column + 6;
- exit Blanks_Loop;
- end if;
- else
- Scan_Ptr := Scan_Ptr + 5;
- Start_Column := Start_Column + 5;
- exit Blanks_Loop;
- end if;
- else
- Scan_Ptr := Scan_Ptr + 4;
- Start_Column := Start_Column + 4;
- exit Blanks_Loop;
- end if;
- else
- Scan_Ptr := Scan_Ptr + 3;
- Start_Column := Start_Column + 3;
- exit Blanks_Loop;
- end if;
- else
- Scan_Ptr := Scan_Ptr + 2;
- Start_Column := Start_Column + 2;
- exit Blanks_Loop;
- end if;
- else
- Scan_Ptr := Scan_Ptr + 1;
- Start_Column := Start_Column + 1;
- exit Blanks_Loop;
- end if;
- else
- exit Blanks_Loop;
- end if;
- end loop Blanks_Loop;
-
- -- Outer loop keeps going only if a horizontal tab follows
-
- if Source (Scan_Ptr) = HT then
- if Style_Check then Style.Check_HT; end if;
- Scan_Ptr := Scan_Ptr + 1;
- Start_Column := (Start_Column / 8) * 8 + 8;
- else
- exit Tabs_Loop;
- end if;
-
- end loop Tabs_Loop;
-
- return Start_Column;
- end Set_Start_Column;
-
- ----------
- -- Slit --
- ----------
-
- procedure Slit is separate;
-
end Scn;
diff --git a/gcc/ada/scn.ads b/gcc/ada/scn.ads
index ead6441fbb1..23741e85441 100644
--- a/gcc/ada/scn.ads
+++ b/gcc/ada/scn.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -24,10 +24,13 @@
-- --
------------------------------------------------------------------------------
--- This package contains the lexical analyzer routines. This is used both
--- for scanning Ada source files and also for scanning Ada project files.
+-- This package contains the lexical analyzer routines. This is used by the
+-- compiler for scanning Ada source files.
with Casing; use Casing;
+with Errout; use Errout;
+with Scng;
+with Style; use Style;
with Types; use Types;
package Scn is
@@ -41,15 +44,14 @@ package Scn is
-- case is when Unit = No_Unit_Number, and Index corresponds to the
-- source index for reading the configuration pragma file.
- procedure Scan;
- -- Scan scans out the next token, and advances the scan state accordingly
- -- (see package Scan_State for details). If the scan encounters an illegal
- -- token, then an error message is issued pointing to the bad character,
- -- and Scan returns a reasonable substitute token of some kind.
+ function Determine_Token_Casing return Casing_Type;
+ -- Determines the casing style of the current token, which is
+ -- either a keyword or an identifier. See also package Casing.
- function Scan_First_Char return Source_Ptr;
- -- This routine returns the position in Source of the first non-blank
- -- character on the current line, used for certain error recovery actions.
+ procedure Post_Scan;
+ pragma Inline (Post_Scan);
+ -- Create nodes for tokens: Char_Literal, Identifier, Real_Literal,
+ -- Integer_Literal, String_Literal and Operator_Symbol.
procedure Scan_Reserved_Identifier (Force_Msg : Boolean);
-- This procedure is called to convert the current token, which the caller
@@ -59,9 +61,25 @@ package Scn is
-- message, pointing to the token, is also issued if either this is the
-- first occurrence of misuse of this identifier, or if Force_Msg is True.
- function Determine_Token_Casing return Casing_Type;
- pragma Inline (Determine_Token_Casing);
- -- Determines the casing style of the current token, which is
- -- either a keyword or an identifier. See also package Casing.
+ -------------
+ -- Scanner --
+ -------------
+
+ -- The scanner used by the compiler is an instantiation of the
+ -- generic package Scng with routines appropriate to the compiler
+
+ package Scanner is new Scng
+ (Post_Scan => Post_Scan,
+ Error_Msg => Error_Msg,
+ Error_Msg_S => Error_Msg_S,
+ Error_Msg_SC => Error_Msg_SC,
+ Error_Msg_SP => Error_Msg_SP,
+ Style => Style.Style_Inst);
+
+ procedure Scan renames Scanner.Scan;
+ -- Scan scans out the next token, and advances the scan state accordingly
+ -- (see package Scans for details). If the scan encounters an illegal
+ -- token, then an error message is issued pointing to the bad character,
+ -- and Scan returns a reasonable substitute token of some kind.
end Scn;
diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb
new file mode 100644
index 00000000000..369a6acc944
--- /dev/null
+++ b/gcc/ada/scng.adb
@@ -0,0 +1,2175 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S C N G --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Csets; use Csets;
+with Err_Vars; use Err_Vars;
+with Hostparm; use Hostparm;
+with Namet; use Namet;
+with Opt; use Opt;
+with Scans; use Scans;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stringt; use Stringt;
+with Stylesw; use Stylesw;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Widechar; use Widechar;
+
+with System.CRC32;
+with System.WCh_Con; use System.WCh_Con;
+
+package body Scng is
+
+ use ASCII;
+ -- Make control characters visible
+
+ Special_Characters : array (Character) of Boolean := (others => False);
+ -- For characters that are Special token, the value is True
+
+ End_Of_Line_Is_Token : Boolean := False;
+ -- True if End_Of_Line is a token
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Accumulate_Checksum (C : Character);
+ pragma Inline (Accumulate_Checksum);
+ -- This routine accumulates the checksum given character C. During the
+ -- scanning of a source file, this routine is called with every character
+ -- in the source, excluding blanks, and all control characters (except
+ -- that ESC is included in the checksum). Upper case letters not in string
+ -- literals are folded by the caller. See Sinput spec for the documentation
+ -- of the checksum algorithm. Note: checksum values are only used if we
+ -- generate code, so it is not necessary to worry about making the right
+ -- sequence of calls in any error situation.
+
+ procedure Accumulate_Checksum (C : Char_Code);
+ pragma Inline (Accumulate_Checksum);
+ -- This version is identical, except that the argument, C, is a character
+ -- code value instead of a character. This is used when wide characters
+ -- are scanned. We use the character code rather than the ASCII characters
+ -- so that the checksum is independent of wide character encoding method.
+
+ procedure Initialize_Checksum;
+ pragma Inline (Initialize_Checksum);
+ -- Initialize checksum value
+
+ -------------------------
+ -- Accumulate_Checksum --
+ -------------------------
+
+ procedure Accumulate_Checksum (C : Character) is
+ begin
+ System.CRC32.Update (System.CRC32.CRC32 (Checksum), C);
+ end Accumulate_Checksum;
+
+ procedure Accumulate_Checksum (C : Char_Code) is
+ begin
+ Accumulate_Checksum (Character'Val (C / 256));
+ Accumulate_Checksum (Character'Val (C mod 256));
+ end Accumulate_Checksum;
+
+ ----------------------------
+ -- Determine_Token_Casing --
+ ----------------------------
+
+ function Determine_Token_Casing return Casing_Type is
+ begin
+ return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1));
+ end Determine_Token_Casing;
+
+ -------------------------
+ -- Initialize_Checksum --
+ -------------------------
+
+ procedure Initialize_Checksum is
+ begin
+ System.CRC32.Initialize (System.CRC32.CRC32 (Checksum));
+ end Initialize_Checksum;
+
+ ------------------------
+ -- Initialize_Scanner --
+ ------------------------
+
+ procedure Initialize_Scanner
+ (Unit : Unit_Number_Type;
+ Index : Source_File_Index)
+ is
+ begin
+ -- Set up Token_Type values in Names Table entries for reserved keywords
+ -- We use the Pos value of the Token_Type value. Note we are relying on
+ -- the fact that Token_Type'Val (0) is not a reserved word!
+
+ Set_Name_Table_Byte (Name_Abort, Token_Type'Pos (Tok_Abort));
+ Set_Name_Table_Byte (Name_Abs, Token_Type'Pos (Tok_Abs));
+ Set_Name_Table_Byte (Name_Abstract, Token_Type'Pos (Tok_Abstract));
+ Set_Name_Table_Byte (Name_Accept, Token_Type'Pos (Tok_Accept));
+ Set_Name_Table_Byte (Name_Access, Token_Type'Pos (Tok_Access));
+ Set_Name_Table_Byte (Name_And, Token_Type'Pos (Tok_And));
+ Set_Name_Table_Byte (Name_Aliased, Token_Type'Pos (Tok_Aliased));
+ Set_Name_Table_Byte (Name_All, Token_Type'Pos (Tok_All));
+ Set_Name_Table_Byte (Name_Array, Token_Type'Pos (Tok_Array));
+ Set_Name_Table_Byte (Name_At, Token_Type'Pos (Tok_At));
+ Set_Name_Table_Byte (Name_Begin, Token_Type'Pos (Tok_Begin));
+ Set_Name_Table_Byte (Name_Body, Token_Type'Pos (Tok_Body));
+ Set_Name_Table_Byte (Name_Case, Token_Type'Pos (Tok_Case));
+ Set_Name_Table_Byte (Name_Constant, Token_Type'Pos (Tok_Constant));
+ Set_Name_Table_Byte (Name_Declare, Token_Type'Pos (Tok_Declare));
+ Set_Name_Table_Byte (Name_Delay, Token_Type'Pos (Tok_Delay));
+ Set_Name_Table_Byte (Name_Delta, Token_Type'Pos (Tok_Delta));
+ Set_Name_Table_Byte (Name_Digits, Token_Type'Pos (Tok_Digits));
+ Set_Name_Table_Byte (Name_Do, Token_Type'Pos (Tok_Do));
+ Set_Name_Table_Byte (Name_Else, Token_Type'Pos (Tok_Else));
+ Set_Name_Table_Byte (Name_Elsif, Token_Type'Pos (Tok_Elsif));
+ Set_Name_Table_Byte (Name_End, Token_Type'Pos (Tok_End));
+ Set_Name_Table_Byte (Name_Entry, Token_Type'Pos (Tok_Entry));
+ Set_Name_Table_Byte (Name_Exception, Token_Type'Pos (Tok_Exception));
+ Set_Name_Table_Byte (Name_Exit, Token_Type'Pos (Tok_Exit));
+ Set_Name_Table_Byte (Name_For, Token_Type'Pos (Tok_For));
+ Set_Name_Table_Byte (Name_Function, Token_Type'Pos (Tok_Function));
+ Set_Name_Table_Byte (Name_Generic, Token_Type'Pos (Tok_Generic));
+ Set_Name_Table_Byte (Name_Goto, Token_Type'Pos (Tok_Goto));
+ Set_Name_Table_Byte (Name_If, Token_Type'Pos (Tok_If));
+ Set_Name_Table_Byte (Name_In, Token_Type'Pos (Tok_In));
+ Set_Name_Table_Byte (Name_Is, Token_Type'Pos (Tok_Is));
+ Set_Name_Table_Byte (Name_Limited, Token_Type'Pos (Tok_Limited));
+ Set_Name_Table_Byte (Name_Loop, Token_Type'Pos (Tok_Loop));
+ Set_Name_Table_Byte (Name_Mod, Token_Type'Pos (Tok_Mod));
+ Set_Name_Table_Byte (Name_New, Token_Type'Pos (Tok_New));
+ Set_Name_Table_Byte (Name_Not, Token_Type'Pos (Tok_Not));
+ Set_Name_Table_Byte (Name_Null, Token_Type'Pos (Tok_Null));
+ Set_Name_Table_Byte (Name_Of, Token_Type'Pos (Tok_Of));
+ Set_Name_Table_Byte (Name_Or, Token_Type'Pos (Tok_Or));
+ Set_Name_Table_Byte (Name_Others, Token_Type'Pos (Tok_Others));
+ Set_Name_Table_Byte (Name_Out, Token_Type'Pos (Tok_Out));
+ Set_Name_Table_Byte (Name_Package, Token_Type'Pos (Tok_Package));
+ Set_Name_Table_Byte (Name_Pragma, Token_Type'Pos (Tok_Pragma));
+ Set_Name_Table_Byte (Name_Private, Token_Type'Pos (Tok_Private));
+ Set_Name_Table_Byte (Name_Procedure, Token_Type'Pos (Tok_Procedure));
+ Set_Name_Table_Byte (Name_Protected, Token_Type'Pos (Tok_Protected));
+ Set_Name_Table_Byte (Name_Raise, Token_Type'Pos (Tok_Raise));
+ Set_Name_Table_Byte (Name_Range, Token_Type'Pos (Tok_Range));
+ Set_Name_Table_Byte (Name_Record, Token_Type'Pos (Tok_Record));
+ Set_Name_Table_Byte (Name_Rem, Token_Type'Pos (Tok_Rem));
+ Set_Name_Table_Byte (Name_Renames, Token_Type'Pos (Tok_Renames));
+ Set_Name_Table_Byte (Name_Requeue, Token_Type'Pos (Tok_Requeue));
+ Set_Name_Table_Byte (Name_Return, Token_Type'Pos (Tok_Return));
+ Set_Name_Table_Byte (Name_Reverse, Token_Type'Pos (Tok_Reverse));
+ Set_Name_Table_Byte (Name_Select, Token_Type'Pos (Tok_Select));
+ Set_Name_Table_Byte (Name_Separate, Token_Type'Pos (Tok_Separate));
+ Set_Name_Table_Byte (Name_Subtype, Token_Type'Pos (Tok_Subtype));
+ Set_Name_Table_Byte (Name_Tagged, Token_Type'Pos (Tok_Tagged));
+ Set_Name_Table_Byte (Name_Task, Token_Type'Pos (Tok_Task));
+ Set_Name_Table_Byte (Name_Terminate, Token_Type'Pos (Tok_Terminate));
+ Set_Name_Table_Byte (Name_Then, Token_Type'Pos (Tok_Then));
+ Set_Name_Table_Byte (Name_Type, Token_Type'Pos (Tok_Type));
+ Set_Name_Table_Byte (Name_Until, Token_Type'Pos (Tok_Until));
+ Set_Name_Table_Byte (Name_Use, Token_Type'Pos (Tok_Use));
+ Set_Name_Table_Byte (Name_When, Token_Type'Pos (Tok_When));
+ Set_Name_Table_Byte (Name_While, Token_Type'Pos (Tok_While));
+ Set_Name_Table_Byte (Name_With, Token_Type'Pos (Tok_With));
+ Set_Name_Table_Byte (Name_Xor, Token_Type'Pos (Tok_Xor));
+
+ -- Initialize scan control variables
+
+ Current_Source_File := Index;
+ Source := Source_Text (Current_Source_File);
+ Current_Source_Unit := Unit;
+ Scan_Ptr := Source_First (Current_Source_File);
+ Token := No_Token;
+ Token_Ptr := Scan_Ptr;
+ Current_Line_Start := Scan_Ptr;
+ Token_Node := Empty;
+ Token_Name := No_Name;
+ Start_Column := Set_Start_Column;
+ First_Non_Blank_Location := Scan_Ptr;
+
+ Initialize_Checksum;
+
+ -- Do not call Scan, otherwise the License stuff does not work in Scn.
+
+ end Initialize_Scanner;
+
+ ------------------------------
+ -- Reset_Special_Characters --
+ ------------------------------
+
+ procedure Reset_Special_Characters is
+ begin
+ Special_Characters := (others => False);
+ end Reset_Special_Characters;
+
+ ----------
+ -- Scan --
+ ----------
+
+ procedure Scan is
+
+ procedure Check_End_Of_Line;
+ -- Called when end of line encountered. Checks that line is not
+ -- too long, and that other style checks for the end of line are met.
+
+ function Double_Char_Token (C : Character) return Boolean;
+ -- This function is used for double character tokens like := or <>. It
+ -- checks if the character following Source (Scan_Ptr) is C, and if so
+ -- bumps Scan_Ptr past the pair of characters and returns True. A space
+ -- between the two characters is also recognized with an appropriate
+ -- error message being issued. If C is not present, False is returned.
+ -- Note that Double_Char_Token can only be used for tokens defined in
+ -- the Ada syntax (it's use for error cases like && is not appropriate
+ -- since we do not want a junk message for a case like &-space-&).
+
+ procedure Error_Illegal_Character;
+ -- Give illegal character error, Scan_Ptr points to character.
+ -- On return, Scan_Ptr is bumped past the illegal character.
+
+ procedure Error_Illegal_Wide_Character;
+ -- Give illegal wide character message. On return, Scan_Ptr is bumped
+ -- past the illegal character, which may still leave us pointing to
+ -- junk, not much we can do if the escape sequence is messed up!
+
+ procedure Error_Long_Line;
+ -- Signal error of excessively long line
+
+ procedure Error_No_Double_Underline;
+ -- Signal error of double underline character
+
+ procedure Nlit;
+ -- This is the procedure for scanning out numeric literals. On entry,
+ -- Scan_Ptr points to the digit that starts the numeric literal (the
+ -- checksum for this character has not been accumulated yet). On return
+ -- Scan_Ptr points past the last character of the numeric literal, Token
+ -- and Token_Node are set appropriately, and the checksum is updated.
+
+ procedure Slit;
+ -- This is the procedure for scanning out string literals. On entry,
+ -- Scan_Ptr points to the opening string quote (the checksum for this
+ -- character has not been accumulated yet). On return Scan_Ptr points
+ -- past the closing quote of the string literal, Token and Token_Node
+ -- are set appropriately, and the checksum is upated.
+
+ -----------------------
+ -- Check_End_Of_Line --
+ -----------------------
+
+ procedure Check_End_Of_Line is
+ Len : constant Int := Int (Scan_Ptr) - Int (Current_Line_Start);
+
+ begin
+ if Style_Check and Style_Check_Max_Line_Length then
+ Style.Check_Line_Terminator (Len);
+
+ elsif Len > Hostparm.Max_Line_Length then
+ Error_Long_Line;
+ end if;
+ end Check_End_Of_Line;
+
+ -----------------------
+ -- Double_Char_Token --
+ -----------------------
+
+ function Double_Char_Token (C : Character) return Boolean is
+ begin
+ if Source (Scan_Ptr + 1) = C then
+ Accumulate_Checksum (C);
+ Scan_Ptr := Scan_Ptr + 2;
+ return True;
+
+ elsif Source (Scan_Ptr + 1) = ' '
+ and then Source (Scan_Ptr + 2) = C
+ then
+ Scan_Ptr := Scan_Ptr + 1;
+ Error_Msg_S ("no space allowed here");
+ Scan_Ptr := Scan_Ptr + 2;
+ return True;
+
+ else
+ return False;
+ end if;
+ end Double_Char_Token;
+
+ -----------------------------
+ -- Error_Illegal_Character --
+ -----------------------------
+
+ procedure Error_Illegal_Character is
+ begin
+ Error_Msg_S ("illegal character");
+ Scan_Ptr := Scan_Ptr + 1;
+ end Error_Illegal_Character;
+
+ ----------------------------------
+ -- Error_Illegal_Wide_Character --
+ ----------------------------------
+
+ procedure Error_Illegal_Wide_Character is
+ begin
+ if OpenVMS then
+ Error_Msg_S
+ ("illegal wide character, check " &
+ "'/'W'I'D'E'_'C'H'A'R'A'C'T'E'R'_'E'N'C'O'D'I'N'G qualifier");
+ else
+ Error_Msg_S
+ ("illegal wide character, check -gnatW switch");
+ end if;
+
+ Scan_Ptr := Scan_Ptr + 1;
+ end Error_Illegal_Wide_Character;
+
+ ---------------------
+ -- Error_Long_Line --
+ ---------------------
+
+ procedure Error_Long_Line is
+ begin
+ Error_Msg
+ ("this line is too long",
+ Current_Line_Start + Hostparm.Max_Line_Length);
+ end Error_Long_Line;
+
+ -------------------------------
+ -- Error_No_Double_Underline --
+ -------------------------------
+
+ procedure Error_No_Double_Underline is
+ begin
+ Error_Msg_S ("two consecutive underlines not permitted");
+ end Error_No_Double_Underline;
+
+ ----------
+ -- Nlit --
+ ----------
+
+ procedure Nlit is
+
+ C : Character;
+ -- Current source program character
+
+ Base_Char : Character;
+ -- Either # or : (character at start of based number)
+
+ Base : Int;
+ -- Value of base
+
+ UI_Base : Uint;
+ -- Value of base in Uint format
+
+ UI_Int_Value : Uint;
+ -- Value of integer scanned by Scan_Integer in Uint format
+
+ UI_Num_Value : Uint;
+ -- Value of integer in numeric value being scanned
+
+ Scale : Int;
+ -- Scale value for real literal
+
+ UI_Scale : Uint;
+ -- Scale in Uint format
+
+ Exponent_Is_Negative : Boolean;
+ -- Set true for negative exponent
+
+ Extended_Digit_Value : Int;
+ -- Extended digit value
+
+ Point_Scanned : Boolean;
+ -- Flag for decimal point scanned in numeric literal
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Error_Digit_Expected;
+ -- Signal error of bad digit, Scan_Ptr points to the location at
+ -- which the digit was expected on input, and is unchanged on return.
+
+ procedure Scan_Integer;
+ -- Procedure to scan integer literal. On entry, Scan_Ptr points to
+ -- a digit, on exit Scan_Ptr points past the last character of
+ -- the integer.
+ -- For each digit encountered, UI_Int_Value is multiplied by 10,
+ -- and the value of the digit added to the result. In addition,
+ -- the value in Scale is decremented by one for each actual digit
+ -- scanned.
+
+ --------------------------
+ -- Error_Digit_Expected --
+ --------------------------
+
+ procedure Error_Digit_Expected is
+ begin
+ Error_Msg_S ("digit expected");
+ end Error_Digit_Expected;
+
+ -------------------
+ -- Scan_Integer --
+ -------------------
+
+ procedure Scan_Integer is
+ C : Character;
+ -- Next character scanned
+
+ begin
+ C := Source (Scan_Ptr);
+
+ -- Loop through digits (allowing underlines)
+
+ loop
+ Accumulate_Checksum (C);
+ UI_Int_Value :=
+ UI_Int_Value * 10 + (Character'Pos (C) - Character'Pos ('0'));
+ Scan_Ptr := Scan_Ptr + 1;
+ Scale := Scale - 1;
+ C := Source (Scan_Ptr);
+
+ if C = '_' then
+ Accumulate_Checksum ('_');
+
+ loop
+ Scan_Ptr := Scan_Ptr + 1;
+ C := Source (Scan_Ptr);
+ exit when C /= '_';
+ Error_No_Double_Underline;
+ end loop;
+
+ if C not in '0' .. '9' then
+ Error_Digit_Expected;
+ exit;
+ end if;
+
+ else
+ exit when C not in '0' .. '9';
+ end if;
+ end loop;
+
+ end Scan_Integer;
+
+ ----------------------------------
+ -- Start of Processing for Nlit --
+ ----------------------------------
+
+ begin
+ Base := 10;
+ UI_Base := Uint_10;
+ UI_Int_Value := Uint_0;
+ Scale := 0;
+ Scan_Integer;
+ Scale := 0;
+ Point_Scanned := False;
+ UI_Num_Value := UI_Int_Value;
+
+ -- Various possibilities now for continuing the literal are
+ -- period, E/e (for exponent), or :/# (for based literal).
+
+ Scale := 0;
+ C := Source (Scan_Ptr);
+
+ if C = '.' then
+
+ -- Scan out point, but do not scan past .. which is a range
+ -- sequence, and must not be eaten up scanning a numeric literal.
+
+ while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop
+ Accumulate_Checksum ('.');
+
+ if Point_Scanned then
+ Error_Msg_S ("duplicate point ignored");
+ end if;
+
+ Point_Scanned := True;
+ Scan_Ptr := Scan_Ptr + 1;
+ C := Source (Scan_Ptr);
+
+ if C not in '0' .. '9' then
+ Error_Msg
+ ("real literal cannot end with point", Scan_Ptr - 1);
+ else
+ Scan_Integer;
+ UI_Num_Value := UI_Int_Value;
+ end if;
+ end loop;
+
+ -- Based literal case. The base is the value we already scanned.
+ -- In the case of colon, we insist that the following character
+ -- is indeed an extended digit or a period. This catches a number
+ -- of common errors, as well as catching the well known tricky
+ -- bug otherwise arising from "x : integer range 1 .. 10:= 6;"
+
+ elsif C = '#'
+ or else (C = ':' and then
+ (Source (Scan_Ptr + 1) = '.'
+ or else
+ Source (Scan_Ptr + 1) in '0' .. '9'
+ or else
+ Source (Scan_Ptr + 1) in 'A' .. 'Z'
+ or else
+ Source (Scan_Ptr + 1) in 'a' .. 'z'))
+ then
+ if C = ':' and then Warn_On_Obsolescent_Feature then
+ Error_Msg_S
+ ("use of "":"" is an obsolescent feature ('R'M 'J.2(3))?");
+ Error_Msg_S
+ ("\use ""'#"" instead?");
+ end if;
+
+ Accumulate_Checksum (C);
+ Base_Char := C;
+ UI_Base := UI_Int_Value;
+
+ if UI_Base < 2 or else UI_Base > 16 then
+ Error_Msg_SC ("base not 2-16");
+ UI_Base := Uint_16;
+ end if;
+
+ Base := UI_To_Int (UI_Base);
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- Scan out extended integer [. integer]
+
+ C := Source (Scan_Ptr);
+ UI_Int_Value := Uint_0;
+ Scale := 0;
+
+ loop
+ if C in '0' .. '9' then
+ Accumulate_Checksum (C);
+ Extended_Digit_Value :=
+ Int'(Character'Pos (C)) - Int'(Character'Pos ('0'));
+
+ elsif C in 'A' .. 'F' then
+ Accumulate_Checksum (Character'Val (Character'Pos (C) + 32));
+ Extended_Digit_Value :=
+ Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10;
+
+ elsif C in 'a' .. 'f' then
+ Accumulate_Checksum (C);
+ Extended_Digit_Value :=
+ Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10;
+
+ else
+ Error_Msg_S ("extended digit expected");
+ exit;
+ end if;
+
+ if Extended_Digit_Value >= Base then
+ Error_Msg_S ("digit '>= base");
+ end if;
+
+ UI_Int_Value := UI_Int_Value * UI_Base + Extended_Digit_Value;
+ Scale := Scale - 1;
+ Scan_Ptr := Scan_Ptr + 1;
+ C := Source (Scan_Ptr);
+
+ if C = '_' then
+ loop
+ Accumulate_Checksum ('_');
+ Scan_Ptr := Scan_Ptr + 1;
+ C := Source (Scan_Ptr);
+ exit when C /= '_';
+ Error_No_Double_Underline;
+ end loop;
+
+ elsif C = '.' then
+ Accumulate_Checksum ('.');
+
+ if Point_Scanned then
+ Error_Msg_S ("duplicate point ignored");
+ end if;
+
+ Scan_Ptr := Scan_Ptr + 1;
+ C := Source (Scan_Ptr);
+ Point_Scanned := True;
+ Scale := 0;
+
+ elsif C = Base_Char then
+ Accumulate_Checksum (C);
+ Scan_Ptr := Scan_Ptr + 1;
+ exit;
+
+ elsif C = '#' or else C = ':' then
+ Error_Msg_S ("based number delimiters must match");
+ Scan_Ptr := Scan_Ptr + 1;
+ exit;
+
+ elsif not Identifier_Char (C) then
+ if Base_Char = '#' then
+ Error_Msg_S ("missing '#");
+ else
+ Error_Msg_S ("missing ':");
+ end if;
+
+ exit;
+ end if;
+
+ end loop;
+
+ UI_Num_Value := UI_Int_Value;
+ end if;
+
+ -- Scan out exponent
+
+ if not Point_Scanned then
+ Scale := 0;
+ UI_Scale := Uint_0;
+ else
+ UI_Scale := UI_From_Int (Scale);
+ end if;
+
+ if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then
+ Accumulate_Checksum ('e');
+ Scan_Ptr := Scan_Ptr + 1;
+ Exponent_Is_Negative := False;
+
+ if Source (Scan_Ptr) = '+' then
+ Accumulate_Checksum ('+');
+ Scan_Ptr := Scan_Ptr + 1;
+
+ elsif Source (Scan_Ptr) = '-' then
+ Accumulate_Checksum ('-');
+
+ if not Point_Scanned then
+ Error_Msg_S
+ ("negative exponent not allowed for integer literal");
+ else
+ Exponent_Is_Negative := True;
+ end if;
+
+ Scan_Ptr := Scan_Ptr + 1;
+ end if;
+
+ UI_Int_Value := Uint_0;
+
+ if Source (Scan_Ptr) in '0' .. '9' then
+ Scan_Integer;
+ else
+ Error_Digit_Expected;
+ end if;
+
+ if Exponent_Is_Negative then
+ UI_Scale := UI_Scale - UI_Int_Value;
+ else
+ UI_Scale := UI_Scale + UI_Int_Value;
+ end if;
+ end if;
+
+ -- Case of real literal to be returned
+
+ if Point_Scanned then
+ Token := Tok_Real_Literal;
+ Real_Literal_Value :=
+ UR_From_Components (
+ Num => UI_Num_Value,
+ Den => -UI_Scale,
+ Rbase => Base);
+
+ -- Case of integer literal to be returned
+
+ else
+ Token := Tok_Integer_Literal;
+
+ if UI_Scale = 0 then
+ Int_Literal_Value := UI_Num_Value;
+
+ -- Avoid doing possibly expensive calculations in cases like
+ -- parsing 163E800_000# when semantics will not be done anyway.
+ -- This is especially useful when parsing garbled input.
+
+ elsif Operating_Mode /= Check_Syntax
+ and then (Serious_Errors_Detected = 0 or else Try_Semantics)
+ then
+ Int_Literal_Value := UI_Num_Value * UI_Base ** UI_Scale;
+
+ else
+ Int_Literal_Value := No_Uint;
+
+ end if;
+
+ end if;
+
+ return;
+
+ end Nlit;
+
+ ----------
+ -- Slit --
+ ----------
+
+ procedure Slit is
+
+ Delimiter : Character;
+ -- Delimiter (first character of string)
+
+ C : Character;
+ -- Current source program character
+
+ Code : Char_Code;
+ -- Current character code value
+
+ Err : Boolean;
+ -- Error flag for Scan_Wide call
+
+ procedure Error_Bad_String_Char;
+ -- Signal bad character in string/character literal. On entry
+ -- Scan_Ptr points to the improper character encountered during
+ -- the scan. Scan_Ptr is not modified, so it still points to the bad
+ -- character on return.
+
+ procedure Error_Unterminated_String;
+ -- Procedure called if a line terminator character is encountered
+ -- during scanning a string, meaning that the string is not properly
+ -- terminated.
+
+ procedure Set_String;
+ -- Procedure used to distinguish between string and operator symbol.
+ -- On entry the string has been scanned out, and its characters start
+ -- at Token_Ptr and end one character before Scan_Ptr. On exit Token
+ -- is set to Tok_String_Literal or Tok_Operator_Symbol as
+ -- appropriate, and Token_Node is appropriately initialized.
+ -- In addition, in the operator symbol case, Token_Name is
+ -- appropriately set.
+
+ ---------------------------
+ -- Error_Bad_String_Char --
+ ---------------------------
+
+ procedure Error_Bad_String_Char is
+ C : constant Character := Source (Scan_Ptr);
+
+ begin
+ if C = HT then
+ Error_Msg_S ("horizontal tab not allowed in string");
+
+ elsif C = VT or else C = FF then
+ Error_Msg_S ("format effector not allowed in string");
+
+ elsif C in Upper_Half_Character then
+ Error_Msg_S ("(Ada 83) upper half character not allowed");
+
+ else
+ Error_Msg_S ("control character not allowed in string");
+ end if;
+ end Error_Bad_String_Char;
+
+ -------------------------------
+ -- Error_Unterminated_String --
+ -------------------------------
+
+ procedure Error_Unterminated_String is
+ begin
+ -- An interesting little refinement. Consider the following
+ -- examples:
+
+ -- A := "this is an unterminated string;
+ -- A := "this is an unterminated string &
+ -- P(A, "this is a parameter that didn't get terminated);
+
+ -- We fiddle a little to do slightly better placement in these
+ -- cases also if there is white space at the end of the line we
+ -- place the flag at the start of this white space, not at the
+ -- end. Note that we only have to test for blanks, since tabs
+ -- aren't allowed in strings in the first place and would have
+ -- caused an error message.
+
+ -- Two more cases that we treat specially are:
+
+ -- A := "this string uses the wrong terminator'
+ -- A := "this string uses the wrong terminator' &
+
+ -- In these cases we give a different error message as well
+
+ -- We actually reposition the scan pointer to the point where we
+ -- place the flag in these cases, since it seems a better bet on
+ -- the original intention.
+
+ while Source (Scan_Ptr - 1) = ' '
+ or else Source (Scan_Ptr - 1) = '&'
+ loop
+ Scan_Ptr := Scan_Ptr - 1;
+ Unstore_String_Char;
+ end loop;
+
+ -- Check for case of incorrect string terminator, but single quote
+ -- is not considered incorrect if the opening terminator misused
+ -- a single quote (error message already given).
+
+ if Delimiter /= '''
+ and then Source (Scan_Ptr - 1) = '''
+ then
+ Unstore_String_Char;
+ Error_Msg
+ ("incorrect string terminator character", Scan_Ptr - 1);
+ return;
+ end if;
+
+ if Source (Scan_Ptr - 1) = ';' then
+ Scan_Ptr := Scan_Ptr - 1;
+ Unstore_String_Char;
+
+ if Source (Scan_Ptr - 1) = ')' then
+ Scan_Ptr := Scan_Ptr - 1;
+ Unstore_String_Char;
+ end if;
+ end if;
+
+ Error_Msg_S ("missing string quote");
+ end Error_Unterminated_String;
+
+ ----------------
+ -- Set_String --
+ ----------------
+
+ procedure Set_String is
+ Slen : constant Int := Int (Scan_Ptr - Token_Ptr - 2);
+ C1 : Character;
+ C2 : Character;
+ C3 : Character;
+
+ begin
+ -- Token_Name is currently set to Error_Name. The following
+ -- section of code resets Token_Name to the proper Name_Op_xx
+ -- value if the string is a valid operator symbol, otherwise it is
+ -- left set to Error_Name.
+
+ if Slen = 1 then
+ C1 := Source (Token_Ptr + 1);
+
+ case C1 is
+ when '=' =>
+ Token_Name := Name_Op_Eq;
+
+ when '>' =>
+ Token_Name := Name_Op_Gt;
+
+ when '<' =>
+ Token_Name := Name_Op_Lt;
+
+ when '+' =>
+ Token_Name := Name_Op_Add;
+
+ when '-' =>
+ Token_Name := Name_Op_Subtract;
+
+ when '&' =>
+ Token_Name := Name_Op_Concat;
+
+ when '*' =>
+ Token_Name := Name_Op_Multiply;
+
+ when '/' =>
+ Token_Name := Name_Op_Divide;
+
+ when others =>
+ null;
+ end case;
+
+ elsif Slen = 2 then
+ C1 := Source (Token_Ptr + 1);
+ C2 := Source (Token_Ptr + 2);
+
+ if C1 = '*' and then C2 = '*' then
+ Token_Name := Name_Op_Expon;
+
+ elsif C2 = '=' then
+
+ if C1 = '/' then
+ Token_Name := Name_Op_Ne;
+ elsif C1 = '<' then
+ Token_Name := Name_Op_Le;
+ elsif C1 = '>' then
+ Token_Name := Name_Op_Ge;
+ end if;
+
+ elsif (C1 = 'O' or else C1 = 'o') and then -- OR
+ (C2 = 'R' or else C2 = 'r')
+ then
+ Token_Name := Name_Op_Or;
+ end if;
+
+ elsif Slen = 3 then
+ C1 := Source (Token_Ptr + 1);
+ C2 := Source (Token_Ptr + 2);
+ C3 := Source (Token_Ptr + 3);
+
+ if (C1 = 'A' or else C1 = 'a') and then -- AND
+ (C2 = 'N' or else C2 = 'n') and then
+ (C3 = 'D' or else C3 = 'd')
+ then
+ Token_Name := Name_Op_And;
+
+ elsif (C1 = 'A' or else C1 = 'a') and then -- ABS
+ (C2 = 'B' or else C2 = 'b') and then
+ (C3 = 'S' or else C3 = 's')
+ then
+ Token_Name := Name_Op_Abs;
+
+ elsif (C1 = 'M' or else C1 = 'm') and then -- MOD
+ (C2 = 'O' or else C2 = 'o') and then
+ (C3 = 'D' or else C3 = 'd')
+ then
+ Token_Name := Name_Op_Mod;
+
+ elsif (C1 = 'N' or else C1 = 'n') and then -- NOT
+ (C2 = 'O' or else C2 = 'o') and then
+ (C3 = 'T' or else C3 = 't')
+ then
+ Token_Name := Name_Op_Not;
+
+ elsif (C1 = 'R' or else C1 = 'r') and then -- REM
+ (C2 = 'E' or else C2 = 'e') and then
+ (C3 = 'M' or else C3 = 'm')
+ then
+ Token_Name := Name_Op_Rem;
+
+ elsif (C1 = 'X' or else C1 = 'x') and then -- XOR
+ (C2 = 'O' or else C2 = 'o') and then
+ (C3 = 'R' or else C3 = 'r')
+ then
+ Token_Name := Name_Op_Xor;
+ end if;
+
+ end if;
+
+ -- If it is an operator symbol, then Token_Name is set.
+ -- If it is some other string value, then Token_Name still
+ -- contains Error_Name.
+
+ if Token_Name = Error_Name then
+ Token := Tok_String_Literal;
+
+ else
+ Token := Tok_Operator_Symbol;
+ end if;
+
+ end Set_String;
+
+ ----------
+ -- Slit --
+ ----------
+
+ begin
+ -- On entry, Scan_Ptr points to the opening character of the string
+ -- which is either a percent, double quote, or apostrophe
+ -- (single quote). The latter case is an error detected by
+ -- the character literal circuit.
+
+ Delimiter := Source (Scan_Ptr);
+ Accumulate_Checksum (Delimiter);
+ Start_String;
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- Loop to scan out characters of string literal
+
+ loop
+ C := Source (Scan_Ptr);
+
+ if C = Delimiter then
+ Accumulate_Checksum (C);
+ Scan_Ptr := Scan_Ptr + 1;
+ exit when Source (Scan_Ptr) /= Delimiter;
+ Code := Get_Char_Code (C);
+ Accumulate_Checksum (C);
+ Scan_Ptr := Scan_Ptr + 1;
+
+ else
+ if C = '"' and then Delimiter = '%' then
+ Error_Msg_S
+ ("quote not allowed in percent delimited string");
+ Code := Get_Char_Code (C);
+ Scan_Ptr := Scan_Ptr + 1;
+
+ elsif (C = ESC
+ and then
+ Wide_Character_Encoding_Method
+ in WC_ESC_Encoding_Method)
+ or else
+ (C in Upper_Half_Character
+ and then
+ Upper_Half_Encoding)
+ or else
+ (C = '['
+ and then
+ Source (Scan_Ptr + 1) = '"'
+ and then
+ Identifier_Char (Source (Scan_Ptr + 2)))
+ then
+ Scan_Wide (Source, Scan_Ptr, Code, Err);
+ Accumulate_Checksum (Code);
+
+ if Err then
+ Error_Illegal_Wide_Character;
+ Code := Get_Char_Code (' ');
+ end if;
+
+ else
+ Accumulate_Checksum (C);
+
+ if C not in Graphic_Character then
+ if C in Line_Terminator then
+ Error_Unterminated_String;
+ exit;
+
+ elsif C in Upper_Half_Character then
+ if Ada_83 then
+ Error_Bad_String_Char;
+ end if;
+
+ else
+ Error_Bad_String_Char;
+ end if;
+ end if;
+
+ Code := Get_Char_Code (C);
+ Scan_Ptr := Scan_Ptr + 1;
+ end if;
+ end if;
+
+ Store_String_Char (Code);
+
+ if not In_Character_Range (Code) then
+ Wide_Character_Found := True;
+ end if;
+ end loop;
+
+ String_Literal_Id := End_String;
+ Set_String;
+ return;
+
+ end Slit;
+
+ -- Start of body of Scan
+
+ begin
+ Prev_Token := Token;
+ Prev_Token_Ptr := Token_Ptr;
+ Token_Name := Error_Name;
+
+ -- The following loop runs more than once only if a format effector
+ -- (tab, vertical tab, form feed, line feed, carriage return) is
+ -- encountered and skipped, or some error situation, such as an
+ -- illegal character, is encountered.
+
+ loop
+ -- Skip past blanks, loop is opened up for speed
+
+ while Source (Scan_Ptr) = ' ' loop
+
+ if Source (Scan_Ptr + 1) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 1;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 2) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 2;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 3) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 3;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 4) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 4;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 5) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 5;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 6) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 6;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 7) /= ' ' then
+ Scan_Ptr := Scan_Ptr + 7;
+ exit;
+ end if;
+
+ Scan_Ptr := Scan_Ptr + 8;
+ end loop;
+
+ -- We are now at a non-blank character, which is the first character
+ -- of the token we will scan, and hence the value of Token_Ptr.
+
+ Token_Ptr := Scan_Ptr;
+
+ -- Here begins the main case statement which transfers control on
+ -- the basis of the non-blank character we have encountered.
+
+ case Source (Scan_Ptr) is
+
+ -- Line terminator characters
+
+ when CR | LF | FF | VT => Line_Terminator_Case : begin
+
+ -- Check line too long
+
+ Check_End_Of_Line;
+
+ -- Set Token_Ptr, if End_Of_Line is a token, for the case when
+ -- it is a physical line.
+
+ if End_Of_Line_Is_Token then
+ Token_Ptr := Scan_Ptr;
+ end if;
+
+ declare
+ Physical : Boolean;
+
+ begin
+ Skip_Line_Terminators (Scan_Ptr, Physical);
+
+ -- If we are at start of physical line, update scan pointers
+ -- to reflect the start of the new line.
+
+ if Physical then
+ Current_Line_Start := Scan_Ptr;
+ Start_Column := Set_Start_Column;
+ First_Non_Blank_Location := Scan_Ptr;
+
+ -- If End_Of_Line is a token, we return it as it is
+ -- a physical line.
+
+ if End_Of_Line_Is_Token then
+ Token := Tok_End_Of_Line;
+ return;
+ end if;
+ end if;
+ end;
+ end Line_Terminator_Case;
+
+ -- Horizontal tab, just skip past it
+
+ when HT =>
+ if Style_Check then Style.Check_HT; end if;
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- End of file character, treated as an end of file only if it
+ -- is the last character in the buffer, otherwise it is ignored.
+
+ when EOF =>
+ if Scan_Ptr = Source_Last (Current_Source_File) then
+ Check_End_Of_Line;
+ Token := Tok_EOF;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ end if;
+
+ -- Ampersand
+
+ when '&' =>
+ Accumulate_Checksum ('&');
+
+ if Source (Scan_Ptr + 1) = '&' then
+ Error_Msg_S ("'&'& should be `AND THEN`");
+ Scan_Ptr := Scan_Ptr + 2;
+ Token := Tok_And;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Ampersand;
+ return;
+ end if;
+
+ -- Asterisk (can be multiplication operator or double asterisk
+ -- which is the exponentiation compound delimiter).
+
+ when '*' =>
+ Accumulate_Checksum ('*');
+
+ if Source (Scan_Ptr + 1) = '*' then
+ Accumulate_Checksum ('*');
+ Scan_Ptr := Scan_Ptr + 2;
+ Token := Tok_Double_Asterisk;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Asterisk;
+ return;
+ end if;
+
+ -- Colon, which can either be an isolated colon, or part of an
+ -- assignment compound delimiter.
+
+ when ':' =>
+ Accumulate_Checksum (':');
+
+ if Double_Char_Token ('=') then
+ Token := Tok_Colon_Equal;
+ if Style_Check then Style.Check_Colon_Equal; end if;
+ return;
+
+ elsif Source (Scan_Ptr + 1) = '-'
+ and then Source (Scan_Ptr + 2) /= '-'
+ then
+ Token := Tok_Colon_Equal;
+ Error_Msg (":- should be :=", Scan_Ptr);
+ Scan_Ptr := Scan_Ptr + 2;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Colon;
+ if Style_Check then Style.Check_Colon; end if;
+ return;
+ end if;
+
+ -- Left parenthesis
+
+ when '(' =>
+ Accumulate_Checksum ('(');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Left_Paren;
+ if Style_Check then Style.Check_Left_Paren; end if;
+ return;
+
+ -- Left bracket
+
+ when '[' =>
+ if Source (Scan_Ptr + 1) = '"' then
+ Name_Len := 0;
+ goto Scan_Identifier;
+
+ else
+ Error_Msg_S ("illegal character, replaced by ""(""");
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Left_Paren;
+ return;
+ end if;
+
+ -- Left brace
+
+ when '{' =>
+ Error_Msg_S ("illegal character, replaced by ""(""");
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Left_Paren;
+ return;
+
+ -- Comma
+
+ when ',' =>
+ Accumulate_Checksum (',');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Comma;
+ if Style_Check then Style.Check_Comma; end if;
+ return;
+
+ -- Dot, which is either an isolated period, or part of a double
+ -- dot compound delimiter sequence. We also check for the case of
+ -- a digit following the period, to give a better error message.
+
+ when '.' =>
+ Accumulate_Checksum ('.');
+
+ if Double_Char_Token ('.') then
+ Token := Tok_Dot_Dot;
+ if Style_Check then Style.Check_Dot_Dot; end if;
+ return;
+
+ elsif Source (Scan_Ptr + 1) in '0' .. '9' then
+ Error_Msg_S ("numeric literal cannot start with point");
+ Scan_Ptr := Scan_Ptr + 1;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Dot;
+ return;
+ end if;
+
+ -- Equal, which can either be an equality operator, or part of the
+ -- arrow (=>) compound delimiter.
+
+ when '=' =>
+ Accumulate_Checksum ('=');
+
+ if Double_Char_Token ('>') then
+ Token := Tok_Arrow;
+ if Style_Check then Style.Check_Arrow; end if;
+ return;
+
+ elsif Source (Scan_Ptr + 1) = '=' then
+ Error_Msg_S ("== should be =");
+ Scan_Ptr := Scan_Ptr + 1;
+ end if;
+
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Equal;
+ return;
+
+ -- Greater than, which can be a greater than operator, greater than
+ -- or equal operator, or first character of a right label bracket.
+
+ when '>' =>
+ Accumulate_Checksum ('>');
+
+ if Double_Char_Token ('=') then
+ Token := Tok_Greater_Equal;
+ return;
+
+ elsif Double_Char_Token ('>') then
+ Token := Tok_Greater_Greater;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Greater;
+ return;
+ end if;
+
+ -- Less than, which can be a less than operator, less than or equal
+ -- operator, or the first character of a left label bracket, or the
+ -- first character of a box (<>) compound delimiter.
+
+ when '<' =>
+ Accumulate_Checksum ('<');
+
+ if Double_Char_Token ('=') then
+ Token := Tok_Less_Equal;
+ return;
+
+ elsif Double_Char_Token ('>') then
+ Token := Tok_Box;
+ if Style_Check then Style.Check_Box; end if;
+ return;
+
+ elsif Double_Char_Token ('<') then
+ Token := Tok_Less_Less;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Less;
+ return;
+ end if;
+
+ -- Minus, which is either a subtraction operator, or the first
+ -- character of double minus starting a comment
+
+ when '-' => Minus_Case : begin
+ if Source (Scan_Ptr + 1) = '>' then
+ Error_Msg_S ("invalid token");
+ Scan_Ptr := Scan_Ptr + 2;
+ Token := Tok_Arrow;
+ return;
+
+ elsif Source (Scan_Ptr + 1) /= '-' then
+ Accumulate_Checksum ('-');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Minus;
+ return;
+
+ -- Comment
+
+ else -- Source (Scan_Ptr + 1) = '-' then
+ if Style_Check then Style.Check_Comment; end if;
+ Scan_Ptr := Scan_Ptr + 2;
+
+ -- Loop to scan comment (this loop runs more than once only if
+ -- a horizontal tab or other non-graphic character is scanned)
+
+ loop
+ -- Scan to non graphic character (opened up for speed)
+
+ loop
+ exit when Source (Scan_Ptr) not in Graphic_Character;
+ Scan_Ptr := Scan_Ptr + 1;
+ exit when Source (Scan_Ptr) not in Graphic_Character;
+ Scan_Ptr := Scan_Ptr + 1;
+ exit when Source (Scan_Ptr) not in Graphic_Character;
+ Scan_Ptr := Scan_Ptr + 1;
+ exit when Source (Scan_Ptr) not in Graphic_Character;
+ Scan_Ptr := Scan_Ptr + 1;
+ exit when Source (Scan_Ptr) not in Graphic_Character;
+ Scan_Ptr := Scan_Ptr + 1;
+ end loop;
+
+ -- Keep going if horizontal tab
+
+ if Source (Scan_Ptr) = HT then
+ if Style_Check then Style.Check_HT; end if;
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- Terminate scan of comment if line terminator
+
+ elsif Source (Scan_Ptr) in Line_Terminator then
+ exit;
+
+ -- Terminate scan of comment if end of file encountered
+ -- (embedded EOF character or real last character in file)
+
+ elsif Source (Scan_Ptr) = EOF then
+ exit;
+
+ -- Keep going if character in 80-FF range, or is ESC. These
+ -- characters are allowed in comments by RM-2.1(1), 2.7(2).
+ -- They are allowed even in Ada 83 mode according to the
+ -- approved AI. ESC was added to the AI in June 93.
+
+ elsif Source (Scan_Ptr) in Upper_Half_Character
+ or else Source (Scan_Ptr) = ESC
+ then
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- Otherwise we have an illegal comment character
+
+ else
+ Error_Illegal_Character;
+ end if;
+
+ end loop;
+
+ -- Note that we do NOT execute a return here, instead we fall
+ -- through to reexecute the scan loop to look for a token.
+
+ end if;
+ end Minus_Case;
+
+ -- Double quote starting a string literal
+
+ when '"' =>
+ Slit;
+ Post_Scan;
+ return;
+
+ -- Percent starting a string literal
+
+ when '%' =>
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_S
+ ("use of ""'%"" is an obsolescent feature ('R'M 'J.2(4))?");
+ Error_Msg_S
+ ("\use """""" instead?");
+ end if;
+
+ Slit;
+ Post_Scan;
+ return;
+
+ -- Apostrophe. This can either be the start of a character literal,
+ -- or an isolated apostrophe used in a qualified expression or an
+ -- attribute. We treat it as a character literal if it does not
+ -- follow a right parenthesis, identifier, the keyword ALL or
+ -- a literal. This means that we correctly treat constructs like:
+
+ -- A := CHARACTER'('A');
+
+ -- Note that RM-2.2(7) does not require a separator between
+ -- "CHARACTER" and "'" in the above.
+
+ when ''' => Char_Literal_Case : declare
+ Code : Char_Code;
+ Err : Boolean;
+
+ begin
+ Accumulate_Checksum (''');
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- Here is where we make the test to distinguish the cases. Treat
+ -- as apostrophe if previous token is an identifier, right paren
+ -- or the reserved word "all" (latter case as in A.all'Address)
+ -- (or the reserved word "project" in project files).
+ -- Also treat it as apostrophe after a literal (this catches
+ -- some legitimate cases, like A."abs"'Address, and also gives
+ -- better error behavior for impossible cases like 123'xxx).
+
+ if Prev_Token = Tok_Identifier
+ or else Prev_Token = Tok_Right_Paren
+ or else Prev_Token = Tok_All
+ or else Prev_Token = Tok_Project
+ or else Prev_Token in Token_Class_Literal
+ then
+ Token := Tok_Apostrophe;
+ if Style_Check then Style.Check_Apostrophe; end if;
+ return;
+
+ -- Otherwise the apostrophe starts a character literal
+
+ else
+ -- Case of wide character literal with ESC or [ encoding
+
+ if (Source (Scan_Ptr) = ESC
+ and then
+ Wide_Character_Encoding_Method in WC_ESC_Encoding_Method)
+ or else
+ (Source (Scan_Ptr) in Upper_Half_Character
+ and then
+ Upper_Half_Encoding)
+ or else
+ (Source (Scan_Ptr) = '['
+ and then
+ Source (Scan_Ptr + 1) = '"')
+ then
+ Scan_Wide (Source, Scan_Ptr, Code, Err);
+ Accumulate_Checksum (Code);
+
+ if Err then
+ Error_Illegal_Wide_Character;
+ end if;
+
+ if Source (Scan_Ptr) /= ''' then
+ Error_Msg_S ("missing apostrophe");
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ end if;
+
+ -- If we do not find a closing quote in the expected place then
+ -- assume that we have a misguided attempt at a string literal.
+
+ -- However, if previous token is RANGE, then we return an
+ -- apostrophe instead since this gives better error recovery
+
+ elsif Source (Scan_Ptr + 1) /= ''' then
+
+ if Prev_Token = Tok_Range then
+ Token := Tok_Apostrophe;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr - 1;
+ Error_Msg_S
+ ("strings are delimited by double quote character");
+ Slit;
+ Post_Scan;
+ return;
+ end if;
+
+ -- Otherwise we have a (non-wide) character literal
+
+ else
+ Accumulate_Checksum (Source (Scan_Ptr));
+
+ if Source (Scan_Ptr) not in Graphic_Character then
+ if Source (Scan_Ptr) in Upper_Half_Character then
+ if Ada_83 then
+ Error_Illegal_Character;
+ end if;
+
+ else
+ Error_Illegal_Character;
+ end if;
+ end if;
+
+ Code := Get_Char_Code (Source (Scan_Ptr));
+ Scan_Ptr := Scan_Ptr + 2;
+ end if;
+
+ -- Fall through here with Scan_Ptr updated past the closing
+ -- quote, and Code set to the Char_Code value for the literal
+
+ Accumulate_Checksum (''');
+ Token := Tok_Char_Literal;
+ Set_Character_Literal_Name (Code);
+ Token_Name := Name_Find;
+ Character_Code := Code;
+ Post_Scan;
+ return;
+ end if;
+ end Char_Literal_Case;
+
+ -- Right parenthesis
+
+ when ')' =>
+ Accumulate_Checksum (')');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Right_Paren;
+ if Style_Check then Style.Check_Right_Paren; end if;
+ return;
+
+ -- Right bracket or right brace, treated as right paren
+
+ when ']' | '}' =>
+ Error_Msg_S ("illegal character, replaced by "")""");
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Right_Paren;
+ return;
+
+ -- Slash (can be division operator or first character of not equal)
+
+ when '/' =>
+ Accumulate_Checksum ('/');
+
+ if Double_Char_Token ('=') then
+ Token := Tok_Not_Equal;
+ return;
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Slash;
+ return;
+ end if;
+
+ -- Semicolon
+
+ when ';' =>
+ Accumulate_Checksum (';');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Semicolon;
+ if Style_Check then Style.Check_Semicolon; end if;
+ return;
+
+ -- Vertical bar
+
+ when '|' => Vertical_Bar_Case : begin
+ Accumulate_Checksum ('|');
+
+ -- Special check for || to give nice message
+
+ if Source (Scan_Ptr + 1) = '|' then
+ Error_Msg_S ("""'|'|"" should be `OR ELSE`");
+ Scan_Ptr := Scan_Ptr + 2;
+ Token := Tok_Or;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Vertical_Bar;
+ if Style_Check then Style.Check_Vertical_Bar; end if;
+ return;
+ end if;
+ end Vertical_Bar_Case;
+
+ -- Exclamation, replacement character for vertical bar
+
+ when '!' => Exclamation_Case : begin
+ Accumulate_Checksum ('!');
+
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_S
+ ("use of ""'!"" is an obsolescent feature ('R'M 'J.2(2))?");
+ Error_Msg_S
+ ("\use ""'|"" instead?");
+ end if;
+
+ if Source (Scan_Ptr + 1) = '=' then
+ Error_Msg_S ("'!= should be /=");
+ Scan_Ptr := Scan_Ptr + 2;
+ Token := Tok_Not_Equal;
+ return;
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Vertical_Bar;
+ return;
+ end if;
+
+ end Exclamation_Case;
+
+ -- Plus
+
+ when '+' => Plus_Case : begin
+ Accumulate_Checksum ('+');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Plus;
+ return;
+ end Plus_Case;
+
+ -- Digits starting a numeric literal
+
+ when '0' .. '9' =>
+ Nlit;
+
+ if Identifier_Char (Source (Scan_Ptr)) then
+ Error_Msg_S
+ ("delimiter required between literal and identifier");
+ end if;
+ Post_Scan;
+ return;
+
+ -- Lower case letters
+
+ when 'a' .. 'z' =>
+ Name_Len := 1;
+ Name_Buffer (1) := Source (Scan_Ptr);
+ Accumulate_Checksum (Name_Buffer (1));
+ Scan_Ptr := Scan_Ptr + 1;
+ goto Scan_Identifier;
+
+ -- Upper case letters
+
+ when 'A' .. 'Z' =>
+ Name_Len := 1;
+ Name_Buffer (1) :=
+ Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
+ Accumulate_Checksum (Name_Buffer (1));
+ Scan_Ptr := Scan_Ptr + 1;
+ goto Scan_Identifier;
+
+ -- Underline character
+
+ when '_' =>
+ if Special_Characters ('_') then
+ Token_Ptr := Scan_Ptr;
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_Special;
+ Special_Character := '_';
+ return;
+ end if;
+
+ Error_Msg_S ("identifier cannot start with underline");
+ Name_Len := 1;
+ Name_Buffer (1) := '_';
+ Scan_Ptr := Scan_Ptr + 1;
+ goto Scan_Identifier;
+
+ -- Space (not possible, because we scanned past blanks)
+
+ when ' ' =>
+ raise Program_Error;
+
+ -- Characters in top half of ASCII 8-bit chart
+
+ when Upper_Half_Character =>
+
+ -- Wide character case. Note that Scan_Identifier will issue
+ -- an appropriate message if wide characters are not allowed
+ -- in identifiers.
+
+ if Upper_Half_Encoding then
+ Name_Len := 0;
+ goto Scan_Identifier;
+
+ -- Otherwise we have OK Latin-1 character
+
+ else
+ -- Upper half characters may possibly be identifier letters
+ -- but can never be digits, so Identifier_Char can be used
+ -- to test for a valid start of identifier character.
+
+ if Identifier_Char (Source (Scan_Ptr)) then
+ Name_Len := 0;
+ goto Scan_Identifier;
+ else
+ Error_Illegal_Character;
+ end if;
+ end if;
+
+ when ESC =>
+
+ -- ESC character, possible start of identifier if wide characters
+ -- using ESC encoding are allowed in identifiers, which we can
+ -- tell by looking at the Identifier_Char flag for ESC, which is
+ -- only true if these conditions are met.
+
+ if Identifier_Char (ESC) then
+ Name_Len := 0;
+ goto Scan_Identifier;
+ else
+ Error_Illegal_Wide_Character;
+ end if;
+
+ -- Invalid control characters
+
+ when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | SO |
+ SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
+ EM | FS | GS | RS | US | DEL
+ =>
+ Error_Illegal_Character;
+
+ -- Invalid graphic characters
+
+ when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' =>
+ -- If Set_Special_Character has been called for this character,
+ -- set Scans.Special_Character and return a Special token.
+
+ if Special_Characters (Source (Scan_Ptr)) then
+ Token_Ptr := Scan_Ptr;
+ Token := Tok_Special;
+ Special_Character := Source (Scan_Ptr);
+ Scan_Ptr := Scan_Ptr + 1;
+ return;
+
+ -- otherwise, this is an illegal character
+
+ else
+ Error_Illegal_Character;
+ end if;
+
+ -- End switch on non-blank character
+
+ end case;
+
+ -- End loop past format effectors. The exit from this loop is by
+ -- executing a return statement following completion of token scan
+ -- (control never falls out of this loop to the code which follows)
+
+ end loop;
+
+ -- Identifier scanning routine. On entry, some initial characters
+ -- of the identifier may have already been stored in Name_Buffer.
+ -- If so, Name_Len has the number of characters stored. otherwise
+ -- Name_Len is set to zero on entry.
+
+ <<Scan_Identifier>>
+
+ -- This loop scans as fast as possible past lower half letters
+ -- and digits, which we expect to be the most common characters.
+
+ loop
+ if Source (Scan_Ptr) in 'a' .. 'z'
+ or else Source (Scan_Ptr) in '0' .. '9'
+ then
+ Name_Buffer (Name_Len + 1) := Source (Scan_Ptr);
+ Accumulate_Checksum (Source (Scan_Ptr));
+
+ elsif Source (Scan_Ptr) in 'A' .. 'Z' then
+ Name_Buffer (Name_Len + 1) :=
+ Character'Val (Character'Pos (Source (Scan_Ptr)) + 32);
+ Accumulate_Checksum (Name_Buffer (Name_Len + 1));
+ else
+ exit;
+ end if;
+
+ -- Open out the loop a couple of times for speed
+
+ if Source (Scan_Ptr + 1) in 'a' .. 'z'
+ or else Source (Scan_Ptr + 1) in '0' .. '9'
+ then
+ Name_Buffer (Name_Len + 2) := Source (Scan_Ptr + 1);
+ Accumulate_Checksum (Source (Scan_Ptr + 1));
+
+ elsif Source (Scan_Ptr + 1) in 'A' .. 'Z' then
+ Name_Buffer (Name_Len + 2) :=
+ Character'Val (Character'Pos (Source (Scan_Ptr + 1)) + 32);
+ Accumulate_Checksum (Name_Buffer (Name_Len + 2));
+
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Name_Len := Name_Len + 1;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 2) in 'a' .. 'z'
+ or else Source (Scan_Ptr + 2) in '0' .. '9'
+ then
+ Name_Buffer (Name_Len + 3) := Source (Scan_Ptr + 2);
+ Accumulate_Checksum (Source (Scan_Ptr + 2));
+
+ elsif Source (Scan_Ptr + 2) in 'A' .. 'Z' then
+ Name_Buffer (Name_Len + 3) :=
+ Character'Val (Character'Pos (Source (Scan_Ptr + 2)) + 32);
+ Accumulate_Checksum (Name_Buffer (Name_Len + 3));
+ else
+ Scan_Ptr := Scan_Ptr + 2;
+ Name_Len := Name_Len + 2;
+ exit;
+ end if;
+
+ if Source (Scan_Ptr + 3) in 'a' .. 'z'
+ or else Source (Scan_Ptr + 3) in '0' .. '9'
+ then
+ Name_Buffer (Name_Len + 4) := Source (Scan_Ptr + 3);
+ Accumulate_Checksum (Source (Scan_Ptr + 3));
+
+ elsif Source (Scan_Ptr + 3) in 'A' .. 'Z' then
+ Name_Buffer (Name_Len + 4) :=
+ Character'Val (Character'Pos (Source (Scan_Ptr + 3)) + 32);
+ Accumulate_Checksum (Name_Buffer (Name_Len + 4));
+
+ else
+ Scan_Ptr := Scan_Ptr + 3;
+ Name_Len := Name_Len + 3;
+ exit;
+ end if;
+
+ Scan_Ptr := Scan_Ptr + 4;
+ Name_Len := Name_Len + 4;
+ end loop;
+
+ -- If we fall through, then we have encountered either an underline
+ -- character, or an extended identifier character (i.e. one from the
+ -- upper half), or a wide character, or an identifier terminator.
+ -- The initial test speeds us up in the most common case where we
+ -- have an identifier terminator. Note that ESC is an identifier
+ -- character only if a wide character encoding method that uses
+ -- ESC encoding is active, so if we find an ESC character we know
+ -- that we have a wide character.
+
+ if Identifier_Char (Source (Scan_Ptr)) then
+
+ -- Case of underline
+
+ if Source (Scan_Ptr) = '_' then
+ Accumulate_Checksum ('_');
+
+ -- Check error case of identifier ending with underscore
+ -- In this case we ignore the underscore and do not store it.
+
+ if not Identifier_Char (Source (Scan_Ptr + 1)) then
+ Error_Msg_S ("identifier cannot end with underline");
+ Scan_Ptr := Scan_Ptr + 1;
+
+ -- Check error case of two underscores. In this case we do
+ -- not store the first underscore (we will store the second)
+
+ elsif Source (Scan_Ptr + 1) = '_' then
+ Error_No_Double_Underline;
+
+ -- Normal case of legal underscore
+
+ else
+ Name_Len := Name_Len + 1;
+ Name_Buffer (Name_Len) := '_';
+ end if;
+
+ Scan_Ptr := Scan_Ptr + 1;
+ goto Scan_Identifier;
+
+ -- Upper half character
+
+ elsif Source (Scan_Ptr) in Upper_Half_Character
+ and then not Upper_Half_Encoding
+ then
+ Accumulate_Checksum (Source (Scan_Ptr));
+ Store_Encoded_Character
+ (Get_Char_Code (Fold_Lower (Source (Scan_Ptr))));
+ Scan_Ptr := Scan_Ptr + 1;
+ goto Scan_Identifier;
+
+ -- Left bracket not followed by a quote terminates an identifier.
+ -- This is an error, but we don't want to give a junk error msg
+ -- about wide characters in this case!
+
+ elsif Source (Scan_Ptr) = '['
+ and then Source (Scan_Ptr + 1) /= '"'
+ then
+ null;
+
+ -- We know we have a wide character encoding here (the current
+ -- character is either ESC, left bracket, or an upper half
+ -- character depending on the encoding method).
+
+ else
+ -- Scan out the wide character and insert the appropriate
+ -- encoding into the name table entry for the identifier.
+
+ declare
+ Sptr : constant Source_Ptr := Scan_Ptr;
+ Code : Char_Code;
+ Err : Boolean;
+ Chr : Character;
+
+ begin
+ Scan_Wide (Source, Scan_Ptr, Code, Err);
+
+ -- If error, signal error
+
+ if Err then
+ Error_Illegal_Wide_Character;
+
+ -- If the character scanned is a normal identifier
+ -- character, then we treat it that way.
+
+ elsif In_Character_Range (Code)
+ and then Identifier_Char (Get_Character (Code))
+ then
+ Chr := Get_Character (Code);
+ Accumulate_Checksum (Chr);
+ Store_Encoded_Character
+ (Get_Char_Code (Fold_Lower (Chr)));
+
+ -- Character is not normal identifier character, store
+ -- it in encoded form.
+
+ else
+ Accumulate_Checksum (Code);
+ Store_Encoded_Character (Code);
+
+ -- Make sure we are allowing wide characters in
+ -- identifiers. Note that we allow wide character
+ -- notation for an OK identifier character. This
+ -- in particular allows bracket or other notation
+ -- to be used for upper half letters.
+
+ if Identifier_Character_Set /= 'w' then
+ Error_Msg
+ ("wide character not allowed in identifier", Sptr);
+ end if;
+ end if;
+ end;
+
+ goto Scan_Identifier;
+ end if;
+ end if;
+
+ -- Scan of identifier is complete. The identifier is stored in
+ -- Name_Buffer, and Scan_Ptr points past the last character.
+
+ Token_Name := Name_Find;
+
+ -- Here is where we check if it was a keyword
+
+ if Get_Name_Table_Byte (Token_Name) /= 0
+ and then (Ada_95 or else Token_Name not in Ada_95_Reserved_Words)
+ then
+ Token := Token_Type'Val (Get_Name_Table_Byte (Token_Name));
+
+ -- Deal with possible style check for non-lower case keyword,
+ -- but we don't treat ACCESS, DELTA, DIGITS, RANGE as keywords
+ -- for this purpose if they appear as attribute designators.
+ -- Actually we only check the first character for speed.
+
+ if Style_Check
+ and then Source (Token_Ptr) <= 'Z'
+ and then (Prev_Token /= Tok_Apostrophe
+ or else
+ (Token /= Tok_Access
+ and then Token /= Tok_Delta
+ and then Token /= Tok_Digits
+ and then Token /= Tok_Range))
+ then
+ Style.Non_Lower_Case_Keyword;
+ end if;
+
+ -- We must reset Token_Name since this is not an identifier
+ -- and if we leave Token_Name set, the parser gets confused
+ -- because it thinks it is dealing with an identifier instead
+ -- of the corresponding keyword.
+
+ Token_Name := No_Name;
+ return;
+
+ -- It is an identifier after all
+
+ else
+ Token := Tok_Identifier;
+ Post_Scan;
+ return;
+ end if;
+ end Scan;
+
+ ------------------------------
+ -- Set_End_Of_Line_As_Token --
+ ------------------------------
+
+ procedure Set_End_Of_Line_As_Token (Value : Boolean) is
+ begin
+ End_Of_Line_Is_Token := Value;
+ end Set_End_Of_Line_As_Token;
+
+ ---------------------------
+ -- Set_Special_Character --
+ ---------------------------
+
+ procedure Set_Special_Character (C : Character) is
+ begin
+ case C is
+ when '#' | '$' | '_' | '?' | '@' | '`' | '\' | '^' | '~' =>
+ Special_Characters (C) := True;
+
+ when others =>
+ null;
+ end case;
+ end Set_Special_Character;
+
+ ----------------------
+ -- Set_Start_Column --
+ ----------------------
+
+ -- Note: it seems at first glance a little expensive to compute this value
+ -- for every source line (since it is certainly not used for all source
+ -- lines). On the other hand, it doesn't take much more work to skip past
+ -- the initial white space on the line counting the columns than it would
+ -- to scan past the white space using the standard scanning circuits.
+
+ function Set_Start_Column return Column_Number is
+ Start_Column : Column_Number := 0;
+
+ begin
+ -- Outer loop scans past horizontal tab characters
+
+ Tabs_Loop : loop
+
+ -- Inner loop scans past blanks as fast as possible, bumping Scan_Ptr
+ -- past the blanks and adjusting Start_Column to account for them.
+
+ Blanks_Loop : loop
+ if Source (Scan_Ptr) = ' ' then
+ if Source (Scan_Ptr + 1) = ' ' then
+ if Source (Scan_Ptr + 2) = ' ' then
+ if Source (Scan_Ptr + 3) = ' ' then
+ if Source (Scan_Ptr + 4) = ' ' then
+ if Source (Scan_Ptr + 5) = ' ' then
+ if Source (Scan_Ptr + 6) = ' ' then
+ Scan_Ptr := Scan_Ptr + 7;
+ Start_Column := Start_Column + 7;
+ else
+ Scan_Ptr := Scan_Ptr + 6;
+ Start_Column := Start_Column + 6;
+ exit Blanks_Loop;
+ end if;
+ else
+ Scan_Ptr := Scan_Ptr + 5;
+ Start_Column := Start_Column + 5;
+ exit Blanks_Loop;
+ end if;
+ else
+ Scan_Ptr := Scan_Ptr + 4;
+ Start_Column := Start_Column + 4;
+ exit Blanks_Loop;
+ end if;
+ else
+ Scan_Ptr := Scan_Ptr + 3;
+ Start_Column := Start_Column + 3;
+ exit Blanks_Loop;
+ end if;
+ else
+ Scan_Ptr := Scan_Ptr + 2;
+ Start_Column := Start_Column + 2;
+ exit Blanks_Loop;
+ end if;
+ else
+ Scan_Ptr := Scan_Ptr + 1;
+ Start_Column := Start_Column + 1;
+ exit Blanks_Loop;
+ end if;
+ else
+ exit Blanks_Loop;
+ end if;
+ end loop Blanks_Loop;
+
+ -- Outer loop keeps going only if a horizontal tab follows
+
+ if Source (Scan_Ptr) = HT then
+ if Style_Check then Style.Check_HT; end if;
+ Scan_Ptr := Scan_Ptr + 1;
+ Start_Column := (Start_Column / 8) * 8 + 8;
+ else
+ exit Tabs_Loop;
+ end if;
+
+ end loop Tabs_Loop;
+
+ return Start_Column;
+ end Set_Start_Column;
+
+end Scng;
diff --git a/gcc/ada/scng.ads b/gcc/ada/scng.ads
new file mode 100644
index 00000000000..7ebb441f63e
--- /dev/null
+++ b/gcc/ada/scng.ads
@@ -0,0 +1,102 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S C N G --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains a generic lexical analyzer. This is used
+-- for scanning Ada source files or text files with an Ada-like syntax,
+-- such as project files. It is instantiated in Scn and Prj.Err.
+
+with Casing; use Casing;
+with Styleg;
+with Types; use Types;
+
+generic
+ with procedure Post_Scan;
+ -- Procedure called by Scan for the following tokens:
+ -- Tok_Char_Literal, Tok_Identifier, Tok_Real_Literal, Tok_Real_Literal,
+ -- Tok_Integer_Literal, Tok_String_Literal, Tok_Operator_Symbol.
+
+ with procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
+ -- Output a message at specified location
+
+ with procedure Error_Msg_S (Msg : String);
+ -- Output a message at current scan pointer location
+
+ with procedure Error_Msg_SC (Msg : String);
+ -- Output a message at the start of the current token
+
+ with procedure Error_Msg_SP (Msg : String);
+ -- Output a message at the start of the previous token
+
+ with package Style is new Styleg
+ (Error_Msg, Error_Msg_S, Error_Msg_SC, Error_Msg_SP);
+ -- Instantiation of Styleg with the same error reporting routines
+
+package Scng is
+
+ procedure Initialize_Scanner
+ (Unit : Unit_Number_Type;
+ Index : Source_File_Index);
+ -- Initialize lexical scanner for scanning a new file. The caller has
+ -- completed the construction of the Units.Table entry for the specified
+ -- Unit and Index references the corresponding source file. A special
+ -- case is when Unit = No_Unit_Number, and Index corresponds to the
+ -- source index for reading the configuration pragma file.
+ -- Initialize_Scanner does not call Scan.
+
+ procedure Scan;
+ -- Scan scans out the next token, and advances the scan state accordingly
+ -- (see package Scan_State for details). If the scan encounters an illegal
+ -- token, then an error message is issued pointing to the bad character,
+ -- and Scan returns a reasonable substitute token of some kind.
+ -- For tokens Char_Literal, Identifier, Real_Literal, Integer_Literal,
+ -- String_Literal and Operator_Symbol, Post_Scan is called after scanning.
+
+ function Determine_Token_Casing return Casing_Type;
+ pragma Inline (Determine_Token_Casing);
+ -- Determines the casing style of the current token, which is
+ -- either a keyword or an identifier. See also package Casing.
+
+ procedure Set_Special_Character (C : Character);
+ -- Indicate that one of the following character '#', '$', '?', '@', '`',
+ -- '\', '^', '_' or '~', when found is a Special token.
+
+ procedure Reset_Special_Characters;
+ -- Indicate that there is no characters that are Special tokens., which
+ -- is the default.
+
+ procedure Set_End_Of_Line_As_Token (Value : Boolean);
+ -- Indicate if End_Of_Line is a token or not.
+ -- By default, End_Of_Line is not a token.
+
+ function Set_Start_Column return Column_Number;
+ -- This routine is called with Scan_Ptr pointing to the first character
+ -- of a line. On exit, Scan_Ptr is advanced to the first non-blank
+ -- character of this line (or to the terminating format effector if the
+ -- line contains no non-blank characters), and the returned result is the
+ -- column number of this non-blank character (zero origin), which is the
+ -- value to be stored in the Start_Column scan variable.
+
+end Scng;
diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb
index d6d8a547043..edbb6ddb0cc 100644
--- a/gcc/ada/sem.adb
+++ b/gcc/ada/sem.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -80,8 +80,6 @@ package body Sem is
return;
end if;
- Current_Error_Node := N;
-
-- Otherwise processing depends on the node kind
case Nkind (N) is
@@ -640,7 +638,6 @@ package body Sem is
if Nkind (N) not in N_Subexpr then
Expand (N);
end if;
-
end Analyze;
-- Version with check(s) suppressed
@@ -649,7 +646,7 @@ package body Sem is
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
@@ -659,12 +656,12 @@ package body Sem is
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Analyze (N);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Analyze;
@@ -690,7 +687,7 @@ package body Sem is
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
@@ -700,16 +697,86 @@ package body Sem is
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Analyze_List (L);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Analyze_List;
+ --------------------------
+ -- Copy_Suppress_Status --
+ --------------------------
+
+ procedure Copy_Suppress_Status
+ (C : Check_Id;
+ From : Entity_Id;
+ To : Entity_Id)
+ is
+ begin
+ if not Checks_May_Be_Suppressed (From) then
+ return;
+ end if;
+
+ -- First search the local entity suppress table, we search this in
+ -- reverse order so that we get the innermost entry that applies to
+ -- this case if there are nested entries. Note that for the purpose
+ -- of this procedure we are ONLY looking for entries corresponding
+ -- to a two-argument Suppress, where the second argument matches From.
+
+ for J in
+ reverse Local_Entity_Suppress.First .. Local_Entity_Suppress.Last
+ loop
+ declare
+ R : Entity_Check_Suppress_Record
+ renames Local_Entity_Suppress.Table (J);
+
+ begin
+ if R.Entity = From
+ and then (R.Check = All_Checks or else R.Check = C)
+ then
+ if R.Suppress then
+ Set_Checks_May_Be_Suppressed (To, True);
+ Local_Entity_Suppress.Append
+ ((Entity => To,
+ Check => C,
+ Suppress => True));
+ return;
+ end if;
+ end if;
+ end;
+ end loop;
+
+ -- Now search the global entity suppress table for a matching entry
+ -- We also search this in reverse order so that if there are multiple
+ -- pragmas for the same entity, the last one applies.
+
+ for J in
+ reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last
+ loop
+ declare
+ R : Entity_Check_Suppress_Record
+ renames Global_Entity_Suppress.Table (J);
+
+ begin
+ if R.Entity = From
+ and then (R.Check = All_Checks or else R.Check = C)
+ then
+ if R.Suppress then
+ Set_Checks_May_Be_Suppressed (To, True);
+ Local_Entity_Suppress.Append
+ ((Entity => To,
+ Check => C,
+ Suppress => True));
+ end if;
+ end if;
+ end;
+ end loop;
+ end Copy_Suppress_Status;
+
-------------------------
-- Enter_Generic_Scope --
-------------------------
@@ -730,48 +797,75 @@ package body Sem is
if S = Outer_Generic_Scope then
Outer_Generic_Scope := Empty;
end if;
- end Exit_Generic_Scope;
+ end Exit_Generic_Scope;
+
+ -----------------------
+ -- Explicit_Suppress --
+ -----------------------
+
+ function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
+ begin
+ if not Checks_May_Be_Suppressed (E) then
+ return False;
+
+ else
+ for J in
+ reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last
+ loop
+ declare
+ R : Entity_Check_Suppress_Record
+ renames Global_Entity_Suppress.Table (J);
+
+ begin
+ if R.Entity = E
+ and then (R.Check = All_Checks or else R.Check = C)
+ then
+ return R.Suppress;
+ end if;
+ end;
+ end loop;
+
+ return False;
+ end if;
+ end Explicit_Suppress;
-----------------------------
-- External_Ref_In_Generic --
-----------------------------
function External_Ref_In_Generic (E : Entity_Id) return Boolean is
- begin
+ Scop : Entity_Id;
+ begin
-- Entity is global if defined outside of current outer_generic_scope:
-- Either the entity has a smaller depth that the outer generic, or it
- -- is in a different compilation unit.
+ -- is in a different compilation unit, or it is defined within a unit
+ -- in the same compilation, that is not within the outer_generic.
- return Present (Outer_Generic_Scope)
- and then (Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
- or else not In_Same_Source_Unit (E, Outer_Generic_Scope));
- end External_Ref_In_Generic;
+ if No (Outer_Generic_Scope) then
+ return False;
- ------------------------
- -- Get_Scope_Suppress --
- ------------------------
+ elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
+ or else not In_Same_Source_Unit (E, Outer_Generic_Scope)
+ then
+ return True;
- function Get_Scope_Suppress (C : Check_Id) return Boolean is
- S : Suppress_Record renames Scope_Suppress;
+ else
+ Scop := Scope (E);
+
+ while Present (Scop) loop
+ if Scop = Outer_Generic_Scope then
+ return False;
+ elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then
+ return True;
+ else
+ Scop := Scope (Scop);
+ end if;
+ end loop;
- begin
- case C is
- when Access_Check => return S.Access_Checks;
- when Accessibility_Check => return S.Accessibility_Checks;
- when Discriminant_Check => return S.Discriminant_Checks;
- when Division_Check => return S.Division_Checks;
- when Elaboration_Check => return S.Discriminant_Checks;
- when Index_Check => return S.Elaboration_Checks;
- when Length_Check => return S.Discriminant_Checks;
- when Overflow_Check => return S.Overflow_Checks;
- when Range_Check => return S.Range_Checks;
- when Storage_Check => return S.Storage_Checks;
- when Tag_Check => return S.Tag_Checks;
- when All_Checks =>
- raise Program_Error;
- end case;
- end Get_Scope_Suppress;
+ return True;
+ end if;
+ end External_Ref_In_Generic;
----------------
-- Initialize --
@@ -779,7 +873,8 @@ package body Sem is
procedure Initialize is
begin
- Entity_Suppress.Init;
+ Local_Entity_Suppress.Init;
+ Global_Entity_Suppress.Init;
Scope_Stack.Init;
Unloaded_Subunits := False;
end Initialize;
@@ -821,18 +916,19 @@ package body Sem is
end loop;
end if;
end if;
-
end Insert_After_And_Analyze;
-- Version with check(s) suppressed
procedure Insert_After_And_Analyze
- (N : Node_Id; M : Node_Id; Suppress : Check_Id)
+ (N : Node_Id;
+ M : Node_Id;
+ Suppress : Check_Id)
is
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
@@ -842,12 +938,12 @@ package body Sem is
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Insert_After_And_Analyze (N, M);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Insert_After_And_Analyze;
@@ -882,18 +978,19 @@ package body Sem is
Next (Node);
end loop;
end if;
-
end Insert_Before_And_Analyze;
-- Version with check(s) suppressed
procedure Insert_Before_And_Analyze
- (N : Node_Id; M : Node_Id; Suppress : Check_Id)
+ (N : Node_Id;
+ M : Node_Id;
+ Suppress : Check_Id)
is
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
@@ -903,12 +1000,12 @@ package body Sem is
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Insert_Before_And_Analyze (N, M);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Insert_Before_And_Analyze;
@@ -944,7 +1041,6 @@ package body Sem is
Next (Node);
end loop;
end if;
-
end Insert_List_After_And_Analyze;
-- Version with check(s) suppressed
@@ -955,7 +1051,7 @@ package body Sem is
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
@@ -965,12 +1061,12 @@ package body Sem is
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Insert_List_After_And_Analyze (N, L);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Insert_List_After_And_Analyze;
@@ -1005,7 +1101,6 @@ package body Sem is
Next (Node);
end loop;
end if;
-
end Insert_List_Before_And_Analyze;
-- Version with check(s) suppressed
@@ -1016,7 +1111,7 @@ package body Sem is
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
@@ -1026,25 +1121,81 @@ package body Sem is
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Insert_List_Before_And_Analyze (N, L);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Insert_List_Before_And_Analyze;
+ -------------------------
+ -- Is_Check_Suppressed --
+ -------------------------
+
+ function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
+ begin
+ -- First search the local entity suppress table, we search this in
+ -- reverse order so that we get the innermost entry that applies to
+ -- this case if there are nested entries.
+
+ for J in
+ reverse Local_Entity_Suppress.First .. Local_Entity_Suppress.Last
+ loop
+ declare
+ R : Entity_Check_Suppress_Record
+ renames Local_Entity_Suppress.Table (J);
+
+ begin
+ if (R.Entity = Empty or else R.Entity = E)
+ and then (R.Check = All_Checks or else R.Check = C)
+ then
+ return R.Suppress;
+ end if;
+ end;
+ end loop;
+
+ -- Now search the global entity suppress table for a matching entry
+ -- We also search this in reverse order so that if there are multiple
+ -- pragmas for the same entity, the last one applies (not clear what
+ -- or whether the RM specifies this handling, but it seems reasonable).
+
+ for J in
+ reverse Global_Entity_Suppress.First .. Global_Entity_Suppress.Last
+ loop
+ declare
+ R : Entity_Check_Suppress_Record
+ renames Global_Entity_Suppress.Table (J);
+
+ begin
+ if R.Entity = E
+ and then (R.Check = All_Checks or else R.Check = C)
+ then
+ return R.Suppress;
+ end if;
+ end;
+ end loop;
+
+ -- If we did not find a matching entry, then use the normal scope
+ -- suppress value after all (actually this will be the global setting
+ -- since it clearly was not overridden at any point)
+
+ return Scope_Suppress (C);
+ end Is_Check_Suppressed;
+
----------
-- Lock --
----------
procedure Lock is
begin
- Entity_Suppress.Locked := True;
+ Local_Entity_Suppress.Locked := True;
+ Global_Entity_Suppress.Locked := True;
Scope_Stack.Locked := True;
- Entity_Suppress.Release;
+ Local_Entity_Suppress.Release;
+ Global_Entity_Suppress.Release;
Scope_Stack.Release;
end Lock;
@@ -1067,6 +1218,13 @@ package body Sem is
S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
S_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
+ Generic_Main : constant Boolean :=
+ Nkind (Unit (Cunit (Main_Unit)))
+ in N_Generic_Declaration;
+
+ -- If the main unit is generic, every compiled unit, including its
+ -- context, is compiled with expansion disabled.
+
Save_Config_Switches : Config_Switches_Type;
-- Variable used to save values of config switches while we analyze
-- the new unit, to be restored on exit for proper recursive behavior.
@@ -1075,6 +1233,10 @@ package body Sem is
-- Procedure to analyze the compilation unit. This is called more
-- than once when the high level optimizer is activated.
+ ----------------
+ -- Do_Analyze --
+ ----------------
+
procedure Do_Analyze is
begin
Save_Scope_Stack;
@@ -1101,14 +1263,18 @@ package body Sem is
Restore_Scope_Stack;
end Do_Analyze;
- -- Start of processing for Sem
+ -- Start of processing for Semantics
begin
Compiler_State := Analyzing;
Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit);
- Expander_Mode_Save_And_Set
- (Operating_Mode = Generate_Code or Debug_Flag_X);
+ if Generic_Main then
+ Expander_Mode_Save_And_Set (False);
+ else
+ Expander_Mode_Save_And_Set
+ (Operating_Mode = Generate_Code or Debug_Flag_X);
+ end if;
Full_Analysis := True;
Inside_A_Generic := False;
@@ -1153,30 +1319,4 @@ package body Sem is
Expander_Mode_Restore;
end Semantics;
-
- ------------------------
- -- Set_Scope_Suppress --
- ------------------------
-
- procedure Set_Scope_Suppress (C : Check_Id; B : Boolean) is
- S : Suppress_Record renames Scope_Suppress;
-
- begin
- case C is
- when Access_Check => S.Access_Checks := B;
- when Accessibility_Check => S.Accessibility_Checks := B;
- when Discriminant_Check => S.Discriminant_Checks := B;
- when Division_Check => S.Division_Checks := B;
- when Elaboration_Check => S.Discriminant_Checks := B;
- when Index_Check => S.Elaboration_Checks := B;
- when Length_Check => S.Discriminant_Checks := B;
- when Overflow_Check => S.Overflow_Checks := B;
- when Range_Check => S.Range_Checks := B;
- when Storage_Check => S.Storage_Checks := B;
- when Tag_Check => S.Tag_Checks := B;
- when All_Checks =>
- raise Program_Error;
- end case;
- end Set_Scope_Suppress;
-
end Sem;
diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads
index 5d4ca4687e0..ccd082debcc 100644
--- a/gcc/ada/sem.ads
+++ b/gcc/ada/sem.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -30,7 +30,7 @@
-- Semantic processing involves 3 phases which are highly interwined
-- (ie mutually recursive):
---
+
-- Analysis implements the bulk of semantic analysis such as
-- name analysis and type resolution for declarations,
-- instructions and expressions. The main routine
@@ -41,7 +41,7 @@
-- For expressions this phase determines unambiguous types
-- and collects sets of possible types where the
-- interpretation is potentially ambiguous.
---
+
-- Resolution is carried out only for expressions to finish type
-- resolution that was initiated but not necessarily
-- completed during analysis (because of overloading
@@ -50,7 +50,7 @@
-- Resolve routine (see the spec of sem_res for more info)
-- is called to perform a top down resolution with
-- recursive calls to itself to resolve operands.
---
+
-- Expansion if we are not generating code this phase is a no-op.
-- otherwise this phase expands, ie transforms, original
-- declaration, expressions or instructions into simpler
@@ -67,7 +67,7 @@
-- and declarations or the call to Resolve for expressions.
-- The main routine driving expansion is Expand.
-- See the spec of Expander for more details.
---
+
-- To summarize, in normal code generation mode we recursively traverse the
-- abstract syntax tree top-down performing semantic analysis bottom
-- up. For instructions and declarations, before the call to the Analyze
@@ -78,53 +78,63 @@
-- ambiguities in the expression. Just before the call to Resolve
-- terminates, the expression can be expanded since all the semantic
-- information is available at that point.
---
+
-- If we are not generating code then the expansion phase is a no-op.
---
+
-- When generating code there are a number of exceptions to the basic
-- Analysis-Resolution-Expansion model for expressions. The most prominent
-- examples are the handling of default expressions and aggregates.
--------------------------------------
--- Handling of Default Expressions --
--------------------------------------
+----------------------------------------------------
+-- Handling of Default and Per-Object Expressions --
+----------------------------------------------------
-- The default expressions in component declarations and in procedure
-- specifications (but not the ones in object declarations) are quite
-- tricky to handle. The problem is that some processing is required
-- at the point where the expression appears:
---
+
-- visibility analysis (including user defined operators)
-- freezing of static expressions
---
+
-- but other processing must be deferred until the enclosing entity
-- (record or procedure specification) is frozen:
---
+
-- freezing of any other types in the expression
-- expansion
---
+
+-- A similar situation occurs with the argument of priority and interrupt
+-- priority pragmas that appear in task and protected definition specs and
+-- other cases of per-object expressions (see RM 3.8(18)).
+
-- Expansion has to be deferred since you can't generate code for
-- expressions that refernce types that have not been frozen yet. As an
-- example, consider the following:
---
+
-- type x is delta 0.5 range -10.0 .. +10.0;
-- ...
-- type q is record
-- xx : x := y * z;
-- end record;
---
+
-- for x'small use 0.25
---
+
-- The expander is in charge of dealing with fixed-point, and of course
-- the small declaration, which is not too late, since the declaration of
-- type q does *not* freeze type x, definitely affects the expanded code.
---
+
+-- Another reason that we cannot expand early is that expansion can generate
+-- range checks. These range checks need to be inserted not at the point of
+-- definition but at the point of use. The whole point here is that the value
+-- of the expression cannot be obtained at the point of declaration, only at
+-- the point of use.
+
-- Generally our model is to combine analysis resolution and expansion, but
-- this is the one case where this model falls down. Here is how we patch
-- it up without causing too much distortion to our basic model.
---
+
-- A switch (sede below) is set to indicate that we are in the initial
--- occurrence of a default expression. The analyzer is then called on this
+-- occurence of a default expression. The analyzer is then called on this
-- expression with the switch set true. Analysis and resolution proceed
-- almost as usual, except that Freeze_Expression will not freeze
-- non-static expressions if this switch is set, and the call to Expand at
@@ -136,11 +146,13 @@
-- expression with the switch off. The effect is that this second analysis
-- freezes the rest of the types as required, and generates code but
-- visibility analysis is not repeated since all the entities are marked.
---
+
-- The second analysis (the one that generates code) is in the context
-- where the code is required. For a record field default, this is in
-- the initialization procedure for the record and for a subprogram
-- default parameter, it is at the point the subprogram is frozen.
+-- For a priority or storage size pragma it is in the context of the
+-- Init_Proc for the task or protected object.
------------------
-- Pre-Analysis --
@@ -185,7 +197,6 @@
with Alloc;
with Einfo; use Einfo;
with Opt; use Opt;
-with Snames; use Snames;
with Table;
with Types; use Types;
@@ -199,6 +210,11 @@ package Sem is
-- Semantic Analysis Flags --
-----------------------------
+ Explicit_Overriding : Boolean := False;
+ -- Switch to indicate whether checking mechanism described in AI-218
+ -- is enforced: subprograms that override inherited operations must be
+ -- be marked explicitly, to prevent accidental or omitted overriding.
+
Full_Analysis : Boolean := True;
-- Switch to indicate whether we are doing a full analysis or a
-- pre-analysis. In normal analysis mode (Analysis-Expansion for
@@ -221,6 +237,13 @@ package Sem is
-- When this switch is True then Full_Analysis above must be False.
-- You should really regard this as a read only flag.
+ In_Deleted_Code : Boolean := False;
+ -- If the condition in an if-statement is statically known, the branch
+ -- that is not taken is analyzed with expansion disabled, and the tree
+ -- is deleted after analysis. Itypes generated in deleted code must be
+ -- frozen from start, because the tree on which they depend will not
+ -- be available at the freeze point.
+
In_Inlined_Body : Boolean := False;
-- Switch to indicate that we are analyzing and resolving an inlined
-- body. Type checking is disabled in this context, because types are
@@ -246,12 +269,6 @@ package Sem is
-- Scope Stack --
-----------------
- Scope_Suppress : Suppress_Record := Suppress_Options;
- -- This record contains the current scope based settings of the suppress
- -- switches. It is initialized from the options as shown, and then modified
- -- by pragma Suppress. On entry to each scope, the current setting is saved
- -- the scope stack, and then restored on exit from the scope.
-
-- The scope stack holds all entries of the scope table. As in the parser,
-- we use Last as the stack pointer, so that we can always find the scope
-- that is currently open in Scope_Stack.Table (Scope_Stack.Last). The
@@ -259,56 +276,6 @@ package Sem is
-- include the entity for the referenced scope, together with information
-- used to restore the proper setting of check suppressions on scope exit.
- -- There are two kinds of suppress checks, scope based suppress checks
- -- (from initial command line arguments, or from Suppress pragmas not
- -- including an entity name). The scope based suppress checks are recorded
- -- in the Sem.Supress variable, and all that is necessary is to save the
- -- state of this variable on scope entry, and restore it on scope exit.
-
- -- The other kind of suppress check is entity based suppress checks, from
- -- Suppress pragmas giving an Entity_Id. These checks are reflected by the
- -- appropriate bit being set in the corresponding entity, and restoring the
- -- setting of these bits is a little trickier. In particular a given pragma
- -- Suppress may or may not affect the current state. If it sets a check for
- -- an entity that is already checked, then it is important that this check
- -- not be restored on scope exit. The situation is made more complicated
- -- by the fact that a given suppress pragma can specify multiple entities
- -- (in the overloaded case), and multiple checks (by using All_Checks), so
- -- that it may be partially effective. On exit only checks that were in
- -- fact effective must be removed. Logically we could do this by saving
- -- the entire state of the entity flags on scope entry and restoring them
- -- on scope exit, but that would be ludicrous, so what we do instead is to
- -- maintain the following differential structure that shows what checks
- -- were installed for the current scope.
-
- -- Note: Suppress pragmas that specify entities defined in a package
- -- spec do not make entries in this table, since such checks suppress
- -- requests are valid for the entire life of the entity.
-
- type Entity_Check_Suppress_Record is record
- Entity : Entity_Id;
- -- Entity to which the check applies
-
- Check : Check_Id;
- -- Check which is set (note this cannot be All_Checks, if the All_Checks
- -- case, a sequence of eentries appears for the individual checks.
- end record;
-
- -- Entity_Suppress is a stack, to which new entries are added as they
- -- are processed (see pragma Suppress circuit in Sem_Prag). The scope
- -- stack entry simply saves the stack pointer on entry, and restores
- -- it on exit by reversing the checks one by one.
-
- package Entity_Suppress is new Table.Table (
- Table_Component_Type => Entity_Check_Suppress_Record,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => Alloc.Entity_Suppress_Initial,
- Table_Increment => Alloc.Entity_Suppress_Increment,
- Table_Name => "Entity_Suppress");
-
- -- Here is the scope stack itself
-
type Scope_Stack_Entry is record
Entity : Entity_Id;
-- Entity representing the scope
@@ -317,11 +284,11 @@ package Sem is
-- Pointer to name of last subprogram body in this scope. Used for
-- testing proper alpha ordering of subprogram bodies in scope.
- Save_Scope_Suppress : Suppress_Record;
+ Save_Scope_Suppress : Suppress_Array;
-- Save contents of Scope_Suppress on entry
- Save_Entity_Suppress : Int;
- -- Save contents of Entity_Suppress.Last on entry
+ Save_Local_Entity_Suppress : Int;
+ -- Save contents of Local_Entity_Suppress.Last on entry
Is_Transient : Boolean;
-- Marks Transient Scopes (See Exp_Ch7 body for details)
@@ -376,11 +343,89 @@ package Sem is
Table_Increment => Alloc.Scope_Stack_Increment,
Table_Name => "Sem.Scope_Stack");
- function Get_Scope_Suppress (C : Check_Id) return Boolean;
- -- Get suppress status of check C for the current scope
+ -----------------------------------
+ -- Handling of Check Suppression --
+ -----------------------------------
- procedure Set_Scope_Suppress (C : Check_Id; B : Boolean);
- -- Set suppress status of check C for the current scope
+ -- There are two kinds of suppress checks, scope based suppress checks
+ -- (from initial command line arguments, or from Suppress pragmas not
+ -- including an entity name). The scope based suppress checks are recorded
+ -- in the Sem.Supress variable, and all that is necessary is to save the
+ -- state of this variable on scope entry, and restore it on scope exit.
+
+ -- The other kind of suppress check is entity based suppress checks, from
+ -- Suppress pragmas giving an Entity_Id. These are handled as follows. If
+ -- a suppress or unsuppress pragma is encountered for a given entity, then
+ -- the flag Checks_May_Be_Suppressed is set in the entity and an entry is
+ -- made in either the Local_Entity_Suppress table (case of pragma that
+ -- appears in other than a package spec), or in the Global_Entity_Suppress
+ -- table (case of pragma that appears in a package spec, which is by the
+ -- rule of RM 11.5(7) applicable throughout the life of the entity).
+
+ -- If the Checks_May_Be_Suppressed flag is set in an entity then the
+ -- procedure is to search first the local and then the global suppress
+ -- tables (the local one being searched in reverse order, i.e. last in
+ -- searched first). The only other point is that we have to make sure
+ -- that we have proper nested interaction between such specific pragmas
+ -- and locally applied general pragmas applying to all entities. This
+ -- is achieved by including in the Local_Entity_Suppress table dummy
+ -- entries with an empty Entity field that are applicable to all entities.
+
+ Scope_Suppress : Suppress_Array := Suppress_Options;
+ -- This array contains the current scope based settings of the suppress
+ -- switches. It is initialized from the options as shown, and then modified
+ -- by pragma Suppress. On entry to each scope, the current setting is saved
+ -- the scope stack, and then restored on exit from the scope. This record
+ -- may be rapidly checked to determine the current status of a check if
+ -- no specific entity is involved or if the specific entity involved is
+ -- one for which no specific Suppress/Unsuppress pragma has been set (as
+ -- indicated by the Checks_May_Be_Suppressed flag being set).
+
+ -- This scheme is a little complex, but serves the purpose of enabling
+ -- a very rapid check in the common case where no entity specific pragma
+ -- applies, and gives the right result when such pragmas are used even
+ -- in complex cases of nested Suppress and Unsuppress pragmas.
+
+ type Entity_Check_Suppress_Record is record
+ Entity : Entity_Id;
+ -- Entity to which the check applies, or Empty for a local check
+ -- that has no entity name (and thus applies to all entities).
+
+ Check : Check_Id;
+ -- Check which is set (note this cannot be All_Checks, if the All_Checks
+ -- case, a sequence of eentries appears for the individual checks.
+
+ Suppress : Boolean;
+ -- Set True for Suppress, and False for Unsuppress
+ end record;
+
+ -- The Local_Entity_Suppress table is a stack, to which new entries are
+ -- added for Suppress and Unsuppress pragmas appearing in other than
+ -- package specs. Such pragmas are effective only to the end of the scope
+ -- in which they appear. This is achieved by marking the stack on entry
+ -- to a scope and then cutting back the stack to that marked point on
+ -- scope exit.
+
+ package Local_Entity_Suppress is new Table.Table (
+ Table_Component_Type => Entity_Check_Suppress_Record,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => Alloc.Entity_Suppress_Initial,
+ Table_Increment => Alloc.Entity_Suppress_Increment,
+ Table_Name => "Local_Entity_Suppress");
+
+ -- The Global_Entity_Suppress table is used for entities which have
+ -- a Suppress or Unsuppress pragma naming a specific entity in a
+ -- package spec. Such pragmas always refer to entities in the package
+ -- spec and are effective throughout the lifetime of the named entity.
+
+ package Global_Entity_Suppress is new Table.Table (
+ Table_Component_Type => Entity_Check_Suppress_Record,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => Alloc.Entity_Suppress_Initial,
+ Table_Increment => Alloc.Entity_Suppress_Increment,
+ Table_Name => "Global_Entity_Suppress");
-----------------
-- Subprograms --
@@ -428,6 +473,13 @@ package Sem is
-- then the analysis is done with the specified check suppressed (can
-- be All_Checks to suppress all checks).
+ procedure Copy_Suppress_Status
+ (C : Check_Id;
+ From : Entity_Id;
+ To : Entity_Id);
+ -- If From is an entity for which check C is explicitly suppressed
+ -- then also explicitly suppress the corresponding check in To.
+
procedure Insert_List_After_And_Analyze
(N : Node_Id; L : List_Id);
procedure Insert_List_After_And_Analyze
@@ -487,4 +539,15 @@ package Sem is
-- exited. S is the entity of the scope.
-- ??? At the moment, only called for package specs exit.
+ function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean;
+ -- This function returns True if an explicit pragma Suppress for check C
+ -- is present in the package defining E.
+
+ function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean;
+ -- This function is called if Checks_May_Be_Suppressed (E) is True to
+ -- determine whether check C is suppressed either on the entity E or
+ -- as the result of a scope suppress pragma. If Checks_May_Be_Suppressed
+ -- is False, then the status of the check can be determined simply by
+ -- examining Scope_Checks (C), so this routine is not called in that case.
+
end Sem;
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 6ddeaab6c91..d02abfd52dd 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,6 +32,7 @@ with Errout; use Errout;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Itypes; use Itypes;
+with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
@@ -44,10 +45,12 @@ with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
+with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stringt; use Stringt;
with Stand; use Stand;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
@@ -103,7 +106,7 @@ package body Sem_Aggr is
-- yields the aggregate format expected by Gigi. Typically, this kind of
-- tree manipulations are done in the expander. However, because the
-- semantic checks that need to be performed on record aggregates really
- -- go hand in hand with the record aggreagate normalization, the aggregate
+ -- go hand in hand with the record aggregate normalization, the aggregate
-- subtree transformation is performed during resolution rather than
-- expansion. Had we decided otherwise we would have had to duplicate
-- most of the code in the expansion procedure Expand_Record_Aggregate.
@@ -315,7 +318,7 @@ package body Sem_Aggr is
-- entails the following code modifications
--
-- P7b : constant Acc_Rec := new Rec;
- -- Rec_init_proc (P7b.all);
+ -- RecIP (P7b.all);
-- Arr : array (1..3) of Acc_Rec := (1 .. 3 => P7b);
--
-- This code transformation is clearly wrong, since we need to call
@@ -454,12 +457,13 @@ package body Sem_Aggr is
else
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
+ Check_Unset_Reference (Exp);
end if;
else
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
+ Check_Unset_Reference (Exp);
end if;
-
end if;
end Aggregate_Constraint_Checks;
@@ -578,7 +582,7 @@ package body Sem_Aggr is
Itype : Entity_Id;
-- the final itype of the overall aggregate
- Index_Constraints : List_Id := New_List;
+ Index_Constraints : constant List_Id := New_List;
-- The list of index constraints of the aggregate itype.
-- Start of processing for Array_Aggr_Subtype
@@ -594,7 +598,8 @@ package body Sem_Aggr is
for J in 1 .. Aggr_Dimension loop
Create_Index : declare
- Index_Base : Entity_Id := Base_Type (Etype (Aggr_Range (J)));
+ Index_Base : constant Entity_Id :=
+ Base_Type (Etype (Aggr_Range (J)));
Index_Typ : Entity_Id;
begin
@@ -633,10 +638,11 @@ package body Sem_Aggr is
Set_Etype (Itype, Base_Type (Typ));
Set_Has_Alignment_Clause (Itype, Has_Alignment_Clause (Typ));
Set_Is_Aliased (Itype, Is_Aliased (Typ));
- Set_Suppress_Index_Checks (Itype, Suppress_Index_Checks (Typ));
- Set_Suppress_Length_Checks (Itype, Suppress_Length_Checks (Typ));
Set_Depends_On_Private (Itype, Depends_On_Private (Typ));
+ Copy_Suppress_Status (Index_Check, Typ, Itype);
+ Copy_Suppress_Status (Length_Check, Typ, Itype);
+
Set_First_Index (Itype, First (Index_Constraints));
Set_Is_Constrained (Itype, True);
Set_Is_Internal (Itype, True);
@@ -802,16 +808,17 @@ package body Sem_Aggr is
--------------------------------
procedure Make_String_Into_Aggregate (N : Node_Id) is
- C : Char_Code;
- C_Node : Node_Id;
- Exprs : List_Id := New_List;
+ Exprs : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (N);
- New_N : Node_Id;
- P : Source_Ptr := Loc + 1;
Str : constant String_Id := Strval (N);
Strlen : constant Nat := String_Length (Str);
+ C : Char_Code;
+ C_Node : Node_Id;
+ New_N : Node_Id;
+ P : Source_Ptr;
begin
+ P := Loc + 1;
for J in 1 .. Strlen loop
C := Get_String_Char (Str, J);
Set_Character_Literal_Name (C);
@@ -821,7 +828,7 @@ package body Sem_Aggr is
Append_To (Exprs, C_Node);
P := P + 1;
- -- something special for wide strings ?
+ -- something special for wide strings ???
end loop;
New_N := Make_Aggregate (Loc, Expressions => Exprs);
@@ -843,11 +850,25 @@ package body Sem_Aggr is
-- which is the subtype of the context in which the aggregate was found.
begin
- if Is_Limited_Type (Typ) then
- Error_Msg_N ("aggregate type cannot be limited", N);
+ -- Check for aggregates not allowed in configurable run-time mode.
+ -- We allow all cases of aggregates that do not come from source,
+ -- since these are all assumed to be small (e.g. bounds of a string
+ -- literal). We also allow aggregates of types we know to be small.
+
+ if not Support_Aggregates_On_Target
+ and then Comes_From_Source (N)
+ and then (not Known_Static_Esize (Typ) or else Esize (Typ) > 64)
+ then
+ Error_Msg_CRT ("aggregate", N);
+ end if;
- elsif Is_Limited_Composite (Typ) then
+ if Is_Limited_Composite (Typ) then
Error_Msg_N ("aggregate type cannot have limited component", N);
+ Explain_Limited_Type (Typ, N);
+
+ elsif Is_Limited_Type (Typ) then
+ Error_Msg_N ("aggregate type cannot be limited", N);
+ Explain_Limited_Type (Typ, N);
elsif Is_Class_Wide_Type (Typ) then
Error_Msg_N ("type of aggregate cannot be class-wide", N);
@@ -917,7 +938,8 @@ package body Sem_Aggr is
Array_Aggregate : declare
Aggr_Resolved : Boolean;
- Aggr_Typ : Entity_Id := Etype (Typ);
+
+ Aggr_Typ : constant Entity_Id := Etype (Typ);
-- This is the unconstrained array type, which is the type
-- against which the aggregate is to be resoved. Typ itself
-- is the array type of the context which may not be the same
@@ -998,7 +1020,6 @@ package body Sem_Aggr is
Set_Etype (N, Aggr_Subtyp);
Set_Analyzed (N);
end if;
-
end Resolve_Aggregate;
-----------------------------
@@ -1203,13 +1224,13 @@ package body Sem_Aggr is
if OK_L and then Val_L > Val_AL then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("lower bound of aggregate out of range?", N);
- Error_Msg_N ("Constraint_Error will be raised at run-time?", N);
+ Error_Msg_N ("\Constraint_Error will be raised at run-time?", N);
end if;
if OK_H and then Val_H < Val_AH then
Set_Raises_Constraint_Error (N);
Error_Msg_N ("upper bound of aggregate out of range?", N);
- Error_Msg_N ("Constraint_Error will be raised at run-time?", N);
+ Error_Msg_N ("\Constraint_Error will be raised at run-time?", N);
end if;
end Check_Bounds;
@@ -1309,9 +1330,9 @@ package body Sem_Aggr is
Single_Elmt : Boolean)
return Boolean
is
- Nxt_Ind : Node_Id := Next_Index (Index);
- Nxt_Ind_Constr : Node_Id := Next_Index (Index_Constr);
- -- Index is the current index corresponding to the expression.
+ Nxt_Ind : constant Node_Id := Next_Index (Index);
+ Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr);
+ -- Index is the current index corresponding to the expresion.
Resolution_OK : Boolean := True;
-- Set to False if resolution of the expression failed.
@@ -1364,6 +1385,7 @@ package body Sem_Aggr is
Analyze_And_Resolve (Expr, Component_Typ);
Check_Non_Static_Context (Expr);
Aggregate_Constraint_Checks (Expr, Component_Typ);
+ Check_Unset_Reference (Expr);
end if;
if Raises_Constraint_Error (Expr)
@@ -1557,6 +1579,7 @@ package body Sem_Aggr is
else -- Choice is a range or an expression
Resolve (Choice, Index_Base);
+ Check_Unset_Reference (Choice);
Check_Non_Static_Context (Choice);
-- Do not range check a choice. This check is redundant
@@ -1817,6 +1840,7 @@ package body Sem_Aggr is
Set_Parent (Aggregate_Bounds (N), N);
Analyze_And_Resolve (Aggregate_Bounds (N), Index_Typ);
+ Check_Unset_Reference (Aggregate_Bounds (N));
if not Others_Present and then Nb_Discrete_Choices = 0 then
Set_High_Bound (Aggregate_Bounds (N),
@@ -1848,16 +1872,19 @@ package body Sem_Aggr is
-- of the expected type.
procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id) is
- A : constant Node_Id := Ancestor_Part (N);
- A_Type : Entity_Id;
- I : Interp_Index;
- It : Interp;
- Imm_Type : Entity_Id;
+ A : constant Node_Id := Ancestor_Part (N);
+ A_Type : Entity_Id;
+ I : Interp_Index;
+ It : Interp;
function Valid_Ancestor_Type return Boolean;
-- Verify that the type of the ancestor part is a non-private ancestor
-- of the expected type.
+ -------------------------
+ -- Valid_Ancestor_Type --
+ -------------------------
+
function Valid_Ancestor_Type return Boolean is
Imm_Type : Entity_Id;
@@ -1888,6 +1915,7 @@ package body Sem_Aggr is
elsif Is_Limited_Type (Typ) then
Error_Msg_N ("aggregate type cannot be limited", N);
+ Explain_Limited_Type (Typ, N);
return;
elsif Is_Class_Wide_Type (Typ) then
@@ -1898,8 +1926,7 @@ package body Sem_Aggr is
if Is_Entity_Name (A)
and then Is_Type (Entity (A))
then
- A_Type := Get_Full_View (Entity (A));
- Imm_Type := Base_Type (Typ);
+ A_Type := Get_Full_View (Entity (A));
if Valid_Ancestor_Type then
Set_Entity (A, A_Type);
@@ -1942,14 +1969,28 @@ package body Sem_Aggr is
if Valid_Ancestor_Type then
Resolve (A, A_Type);
+ Check_Unset_Reference (A);
Check_Non_Static_Context (A);
- Resolve_Record_Aggregate (N, Typ);
+
+ if Is_Class_Wide_Type (Etype (A))
+ and then Nkind (Original_Node (A)) = N_Function_Call
+ then
+ -- If the ancestor part is a dispatching call, it appears
+ -- statically to be a legal ancestor, but it yields any
+ -- member of the class, and it is not possible to determine
+ -- whether it is an ancestor of the extension aggregate (much
+ -- less which ancestor). It is not possible to determine the
+ -- required components of the extension part.
+
+ Error_Msg_N ("ancestor part must be statically tagged", A);
+ else
+ Resolve_Record_Aggregate (N, Typ);
+ end if;
end if;
else
Error_Msg_N (" No unique type for this aggregate", A);
end if;
-
end Resolve_Extension_Aggregate;
------------------------------
@@ -1957,10 +1998,8 @@ package body Sem_Aggr is
------------------------------
procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate;
-
- New_Assoc_List : List_Id := New_List;
- New_Assoc : Node_Id;
+ New_Assoc_List : constant List_Id := New_List;
+ New_Assoc : Node_Id;
-- New_Assoc_List is the newly built list of N_Component_Association
-- nodes. New_Assoc is one such N_Component_Association node in it.
-- Please note that while Assoc and New_Assoc contain the same
@@ -1985,7 +2024,7 @@ package body Sem_Aggr is
function Discr_Present (Discr : Entity_Id) return Boolean;
-- If aggregate N is a regular aggregate this routine will return True.
- -- Otherwise, if N is an extension aggreagte, Discr is a discriminant
+ -- Otherwise, if N is an extension aggregate, Discr is a discriminant
-- whose value may already have been specified by N's ancestor part,
-- this routine checks whether this is indeed the case and if so
-- returns False, signaling that no value for Discr should appear in the
@@ -2019,15 +2058,15 @@ package body Sem_Aggr is
-- It finally saves a Expr in the newly created association list that
-- will be attached to the final record aggregate. Note that if the
-- Parent pointer of Expr is not set then Expr was produced with a
- -- New_copy_Tree or some such.
+ -- New_Copy_Tree or some such.
---------------------
-- Add_Association --
---------------------
procedure Add_Association (Component : Entity_Id; Expr : Node_Id) is
+ Choice_List : constant List_Id := New_List;
New_Assoc : Node_Id;
- Choice_List : List_Id := New_List;
begin
Append (New_Occurrence_Of (Component, Sloc (Expr)), Choice_List);
@@ -2043,6 +2082,8 @@ package body Sem_Aggr is
-------------------
function Discr_Present (Discr : Entity_Id) return Boolean is
+ Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate;
+
Loc : Source_Ptr;
Ancestor : Node_Id;
@@ -2156,27 +2197,13 @@ package body Sem_Aggr is
-- We need to duplicate the expression for each
-- successive component covered by the others choice.
- -- If the expression is itself an array aggregate with
- -- "others", its subtype must be obtained from the
- -- current component, and therefore it must be (at least
- -- partly) reanalyzed.
-
- if Analyzed (Expression (Assoc)) then
- Expr := New_Copy_Tree (Expression (Assoc));
-
- if Nkind (Expr) = N_Aggregate
- and then Is_Array_Type (Etype (Expr))
- and then No (Expressions (Expr))
- and then
- Nkind (First (Choices
- (First (Component_Associations (Expr)))))
- = N_Others_Choice
- then
- Set_Analyzed (Expr, False);
- end if;
-
- return Expr;
+ -- This is redundant if the others_choice covers only
+ -- one component (small optimization possible???), but
+ -- indispensable otherwise, because each one must be
+ -- expanded individually to preserve side-effects.
+ if Expander_Active then
+ return New_Copy_Tree (Expression (Assoc));
else
return Expression (Assoc);
end if;
@@ -2184,6 +2211,7 @@ package body Sem_Aggr is
elsif Chars (Compon) = Chars (Selector_Name) then
if No (Expr) then
+
-- We need to duplicate the expression when several
-- components are grouped together with a "|" choice.
-- For instance "filed1 | filed2 => Expr"
@@ -2194,6 +2222,8 @@ package body Sem_Aggr is
Expr := Expression (Assoc);
end if;
+ Generate_Reference (Compon, Selector_Name);
+
else
Error_Msg_NE
("more than one value supplied for &",
@@ -2285,8 +2315,8 @@ package body Sem_Aggr is
-- For each range in an array type where a discriminant has been
-- replaced with the constraint, check that this range is within
-- the range of the base type. This checks is done in the
- -- _init_proc for regular objects, but has to be done here for
- -- aggregates since no _init_proc is called for them.
+ -- init proc for regular objects, but has to be done here for
+ -- aggregates since no init proc is called for them.
if Is_Array_Type (Expr_Type) then
declare
@@ -2334,6 +2364,7 @@ package body Sem_Aggr is
Analyze_And_Resolve (Expr, Expr_Type);
Check_Non_Static_Context (Expr);
+ Check_Unset_Reference (Expr);
if not Has_Expansion_Delayed (Expr) then
Aggregate_Constraint_Checks (Expr, Expr_Type);
@@ -2348,7 +2379,6 @@ package body Sem_Aggr is
else
Add_Association (New_C, Expr);
end if;
-
end Resolve_Aggr_Expr;
-- Resolve_Record_Aggregate local variables
@@ -2358,10 +2388,10 @@ package body Sem_Aggr is
Expr : Node_Id;
Positional_Expr : Node_Id;
+ Component : Entity_Id;
+ Component_Elmt : Elmt_Id;
- Component : Entity_Id;
- Component_Elmt : Elmt_Id;
- Components : Elist_Id := New_Elmt_List;
+ Components : constant Elist_Id := New_Elmt_List;
-- Components is the list of the record components whose value must
-- be provided in the aggregate. This list does include discriminants.
@@ -2539,7 +2569,7 @@ package body Sem_Aggr is
Subtyp_Decl : Node_Id;
Def_Id : Entity_Id;
- C : List_Id := New_List;
+ C : constant List_Id := New_List;
begin
New_Assoc := First (New_Assoc_List);
@@ -2615,7 +2645,7 @@ package body Sem_Aggr is
-- error which will get signalled later so skip this part.
-- Otherwise, gather components of root that apply to the
-- aggregate type. We use the base type in case there is an
- -- applicable girder constraint that renames the discriminants
+ -- applicable stored constraint that renames the discriminants
-- of the root.
if Nkind (Dnode) = N_Full_Type_Declaration then
@@ -2634,10 +2664,10 @@ package body Sem_Aggr is
Prepend_Elmt (Parent_Typ, To => Parent_Typ_List);
Parent_Typ := Etype (Parent_Typ);
- if (Nkind (Parent (Base_Type (Parent_Typ))) =
+ if Nkind (Parent (Base_Type (Parent_Typ))) =
N_Private_Type_Declaration
- or else Nkind (Parent (Base_Type (Parent_Typ))) =
- N_Private_Extension_Declaration)
+ or else Nkind (Parent (Base_Type (Parent_Typ))) =
+ N_Private_Extension_Declaration
then
if Nkind (N) /= N_Extension_Aggregate then
Error_Msg_NE
@@ -2811,7 +2841,7 @@ package body Sem_Aggr is
-- STEP 8: replace the original aggregate
Step_8 : declare
- New_Aggregate : Node_Id := New_Copy (N);
+ New_Aggregate : constant Node_Id := New_Copy (N);
begin
Set_Expressions (New_Aggregate, No_List);
@@ -2827,8 +2857,8 @@ package body Sem_Aggr is
---------------------
procedure Sort_Case_Table (Case_Table : in out Case_Table_Type) is
- L : Int := Case_Table'First;
- U : Int := Case_Table'Last;
+ L : constant Int := Case_Table'First;
+ U : constant Int := Case_Table'Last;
K : Int;
J : Int;
T : Case_Bounds;
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index ca6b3ea0204..83833c15b5a 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.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,6 +35,7 @@ with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Expander; use Expander;
with Freeze; use Freeze;
+with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nlists; use Nlists;
@@ -42,6 +43,7 @@ with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
+with Sdefault; use Sdefault;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
@@ -78,7 +80,7 @@ package body Sem_Attr is
-- The following array is the list of attributes defined in the Ada 83 RM
- Attribute_83 : Attribute_Class_Array := Attribute_Class_Array'(
+ Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Address |
Attribute_Aft |
Attribute_Alignment |
@@ -171,16 +173,11 @@ package body Sem_Attr is
P_Base_Type : Entity_Id;
-- Base type of prefix after analysis
- P_Root_Type : Entity_Id;
- -- Root type of prefix after analysis
-
- Unanalyzed : Node_Id;
-
-----------------------
-- Local Subprograms --
-----------------------
- procedure Access_Attribute;
+ procedure Analyze_Access_Attribute;
-- Used for Access, Unchecked_Access, Unrestricted_Access attributes.
-- Internally, Id distinguishes which of the three cases is involved.
@@ -279,10 +276,10 @@ package body Sem_Attr is
procedure Check_Standard_Prefix;
-- Verify that prefix of attribute N is package Standard
- procedure Check_Stream_Attribute (Nam : Name_Id);
- -- Validity checking for stream attribute. Nam is the name of the
+ procedure Check_Stream_Attribute (Nam : TSS_Name_Type);
+ -- Validity checking for stream attribute. Nam is the TSS name of the
-- corresponding possible defined attribute function (e.g. for the
- -- Read attribute, Nam will be Name_uRead).
+ -- Read attribute, Nam will be TSS_Stream_Read).
procedure Check_Task_Prefix;
-- Verify that prefix of attribute N is a task or task type
@@ -301,10 +298,14 @@ package body Sem_Attr is
procedure Error_Attr (Msg : String; Error_Node : Node_Id);
pragma No_Return (Error_Attr);
+ procedure Error_Attr;
+ pragma No_Return (Error_Attr);
-- Posts error using Error_Msg_N at given node, sets type of attribute
-- node to Any_Type, and then raises Bad_Attribute to avoid any further
-- semantic processing. The message typically contains a % insertion
- -- character which is replaced by the attribute name.
+ -- character which is replaced by the attribute name. The call with
+ -- no arguments is used when the caller has already generated the
+ -- required error messages.
procedure Standard_Attribute (Val : Int);
-- Used to process attributes whose prefix is package Standard which
@@ -320,11 +321,11 @@ package body Sem_Attr is
-- non-scalar arguments or returns a non-scalar result. Verifies that
-- such a call does not appear in a preelaborable context.
- ----------------------
- -- Access_Attribute --
- ----------------------
+ ------------------------------
+ -- Analyze_Access_Attribute --
+ ------------------------------
- procedure Access_Attribute is
+ procedure Analyze_Access_Attribute is
Acc_Type : Entity_Id;
Scop : Entity_Id;
@@ -378,6 +379,10 @@ package body Sem_Attr is
-- Distinguish between access to regular and protected
-- subprograms.
+ --------------
+ -- Get_Kind --
+ --------------
+
function Get_Kind (E : Entity_Id) return Entity_Kind is
begin
if Convention (E) = Convention_Protected then
@@ -422,7 +427,7 @@ package body Sem_Attr is
end if;
end Build_Access_Subprogram_Type;
- -- Start of processing for Access_Attribute
+ -- Start of processing for Analyze_Access_Attribute
begin
Check_E0;
@@ -430,12 +435,13 @@ package body Sem_Attr is
if Nkind (P) = N_Character_Literal then
Error_Attr
("prefix of % attribute cannot be enumeration literal", P);
+ end if;
-- In the case of an access to subprogram, use the name of the
-- subprogram itself as the designated type. Type-checking in
-- this case compares the signatures of the designated types.
- elsif Is_Entity_Name (P)
+ if Is_Entity_Name (P)
and then Is_Overloadable (Entity (P))
then
if not Is_Library_Level_Entity (Entity (P)) then
@@ -443,12 +449,21 @@ package body Sem_Attr is
end if;
Build_Access_Subprogram_Type (P);
+
+ -- For unrestricted access, kill current values, since this
+ -- attribute allows a reference to a local subprogram that
+ -- could modify local variables to be passed out of scope
+
+ if Aname = Name_Unrestricted_Access then
+ Kill_Current_Values;
+ end if;
+
return;
-- Component is an operation of a protected type.
- elsif (Nkind (P) = N_Selected_Component
- and then Is_Overloadable (Entity (Selector_Name (P))))
+ elsif Nkind (P) = N_Selected_Component
+ and then Is_Overloadable (Entity (Selector_Name (P)))
then
if Ekind (Entity (Selector_Name (P))) = E_Entry then
Error_Attr ("prefix of % attribute must be subprogram", P);
@@ -518,7 +533,7 @@ package body Sem_Attr is
-- is rewritten as a reference to the current object.
elsif Ekind (Scop) = E_Procedure
- and then Chars (Scop) = Name_uInit_Proc
+ and then Is_Init_Proc (Scop)
and then Etype (First_Formal (Scop)) = Typ
then
Rewrite (N,
@@ -568,6 +583,16 @@ package body Sem_Attr is
end;
end if;
+ -- If we have an access to an object, and the attribute comes
+ -- from source, then set the object as potentially source modified.
+ -- We do this because the resulting access pointer can be used to
+ -- modify the variable, and we might not detect this, leading to
+ -- some junk warnings.
+
+ if Is_Entity_Name (P) then
+ Set_Never_Set_In_Source (Entity (P), False);
+ end if;
+
-- Check for aliased view unless unrestricted case. We allow
-- a nonaliased prefix when within an instance because the
-- prefix may have been a tagged formal object, which is
@@ -580,8 +605,7 @@ package body Sem_Attr is
then
Error_Attr ("prefix of % attribute must be aliased", P);
end if;
-
- end Access_Attribute;
+ end Analyze_Access_Attribute;
--------------------------------
-- Check_Array_Or_Scalar_Type --
@@ -743,7 +767,9 @@ package body Sem_Attr is
if not Is_Static_Expression (E1)
or else Raises_Constraint_Error (E1)
then
- Error_Attr ("expression for dimension must be static", E1);
+ Flag_Non_Static_Expr
+ ("expression for dimension must be static!", E1);
+ Error_Attr;
elsif UI_To_Int (Expr_Value (E1)) > D
or else UI_To_Int (Expr_Value (E1)) < 1
@@ -770,8 +796,9 @@ package body Sem_Attr is
return;
elsif not Is_OK_Static_Expression (E1) then
- Error_Attr
- ("constraint argument must be static string expression", E1);
+ Flag_Non_Static_Expr
+ ("constraint argument must be static string expression!", E1);
+ Error_Attr;
end if;
-- Check second argument is right type
@@ -838,7 +865,6 @@ package body Sem_Attr is
end if;
P_Base_Type := Base_Type (P_Type);
- P_Root_Type := Root_Type (P_Base_Type);
end if;
end Check_Dereference;
@@ -1152,7 +1178,7 @@ package body Sem_Attr is
-- Check_Stream_Attribute --
----------------------------
- procedure Check_Stream_Attribute (Nam : Name_Id) is
+ procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
Etyp : Entity_Id;
Btyp : Entity_Id;
@@ -1164,7 +1190,7 @@ package body Sem_Attr is
-- for this here, before they are rewritten, to give a more precise
-- diagnostic.
- if Nam = Name_uInput then
+ if Nam = TSS_Stream_Input then
null;
elsif Is_List_Member (N)
@@ -1175,7 +1201,7 @@ package body Sem_Attr is
else
Error_Attr
- ("invalid context for attribute %, which is a procedure", N);
+ ("invalid context for attribute%, which is a procedure", N);
end if;
Check_Type;
@@ -1189,22 +1215,19 @@ package body Sem_Attr is
and then not Present (TSS (Btyp, Nam))
and then No (Get_Rep_Pragma (Btyp, Name_Stream_Convert))
then
- -- Special case the message if we are compiling the stub version
- -- of a remote operation. One error on the type is sufficient.
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_NE
+ ("limited type& has no% attribute", P, Btyp);
+ Explain_Limited_Type (P_Type, P);
+ end if;
- if (Is_Remote_Types (Current_Scope)
- or else Is_Remote_Call_Interface (Current_Scope))
- and then not Error_Posted (Btyp)
- then
- Error_Msg_Node_2 := Current_Scope;
- Error_Msg_NE
- ("limited type& used in& has no stream attributes", P, Btyp);
- Set_Error_Posted (Btyp);
-
- elsif not Error_Posted (Btyp) then
- Error_Msg_NE
- ("limited type& has no stream attributes", P, Btyp);
- end if;
+ -- Check for violation of restriction No_Stream_Attributes
+
+ if Is_RTE (P_Type, RE_Exception_Id)
+ or else
+ Is_RTE (P_Type, RE_Exception_Occurrence)
+ then
+ Check_Restriction (No_Exception_Registration, P);
end if;
-- Here we must check that the first argument is an access type
@@ -1231,7 +1254,7 @@ package body Sem_Attr is
if Present (E2) then
Analyze (E2);
- if Nam = Name_uRead
+ if Nam = TSS_Stream_Read
and then not Is_OK_Variable_For_Out_Formal (E2)
then
Error_Attr
@@ -1254,7 +1277,7 @@ package body Sem_Attr is
or else (Is_Access_Type (Etype (P))
and then Is_Task_Type (Designated_Type (Etype (P))))
then
- Resolve (P, Etype (P));
+ Resolve (P);
else
Error_Attr ("prefix of % attribute must be a task", P);
end if;
@@ -1307,15 +1330,20 @@ package body Sem_Attr is
-- Error_Attr --
----------------
- procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
+ procedure Error_Attr is
begin
- Error_Msg_Name_1 := Aname;
- Error_Msg_N (Msg, Error_Node);
Set_Etype (N, Any_Type);
Set_Entity (N, Any_Type);
raise Bad_Attribute;
end Error_Attr;
+ procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
+ begin
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N (Msg, Error_Node);
+ Error_Attr;
+ end Error_Attr;
+
----------------------------
-- Legal_Formal_Attribute --
----------------------------
@@ -1355,8 +1383,81 @@ package body Sem_Attr is
procedure Standard_Attribute (Val : Int) is
begin
Check_Standard_Prefix;
- Rewrite (N,
- Make_Integer_Literal (Loc, Val));
+
+ -- First a special check (more like a kludge really). For GNAT5
+ -- on Windows, the alignments in GCC are severely mixed up. In
+ -- particular, we have a situation where the maximum alignment
+ -- that GCC thinks is possible is greater than the guaranteed
+ -- alignment at run-time. That causes many problems. As a partial
+ -- cure for this situation, we force a value of 4 for the maximum
+ -- alignment attribute on this target. This still does not solve
+ -- all problems, but it helps.
+
+ -- A further (even more horrible) dimension to this kludge is now
+ -- installed. There are two uses for Maximum_Alignment, one is to
+ -- determine the maximum guaranteed alignment, that's the one we
+ -- want the kludge to yield as 4. The other use is to maximally
+ -- align objects, we can't use 4 here, since for example, long
+ -- long integer has an alignment of 8, so we will get errors.
+
+ -- It is of course impossible to determine which use the programmer
+ -- has in mind, but an approximation for now is to disconnect the
+ -- kludge if the attribute appears in an alignment clause.
+
+ -- To be removed if GCC ever gets its act together here ???
+
+ Alignment_Kludge : declare
+ P : Node_Id;
+
+ function On_X86 return Boolean;
+ -- Determine if target is x86 (ia32), return True if so
+
+ ------------
+ -- On_X86 --
+ ------------
+
+ function On_X86 return Boolean is
+ T : String := Sdefault.Target_Name.all;
+
+ begin
+ -- There is no clean way to check this. That's not surprising,
+ -- the front end should not be doing this kind of test ???. The
+ -- way we do it is test for either "86" or "pentium" being in
+ -- the string for the target name.
+
+ for J in T'First .. T'Last - 1 loop
+ if T (J .. J + 1) = "86"
+ or else (J <= T'Last - 6
+ and then T (J .. J + 6) = "pentium")
+ then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end On_X86;
+
+ begin
+ if Aname = Name_Maximum_Alignment and then On_X86 then
+ P := Parent (N);
+
+ while Nkind (P) in N_Subexpr loop
+ P := Parent (P);
+ end loop;
+
+ if Nkind (P) /= N_Attribute_Definition_Clause
+ or else Chars (P) /= Name_Alignment
+ then
+ Rewrite (N, Make_Integer_Literal (Loc, 4));
+ Analyze (N);
+ return;
+ end if;
+ end if;
+ end Alignment_Kludge;
+
+ -- Normally we get the value from gcc ???
+
+ Rewrite (N, Make_Integer_Literal (Loc, Val));
Analyze (N);
end Standard_Attribute;
@@ -1380,7 +1481,8 @@ package body Sem_Attr is
if In_Preelaborated_Unit
and then not In_Subprogram_Or_Concurrent_Unit
then
- Error_Msg_N ("non-static function call in preelaborated unit", N);
+ Flag_Non_Static_Expr
+ ("non-static function call in preelaborated unit!", N);
end if;
end Validate_Non_Static_Attribute_Function_Call;
@@ -1398,14 +1500,16 @@ package body Sem_Attr is
-- Deal with Ada 83 and Features issues
- if not Attribute_83 (Attr_Id) then
- if Ada_83 and then Comes_From_Source (N) then
- Error_Msg_Name_1 := Aname;
- Error_Msg_N ("(Ada 83) attribute% is not standard?", N);
- end if;
+ if Comes_From_Source (N) then
+ if not Attribute_83 (Attr_Id) then
+ if Ada_83 and then Comes_From_Source (N) then
+ Error_Msg_Name_1 := Aname;
+ Error_Msg_N ("(Ada 83) attribute% is not standard?", N);
+ end if;
- if Attribute_Impl_Def (Attr_Id) then
- Check_Restriction (No_Implementation_Attributes, N);
+ if Attribute_Impl_Def (Attr_Id) then
+ Check_Restriction (No_Implementation_Attributes, N);
+ end if;
end if;
end if;
@@ -1416,7 +1520,7 @@ package body Sem_Attr is
-- with N_aggregate which represents a fat pointer aggregate.
if Aname = Name_Access then
- Unanalyzed := Copy_Separate_Tree (N);
+ Discard_Node (Copy_Separate_Tree (N));
end if;
-- Analyze prefix and exit if error in analysis. If the prefix is an
@@ -1448,7 +1552,6 @@ package body Sem_Attr is
end if;
P_Base_Type := Base_Type (P_Type);
- P_Root_Type := Root_Type (P_Base_Type);
end if;
-- Analyze expressions that may be present, exiting if an error occurs
@@ -1511,7 +1614,7 @@ package body Sem_Attr is
------------
when Attribute_Access =>
- Access_Attribute;
+ Analyze_Access_Attribute;
-------------
-- Address --
@@ -1533,33 +1636,46 @@ package body Sem_Attr is
-- An Address attribute created by expansion is legal even when it
-- applies to other entity-denoting expressions.
- if (Is_Entity_Name (P)) then
- if Is_Subprogram (Entity (P)) then
- if not Is_Library_Level_Entity (Entity (P)) then
- Check_Restriction (No_Implicit_Dynamic_Code, P);
- end if;
+ if Is_Entity_Name (P) then
+ declare
+ Ent : constant Entity_Id := Entity (P);
- Set_Address_Taken (Entity (P));
+ begin
+ if Is_Subprogram (Ent) then
+ if not Is_Library_Level_Entity (Ent) then
+ Check_Restriction (No_Implicit_Dynamic_Code, P);
+ end if;
- elsif Is_Object (Entity (P))
- or else Ekind (Entity (P)) = E_Label
- then
- Set_Address_Taken (Entity (P));
+ Set_Address_Taken (Ent);
- elsif (Is_Concurrent_Type (Etype (Entity (P)))
- and then Etype (Entity (P)) = Base_Type (Entity (P)))
- or else Ekind (Entity (P)) = E_Package
- or else Is_Generic_Unit (Entity (P))
- then
- Rewrite (N,
- New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
+ elsif Is_Object (Ent)
+ or else Ekind (Ent) = E_Label
+ then
+ Set_Address_Taken (Ent);
- else
- Error_Attr ("invalid prefix for % attribute", P);
- end if;
+ -- If we have an address of an object, and the attribute
+ -- comes from source, then set the object as potentially
+ -- source modified. We do this because the resulting address
+ -- can potentially be used to modify the variable and we
+ -- might not detect this, leading to some junk warnings.
+
+ Set_Never_Set_In_Source (Ent, False);
+
+ elsif (Is_Concurrent_Type (Etype (Ent))
+ and then Etype (Ent) = Base_Type (Ent))
+ or else Ekind (Ent) = E_Package
+ or else Is_Generic_Unit (Ent)
+ then
+ Rewrite (N,
+ New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
+
+ else
+ Error_Attr ("invalid prefix for % attribute", P);
+ end if;
+ end;
elsif Nkind (P) = N_Attribute_Reference
- and then Attribute_Name (P) = Name_AST_Entry
+ and then Attribute_Name (P) = Name_AST_Entry
then
Rewrite (N,
New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
@@ -1572,6 +1688,9 @@ package body Sem_Attr is
then
null;
+ -- What exactly are we allowing here ??? and is this properly
+ -- documented in the sinfo documentation for this node ???
+
elsif not Comes_From_Source (N) then
null;
@@ -1767,6 +1886,10 @@ package body Sem_Attr is
-- Base --
----------
+ -- Note: when the base attribute appears in the context of a subtype
+ -- mark, the analysis is done by Sem_Ch8.Find_Type, rather than by
+ -- the following circuit.
+
when Attribute_Base => Base : declare
Typ : Entity_Id;
@@ -1775,7 +1898,13 @@ package body Sem_Attr is
Find_Type (P);
Typ := Entity (P);
- if Sloc (Typ) = Standard_Location
+ if Ada_95
+ and then not Is_Scalar_Type (Typ)
+ and then not Is_Generic_Type (Typ)
+ then
+ Error_Msg_N ("prefix of Base attribute must be scalar type", N);
+
+ elsif Sloc (Typ) = Standard_Location
and then Base_Type (Typ) = Typ
and then Warn_On_Redundant_Constructs
then
@@ -1859,7 +1988,7 @@ package body Sem_Attr is
end if;
Set_Etype (N, RTE (RE_Bit_Order));
- Resolve (N, Etype (N));
+ Resolve (N);
-- Reset incorrect indication of staticness
@@ -2058,10 +2187,18 @@ package body Sem_Attr is
-- be completed, cannot apply Constrained to incomplete type.
elsif Is_Private_Type (Entity (P)) then
+
+ -- Note: this is one of the Annex J features that does not
+ -- generate a warning from -gnatwj, since in fact it seems
+ -- very useful, and is used in the GNAT runtime.
+
Check_Not_Incomplete_Type;
return;
end if;
+ -- Normal (non-obsolescent case) of application to object of
+ -- a discriminated type.
+
else
Check_Object_Reference (P);
@@ -2221,17 +2358,8 @@ package body Sem_Attr is
if It.Nam = Ent then
null;
- elsif Scope (It.Nam) = Scope (Ent) then
- Error_Attr ("ambiguous entry name", N);
-
else
- -- For now make this into a warning. Will become an
- -- error after the 3.15 release.
-
- Error_Msg_N
- ("ambiguous name, resolved to entry?", N);
- Error_Msg_N
- ("\(this will become an error in a later release)?", N);
+ Error_Attr ("ambiguous entry name", N);
end if;
Get_Next_Interp (Index, It);
@@ -2473,7 +2601,7 @@ package body Sem_Attr is
or else (Is_Access_Type (Etype (P))
and then Is_Task_Type (Designated_Type (Etype (P))))
then
- Resolve (P, Etype (P));
+ Resolve (P);
Set_Etype (N, RTE (RO_AT_Task_ID));
else
@@ -2532,8 +2660,7 @@ package body Sem_Attr is
when Attribute_Input =>
Check_E1;
- Check_Stream_Attribute (Name_uInput);
- Disallow_In_No_Run_Time_Mode (N);
+ Check_Stream_Attribute (TSS_Stream_Input);
Set_Etype (N, P_Base_Type);
-------------------
@@ -2700,7 +2827,6 @@ package body Sem_Attr is
--------------------
when Attribute_Mechanism_Code =>
-
if not Is_Entity_Name (P)
or else not Is_Subprogram (Entity (P))
then
@@ -2714,8 +2840,9 @@ package body Sem_Attr is
Set_Etype (E1, Standard_Integer);
if not Is_Static_Expression (E1) then
- Error_Attr
- ("expression for parameter number must be static", E1);
+ Flag_Non_Static_Expr
+ ("expression for parameter number must be static!", E1);
+ Error_Attr;
elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
or else UI_To_Int (Intval (E1)) < 0
@@ -2901,9 +3028,8 @@ package body Sem_Attr is
when Attribute_Output =>
Check_E2;
- Check_Stream_Attribute (Name_uInput);
+ Check_Stream_Attribute (TSS_Stream_Output);
Set_Etype (N, Standard_Void_Type);
- Disallow_In_No_Run_Time_Mode (N);
Resolve (N, Standard_Void_Type);
------------------
@@ -2941,6 +3067,14 @@ package body Sem_Attr is
Check_Type;
Set_Etype (N, Standard_Boolean);
+ ------------------
+ -- Pool_Address --
+ ------------------
+
+ when Attribute_Pool_Address =>
+ Check_E0;
+ Set_Etype (N, RTE (RE_Address));
+
---------
-- Pos --
---------
@@ -3013,10 +3147,9 @@ package body Sem_Attr is
when Attribute_Read =>
Check_E2;
- Check_Stream_Attribute (Name_uRead);
+ Check_Stream_Attribute (TSS_Stream_Read);
Set_Etype (N, Standard_Void_Type);
Resolve (N, Standard_Void_Type);
- Disallow_In_No_Run_Time_Mode (N);
Note_Possible_Modification (E2);
---------------
@@ -3295,6 +3428,31 @@ package body Sem_Attr is
Set_Etype (N, RTE (RE_Tag));
+ -----------------
+ -- Target_Name --
+ -----------------
+
+ when Attribute_Target_Name => Target_Name : declare
+ TN : constant String := Sdefault.Target_Name.all;
+ TL : Integer := TN'Last;
+
+ begin
+ Check_Standard_Prefix;
+ Check_E0;
+ Start_String;
+
+ if TN (TL) = '/' or else TN (TL) = '\' then
+ TL := TL - 1;
+ end if;
+
+ Store_String_Chars (TN (TN'First .. TL));
+
+ Rewrite (N,
+ Make_String_Literal (Loc,
+ Strval => End_String));
+ Analyze_And_Resolve (N, Standard_String);
+ end Target_Name;
+
----------------
-- Terminated --
----------------
@@ -3368,7 +3526,17 @@ package body Sem_Attr is
Check_Restriction (No_Unchecked_Access, N);
end if;
- Access_Attribute;
+ Analyze_Access_Attribute;
+
+ -------------------------
+ -- Unconstrained_Array --
+ -------------------------
+
+ when Attribute_Unconstrained_Array =>
+ Check_E0;
+ Check_Type;
+ Check_Not_Incomplete_Type;
+ Set_Etype (N, Standard_Boolean);
------------------------------
-- Universal_Literal_String --
@@ -3455,7 +3623,7 @@ package body Sem_Attr is
Set_Address_Taken (Entity (P));
end if;
- Access_Attribute;
+ Analyze_Access_Attribute;
---------
-- Val --
@@ -3507,10 +3675,11 @@ package body Sem_Attr is
Check_Restriction (No_Enumeration_Maps, N);
end if;
- -- Set Etype before resolving expression because expansion
- -- of expression may require enclosing type.
+ -- Set Etype before resolving expression because expansion of
+ -- expression may require enclosing type. Note that the type
+ -- returned by 'Value is the base type of the prefix type.
- Set_Etype (N, P_Type);
+ Set_Etype (N, P_Base_Type);
Validate_Non_Static_Attribute_Function_Call;
end Value;
@@ -3600,9 +3769,8 @@ package body Sem_Attr is
when Attribute_Write =>
Check_E2;
- Check_Stream_Attribute (Name_uWrite);
+ Check_Stream_Attribute (TSS_Stream_Write);
Set_Etype (N, Standard_Void_Type);
- Disallow_In_No_Run_Time_Mode (N);
Resolve (N, Standard_Void_Type);
end case;
@@ -3651,7 +3819,9 @@ package body Sem_Attr is
-- The root type of the prefix type
Static : Boolean;
- -- True if prefix type is static
+ -- True if the result is Static. This is set by the general processing
+ -- to true if the prefix is static, and all expressions are static. It
+ -- can be reset as processing continues for particular attributes
Lo_Bound, Hi_Bound : Node_Id;
-- Expressions for low and high bounds of type or array index referenced
@@ -3673,6 +3843,12 @@ package body Sem_Attr is
-- any, of the attribute, are in a non-static context. This procedure
-- performs the required additional checks.
+ function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean;
+ -- Determines if the given type has compile time known bounds. Note
+ -- that we enter the case statement even in cases where the prefix
+ -- type does NOT have known bounds, so it is important to guard any
+ -- attempt to evaluate both bounds with a call to this function.
+
procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint);
-- This procedure is called when the attribute N has a non-static
-- but compile time known value given by Val. It includes the
@@ -3684,7 +3860,9 @@ package body Sem_Attr is
IEEEX_Val : Int;
VAXFF_Val : Int;
VAXDF_Val : Int;
- VAXGF_Val : Int);
+ VAXGF_Val : Int;
+ AAMPS_Val : Int;
+ AAMPL_Val : Int);
-- This procedure evaluates a float attribute with no arguments that
-- returns a universal integer result. The parameters give the values
-- for the possible floating-point root types. See ttypef for details.
@@ -3696,7 +3874,9 @@ package body Sem_Attr is
IEEEX_Val : String;
VAXFF_Val : String;
VAXDF_Val : String;
- VAXGF_Val : String);
+ VAXGF_Val : String;
+ AAMPS_Val : String;
+ AAMPL_Val : String);
-- This procedure evaluates a float attribute with no arguments that
-- returns a universal real result. The parameters give the values
-- required for the possible floating-point root types in string
@@ -3712,11 +3892,12 @@ package body Sem_Attr is
procedure Set_Bounds;
-- Used for First, Last and Length attributes applied to an array or
- -- array subtype. Sets the variables Index_Lo and Index_Hi to the low
+ -- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low
-- and high bound expressions for the index referenced by the attribute
-- designator (i.e. the first index if no expression is present, and
-- the N'th index if the value N is present as an expression). Also
- -- used for First and Last of scalar types.
+ -- used for First and Last of scalar types. Static is reset to False
+ -- if the type or index type is not statically constrained.
---------------
-- Aft_Value --
@@ -3760,8 +3941,7 @@ package body Sem_Attr is
T : constant Entity_Id := Etype (N);
begin
- Fold_Uint (N, Val);
- Set_Is_Static_Expression (N, False);
+ Fold_Uint (N, Val, False);
-- Check that result is in bounds of the type if it is static
@@ -3780,6 +3960,18 @@ package body Sem_Attr is
end if;
end Compile_Time_Known_Attribute;
+ -------------------------------
+ -- Compile_Time_Known_Bounds --
+ -------------------------------
+
+ function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is
+ begin
+ return
+ Compile_Time_Known_Value (Type_Low_Bound (Typ))
+ and then
+ Compile_Time_Known_Value (Type_High_Bound (Typ));
+ end Compile_Time_Known_Bounds;
+
---------------------------------------
-- Float_Attribute_Universal_Integer --
---------------------------------------
@@ -3790,22 +3982,15 @@ package body Sem_Attr is
IEEEX_Val : Int;
VAXFF_Val : Int;
VAXDF_Val : Int;
- VAXGF_Val : Int)
+ VAXGF_Val : Int;
+ AAMPS_Val : Int;
+ AAMPL_Val : Int)
is
Val : Int;
Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
begin
- if not Vax_Float (P_Base_Type) then
- if Digs = IEEES_Digits then
- Val := IEEES_Val;
- elsif Digs = IEEEL_Digits then
- Val := IEEEL_Val;
- else pragma Assert (Digs = IEEEX_Digits);
- Val := IEEEX_Val;
- end if;
-
- else
+ if Vax_Float (P_Base_Type) then
if Digs = VAXFF_Digits then
Val := VAXFF_Val;
elsif Digs = VAXDF_Digits then
@@ -3813,9 +3998,25 @@ package body Sem_Attr is
else pragma Assert (Digs = VAXGF_Digits);
Val := VAXGF_Val;
end if;
+
+ elsif Is_AAMP_Float (P_Base_Type) then
+ if Digs = AAMPS_Digits then
+ Val := AAMPS_Val;
+ else pragma Assert (Digs = AAMPL_Digits);
+ Val := AAMPL_Val;
+ end if;
+
+ else
+ if Digs = IEEES_Digits then
+ Val := IEEES_Val;
+ elsif Digs = IEEEL_Digits then
+ Val := IEEEL_Val;
+ else pragma Assert (Digs = IEEEX_Digits);
+ Val := IEEEX_Val;
+ end if;
end if;
- Fold_Uint (N, UI_From_Int (Val));
+ Fold_Uint (N, UI_From_Int (Val), True);
end Float_Attribute_Universal_Integer;
------------------------------------
@@ -3828,22 +4029,15 @@ package body Sem_Attr is
IEEEX_Val : String;
VAXFF_Val : String;
VAXDF_Val : String;
- VAXGF_Val : String)
+ VAXGF_Val : String;
+ AAMPS_Val : String;
+ AAMPL_Val : String)
is
Val : Node_Id;
Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
begin
- if not Vax_Float (P_Base_Type) then
- if Digs = IEEES_Digits then
- Val := Real_Convert (IEEES_Val);
- elsif Digs = IEEEL_Digits then
- Val := Real_Convert (IEEEL_Val);
- else pragma Assert (Digs = IEEEX_Digits);
- Val := Real_Convert (IEEEX_Val);
- end if;
-
- else
+ if Vax_Float (P_Base_Type) then
if Digs = VAXFF_Digits then
Val := Real_Convert (VAXFF_Val);
elsif Digs = VAXDF_Digits then
@@ -3851,10 +4045,27 @@ package body Sem_Attr is
else pragma Assert (Digs = VAXGF_Digits);
Val := Real_Convert (VAXGF_Val);
end if;
+
+ elsif Is_AAMP_Float (P_Base_Type) then
+ if Digs = AAMPS_Digits then
+ Val := Real_Convert (AAMPS_Val);
+ else pragma Assert (Digs = AAMPL_Digits);
+ Val := Real_Convert (AAMPL_Val);
+ end if;
+
+ else
+ if Digs = IEEES_Digits then
+ Val := Real_Convert (IEEES_Val);
+ elsif Digs = IEEEL_Digits then
+ Val := Real_Convert (IEEEL_Val);
+ else pragma Assert (Digs = IEEEX_Digits);
+ Val := Real_Convert (IEEEX_Val);
+ end if;
end if;
Set_Sloc (Val, Loc);
Rewrite (N, Val);
+ Set_Is_Static_Expression (N, Static);
Analyze_And_Resolve (N, C_Type);
end Float_Attribute_Universal_Real;
@@ -3975,8 +4186,8 @@ package body Sem_Attr is
-- low bound.
if Ekind (P_Type) = E_String_Literal_Subtype then
- Lo_Bound :=
- Type_Low_Bound (Etype (First_Index (Base_Type (P_Type))));
+ Ityp := Etype (First_Index (Base_Type (P_Type)));
+ Lo_Bound := Type_Low_Bound (Ityp);
Hi_Bound :=
Make_Integer_Literal (Sloc (P),
@@ -3992,6 +4203,9 @@ package body Sem_Attr is
elsif Is_Scalar_Type (P_Type) then
Ityp := P_Type;
+ -- For a fixed-point type, we must freeze to get the attributes
+ -- of the fixed-point type set now so we can reference them.
+
if Is_Fixed_Point_Type (P_Type)
and then not Is_Frozen (Base_Type (P_Type))
and then Compile_Time_Known_Value (Type_Low_Bound (P_Type))
@@ -4037,6 +4251,9 @@ package body Sem_Attr is
Lo_Bound := Type_Low_Bound (Ityp);
Hi_Bound := Type_High_Bound (Ityp);
+ if not Is_Static_Subtype (Ityp) then
+ Static := False;
+ end if;
end Set_Bounds;
-- Start of processing for Eval_Attribute
@@ -4053,9 +4270,11 @@ package body Sem_Attr is
E2 := Empty;
end if;
- -- Special processing for cases where the prefix is an object
+ -- Special processing for cases where the prefix is an object. For
+ -- this purpose, a string literal counts as an object (attributes
+ -- of string literals can only appear in generated code).
- if Is_Object_Reference (P) then
+ if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then
-- For Component_Size, the prefix is an array object, and we apply
-- the attribute to the type of the object. This is allowed for
@@ -4079,10 +4298,10 @@ package body Sem_Attr is
AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P);
begin
- if Present (AS) then
+ if Present (AS) and then Is_Constrained (AS) then
P_Entity := AS;
- -- If no actual subtype, cannot fold
+ -- If we have an unconstrained type, cannot fold
else
Check_Expressions;
@@ -4094,7 +4313,6 @@ package body Sem_Attr is
-- cannot fold Size.
elsif Id = Attribute_Size then
-
if Is_Entity_Name (P)
and then Known_Esize (Entity (P))
then
@@ -4110,12 +4328,10 @@ package body Sem_Attr is
-- cannot fold Alignment.
elsif Id = Attribute_Alignment then
-
if Is_Entity_Name (P)
and then Known_Alignment (Entity (P))
then
- Fold_Uint (N, Alignment (Entity (P)));
- Set_Is_Static_Expression (N, False);
+ Fold_Uint (N, Alignment (Entity (P)), False);
return;
else
@@ -4187,13 +4403,16 @@ package body Sem_Attr is
-- Definite must be folded if the prefix is not a generic type,
-- that is to say if we are within an instantiation. Same processing
- -- applies to the GNAT attributes Has_Discriminants and Type_Class
+ -- applies to the GNAT attributes Has_Discriminants, Type_Class,
+ -- and Unconstrained_Array.
elsif (Id = Attribute_Definite
or else
Id = Attribute_Has_Discriminants
or else
- Id = Attribute_Type_Class)
+ Id = Attribute_Type_Class
+ or else
+ Id = Attribute_Unconstrained_Array)
and then not Is_Generic_Type (P_Entity)
then
P_Type := P_Entity;
@@ -4213,8 +4432,23 @@ package body Sem_Attr is
Compile_Time_Known_Attribute (N, RM_Size (P_Entity));
return;
+ -- We can fold 'Alignment applied to a type if the alignment is known
+ -- (as happens for an alignment from an attribute definition clause).
+ -- At this stage, this can happen only for types (e.g. record
+ -- types) for which the size is always non-static. We exclude
+ -- generic types from consideration (since they have bogus
+ -- sizes set within templates).
+
+ elsif Id = Attribute_Alignment
+ and then Is_Type (P_Entity)
+ and then (not Is_Generic_Type (P_Entity))
+ and then Known_Alignment (P_Entity)
+ then
+ Compile_Time_Known_Attribute (N, Alignment (P_Entity));
+ return;
+
-- No other cases are foldable (they certainly aren't static, and at
- -- the moment we don't try to fold any cases other than the two above)
+ -- the moment we don't try to fold any cases other than these three).
else
Check_Expressions;
@@ -4269,14 +4503,16 @@ package body Sem_Attr is
-- In addition Component_Size is possibly foldable, even though it
-- can never be static.
- -- Definite, Has_Discriminants and Type_Class are again exceptions,
- -- because they apply as well to unconstrained types.
+ -- Definite, Has_Discriminants, Type_Class and Unconstrained_Array are
+ -- again exceptions, because they apply as well to unconstrained types.
elsif Id = Attribute_Definite
or else
Id = Attribute_Has_Discriminants
or else
Id = Attribute_Type_Class
+ or else
+ Id = Attribute_Unconstrained_Array
then
Static := False;
@@ -4296,7 +4532,7 @@ package body Sem_Attr is
-- cases which we can fold at compile time even though they are not
-- static (e.g. 'Length applied to a static index, even though other
-- non-static indexes make the array type non-static). This is only
- -- ab optimization, but it falls out essentially free, so why not.
+ -- an optimization, but it falls out essentially free, so why not.
-- Again we compute the variable Static for easy reference later
-- (note that no array attributes are static in Ada 83).
@@ -4308,7 +4544,17 @@ package body Sem_Attr is
begin
N := First_Index (P_Type);
while Present (N) loop
- Static := Static and Is_Static_Subtype (Etype (N));
+ Static := Static and then Is_Static_Subtype (Etype (N));
+
+ -- If however the index type is generic, attributes cannot
+ -- be folded.
+
+ if Is_Generic_Type (Etype (N))
+ and then Id /= Attribute_Component_Size
+ then
+ return;
+ end if;
+
Next_Index (N);
end loop;
end;
@@ -4330,15 +4576,23 @@ package body Sem_Attr is
while Present (E) loop
-- If expression is not static, then the attribute reference
- -- certainly is neither foldable nor static, so we can quit
- -- after calling Apply_Range_Check for 'Pos attributes.
+ -- result certainly cannot be static.
+
+ if not Is_Static_Expression (E) then
+ Static := False;
+ end if;
- -- We can also quit if the expression is not of a scalar type
- -- as noted above.
+ -- If the result is not known at compile time, or is not of
+ -- a scalar type, then the result is definitely not static,
+ -- so we can quit now.
- if not Is_Static_Expression (E)
+ if not Compile_Time_Known_Value (E)
or else not Is_Scalar_Type (Etype (E))
then
+ -- An odd special case, if this is a Pos attribute, this
+ -- is where we need to apply a range check since it does
+ -- not get done anywhere else.
+
if Id = Attribute_Pos then
if Is_Integer_Type (Etype (E)) then
Apply_Range_Check (E, Etype (N));
@@ -4397,6 +4651,15 @@ package body Sem_Attr is
-- be foldable, and the individual attribute processing routines
-- test Static as required in cases where it makes a difference.
+ -- In the case where Static is not set, we do know that all the
+ -- expressions present are at least known at compile time (we
+ -- assumed above that if this was not the case, then there was
+ -- no hope of static evaluation). However, we did not require
+ -- that the bounds of the prefix type be compile time known,
+ -- let alone static). That's because there are many attributes
+ -- that can be computed at compile time on non-static subtypes,
+ -- even though such references are not static expressions.
+
case Id is
--------------
@@ -4404,18 +4667,16 @@ package body Sem_Attr is
--------------
when Attribute_Adjacent =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Adjacent
- (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Adjacent
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
---------
-- Aft --
---------
when Attribute_Aft =>
- Fold_Uint (N, UI_From_Int (Aft_Value));
+ Fold_Uint (N, UI_From_Int (Aft_Value), True);
---------------
-- Alignment --
@@ -4428,7 +4689,7 @@ package body Sem_Attr is
-- Fold if alignment is set and not otherwise
if Known_Alignment (P_TypeA) then
- Fold_Uint (N, Alignment (P_TypeA));
+ Fold_Uint (N, Alignment (P_TypeA), Is_Discrete_Type (P_TypeA));
end if;
end Alignment_Block;
@@ -4469,18 +4730,16 @@ package body Sem_Attr is
-------------
when Attribute_Ceiling =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1)), Static);
--------------------
-- Component_Size --
--------------------
when Attribute_Component_Size =>
- if Component_Size (P_Type) /= 0 then
- Fold_Uint (N, Component_Size (P_Type));
+ if Known_Static_Component_Size (P_Type) then
+ Fold_Uint (N, Component_Size (P_Type), False);
end if;
-------------
@@ -4488,11 +4747,10 @@ package body Sem_Attr is
-------------
when Attribute_Compose =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Compose
- (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Compose
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)),
+ Static);
-----------------
-- Constrained --
@@ -4509,18 +4767,16 @@ package body Sem_Attr is
---------------
when Attribute_Copy_Sign =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Copy_Sign
- (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Copy_Sign
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
-----------
-- Delta --
-----------
when Attribute_Delta =>
- Fold_Ureal (N, Delta_Value (P_Type));
+ Fold_Ureal (N, Delta_Value (P_Type), True);
--------------
-- Definite --
@@ -4547,14 +4803,14 @@ package body Sem_Attr is
when Attribute_Denorm =>
Fold_Uint
- (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)));
+ (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)), True);
------------
-- Digits --
------------
when Attribute_Digits =>
- Fold_Uint (N, Digits_Value (P_Type));
+ Fold_Uint (N, Digits_Value (P_Type), True);
----------
-- Emax --
@@ -4566,34 +4822,32 @@ package body Sem_Attr is
-- T'Emax = 4 * T'Mantissa
- Fold_Uint (N, 4 * Mantissa);
+ Fold_Uint (N, 4 * Mantissa, True);
--------------
-- Enum_Rep --
--------------
when Attribute_Enum_Rep =>
- if Static then
- -- For an enumeration type with a non-standard representation
- -- use the Enumeration_Rep field of the proper constant. Note
- -- that this would not work for types Character/Wide_Character,
- -- since no real entities are created for the enumeration
- -- literals, but that does not matter since these two types
- -- do not have non-standard representations anyway.
+ -- For an enumeration type with a non-standard representation
+ -- use the Enumeration_Rep field of the proper constant. Note
+ -- that this would not work for types Character/Wide_Character,
+ -- since no real entities are created for the enumeration
+ -- literals, but that does not matter since these two types
+ -- do not have non-standard representations anyway.
- if Is_Enumeration_Type (P_Type)
- and then Has_Non_Standard_Rep (P_Type)
- then
- Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)));
+ if Is_Enumeration_Type (P_Type)
+ and then Has_Non_Standard_Rep (P_Type)
+ then
+ Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static);
- -- For enumeration types with standard representations and all
- -- other cases (i.e. all integer and modular types), Enum_Rep
- -- is equivalent to Pos.
+ -- For enumeration types with standard representations and all
+ -- other cases (i.e. all integer and modular types), Enum_Rep
+ -- is equivalent to Pos.
- else
- Fold_Uint (N, Expr_Value (E1));
- end if;
+ else
+ Fold_Uint (N, Expr_Value (E1), Static);
end if;
-------------
@@ -4606,17 +4860,15 @@ package body Sem_Attr is
-- T'Epsilon = 2.0**(1 - T'Mantissa)
- Fold_Ureal (N, Ureal_2 ** (1 - Mantissa));
+ Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True);
--------------
-- Exponent --
--------------
when Attribute_Exponent =>
- if Static then
- Fold_Uint (N,
- Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Uint (N,
+ Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1)), Static);
-----------
-- First --
@@ -4628,9 +4880,9 @@ package body Sem_Attr is
if Compile_Time_Known_Value (Lo_Bound) then
if Is_Real_Type (P_Type) then
- Fold_Ureal (N, Expr_Value_R (Lo_Bound));
+ Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static);
else
- Fold_Uint (N, Expr_Value (Lo_Bound));
+ Fold_Uint (N, Expr_Value (Lo_Bound), Static);
end if;
end if;
end First_Attr;
@@ -4647,18 +4899,16 @@ package body Sem_Attr is
-----------
when Attribute_Floor =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1)), Static);
----------
-- Fore --
----------
when Attribute_Fore =>
- if Static then
- Fold_Uint (N, UI_From_Int (Fore_Value));
+ if Compile_Time_Known_Bounds (P_Type) then
+ Fold_Uint (N, UI_From_Int (Fore_Value), Static);
end if;
--------------
@@ -4666,10 +4916,8 @@ package body Sem_Attr is
--------------
when Attribute_Fraction =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)), Static);
-----------------------
-- Has_Discriminants --
@@ -4766,8 +5014,8 @@ package body Sem_Attr is
-- T'Emax = 4 * T'Mantissa
Fold_Ureal (N,
- Ureal_2 ** (4 * Mantissa) *
- (Ureal_1 - Ureal_2 ** (-Mantissa)));
+ Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)),
+ True);
end if;
----------
@@ -4780,9 +5028,9 @@ package body Sem_Attr is
if Compile_Time_Known_Value (Hi_Bound) then
if Is_Real_Type (P_Type) then
- Fold_Ureal (N, Expr_Value_R (Hi_Bound));
+ Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static);
else
- Fold_Uint (N, Expr_Value (Hi_Bound));
+ Fold_Uint (N, Expr_Value (Hi_Bound), Static);
end if;
end if;
end Last;
@@ -4792,25 +5040,40 @@ package body Sem_Attr is
------------------
when Attribute_Leading_Part =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Leading_Part
- (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Leading_Part
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
------------
-- Length --
------------
- when Attribute_Length => Length :
+ when Attribute_Length => Length : declare
+ Ind : Node_Id;
+
begin
+ -- In the case of a generic index type, the bounds may
+ -- appear static but the computation is not meaningful,
+ -- and may generate a spurious warning.
+
+ Ind := First_Index (P_Type);
+
+ while Present (Ind) loop
+ if Is_Generic_Type (Etype (Ind)) then
+ return;
+ end if;
+
+ Next_Index (Ind);
+ end loop;
+
Set_Bounds;
if Compile_Time_Known_Value (Lo_Bound)
and then Compile_Time_Known_Value (Hi_Bound)
then
Fold_Uint (N,
- UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))));
+ UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
+ True);
end if;
end Length;
@@ -4819,11 +5082,10 @@ package body Sem_Attr is
-------------
when Attribute_Machine =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Machine (P_Root_Type, Expr_Value_R (E1),
- Eval_Fat.Round));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Machine
+ (P_Root_Type, Expr_Value_R (E1), Eval_Fat.Round, N),
+ Static);
------------------
-- Machine_Emax --
@@ -4836,7 +5098,9 @@ package body Sem_Attr is
IEEEX_Machine_Emax,
VAXFF_Machine_Emax,
VAXDF_Machine_Emax,
- VAXGF_Machine_Emax);
+ VAXGF_Machine_Emax,
+ AAMPS_Machine_Emax,
+ AAMPL_Machine_Emax);
------------------
-- Machine_Emin --
@@ -4849,7 +5113,9 @@ package body Sem_Attr is
IEEEX_Machine_Emin,
VAXFF_Machine_Emin,
VAXDF_Machine_Emin,
- VAXGF_Machine_Emin);
+ VAXGF_Machine_Emin,
+ AAMPS_Machine_Emin,
+ AAMPL_Machine_Emin);
----------------------
-- Machine_Mantissa --
@@ -4862,7 +5128,9 @@ package body Sem_Attr is
IEEEX_Machine_Mantissa,
VAXFF_Machine_Mantissa,
VAXDF_Machine_Mantissa,
- VAXGF_Machine_Mantissa);
+ VAXGF_Machine_Mantissa,
+ AAMPS_Machine_Mantissa,
+ AAMPL_Machine_Mantissa);
-----------------------
-- Machine_Overflows --
@@ -4873,13 +5141,14 @@ package body Sem_Attr is
-- Always true for fixed-point
if Is_Fixed_Point_Type (P_Type) then
- Fold_Uint (N, True_Value);
+ Fold_Uint (N, True_Value, True);
-- Floating point case
else
- Fold_Uint
- (N, UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)));
+ Fold_Uint (N,
+ UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)),
+ True);
end if;
-------------------
@@ -4891,15 +5160,15 @@ package body Sem_Attr is
if Is_Decimal_Fixed_Point_Type (P_Type)
and then Machine_Radix_10 (P_Type)
then
- Fold_Uint (N, Uint_10);
+ Fold_Uint (N, Uint_10, True);
else
- Fold_Uint (N, Uint_2);
+ Fold_Uint (N, Uint_2, True);
end if;
-- All floating-point type always have radix 2
else
- Fold_Uint (N, Uint_2);
+ Fold_Uint (N, Uint_2, True);
end if;
--------------------
@@ -4911,13 +5180,13 @@ package body Sem_Attr is
-- Always False for fixed-point
if Is_Fixed_Point_Type (P_Type) then
- Fold_Uint (N, False_Value);
+ Fold_Uint (N, False_Value, True);
-- Else yield proper floating-point result
else
Fold_Uint
- (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)));
+ (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), True);
end if;
------------------
@@ -4931,7 +5200,7 @@ package body Sem_Attr is
begin
if Known_Esize (P_TypeA) then
- Fold_Uint (N, Esize (P_TypeA));
+ Fold_Uint (N, Esize (P_TypeA), True);
end if;
end Machine_Size;
@@ -5004,7 +5273,7 @@ package body Sem_Attr is
Siz := Siz + 1;
end loop;
- Fold_Uint (N, Siz);
+ Fold_Uint (N, Siz, True);
end;
else
@@ -5017,7 +5286,7 @@ package body Sem_Attr is
-- Floating-point Mantissa
else
- Fold_Uint (N, Mantissa);
+ Fold_Uint (N, Mantissa, True);
end if;
---------
@@ -5027,9 +5296,10 @@ package body Sem_Attr is
when Attribute_Max => Max :
begin
if Is_Real_Type (P_Type) then
- Fold_Ureal (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)));
+ Fold_Ureal
+ (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
else
- Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)));
+ Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static);
end if;
end Max;
@@ -5045,7 +5315,8 @@ package body Sem_Attr is
if Known_Esize (P_Type) then
Fold_Uint (N,
(Esize (P_Type) + System_Storage_Unit - 1) /
- System_Storage_Unit);
+ System_Storage_Unit,
+ Static);
end if;
--------------------
@@ -5073,7 +5344,7 @@ package body Sem_Attr is
end if;
if Mech < 0 then
- Fold_Uint (N, UI_From_Int (Int (-Mech)));
+ Fold_Uint (N, UI_From_Int (Int (-Mech)), True);
end if;
end;
@@ -5084,9 +5355,10 @@ package body Sem_Attr is
when Attribute_Min => Min :
begin
if Is_Real_Type (P_Type) then
- Fold_Ureal (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)));
+ Fold_Ureal
+ (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
else
- Fold_Uint (N, UI_Min (Expr_Value (E1), Expr_Value (E2)));
+ Fold_Uint (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
end if;
end Min;
@@ -5095,10 +5367,8 @@ package body Sem_Attr is
-----------
when Attribute_Model =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1)), Static);
----------------
-- Model_Emin --
@@ -5111,7 +5381,9 @@ package body Sem_Attr is
IEEEX_Model_Emin,
VAXFF_Model_Emin,
VAXDF_Model_Emin,
- VAXGF_Model_Emin);
+ VAXGF_Model_Emin,
+ AAMPS_Model_Emin,
+ AAMPL_Model_Emin);
-------------------
-- Model_Epsilon --
@@ -5124,7 +5396,9 @@ package body Sem_Attr is
IEEEX_Model_Epsilon'Universal_Literal_String,
VAXFF_Model_Epsilon'Universal_Literal_String,
VAXDF_Model_Epsilon'Universal_Literal_String,
- VAXGF_Model_Epsilon'Universal_Literal_String);
+ VAXGF_Model_Epsilon'Universal_Literal_String,
+ AAMPS_Model_Epsilon'Universal_Literal_String,
+ AAMPL_Model_Epsilon'Universal_Literal_String);
--------------------
-- Model_Mantissa --
@@ -5137,7 +5411,9 @@ package body Sem_Attr is
IEEEX_Model_Mantissa,
VAXFF_Model_Mantissa,
VAXDF_Model_Mantissa,
- VAXGF_Model_Mantissa);
+ VAXGF_Model_Mantissa,
+ AAMPS_Model_Mantissa,
+ AAMPL_Model_Mantissa);
-----------------
-- Model_Small --
@@ -5150,14 +5426,16 @@ package body Sem_Attr is
IEEEX_Model_Small'Universal_Literal_String,
VAXFF_Model_Small'Universal_Literal_String,
VAXDF_Model_Small'Universal_Literal_String,
- VAXGF_Model_Small'Universal_Literal_String);
+ VAXGF_Model_Small'Universal_Literal_String,
+ AAMPS_Model_Small'Universal_Literal_String,
+ AAMPL_Model_Small'Universal_Literal_String);
-------------
-- Modulus --
-------------
when Attribute_Modulus =>
- Fold_Uint (N, Modulus (P_Type));
+ Fold_Uint (N, Modulus (P_Type), True);
--------------------
-- Null_Parameter --
@@ -5182,7 +5460,7 @@ package body Sem_Attr is
begin
if Known_Esize (P_TypeA) then
- Fold_Uint (N, Esize (P_TypeA));
+ Fold_Uint (N, Esize (P_TypeA), True);
end if;
end Object_Size;
@@ -5193,14 +5471,14 @@ package body Sem_Attr is
-- Scalar types are never passed by reference
when Attribute_Passed_By_Reference =>
- Fold_Uint (N, False_Value);
+ Fold_Uint (N, False_Value, True);
---------
-- Pos --
---------
when Attribute_Pos =>
- Fold_Uint (N, Expr_Value (E1));
+ Fold_Uint (N, Expr_Value (E1), True);
----------
-- Pred --
@@ -5208,43 +5486,43 @@ package body Sem_Attr is
when Attribute_Pred => Pred :
begin
- if Static then
-
- -- Floating-point case. For now, do not fold this, since we
- -- don't know how to do it right (see fixed bug 3512-001 ???)
+ -- Floating-point case
- if Is_Floating_Point_Type (P_Type) then
- Fold_Ureal (N,
- Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1)));
+ if Is_Floating_Point_Type (P_Type) then
+ Fold_Ureal (N,
+ Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1)), Static);
- -- Fixed-point case
+ -- Fixed-point case
- elsif Is_Fixed_Point_Type (P_Type) then
- Fold_Ureal (N,
- Expr_Value_R (E1) - Small_Value (P_Type));
+ elsif Is_Fixed_Point_Type (P_Type) then
+ Fold_Ureal (N,
+ Expr_Value_R (E1) - Small_Value (P_Type), True);
- -- Modular integer case (wraps)
+ -- Modular integer case (wraps)
- elsif Is_Modular_Integer_Type (P_Type) then
- Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type));
+ elsif Is_Modular_Integer_Type (P_Type) then
+ Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static);
- -- Other scalar cases
+ -- Other scalar cases
- else
- pragma Assert (Is_Scalar_Type (P_Type));
+ else
+ pragma Assert (Is_Scalar_Type (P_Type));
- if Is_Enumeration_Type (P_Type)
- and then Expr_Value (E1) =
- Expr_Value (Type_Low_Bound (P_Base_Type))
- then
- Apply_Compile_Time_Constraint_Error
- (N, "Pred of type''First", CE_Overflow_Check_Failed);
- Check_Expressions;
- return;
- end if;
+ if Is_Enumeration_Type (P_Type)
+ and then Expr_Value (E1) =
+ Expr_Value (Type_Low_Bound (P_Base_Type))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "Pred of `&''First`",
+ CE_Overflow_Check_Failed,
+ Ent => P_Base_Type,
+ Warn => not Static);
- Fold_Uint (N, Expr_Value (E1) - 1);
+ Check_Expressions;
+ return;
end if;
+
+ Fold_Uint (N, Expr_Value (E1) - 1, Static);
end if;
end Pred;
@@ -5270,7 +5548,8 @@ package body Sem_Attr is
then
Fold_Uint (N,
UI_Max
- (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1));
+ (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1),
+ Static);
end if;
---------------
@@ -5278,11 +5557,10 @@ package body Sem_Attr is
---------------
when Attribute_Remainder =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Remainder
- (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Remainder
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)),
+ Static);
-----------
-- Round --
@@ -5294,19 +5572,17 @@ package body Sem_Attr is
Si : Uint;
begin
- if Static then
- -- First we get the (exact result) in units of small
+ -- First we get the (exact result) in units of small
- Sr := Expr_Value_R (E1) / Small_Value (C_Type);
+ Sr := Expr_Value_R (E1) / Small_Value (C_Type);
- -- Now round that exactly to an integer
+ -- Now round that exactly to an integer
- Si := UR_To_Uint (Sr);
+ Si := UR_To_Uint (Sr);
- -- Finally the result is obtained by converting back to real
+ -- Finally the result is obtained by converting back to real
- Fold_Ureal (N, Si * Small_Value (C_Type));
- end if;
+ Fold_Ureal (N, Si * Small_Value (C_Type), Static);
end Round;
--------------
@@ -5314,10 +5590,8 @@ package body Sem_Attr is
--------------
when Attribute_Rounding =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static);
---------------
-- Safe_Emax --
@@ -5330,7 +5604,9 @@ package body Sem_Attr is
IEEEX_Safe_Emax,
VAXFF_Safe_Emax,
VAXDF_Safe_Emax,
- VAXGF_Safe_Emax);
+ VAXGF_Safe_Emax,
+ AAMPS_Safe_Emax,
+ AAMPL_Safe_Emax);
----------------
-- Safe_First --
@@ -5343,7 +5619,9 @@ package body Sem_Attr is
IEEEX_Safe_First'Universal_Literal_String,
VAXFF_Safe_First'Universal_Literal_String,
VAXDF_Safe_First'Universal_Literal_String,
- VAXGF_Safe_First'Universal_Literal_String);
+ VAXGF_Safe_First'Universal_Literal_String,
+ AAMPS_Safe_First'Universal_Literal_String,
+ AAMPL_Safe_First'Universal_Literal_String);
----------------
-- Safe_Large --
@@ -5351,7 +5629,8 @@ package body Sem_Attr is
when Attribute_Safe_Large =>
if Is_Fixed_Point_Type (P_Type) then
- Fold_Ureal (N, Expr_Value_R (Type_High_Bound (P_Base_Type)));
+ Fold_Ureal
+ (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static);
else
Float_Attribute_Universal_Real (
IEEES_Safe_Large'Universal_Literal_String,
@@ -5359,7 +5638,9 @@ package body Sem_Attr is
IEEEX_Safe_Large'Universal_Literal_String,
VAXFF_Safe_Large'Universal_Literal_String,
VAXDF_Safe_Large'Universal_Literal_String,
- VAXGF_Safe_Large'Universal_Literal_String);
+ VAXGF_Safe_Large'Universal_Literal_String,
+ AAMPS_Safe_Large'Universal_Literal_String,
+ AAMPL_Safe_Large'Universal_Literal_String);
end if;
---------------
@@ -5373,7 +5654,9 @@ package body Sem_Attr is
IEEEX_Safe_Last'Universal_Literal_String,
VAXFF_Safe_Last'Universal_Literal_String,
VAXDF_Safe_Last'Universal_Literal_String,
- VAXGF_Safe_Last'Universal_Literal_String);
+ VAXGF_Safe_Last'Universal_Literal_String,
+ AAMPS_Safe_Last'Universal_Literal_String,
+ AAMPL_Safe_Last'Universal_Literal_String);
----------------
-- Safe_Small --
@@ -5386,7 +5669,7 @@ package body Sem_Attr is
-- it for backwards compatibility.
if Is_Fixed_Point_Type (P_Type) then
- Fold_Ureal (N, Small_Value (P_Type));
+ Fold_Ureal (N, Small_Value (P_Type), Static);
-- Ada 83 Safe_Small for floating-point cases
@@ -5397,7 +5680,9 @@ package body Sem_Attr is
IEEEX_Safe_Small'Universal_Literal_String,
VAXFF_Safe_Small'Universal_Literal_String,
VAXDF_Safe_Small'Universal_Literal_String,
- VAXGF_Safe_Small'Universal_Literal_String);
+ VAXGF_Safe_Small'Universal_Literal_String,
+ AAMPS_Safe_Small'Universal_Literal_String,
+ AAMPL_Safe_Small'Universal_Literal_String);
end if;
-----------
@@ -5405,18 +5690,16 @@ package body Sem_Attr is
-----------
when Attribute_Scale =>
- Fold_Uint (N, Scale_Value (P_Type));
+ Fold_Uint (N, Scale_Value (P_Type), True);
-------------
-- Scaling --
-------------
when Attribute_Scaling =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Scaling
- (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Scaling
+ (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
------------------
-- Signed_Zeros --
@@ -5424,7 +5707,7 @@ package body Sem_Attr is
when Attribute_Signed_Zeros =>
Fold_Uint
- (N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)));
+ (N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)), Static);
----------
-- Size --
@@ -5442,8 +5725,7 @@ package body Sem_Attr is
-- VADS_Size case
- if (Id = Attribute_VADS_Size or else Use_VADS_Size) then
-
+ if Id = Attribute_VADS_Size or else Use_VADS_Size then
declare
S : constant Node_Id := Size_Clause (P_TypeA);
@@ -5453,7 +5735,7 @@ package body Sem_Attr is
-- Size_Clause field for a subtype when Has_Size_Clause
-- is False. Consider:
- -- type x is range 1 .. 64;
+ -- type x is range 1 .. 64; g
-- for x'size use 12;
-- subtype y is x range 0 .. 3;
@@ -5464,21 +5746,23 @@ package body Sem_Attr is
if Present (S)
and then Is_OK_Static_Expression (Expression (S))
then
- Fold_Uint (N, Expr_Value (Expression (S)));
+ Fold_Uint (N, Expr_Value (Expression (S)), True);
-- If no size is specified, then we simply use the object
-- size in the VADS_Size case (e.g. Natural'Size is equal
-- to Integer'Size, not one less).
else
- Fold_Uint (N, Esize (P_TypeA));
+ Fold_Uint (N, Esize (P_TypeA), True);
end if;
end;
-- Normal case (Size) in which case we want the RM_Size
else
- Fold_Uint (N, RM_Size (P_TypeA));
+ Fold_Uint (N,
+ RM_Size (P_TypeA),
+ Static and then Is_Discrete_Type (P_TypeA));
end if;
end if;
end Size;
@@ -5489,7 +5773,7 @@ package body Sem_Attr is
when Attribute_Small =>
- -- The floating-point case is present only for Ada 83 compatibility.
+ -- The floating-point case is present only for Ada 83 compatability.
-- Note that strictly this is an illegal addition, since we are
-- extending an Ada 95 defined attribute, but we anticipate an
-- ARG ruling that will permit this.
@@ -5504,12 +5788,12 @@ package body Sem_Attr is
-- T'Emax = 4 * T'Mantissa
- Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1));
+ Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static);
-- Normal Ada 95 fixed-point case
else
- Fold_Ureal (N, Small_Value (P_Type));
+ Fold_Ureal (N, Small_Value (P_Type), True);
end if;
----------
@@ -5518,42 +5802,42 @@ package body Sem_Attr is
when Attribute_Succ => Succ :
begin
- if Static then
+ -- Floating-point case
- -- Floating-point case. For now, do not fold this, since we
- -- don't know how to do it right (see fixed bug 3512-001 ???)
+ if Is_Floating_Point_Type (P_Type) then
+ Fold_Ureal (N,
+ Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1)), Static);
- if Is_Floating_Point_Type (P_Type) then
- Fold_Ureal (N,
- Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1)));
+ -- Fixed-point case
- -- Fixed-point case
+ elsif Is_Fixed_Point_Type (P_Type) then
+ Fold_Ureal (N,
+ Expr_Value_R (E1) + Small_Value (P_Type), Static);
- elsif Is_Fixed_Point_Type (P_Type) then
- Fold_Ureal (N,
- Expr_Value_R (E1) + Small_Value (P_Type));
+ -- Modular integer case (wraps)
- -- Modular integer case (wraps)
+ elsif Is_Modular_Integer_Type (P_Type) then
+ Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static);
- elsif Is_Modular_Integer_Type (P_Type) then
- Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type));
+ -- Other scalar cases
- -- Other scalar cases
+ else
+ pragma Assert (Is_Scalar_Type (P_Type));
- else
- pragma Assert (Is_Scalar_Type (P_Type));
+ if Is_Enumeration_Type (P_Type)
+ and then Expr_Value (E1) =
+ Expr_Value (Type_High_Bound (P_Base_Type))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "Succ of `&''Last`",
+ CE_Overflow_Check_Failed,
+ Ent => P_Base_Type,
+ Warn => not Static);
- if Is_Enumeration_Type (P_Type)
- and then Expr_Value (E1) =
- Expr_Value (Type_High_Bound (P_Base_Type))
- then
- Apply_Compile_Time_Constraint_Error
- (N, "Succ of type''Last", CE_Overflow_Check_Failed);
- Check_Expressions;
- return;
- else
- Fold_Uint (N, Expr_Value (E1) + 1);
- end if;
+ Check_Expressions;
+ return;
+ else
+ Fold_Uint (N, Expr_Value (E1) + 1, Static);
end if;
end if;
end Succ;
@@ -5563,10 +5847,8 @@ package body Sem_Attr is
----------------
when Attribute_Truncation =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1)));
- end if;
+ Fold_Ureal (N,
+ Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1)), Static);
----------------
-- Type_Class --
@@ -5631,11 +5913,33 @@ package body Sem_Attr is
-----------------------
when Attribute_Unbiased_Rounding =>
- if Static then
- Fold_Ureal (N,
- Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1)));
+ Fold_Ureal (N,
+ Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1)),
+ Static);
+
+ -------------------------
+ -- Unconstrained_Array --
+ -------------------------
+
+ when Attribute_Unconstrained_Array => Unconstrained_Array : declare
+ Typ : constant Entity_Id := Underlying_Type (P_Type);
+
+ begin
+ if Is_Array_Type (P_Type)
+ and then not Is_Constrained (Typ)
+ then
+ Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
+ else
+ Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
end if;
+ -- Analyze and resolve as boolean, note that this attribute is
+ -- a static attribute in GNAT.
+
+ Analyze_And_Resolve (N, Standard_Boolean);
+ Static := True;
+ end Unconstrained_Array;
+
---------------
-- VADS_Size --
---------------
@@ -5648,18 +5952,20 @@ package body Sem_Attr is
when Attribute_Val => Val :
begin
- if Static then
- if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
- or else
- Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
- then
- Apply_Compile_Time_Constraint_Error
- (N, "Val expression out of range", CE_Range_Check_Failed);
- Check_Expressions;
- return;
- else
- Fold_Uint (N, Expr_Value (E1));
- end if;
+ if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
+ or else
+ Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "Val expression out of range",
+ CE_Range_Check_Failed,
+ Warn => not Static);
+
+ Check_Expressions;
+ return;
+
+ else
+ Fold_Uint (N, Expr_Value (E1), Static);
end if;
end Val;
@@ -5676,7 +5982,7 @@ package body Sem_Attr is
begin
if RM_Size (P_TypeA) /= Uint_0 then
- Fold_Uint (N, RM_Size (P_TypeA));
+ Fold_Uint (N, RM_Size (P_TypeA), True);
end if;
end Value_Size;
@@ -5714,7 +6020,7 @@ package body Sem_Attr is
when Attribute_Width | Attribute_Wide_Width => Width :
begin
- if Static then
+ if Compile_Time_Known_Bounds (P_Type) then
-- Floating-point types
@@ -5725,7 +6031,7 @@ package body Sem_Attr is
if Expr_Value_R (Type_High_Bound (P_Type)) <
Expr_Value_R (Type_Low_Bound (P_Type))
then
- Fold_Uint (N, Uint_0);
+ Fold_Uint (N, Uint_0, True);
else
-- For floating-point, we have +N.dddE+nnn where length
@@ -5747,7 +6053,7 @@ package body Sem_Attr is
Len := Len + 7;
end if;
- Fold_Uint (N, UI_From_Int (Len));
+ Fold_Uint (N, UI_From_Int (Len), True);
end;
end if;
@@ -5760,14 +6066,15 @@ package body Sem_Attr is
if Expr_Value (Type_High_Bound (P_Type)) <
Expr_Value (Type_Low_Bound (P_Type))
then
- Fold_Uint (N, Uint_0);
+ Fold_Uint (N, Uint_0, True);
-- The non-null case depends on the specific real type
else
-- For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
- Fold_Uint (N, UI_From_Int (Fore_Value + 1 + Aft_Value));
+ Fold_Uint
+ (N, UI_From_Int (Fore_Value + 1 + Aft_Value), True);
end if;
-- Discrete types
@@ -5851,7 +6158,6 @@ package body Sem_Attr is
No_Break_Space .. LC_Y_Diaeresis
=> Wt := 3;
-
end case;
W := Int'Max (W, Wt);
@@ -5932,7 +6238,7 @@ package body Sem_Attr is
end loop;
end if;
- Fold_Uint (N, UI_From_Int (W));
+ Fold_Uint (N, UI_From_Int (W), True);
end;
end if;
end if;
@@ -5968,12 +6274,14 @@ package body Sem_Attr is
Attribute_Maximum_Alignment |
Attribute_Output |
Attribute_Partition_ID |
+ Attribute_Pool_Address |
Attribute_Position |
Attribute_Read |
Attribute_Storage_Pool |
Attribute_Storage_Size |
Attribute_Storage_Unit |
Attribute_Tag |
+ Attribute_Target_Name |
Attribute_Terminated |
Attribute_To_Address |
Attribute_UET_Address |
@@ -5996,6 +6304,9 @@ package body Sem_Attr is
-- in the constant only if the prefix type is a static subtype. For
-- non-static subtypes, the folding is still OK, but not static.
+ -- An exception is the GNAT attribute Constrained_Array which is
+ -- defined to be a static attribute in all cases.
+
if Nkind (N) = N_Integer_Literal
or else Nkind (N) = N_Real_Literal
or else Nkind (N) = N_Character_Literal
@@ -6046,9 +6357,9 @@ package body Sem_Attr is
P : constant Node_Id := Prefix (N);
Aname : constant Name_Id := Attribute_Name (N);
Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
+ Btyp : constant Entity_Id := Base_Type (Typ);
Index : Interp_Index;
It : Interp;
- Btyp : Entity_Id := Base_Type (Typ);
Nom_Subt : Entity_Id;
begin
@@ -6123,7 +6434,7 @@ package body Sem_Attr is
elsif not Is_Overloadable (Entity (P))
and then not Is_Type (Entity (P))
then
- Resolve (P, Etype (P));
+ Resolve (P);
end if;
if not Is_Entity_Name (P) then
@@ -6188,14 +6499,12 @@ package body Sem_Attr is
("subprogram must not be deeper than access type",
P);
else
- Warn_On_Instance := True;
Error_Msg_N
("subprogram must not be deeper than access type?",
P);
Error_Msg_N
("Constraint_Error will be raised ?", P);
Set_Raises_Constraint_Error (N);
- Warn_On_Instance := False;
end if;
-- Check the restriction of 3.10.2(32) that disallows
@@ -6235,7 +6544,7 @@ package body Sem_Attr is
("attribute% cannot be applied to protected operation", P);
end if;
- Resolve (Prefix (P), Etype (Prefix (P)));
+ Resolve (Prefix (P));
Generate_Reference (Entity (Selector_Name (P)), P);
elsif Is_Overloaded (P) then
@@ -6257,7 +6566,7 @@ package body Sem_Attr is
end loop;
end;
else
- Resolve (P, Etype (P));
+ Resolve (P);
end if;
-- X'Access is illegal if X denotes a constant and the access
@@ -6355,10 +6664,12 @@ package body Sem_Attr is
end if;
elsif not Subtypes_Statically_Match
- (Designated_Type (Typ), Nom_Subt)
+ (Designated_Type (Base_Type (Typ)), Nom_Subt)
and then
not (Has_Discriminants (Designated_Type (Typ))
- and then not Is_Constrained (Designated_Type (Typ)))
+ and then
+ not Is_Constrained
+ (Designated_Type (Base_Type (Typ))))
then
Error_Msg_N
("object subtype must statically match "
@@ -6516,7 +6827,7 @@ package body Sem_Attr is
if not Is_Task_Type (Etype (P))
or else Nkind (P) = N_Explicit_Dereference
then
- Resolve (P, Etype (P));
+ Resolve (P);
end if;
end if;
@@ -6571,11 +6882,23 @@ package body Sem_Attr is
-- Count --
-----------
- -- Prefix of the Count attribute is an entry name which must not
- -- be resolved, since this is definitely not an entry call.
+ -- If the prefix of the Count attribute is an entry name it must not
+ -- be resolved, since this is definitely not an entry call. However,
+ -- if it is an element of an entry family, the index itself may
+ -- have to be resolved because it can be a general expression.
when Attribute_Count =>
- null;
+ if Nkind (P) = N_Indexed_Component
+ and then Is_Entity_Name (Prefix (P))
+ then
+ declare
+ Indx : constant Node_Id := First (Expressions (P));
+ Fam : constant Entity_Id := Entity (Prefix (P));
+ begin
+ Resolve (Indx, Entry_Index_Type (Fam));
+ Apply_Range_Check (Indx, Entry_Index_Type (Fam));
+ end;
+ end if;
----------------
-- Elaborated --
@@ -6609,6 +6932,9 @@ package body Sem_Attr is
Process_Partition_Id (N);
return;
+ when Attribute_Pool_Address =>
+ Resolve (P);
+
-----------
-- Range --
-----------
@@ -6635,6 +6961,10 @@ package body Sem_Attr is
-- explicit. This solves some complex visibility problems
-- related to the use of privals.
+ --------------------------------
+ -- Check_Discriminated_Prival --
+ --------------------------------
+
function Check_Discriminated_Prival
(N : Node_Id)
return Node_Id
@@ -6656,7 +6986,7 @@ package body Sem_Attr is
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
then
- Resolve (P, Etype (P));
+ Resolve (P);
end if;
-- Check whether prefix is (renaming of) private component
@@ -6671,11 +7001,13 @@ package body Sem_Attr is
Ekind (Scope (Scope (Entity (P)))) =
E_Protected_Type)
then
- LB := Check_Discriminated_Prival (
- Type_Low_Bound (Etype (First_Index (Etype (P)))));
+ LB :=
+ Check_Discriminated_Prival
+ (Type_Low_Bound (Etype (First_Index (Etype (P)))));
- HB := Check_Discriminated_Prival (
- Type_High_Bound (Etype (First_Index (Etype (P)))));
+ HB :=
+ Check_Discriminated_Prival
+ (Type_High_Bound (Etype (First_Index (Etype (P)))));
else
HB :=
@@ -6797,7 +7129,7 @@ package body Sem_Attr is
if not Is_Entity_Name (P)
or else not Is_Type (Entity (P))
then
- Resolve (P, Etype (P));
+ Resolve (P);
end if;
-- If the attribute reference itself is a type name ('Base,
diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index 5818de6a8f1..32e3eda9154 100644
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -405,6 +405,15 @@ package Sem_Attr is
-- for constructing this definition in package System (see note above
-- in Default_Bit_Order description). The is a static attribute.
+ -----------------
+ -- Target_Name --
+ -----------------
+
+ Attribute_Target_Name => True,
+ --
+ -- Standard'Target_Name yields the string identifying the target
+ -- for the compilation, taken from Sdefault.Target_Name.
+
----------------
-- To_Address --
----------------
diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
index f854f392f41..10858ed183b 100644
--- a/gcc/ada/sem_case.adb
+++ b/gcc/ada/sem_case.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -29,6 +29,8 @@ with Einfo; use Einfo;
with Errout; use Errout;
with Namet; use Namet;
with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
@@ -37,6 +39,7 @@ with Sem_Type; use Sem_Type;
with Snames; use Snames;
with Stand; use Stand;
with Sinfo; use Sinfo;
+with Tbuild; use Tbuild;
with Uintp; use Uintp;
with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
@@ -59,10 +62,10 @@ package body Sem_Case is
Bounds_Type : Entity_Id;
Others_Present : Boolean;
Msg_Sloc : Source_Ptr);
- -- This is the procedure which verifies that a set of case statement,
- -- array aggregate or record variant choices has no duplicates, and
- -- covers the range specified by Bounds_Type. Choice_Table contains the
- -- discrete choices to check. These must start at position 1.
+ -- This is the procedure which verifies that a set of case alternatives
+ -- or record variant choices has no duplicates, and covers the range
+ -- specified by Bounds_Type. Choice_Table contains the discrete choices
+ -- to check. These must start at position 1.
-- Furthermore Choice_Table (0) must exist. This element is used by
-- the sorting algorithm as a temporary. Others_Present is a flag
-- indicating whether or not an Others choice is present. Finally
@@ -73,6 +76,18 @@ package body Sem_Case is
-- Given a Pos value of enumeration type Ctype, returns the name
-- ID of an appropriate string to be used in error message output.
+ procedure Expand_Others_Choice
+ (Case_Table : Choice_Table_Type;
+ Others_Choice : Node_Id;
+ Choice_Type : Entity_Id);
+ -- The case table is the table generated by a call to Analyze_Choices
+ -- (with just 1 .. Last_Choice entries present). Others_Choice is a
+ -- pointer to the N_Others_Choice node (this routine is only called if
+ -- an others choice is present), and Choice_Type is the discrete type
+ -- of the bounds. The effect of this call is to analyze the cases and
+ -- determine the set of values covered by others. This choice list is
+ -- set in the Others_Discrete_Choices field of the N_Others_Choice node.
+
-------------------
-- Check_Choices --
-------------------
@@ -83,7 +98,6 @@ package body Sem_Case is
Others_Present : Boolean;
Msg_Sloc : Source_Ptr)
is
-
function Lt_Choice (C1, C2 : Natural) return Boolean;
-- Comparison routine for comparing Choice_Table entries.
-- Use the lower bound of each Choice as the key.
@@ -161,7 +175,8 @@ package body Sem_Case is
begin
return
Expr_Value (Choice_Table (Nat (C1)).Lo)
- <= Expr_Value (Choice_Table (Nat (C2)).Lo);
+ <
+ Expr_Value (Choice_Table (Nat (C2)).Lo);
end Lt_Choice;
-----------------
@@ -188,7 +203,6 @@ package body Sem_Case is
-- Start processing for Check_Choices
begin
-
-- Choice_Table must start at 0 which is an unused location used
-- by the sorting algorithm. However the first valid position for
-- a discrete choice is 1.
@@ -324,6 +338,193 @@ package body Sem_Case is
return Name_Find;
end Choice_Image;
+ --------------------------
+ -- Expand_Others_Choice --
+ --------------------------
+
+ procedure Expand_Others_Choice
+ (Case_Table : Choice_Table_Type;
+ Others_Choice : Node_Id;
+ Choice_Type : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Others_Choice);
+ Choice_List : constant List_Id := New_List;
+ Choice : Node_Id;
+ Exp_Lo : Node_Id;
+ Exp_Hi : Node_Id;
+ Hi : Uint;
+ Lo : Uint;
+ Previous_Hi : Uint;
+
+ function Build_Choice (Value1, Value2 : Uint) return Node_Id;
+ -- Builds a node representing the missing choices given by the
+ -- Value1 and Value2. A N_Range node is built if there is more than
+ -- one literal value missing. Otherwise a single N_Integer_Literal,
+ -- N_Identifier or N_Character_Literal is built depending on what
+ -- Choice_Type is.
+
+ function Lit_Of (Value : Uint) return Node_Id;
+ -- Returns the Node_Id for the enumeration literal corresponding to the
+ -- position given by Value within the enumeration type Choice_Type.
+
+ ------------------
+ -- Build_Choice --
+ ------------------
+
+ function Build_Choice (Value1, Value2 : Uint) return Node_Id is
+ Lit_Node : Node_Id;
+ Lo, Hi : Node_Id;
+
+ begin
+ -- If there is only one choice value missing between Value1 and
+ -- Value2, build an integer or enumeration literal to represent it.
+
+ if (Value2 - Value1) = 0 then
+ if Is_Integer_Type (Choice_Type) then
+ Lit_Node := Make_Integer_Literal (Loc, Value1);
+ Set_Etype (Lit_Node, Choice_Type);
+ else
+ Lit_Node := Lit_Of (Value1);
+ end if;
+
+ -- Otherwise is more that one choice value that is missing between
+ -- Value1 and Value2, therefore build a N_Range node of either
+ -- integer or enumeration literals.
+
+ else
+ if Is_Integer_Type (Choice_Type) then
+ Lo := Make_Integer_Literal (Loc, Value1);
+ Set_Etype (Lo, Choice_Type);
+ Hi := Make_Integer_Literal (Loc, Value2);
+ Set_Etype (Hi, Choice_Type);
+ Lit_Node :=
+ Make_Range (Loc,
+ Low_Bound => Lo,
+ High_Bound => Hi);
+
+ else
+ Lit_Node :=
+ Make_Range (Loc,
+ Low_Bound => Lit_Of (Value1),
+ High_Bound => Lit_Of (Value2));
+ end if;
+ end if;
+
+ return Lit_Node;
+ end Build_Choice;
+
+ ------------
+ -- Lit_Of --
+ ------------
+
+ function Lit_Of (Value : Uint) return Node_Id is
+ Lit : Entity_Id;
+
+ begin
+ -- In the case where the literal is of type Character, there needs
+ -- to be some special handling since there is no explicit chain
+ -- of literals to search. Instead, a N_Character_Literal node
+ -- is created with the appropriate Char_Code and Chars fields.
+
+ if Root_Type (Choice_Type) = Standard_Character
+ or else
+ Root_Type (Choice_Type) = Standard_Wide_Character
+ then
+ Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
+ Lit := New_Node (N_Character_Literal, Loc);
+ Set_Chars (Lit, Name_Find);
+ Set_Char_Literal_Value (Lit, Char_Code (UI_To_Int (Value)));
+ Set_Etype (Lit, Choice_Type);
+ Set_Is_Static_Expression (Lit, True);
+ return Lit;
+
+ -- Otherwise, iterate through the literals list of Choice_Type
+ -- "Value" number of times until the desired literal is reached
+ -- and then return an occurrence of it.
+
+ else
+ Lit := First_Literal (Choice_Type);
+ for J in 1 .. UI_To_Int (Value) loop
+ Next_Literal (Lit);
+ end loop;
+
+ return New_Occurrence_Of (Lit, Loc);
+ end if;
+ end Lit_Of;
+
+ -- Start of processing for Expand_Others_Choice
+
+ begin
+ if Case_Table'Length = 0 then
+
+ -- Special case: only an others case is present.
+ -- The others case covers the full range of the type.
+
+ if Is_Static_Subtype (Choice_Type) then
+ Choice := New_Occurrence_Of (Choice_Type, Loc);
+ else
+ Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
+ end if;
+
+ Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
+ return;
+ end if;
+
+ -- Establish the bound values for the choice depending upon whether
+ -- the type of the case statement is static or not.
+
+ if Is_OK_Static_Subtype (Choice_Type) then
+ Exp_Lo := Type_Low_Bound (Choice_Type);
+ Exp_Hi := Type_High_Bound (Choice_Type);
+ else
+ Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
+ Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
+ end if;
+
+ Lo := Expr_Value (Case_Table (Case_Table'First).Lo);
+ Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
+ Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
+
+ -- Build the node for any missing choices that are smaller than any
+ -- explicit choices given in the case.
+
+ if Expr_Value (Exp_Lo) < Lo then
+ Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
+ end if;
+
+ -- Build the nodes representing any missing choices that lie between
+ -- the explicit ones given in the case.
+
+ for J in Case_Table'First + 1 .. Case_Table'Last loop
+ Lo := Expr_Value (Case_Table (J).Lo);
+ Hi := Expr_Value (Case_Table (J).Hi);
+
+ if Lo /= (Previous_Hi + 1) then
+ Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
+ end if;
+
+ Previous_Hi := Hi;
+ end loop;
+
+ -- Build the node for any missing choices that are greater than any
+ -- explicit choices given in the case.
+
+ if Expr_Value (Exp_Hi) > Hi then
+ Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
+ end if;
+
+ Set_Others_Discrete_Choices (Others_Choice, Choice_List);
+
+ -- Warn on null others list if warning option set
+
+ if Warn_On_Redundant_Constructs
+ and then Comes_From_Source (Others_Choice)
+ and then Is_Empty_List (Choice_List)
+ then
+ Error_Msg_N ("?others choice is empty", Others_Choice);
+ end if;
+ end Expand_Others_Choice;
+
-----------
-- No_OP --
-----------
@@ -348,11 +549,12 @@ package body Sem_Case is
procedure Analyze_Choices
(N : Node_Id;
Subtyp : Entity_Id;
- Choice_Table : in out Choice_Table_Type;
+ Choice_Table : out Choice_Table_Type;
Last_Choice : out Nat;
Raises_CE : out Boolean;
Others_Present : out Boolean)
is
+ E : Entity_Id;
Nb_Choices : constant Nat := Choice_Table'Length;
Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices);
@@ -364,11 +566,11 @@ package body Sem_Case is
Bounds_Type : Entity_Id;
-- The type from which are derived the bounds of the values
- -- covered by th discrete choices (see 3.8.1 (4)). If a discrete
+ -- covered by the discrete choices (see 3.8.1 (4)). If a discrete
-- choice specifies a value outside of these bounds we have an error.
- Bounds_Lo : Uint;
- Bounds_Hi : Uint;
+ Bounds_Lo : Uint;
+ Bounds_Hi : Uint;
-- The actual bounds of the above type.
Expected_Type : Entity_Id;
@@ -376,6 +578,17 @@ package body Sem_Case is
-- if the expression is universal, in which case the choices can
-- be of any integer type.
+ Alt : Node_Id;
+ -- A case statement alternative or a variant in a record type
+ -- declaration
+
+ Choice : Node_Id;
+ Kind : Node_Kind;
+ -- The node kind of the current Choice
+
+ Others_Choice : Node_Id := Empty;
+ -- Remember others choice if it is present (empty otherwise)
+
procedure Check (Choice : Node_Id; Lo, Hi : Node_Id);
-- Checks the validity of the bounds of a choice. When the bounds
-- are static and no error occurred the bounds are entered into
@@ -446,8 +659,10 @@ package body Sem_Case is
end if;
end if;
- -- We still store the bounds in the table, even if they are out
- -- of range, since this may prevent unnecessary cascaded errors
+ -- Store bounds in the table
+
+ -- Note: we still store the bounds, even if they are out of
+ -- range, since this may prevent unnecessary cascaded errors
-- for values that are covered by such an excessive range.
Last_Choice := Last_Choice + 1;
@@ -456,18 +671,6 @@ package body Sem_Case is
Sort_Choice_Table (Last_Choice).Node := Choice;
end Check;
- -- Variables local to Analyze_Choices
-
- Alt : Node_Id;
- -- A case statement alternative, an array aggregate component
- -- association or a variant in a record type declaration
-
- Choice : Node_Id;
- Kind : Node_Kind;
- -- The node kind of the current Choice.
-
- E : Entity_Id;
-
-- Start of processing for Analyze_Choices
begin
@@ -501,8 +704,7 @@ package body Sem_Case is
Expected_Type := Choice_Type;
end if;
- -- Now loop through the case statement alternatives or array
- -- aggregate component associations or record variants.
+ -- Now loop through the case alternatives or record variants
Alt := First (Get_Alternatives (N));
while Present (Alt) loop
@@ -525,7 +727,7 @@ package body Sem_Case is
if Kind = N_Range
or else (Kind = N_Attribute_Reference
- and then Attribute_Name (Choice) = Name_Range)
+ and then Attribute_Name (Choice) = Name_Range)
then
Resolve (Choice, Expected_Type);
Check (Choice, Low_Bound (Choice), High_Bound (Choice));
@@ -609,6 +811,7 @@ package body Sem_Case is
end if;
Others_Present := True;
+ Others_Choice := Choice;
-- Only other possibility is an expression
@@ -638,6 +841,17 @@ package body Sem_Case is
Choice_Table (Choice_Table'First - 1 + J) := Sort_Choice_Table (J);
end loop;
+ -- If no others choice we are all done, otherwise we have one more
+ -- step, which is to set the Others_Discrete_Choices field of the
+ -- others choice (to contain all otherwise unspecified choices).
+ -- Skip this if CE is known to be raised.
+
+ if Others_Present and not Raises_CE then
+ Expand_Others_Choice
+ (Case_Table => Choice_Table (1 .. Last_Choice),
+ Others_Choice => Others_Choice,
+ Choice_Type => Bounds_Type);
+ end if;
end Analyze_Choices;
-----------------------
@@ -646,8 +860,7 @@ package body Sem_Case is
function Number_Of_Choices (N : Node_Id) return Nat is
Alt : Node_Id;
- -- A case statement alternative, an array aggregate component
- -- association or a record variant.
+ -- A case statement alternative or a record variant.
Choice : Node_Id;
Count : Nat := 0;
diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads
index a1fdfc7f29c..98265b34254 100644
--- a/gcc/ada/sem_case.ads
+++ b/gcc/ada/sem_case.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,11 +26,12 @@
with Types; use Types;
--- Package containing all the routines to process a list of discrete choices.
--- Such lists can occur in 3 different constructs: case statements, array
--- aggregates and record variants. We have factorized what used to be 3 very
--- similar sets of routines here. If you didn't figure it out already Choi
--- in the package name stands for Choices.
+-- Package containing the routines to process a list of discrete choices.
+-- Such lists can occur in two different constructs: case statements and
+-- record variants. We have factorized what used to be two very similar
+-- sets of routines in one place. These are not currently used for the
+-- aggregate case, since issues with nested aggregates make that case
+-- substantially different.
package Sem_Case is
@@ -46,7 +47,7 @@ package Sem_Case is
procedure No_OP (C : Node_Id);
-- The no-operation routine. Does absolutely nothing. Can be used
- -- in the following generic for the parameter Process_Empty_Choice.
+ -- in the following generic for the parameter Proces_Empty_Choice.
generic
with function Get_Alternatives (N : Node_Id) return List_Id;
@@ -83,7 +84,7 @@ package Sem_Case is
procedure Analyze_Choices
(N : Node_Id;
Subtyp : Entity_Id;
- Choice_Table : in out Choice_Table_Type;
+ Choice_Table : out Choice_Table_Type;
Last_Choice : out Nat;
Raises_CE : out Boolean;
Others_Present : out Boolean);
@@ -113,7 +114,8 @@ package Sem_Case is
-- error the flag Raise_CE is set.
--
-- Finally Others_Present is set to True if an Others choice is
- -- present in the list of choices.
+ -- present in the list of choices, and in this case the call also
+ -- sets Others_Discrete_Choices in the N_Others_Choice node.
end Generic_Choices_Processing;
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb
index 3360f6e5db7..bb33f4cf27f 100644
--- a/gcc/ada/sem_cat.adb
+++ b/gcc/ada/sem_cat.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -34,6 +34,7 @@ with Fname; use Fname;
with Lib; use Lib;
with Nlists; use Nlists;
with Sem; use Sem;
+with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
@@ -93,7 +94,7 @@ package body Sem_Cat is
-- a preelaborated library unit.
procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id);
- -- Check validity of declaration if RCI unit. It should not contain
+ -- Check validity of declaration if RCI or RT unit. It should not contain
-- the declaration of an access-to-object type unless it is a
-- general access type that designates a class-wide limited
-- private type. There are also constraints about the primitive
@@ -114,7 +115,7 @@ package body Sem_Cat is
Info_Node : Node_Id;
Is_Subunit : Boolean)
is
- N : Node_Id := Info_Node;
+ N : constant Node_Id := Info_Node;
type Categorization is
(Pure, Shared_Passive, Remote_Types,
@@ -127,6 +128,10 @@ package body Sem_Cat is
-- Check categorization flags from entity, and return in the form
-- of a corresponding enumeration value.
+ ------------------------
+ -- Get_Categorization --
+ ------------------------
+
function Get_Categorization (E : Entity_Id) return Categorization is
begin
if Is_Preelaborated (E) then
@@ -220,8 +225,8 @@ package body Sem_Cat is
and then not Is_Static_Expression (Expression (Component_Decl))
then
Error_Msg_Sloc := Sloc (Component_Decl);
- Error_Msg_N
- ("object in preelaborated unit has nonstatic default#",
+ Error_Msg_F
+ ("object in preelaborated unit has non-static default#",
Obj_Decl);
-- Fix this later ???
@@ -333,7 +338,6 @@ package body Sem_Cat is
function In_Subprogram_Task_Protected_Unit return Boolean is
E : Entity_Id;
- K : Entity_Kind;
begin
-- The following is to verify that a declaration is inside
@@ -344,16 +348,11 @@ package body Sem_Cat is
E := Current_Scope;
loop
- K := Ekind (E);
-
- if K = E_Procedure
- or else K = E_Function
- or else K = E_Generic_Procedure
- or else K = E_Generic_Function
- or else K = E_Task_Type
- or else K = E_Task_Subtype
- or else K = E_Protected_Type
- or else K = E_Protected_Subtype
+ if Is_Subprogram (E)
+ or else
+ Is_Generic_Subprogram (E)
+ or else
+ Is_Concurrent_Type (E)
then
return True;
@@ -363,7 +362,6 @@ package body Sem_Cat is
E := Scope (E);
end loop;
-
end In_Subprogram_Task_Protected_Unit;
-------------------------------
@@ -546,10 +544,59 @@ package body Sem_Cat is
end;
end Set_Categorization_From_Pragmas;
+ -----------------------------------
+ -- Set_Categorization_From_Scope --
+ -----------------------------------
+
+ procedure Set_Categorization_From_Scope (E : Entity_Id; Scop : Entity_Id) is
+ Declaration : Node_Id := Empty;
+ Specification : Node_Id := Empty;
+
+ begin
+ Set_Is_Pure (E,
+ Is_Pure (Scop) and then Is_Library_Level_Entity (E));
+
+ if not Is_Remote_Call_Interface (E) then
+ if Ekind (E) in Subprogram_Kind then
+ Declaration := Unit_Declaration_Node (E);
+
+ if False
+ or else Nkind (Declaration) = N_Subprogram_Body
+ or else Nkind (Declaration) = N_Subprogram_Renaming_Declaration
+ then
+ Specification := Corresponding_Spec (Declaration);
+ end if;
+ end if;
+
+ -- A subprogram body or renaming-as-body is a remote call
+ -- interface if it serves as the completion of a subprogram
+ -- declaration that is a remote call interface.
+
+ if Nkind (Specification) in N_Entity then
+ Set_Is_Remote_Call_Interface
+ (E, Is_Remote_Call_Interface (Specification));
+
+ -- A subprogram declaration is a remote call interface when it is
+ -- declared within the visible part of, or declared by, a library
+ -- unit declaration that is a remote call interface.
+
+ else
+ Set_Is_Remote_Call_Interface
+ (E, Is_Remote_Call_Interface (Scop)
+ and then not (In_Private_Part (Scop)
+ or else In_Package_Body (Scop)));
+ end if;
+ end if;
+
+ Set_Is_Remote_Types (E, Is_Remote_Types (Scop));
+ end Set_Categorization_From_Scope;
+
------------------------------
-- Static_Discriminant_Expr --
------------------------------
+ -- We need to accomodate a Why_Not_Static call somehow here ???
+
function Static_Discriminant_Expr (L : List_Id) return Boolean is
Discriminant_Spec : Node_Id;
@@ -600,9 +647,9 @@ package body Sem_Cat is
("named access type not allowed in pure unit", T);
end if;
- -- Check for RCI unit type declaration. It should not contain
- -- the declaration of an access-to-object type unless it is a
- -- general access type that designates a class-wide limited
+ -- Check for RCI or RT unit type declaration. It should not
+ -- contain the declaration of an access-to-object type unless it
+ -- is a general access type that designates a class-wide limited
-- private type. There are also constraints about the primitive
-- subprograms of the class-wide type.
@@ -617,22 +664,18 @@ package body Sem_Cat is
when others => null;
end case;
- -- Set Categorization flag of package on entity as well, to allow
- -- easy checks later on for required validations of RCI units. This
- -- is only done for entities that are in the original source.
-
- if Comes_From_Source (T) then
- if Is_Remote_Call_Interface (Scope (T))
- and then not In_Package_Body (Scope (T))
- then
- Set_Is_Remote_Call_Interface (T);
- end if;
+ -- Set categorization flag from package on entity as well, to allow
+ -- easy checks later on for required validations of RCI or RT units.
+ -- This is only done for entities that are in the original source.
- if Is_Remote_Types (Scope (T))
- and then not In_Package_Body (Scope (T))
- then
- Set_Is_Remote_Types (T);
- end if;
+ if Comes_From_Source (T)
+ and then not (In_Package_Body (Scope (T))
+ or else In_Private_Part (Scope (T)))
+ then
+ Set_Is_Remote_Call_Interface
+ (T, Is_Remote_Call_Interface (Scope (T)));
+ Set_Is_Remote_Types
+ (T, Is_Remote_Types (Scope (T)));
end if;
end Validate_Access_Type_Declaration;
@@ -641,8 +684,8 @@ package body Sem_Cat is
----------------------------
procedure Validate_Ancestor_Part (N : Node_Id) is
- A : constant Node_Id := Ancestor_Part (N);
- T : Entity_Id := Entity (A);
+ A : constant Node_Id := Ancestor_Part (N);
+ T : constant Entity_Id := Entity (A);
begin
if In_Preelaborated_Unit
@@ -718,7 +761,7 @@ package body Sem_Cat is
return;
end if;
- -- Process with clauses
+ -- Process explicit with_clauses that are not limited.
declare
Item : Node_Id;
@@ -729,7 +772,8 @@ package body Sem_Cat is
while Present (Item) loop
if Nkind (Item) = N_With_Clause
- and then not Implicit_With (Item)
+ and then not (Implicit_With (Item)
+ or else Limited_Present (Item))
then
Entity_Of_Withed := Entity (Name (Item));
Check_Categorization_Dependencies
@@ -1053,13 +1097,12 @@ package body Sem_Cat is
begin
E := First_Entity (P);
-
while Present (E) loop
if Comes_From_Source (E) then
-
if Is_Limited_Type (E) then
Error_Msg_N
("Limited type not allowed in rci unit", Parent (E));
+ Explain_Limited_Type (E, Parent (E));
elsif Ekind (E) = E_Generic_Function
or else Ekind (E) = E_Generic_Package
@@ -1103,7 +1146,7 @@ package body Sem_Cat is
-----------------------------------------
procedure Validate_RCI_Subprogram_Declaration (N : Node_Id) is
- K : Node_Kind := Nkind (N);
+ K : constant Node_Kind := Nkind (N);
Profile : List_Id;
Id : Node_Id;
Param_Spec : Node_Id;
@@ -1178,7 +1221,6 @@ package body Sem_Cat is
and then not (Has_Private_Declaration (Param_Type))
and then Comes_From_Source (N)))
then
-
-- A limited parameter is legal only if user-specified
-- Read and Write attributes exist for it.
-- second part of RM E.2.3 (14)
@@ -1186,7 +1228,7 @@ package body Sem_Cat is
if No (Full_View (Param_Type))
and then Ekind (Param_Type) /= E_Record_Type
then
- -- type does not have completion yet, so if declared in
+ -- Type does not have completion yet, so if declared in
-- in the current RCI scope it is illegal, and will be
-- flagged subsequently.
return;
@@ -1194,10 +1236,10 @@ package body Sem_Cat is
Base_Param_Type := Base_Type (Underlying_Type (Param_Type));
- if No (TSS (Base_Param_Type, Name_uRead))
- or else No (TSS (Base_Param_Type, Name_uWrite))
+ if No (TSS (Base_Param_Type, TSS_Stream_Read))
+ or else
+ No (TSS (Base_Param_Type, TSS_Stream_Write))
then
-
if K = N_Subprogram_Declaration then
Error_Node := Param_Spec;
end if;
@@ -1205,6 +1247,7 @@ package body Sem_Cat is
Error_Msg_N
("limited parameter in rci unit "
& "must have read/write attributes ", Error_Node);
+ Explain_Limited_Type (Param_Type, Error_Node);
end if;
end if;
@@ -1226,7 +1269,6 @@ package body Sem_Cat is
Profile : List_Id;
Param_Spec : Node_Id;
Param_Type : Entity_Id;
- Limited_Type_Decl : Node_Id;
begin
-- We are called from Analyze_Type_Declaration, and the Nkind
@@ -1247,8 +1289,8 @@ package body Sem_Cat is
return;
end if;
- -- Check RCI unit type declaration. It should not contain the
- -- declaration of an access-to-object type unless it is a
+ -- Check RCI or RT unit type declaration. It may not contain
+ -- the declaration of an access-to-object type unless it is a
-- general access type that designates a class-wide limited
-- private type. There are also constraints about the primitive
-- subprograms of the class-wide type (RM E.2.3(14)).
@@ -1269,7 +1311,6 @@ package body Sem_Cat is
end if;
Direct_Designated_Type := Designated_Type (T);
-
Desig_Type := Etype (Direct_Designated_Type);
if not Is_Recursively_Limited_Private (Desig_Type) then
@@ -1326,23 +1367,22 @@ package body Sem_Cat is
then
-- Not a controlling parameter, so type must have Read
-- and Write attributes.
- -- ??? I suspect this to be dead code because any violation
- -- should be caught before in sem_attr.adb (with the message
- -- "limited type ... used in ... has no stream attr."). ST
if Nkind (Param_Type) in N_Has_Etype
and then Nkind (Parent (Etype (Param_Type))) =
N_Private_Type_Declaration
then
Param_Type := Etype (Param_Type);
- Limited_Type_Decl := Parent (Param_Type);
- if No (TSS (Param_Type, Name_uRead))
- or else No (TSS (Param_Type, Name_uWrite))
+ if No (TSS (Param_Type, TSS_Stream_Read))
+ or else
+ No (TSS (Param_Type, TSS_Stream_Write))
then
Error_Msg_N
("limited formal must have Read and Write attributes",
Param_Spec);
+ Explain_Limited_Type
+ (Etype (Defining_Identifier (Param_Spec)), Param_Spec);
end if;
end if;
end if;
@@ -1497,33 +1537,6 @@ package body Sem_Cat is
end if;
end Validate_Remote_Access_To_Class_Wide_Type;
- -----------------------------------------------
- -- Validate_Remote_Access_To_Subprogram_Type --
- -----------------------------------------------
-
- procedure Validate_Remote_Access_To_Subprogram_Type (N : Node_Id) is
- Type_Def : constant Node_Id := Type_Definition (N);
- Current_Parameter : Node_Id;
-
- begin
- if Present (Parameter_Specifications (Type_Def)) then
- Current_Parameter := First (Parameter_Specifications (Type_Def));
- while Present (Current_Parameter) loop
- if Nkind (Parameter_Type (Current_Parameter)) =
- N_Access_Definition
- then
- Error_Msg_N
- ("remote access to subprogram type declaration contains",
- Current_Parameter);
- Error_Msg_N
- ("\parameter of an anonymous access type", Current_Parameter);
- end if;
-
- Current_Parameter := Next (Current_Parameter);
- end loop;
- end if;
- end Validate_Remote_Access_To_Subprogram_Type;
-
------------------------------------------
-- Validate_Remote_Type_Type_Conversion --
------------------------------------------
@@ -1764,7 +1777,8 @@ package body Sem_Cat is
or else Present (Enclosing_Generic_Body (N)))
then
if Ekind (Entity (N)) = E_Variable then
- Error_Msg_N ("non-static object name in preelaborated unit", N);
+ Flag_Non_Static_Expr
+ ("non-static object name in preelaborated unit", N);
-- We take the view that a constant defined in another preelaborated
-- unit is preelaborable, even though it may have a private type and
@@ -1793,7 +1807,8 @@ package body Sem_Cat is
then
null;
else
- Error_Msg_N ("non-static constant in preelaborated unit", N);
+ Flag_Non_Static_Expr
+ ("non-static constant in preelaborated unit", N);
end if;
end if;
end if;
diff --git a/gcc/ada/sem_cat.ads b/gcc/ada/sem_cat.ads
index bd3f395bd1a..cba1b75c358 100644
--- a/gcc/ada/sem_cat.ads
+++ b/gcc/ada/sem_cat.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -57,10 +57,14 @@ package Sem_Cat is
-- (RM 10.2.1(16)).
procedure Set_Categorization_From_Pragmas (N : Node_Id);
- -- Since validation of categorization dependency is done during analyze
- -- so categorization flags from following pragmas should be set before
+ -- Since validation of categorization dependency is done during Analyze,
+ -- categorization flags from following pragmas should be set before
-- validation begin. N is the N_Compilation_Unit node.
+ procedure Set_Categorization_From_Scope (E : Entity_Id; Scop : Entity_Id);
+ -- Set categorization flags Pure, Remote_Call_Interface and Remote_Types
+ -- on entity E according to those of Scop.
+
procedure Validate_Access_Type_Declaration (T : Entity_Id; N : Node_Id);
-- Validate all constraints against declaration of access types in
-- categorized library units. Usually this is a violation in Pure unit,
@@ -106,12 +110,6 @@ package Sem_Cat is
-- type. And a remote access-to-class-wide type shall not be an actual
-- parameter for a generic formal access type. RM E.2.3(22).
- procedure Validate_Remote_Access_To_Subprogram_Type (N : Node_Id);
- -- Checks that a remote access to subprogram type does not have a
- -- parameter of an access type. This is not strictly forbidden at this
- -- time, but this is useless, as such a RAS type will not be usable
- -- per E.2.2(12) and E.2.3(14).
-
procedure Validate_RT_RAT_Component (N : Node_Id);
-- Given N, the package library unit declaration node, we should check
-- against RM:9.95 E.2.2(8): the full view of a type declared in the
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index 37d789e32c0..743e943ff7a 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -28,6 +28,7 @@ with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
with Errout; use Errout;
+with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
@@ -57,6 +58,7 @@ with Sinfo.CN; use Sinfo.CN;
with Sinput; use Sinput;
with Snames; use Snames;
with Style; use Style;
+with Stylesw; use Stylesw;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uname; use Uname;
@@ -70,6 +72,14 @@ package body Sem_Ch10 is
procedure Analyze_Context (N : Node_Id);
-- Analyzes items in the context clause of compilation unit
+ procedure Build_Limited_Views (N : Node_Id);
+ -- Build list of shadow entities for a package mentioned in a
+ -- limited_with clause.
+
+ procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
+ -- Check whether the source for the body of a compilation unit must
+ -- be included in a standalone library.
+
procedure Check_With_Type_Clauses (N : Node_Id);
-- If N is a body, verify that any with_type clauses on the spec, or
-- on the spec of any parent, have a matching with_clause.
@@ -82,6 +92,13 @@ package body Sem_Ch10 is
-- Verify that a stub is declared immediately within a compilation unit,
-- and not in an inner frame.
+ procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id);
+ -- if a child unit appears in a limited_with clause, there are implicit
+ -- limited_with clauses on all parents that are not already visible
+ -- through a regular with clause. This procedure creates the implicit
+ -- limited with_clauses for the parents and loads the corresponding units.
+ -- The shadow entities are created when the inserted clause is analyzed.
+
procedure Expand_With_Clause (Nam : Node_Id; N : Node_Id);
-- When a child unit appears in a context clause, the implicit withs on
-- parents are made explicit, and with clauses are inserted in the context
@@ -106,6 +123,11 @@ package body Sem_Ch10 is
-- Subsidiary to previous one. Process only with_ and use_clauses for
-- current unit and its library unit if any.
+ procedure Install_Limited_Withed_Unit (N : Node_Id);
+ -- Place shadow entities for a limited_with package in the visibility
+ -- structures for the current compilation. Verify that there is no
+ -- regular with_clause in the context.
+
procedure Install_Withed_Unit (With_Clause : Node_Id);
-- If the unit is not a child unit, make unit immediately visible.
-- The caller ensures that the unit is not already currently installed.
@@ -145,6 +167,10 @@ package body Sem_Ch10 is
procedure Remove_Context_Clauses (N : Node_Id);
-- Subsidiary of previous one. Remove use_ and with_clauses.
+ procedure Remove_Limited_With_Clause (N : Node_Id);
+ -- Remove from visibility the shadow entities introduced for a package
+ -- mentioned in a limited_with clause.
+
procedure Remove_Parents (Lib_Unit : Node_Id);
-- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
-- contexts established by the corresponding call to Install_Parents are
@@ -155,6 +181,9 @@ package body Sem_Ch10 is
-- Reset all visibility flags on unit after compiling it, either as a
-- main unit or as a unit in the context.
+ procedure Unchain (E : Entity_Id);
+ -- Remove single entity from visibility list
+
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
-- Common processing for all stubs (subprograms, tasks, packages, and
-- protected cases). N is the stub to be analyzed. Once the subunit
@@ -162,6 +191,34 @@ package body Sem_Ch10 is
-- entity for which the proper body provides a completion. Subprogram
-- stubs are handled differently because they can be declarations.
+ --------------------------
+ -- Limited_With_Clauses --
+ --------------------------
+
+ -- Limited_With clauses are the mechanism chosen for Ada05 to support
+ -- mutually recursive types declared in different units. A limited_with
+ -- clause that names package P in the context of unit U makes the types
+ -- declared in the visible part of P available within U, but with the
+ -- restriction that these types can only be used as incomplete types.
+ -- The limited_with clause does not impose a semantic dependence on P,
+ -- and it is possible for two packages to have limited_with_clauses on
+ -- each other without creating an elaboration circularity.
+
+ -- To support this feature, the analysis of a limited_with clause must
+ -- create an abbreviated view of the package, without performing any
+ -- semantic analysis on it. This "package abstract" contains shadow
+ -- types that are in one-one correspondence with the real types in the
+ -- package, and that have the properties of incomplete types.
+
+ -- The implementation creates two element lists: one to chain the shadow
+ -- entities, and one to chain the corresponding type entities in the tree
+ -- of the package. Links between corresponding entities in both chains
+ -- allow the compiler to select the proper view of a given type, depending
+ -- on the context. Note that in contrast with the handling of private
+ -- types, the limited view and the non-limited view of a type are treated
+ -- as separate entities, and no entity exchange needs to take place, which
+ -- makes the implementation must simpler than could be feared.
+
------------------------------
-- Analyze_Compilation_Unit --
------------------------------
@@ -378,7 +435,7 @@ package body Sem_Ch10 is
-- The analysis of the parent is done with style checks off
declare
- Save_Style_Check : constant Boolean := Opt.Style_Check;
+ Save_Style_Check : constant Boolean := Style_Check;
Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
Compilation_Unit_Restrictions_Save;
@@ -485,6 +542,15 @@ package body Sem_Ch10 is
then
Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
+ -- If the unit is an instantiation whose body will be elaborated
+ -- for inlining purposes, use the the proper entity of the instance.
+
+ elsif Nkind (Unit_Node) = N_Package_Instantiation
+ and then not Error_Posted (Unit_Node)
+ then
+ Remove_Unit_From_Visibility
+ (Defining_Entity (Instance_Spec (Unit_Node)));
+
elsif Nkind (Unit_Node) = N_Package_Body
or else (Nkind (Unit_Node) = N_Subprogram_Body
and then not Acts_As_Spec (Unit_Node))
@@ -515,6 +581,11 @@ package body Sem_Ch10 is
and then Operating_Mode = Generate_Code
and then Expander_Active
then
+ -- Check whether the source for the body of the unit must be
+ -- included in a standalone library.
+
+ Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit));
+
-- Indicate that the main unit is now analyzed, to catch possible
-- circularities between it and generic bodies. Remove main unit
-- from visibility. This might seem superfluous, but the main unit
@@ -528,28 +599,25 @@ package body Sem_Ch10 is
Nam : Entity_Id;
Un : Unit_Number_Type;
- Save_Style_Check : constant Boolean := Opt.Style_Check;
+ Save_Style_Check : constant Boolean := Style_Check;
Save_C_Restrict : constant Save_Compilation_Unit_Restrictions :=
Compilation_Unit_Restrictions_Save;
begin
Item := First (Context_Items (N));
-
while Present (Item) loop
-
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
+ and then not Limited_Present (Item)
then
Nam := Entity (Name (Item));
- if (Ekind (Nam) = E_Generic_Procedure
+ if (Is_Generic_Subprogram (Nam)
and then not Is_Intrinsic_Subprogram (Nam))
- or else (Ekind (Nam) = E_Generic_Function
- and then not Is_Intrinsic_Subprogram (Nam))
or else (Ekind (Nam) = E_Generic_Package
and then Unit_Requires_Body (Nam))
then
- Opt.Style_Check := False;
+ Style_Check := False;
if Present (Renamed_Object (Nam)) then
Un :=
@@ -580,8 +648,9 @@ package body Sem_Ch10 is
elsif not Analyzed (Cunit (Un))
and then Un /= Main_Unit
+ and then not Fatal_Error (Un)
then
- Opt.Style_Check := False;
+ Style_Check := False;
Semantics (Cunit (Un));
end if;
end if;
@@ -682,10 +751,24 @@ package body Sem_Ch10 is
if Nkind (Unit_Node) = N_Package_Declaration
and then Get_Cunit_Unit_Number (N) /= Main_Unit
- and then Front_End_Inlining
and then Expander_Active
then
- Check_Body_For_Inlining (N, Defining_Entity (Unit_Node));
+ declare
+ Save_Style_Check : constant Boolean := Style_Check;
+ Save_Warning : constant Warning_Mode_Type := Warning_Mode;
+ Options : Style_Check_Options;
+
+ begin
+ Save_Style_Check_Options (Options);
+ Reset_Style_Check_Options;
+ Opt.Warning_Mode := Suppress;
+ Check_Body_For_Inlining (N, Defining_Entity (Unit_Node));
+
+ Reset_Style_Check_Options;
+ Set_Style_Check_Options (Options);
+ Style_Check := Save_Style_Check;
+ Warning_Mode := Save_Warning;
+ end;
end if;
end Analyze_Compilation_Unit;
@@ -697,7 +780,11 @@ package body Sem_Ch10 is
Item : Node_Id;
begin
- -- Loop through context items
+ -- Loop through context items. This is done is three passes:
+ -- a) The first pass analyze non-limited with-clauses.
+ -- b) The second pass add implicit limited_with clauses for the
+ -- the parents of child units.
+ -- c) The third pass analyzes limited_with clauses.
Item := First (Context_Items (N));
while Present (Item) loop
@@ -708,7 +795,7 @@ package body Sem_Ch10 is
if Nkind (Item) = N_With_Clause then
-- Skip analyzing with clause if no unit, nothing to do (this
- -- happens for a with that references a non-existent unit)
+ -- happens for a with that references a non-existant unit)
if Present (Library_Unit (Item)) then
Analyze (Item);
@@ -731,6 +818,49 @@ package body Sem_Ch10 is
Next (Item);
end loop;
+
+ -- Second pass: add implicit limited_with_clauses for parents of
+ -- child units mentioned in limited_with clauses.
+
+ Item := First (Context_Items (N));
+
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ and then Nkind (Name (Item)) = N_Selected_Component
+ then
+ Expand_Limited_With_Clause
+ (Nam => Prefix (Name (Item)), N => Item);
+ end if;
+
+ Next (Item);
+ end loop;
+
+ -- Third pass: examine all limited_with clauses.
+
+ Item := First (Context_Items (N));
+
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ then
+
+ -- Skip analyzing with clause if no unit, see above.
+
+ if Present (Library_Unit (Item)) then
+ Analyze (Item);
+ end if;
+
+ -- A limited_with does not impose an elaboration order, but
+ -- there is a semantic dependency for recompilation purposes.
+
+ if not Implicit_With (Item) then
+ Version_Update (N, Library_Unit (Item));
+ end if;
+ end if;
+
+ Next (Item);
+ end loop;
end Analyze_Context;
-------------------------------
@@ -763,6 +893,7 @@ package body Sem_Ch10 is
Set_Has_Completion (Nam);
Set_Scope (Defining_Entity (N), Current_Scope);
+ Generate_Reference (Nam, Id, 'b');
Analyze_Proper_Body (N, Nam);
end if;
end Analyze_Package_Body_Stub;
@@ -774,7 +905,6 @@ package body Sem_Ch10 is
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id) is
Subunit_Name : constant Unit_Name_Type := Get_Unit_Name (N);
Unum : Unit_Number_Type;
- Subunit_Not_Found : Boolean := False;
procedure Optional_Subunit;
-- This procedure is called when the main unit is a stub, or when we
@@ -806,7 +936,9 @@ package body Sem_Ch10 is
-- All done if we successfully loaded the subunit
- if Unum /= No_Unit and then not Fatal_Error (Unum) then
+ if Unum /= No_Unit
+ and then (not Fatal_Error (Unum) or else Try_Semantics)
+ then
Comp_Unit := Cunit (Unum);
Set_Corresponding_Stub (Unit (Comp_Unit), N);
@@ -864,6 +996,16 @@ package body Sem_Ch10 is
if Unum /= No_Unit then
Compiler_State := Analyzing;
+
+ -- Check that the proper body is a subunit and not a child
+ -- unit. If the unit was previously loaded, the error will
+ -- have been emitted when copying the generic node, so we
+ -- just return to avoid cascaded errors.
+
+ if Nkind (Unit (Cunit (Unum))) /= N_Subunit then
+ return;
+ end if;
+
Set_Corresponding_Stub (Unit (Cunit (Unum)), N);
Analyze_Subunit (Cunit (Unum));
Set_Library_Unit (N, Cunit (Unum));
@@ -878,7 +1020,7 @@ package body Sem_Ch10 is
elsif Nkind (Unit (Cunit (Main_Unit))) = N_Subunit
and then Subunit_Name /= Unit_Name (Main_Unit)
then
- if Tree_Output then
+ if ASIS_Mode then
Optional_Subunit;
end if;
@@ -901,7 +1043,7 @@ package body Sem_Ch10 is
-- presence, and emit a warning if not found, rather than terminating
-- the compilation abruptly, as for other missing file problems.
- elsif Operating_Mode = Generate_Code then
+ elsif Original_Operating_Mode = Generate_Code then
-- If the proper body is already linked to the stub node,
-- the stub is in a generic unit and just needs analyzing.
@@ -926,7 +1068,7 @@ package body Sem_Ch10 is
Subunit => True,
Error_Node => N);
- if Operating_Mode = Generate_Code
+ if Original_Operating_Mode = Generate_Code
and then Unum = No_Unit
then
Error_Msg_Name_1 := Subunit_Name;
@@ -935,7 +1077,6 @@ package body Sem_Ch10 is
Error_Msg_N
("subunit% in file{ not found!?", N);
Subunits_Missing := True;
- Subunit_Not_Found := True;
end if;
-- Load_Unit may reset Compiler_State, since it may have been
@@ -944,8 +1085,9 @@ package body Sem_Ch10 is
Compiler_State := Analyzing;
- if Unum /= No_Unit and then not Fatal_Error (Unum) then
-
+ if Unum /= No_Unit
+ and then (not Fatal_Error (Unum) or else Try_Semantics)
+ then
if Debug_Flag_L then
Write_Str ("*** Loaded subunit from stub. Analyze");
Write_Eol;
@@ -1003,7 +1145,7 @@ package body Sem_Ch10 is
begin
Check_Stub_Level (N);
- -- First occurrence of name may have been as an incomplete type.
+ -- First occurence of name may have been as an incomplete type.
if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
Nam := Full_View (Nam);
@@ -1016,6 +1158,7 @@ package body Sem_Ch10 is
else
Set_Scope (Defining_Entity (N), Current_Scope);
Set_Has_Completion (Etype (Nam));
+ Generate_Reference (Nam, Defining_Identifier (N), 'b');
Analyze_Proper_Body (N, Etype (Nam));
end if;
end Analyze_Protected_Body_Stub;
@@ -1065,11 +1208,7 @@ package body Sem_Ch10 is
-- declaration, or else introduces entity and its signature.
Analyze_Subprogram_Body (N);
-
- if Serious_Errors_Detected = 0 then
- Analyze_Proper_Body (N, Empty);
- end if;
-
+ Analyze_Proper_Body (N, Empty);
end Analyze_Subprogram_Body_Stub;
---------------------
@@ -1355,7 +1494,6 @@ package body Sem_Ch10 is
Analyze (Proper_Body (Unit (N)));
Remove_Context (N);
-
end Analyze_Subunit;
----------------------------
@@ -1369,7 +1507,7 @@ package body Sem_Ch10 is
begin
Check_Stub_Level (N);
- -- First occurrence of name may have been as an incomplete type.
+ -- First occurence of name may have been as an incomplete type.
if Present (Nam) and then Ekind (Nam) = E_Incomplete_Type then
Nam := Full_View (Nam);
@@ -1381,6 +1519,7 @@ package body Sem_Ch10 is
Error_Msg_N ("missing specification for task body", N);
else
Set_Scope (Defining_Entity (N), Current_Scope);
+ Generate_Reference (Nam, Defining_Identifier (N), 'b');
Set_Has_Completion (Etype (Nam));
Analyze_Proper_Body (N, Etype (Nam));
@@ -1410,7 +1549,16 @@ package body Sem_Ch10 is
-- label the with clause with the defining entity for the unit.
procedure Analyze_With_Clause (N : Node_Id) is
- Unit_Kind : constant Node_Kind := Nkind (Unit (Library_Unit (N)));
+
+ -- Retrieve the original kind of the unit node, before analysis.
+ -- If it is a subprogram instantiation, its analysis below will
+ -- rewrite as the declaration of the wrapper package. If the same
+ -- instantiation appears indirectly elsewhere in the context, it
+ -- will have been analyzed already.
+
+ Unit_Kind : constant Node_Kind :=
+ Nkind (Original_Node (Unit (Library_Unit (N))));
+
E_Name : Entity_Id;
Par_Name : Entity_Id;
Pref : Node_Id;
@@ -1424,6 +1572,14 @@ package body Sem_Ch10 is
Compilation_Unit_Restrictions_Save;
begin
+ if Limited_Present (N) then
+
+ -- Build visibility structures but do not analyze unit
+
+ Build_Limited_Views (N);
+ return;
+ end if;
+
-- We reset ordinary style checking during the analysis of a with'ed
-- unit, but we do NOT reset GNAT special analysis mode (the latter
-- definitely *does* apply to with'ed units).
@@ -1432,19 +1588,19 @@ package body Sem_Ch10 is
Style_Check := False;
end if;
- -- If the library unit is a predefined unit, and we are in no
- -- run time mode, then temporarily reset No_Run_Time mode for the
- -- analysis of the with'ed unit. The No_Run_Time pragma does not
- -- prevent explicit with'ing of run-time units.
+ -- If the library unit is a predefined unit, and we are in high
+ -- integrity mode, then temporarily reset Configurable_Run_Time_Mode
+ -- for the analysis of the with'ed unit. This mode does not prevent
+ -- explicit with'ing of run-time units.
- if No_Run_Time
+ if Configurable_Run_Time_Mode
and then
Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Unit (Library_Unit (N)))))
then
- No_Run_Time := False;
+ Configurable_Run_Time_Mode := False;
Semantics (Library_Unit (N));
- No_Run_Time := True;
+ Configurable_Run_Time_Mode := True;
else
Semantics (Library_Unit (N));
@@ -1469,12 +1625,14 @@ package body Sem_Ch10 is
-- Check for inappropriate with of internal implementation unit
-- if we are currently compiling the main unit and the main unit
- -- is itself not an internal unit.
+ -- is itself not an internal unit. We do not issue this message
+ -- for implicit with's generated by the compiler itself.
if Implementation_Unit_Warnings
and then Current_Sem_Unit = Main_Unit
and then Implementation_Unit (Get_Source_Unit (U))
and then not Intunit
+ and then not Implicit_With (N)
then
Error_Msg_N ("& is an internal 'G'N'A'T unit?", Name (N));
Error_Msg_N
@@ -1562,7 +1720,7 @@ package body Sem_Ch10 is
-- reference that occurs.
Set_Entity_With_Style_Check (Name (N), E_Name);
- Generate_Reference (E_Name, Name (N), Set_Ref => False);
+ Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False);
if Is_Child_Unit (E_Name) then
Pref := Prefix (Name (N));
@@ -1602,7 +1760,7 @@ package body Sem_Ch10 is
if Chars (E_Name) = Name_System
and then Scope (E_Name) = Standard_Standard
- and then Present (System_Extend_Pragma_Arg)
+ and then Present (System_Extend_Unit)
and then Present_System_Aux (N)
then
-- If the extension is not present, an error will have been emitted.
@@ -1617,7 +1775,7 @@ package body Sem_Ch10 is
procedure Analyze_With_Type_Clause (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Nam : Node_Id := Name (N);
+ Nam : constant Node_Id := Name (N);
Pack : Node_Id;
Decl : Node_Id;
P : Entity_Id;
@@ -1972,8 +2130,10 @@ package body Sem_Ch10 is
-- an explicit designation of private.
function Is_Private_Library_Unit (Unit : Entity_Id) return Boolean is
+ Comp_Unit : constant Node_Id := Parent (Unit_Declaration_Node (Unit));
+
begin
- return Private_Present (Parent (Unit_Declaration_Node (Unit)));
+ return Private_Present (Comp_Unit);
end Is_Private_Library_Unit;
-- Start of processing for Check_Private_Child_Unit
@@ -2180,6 +2340,88 @@ package body Sem_Ch10 is
New_Nodes_OK := New_Nodes_OK - 1;
end Expand_With_Clause;
+ --------------------------------
+ -- Expand_Limited_With_Clause --
+ --------------------------------
+
+ procedure Expand_Limited_With_Clause (Nam : Node_Id; N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Nam);
+ P : Entity_Id;
+ Unum : Unit_Number_Type;
+ Withn : Node_Id;
+
+ begin
+ New_Nodes_OK := New_Nodes_OK + 1;
+
+ if Nkind (Nam) = N_Identifier then
+ Withn :=
+ Make_With_Clause (Loc, Name => Nam);
+ Set_Limited_Present (Withn);
+ Set_First_Name (Withn);
+ Set_Implicit_With (Withn);
+
+ -- Load the corresponding parent unit
+
+ Unum :=
+ Load_Unit
+ (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)),
+ Required => True,
+ Subunit => False,
+ Error_Node => Nam);
+
+ P := Cunit_Entity (Unum);
+
+ if not Analyzed (Cunit (Unum)) then
+ Set_Library_Unit (Withn, Cunit (Unum));
+ Set_Corresponding_Spec
+ (Withn, Specification (Unit (Cunit (Unum))));
+
+ Prepend (Withn, Context_Items (Parent (N)));
+ Mark_Rewrite_Insertion (Withn);
+ end if;
+
+ elsif Nkind (Nam) = N_Selected_Component then
+ Withn :=
+ Make_With_Clause
+ (Loc,
+ Name =>
+ Make_Selected_Component
+ (Loc,
+ Prefix => Prefix (Nam),
+ Selector_Name => Selector_Name (Nam)));
+
+ Set_Parent (Withn, Parent (N));
+ Set_Limited_Present (Withn);
+ Set_First_Name (Withn);
+ Set_Implicit_With (Withn);
+
+ Unum :=
+ Load_Unit
+ (Load_Name => Get_Spec_Name (Get_Unit_Name (Nam)),
+ Required => True,
+ Subunit => False,
+ Error_Node => Nam);
+
+ P := Cunit_Entity (Unum);
+
+ if not Analyzed (Cunit (Unum)) then
+ Set_Library_Unit (Withn, Cunit (Unum));
+ Set_Corresponding_Spec
+ (Withn, Specification (Unit (Cunit (Unum))));
+ Prepend (Withn, Context_Items (Parent (N)));
+ Mark_Rewrite_Insertion (Withn);
+
+ Expand_Limited_With_Clause (Prefix (Nam), N);
+ end if;
+
+ else
+ null;
+ pragma Assert (False);
+ end if;
+
+ New_Nodes_OK := New_Nodes_OK - 1;
+ end Expand_Limited_With_Clause;
+
-----------------------
-- Get_Parent_Entity --
-----------------------
@@ -2204,8 +2446,7 @@ package body Sem_Ch10 is
Loc : constant Source_Ptr := Sloc (N);
P : constant Node_Id := Parent_Spec (Child_Unit);
P_Unit : constant Node_Id := Unit (P);
-
- P_Name : Entity_Id := Get_Parent_Entity (P_Unit);
+ P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit);
Withn : Node_Id;
function Build_Ancestor_Name (P : Node_Id) return Node_Id;
@@ -2220,7 +2461,8 @@ package body Sem_Ch10 is
-------------------------
function Build_Ancestor_Name (P : Node_Id) return Node_Id is
- P_Ref : Node_Id := New_Reference_To (Defining_Entity (P), Loc);
+ P_Ref : constant Node_Id :=
+ New_Reference_To (Defining_Entity (P), Loc);
begin
if No (Parent_Spec (P)) then
@@ -2283,7 +2525,7 @@ package body Sem_Ch10 is
---------------------
procedure Install_Context (N : Node_Id) is
- Lib_Unit : Node_Id := Unit (N);
+ Lib_Unit : constant Node_Id := Unit (N);
begin
Install_Context_Clauses (N);
@@ -2300,15 +2542,18 @@ package body Sem_Ch10 is
-----------------------------
procedure Install_Context_Clauses (N : Node_Id) is
- Lib_Unit : Node_Id := Unit (N);
+ Lib_Unit : constant Node_Id := Unit (N);
Item : Node_Id;
Uname_Node : Entity_Id;
Check_Private : Boolean := False;
Decl_Node : Node_Id;
Lib_Parent : Entity_Id;
+ Lim_Present : Boolean := False;
begin
- -- Loop through context clauses to find the with/use clauses
+ -- Loop through context clauses to find the with/use clauses.
+ -- This is done twice, first for everything except limited_with
+ -- clauses, and then for those, if any are present.
Item := First (Context_Items (N));
while Present (Item) loop
@@ -2318,10 +2563,21 @@ package body Sem_Ch10 is
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
then
+ if Limited_Present (Item) then
+
+ -- Second pass will be necessary
+
+ Lim_Present := True;
+ goto Continue;
+
-- If Name (Item) is not an entity name, something is wrong, and
-- this will be detected in due course, for now ignore the item
- if not Is_Entity_Name (Name (Item)) then
+ elsif not Is_Entity_Name (Name (Item)) then
+ goto Continue;
+
+ elsif No (Entity (Name (Item))) then
+ Set_Entity (Name (Item), Any_Id);
goto Continue;
end if;
@@ -2522,6 +2778,22 @@ package body Sem_Ch10 is
if Check_Private then
Check_Private_Child_Unit (N);
end if;
+
+ -- Second pass: install limited_with clauses
+
+ if Lim_Present then
+ Item := First (Context_Items (N));
+
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ then
+ Install_Limited_Withed_Unit (Item);
+ end if;
+
+ Next (Item);
+ end loop;
+ end if;
end Install_Context_Clauses;
---------------------
@@ -2616,6 +2888,13 @@ package body Sem_Ch10 is
Install_Visible_Declarations (P_Name);
Set_Use (Visible_Declarations (P_Spec));
+ -- If the parent is a generic unit, its formal part may contain
+ -- formal packages and use clauses for them.
+
+ if Ekind (P_Name) = E_Generic_Package then
+ Set_Use (Generic_Formal_Declarations (Parent (P_Spec)));
+ end if;
+
if Is_Private
or else Private_Present (Parent (Lib_Unit))
then
@@ -2670,6 +2949,7 @@ package body Sem_Ch10 is
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
+ and then not Limited_Present (Item)
then
Id := Entity (Name (Item));
@@ -2716,18 +2996,143 @@ package body Sem_Ch10 is
then
Set_Is_Immediately_Visible (Scope (Id));
end if;
+
end if;
Next (Item);
end loop;
end Install_Siblings;
+ -------------------------------
+ -- Install_Limited_With_Unit --
+ -------------------------------
+
+ procedure Install_Limited_Withed_Unit (N : Node_Id) is
+ Unum : Unit_Number_Type :=
+ Get_Source_Unit (Library_Unit (N));
+ P_Unit : Entity_Id := Unit (Library_Unit (N));
+ P : Entity_Id :=
+ Defining_Unit_Name (Specification (P_Unit));
+ Lim_Elmt : Elmt_Id;
+ Lim_Typ : Entity_Id;
+ Is_Child_Package : Boolean := False;
+
+ function In_Chain (E : Entity_Id) return Boolean;
+ -- Check that the shadow entity is not already in the homonym
+ -- chain, for example through a limited_with clause in a parent unit.
+
+ function In_Chain (E : Entity_Id) return Boolean is
+ H : Entity_Id := Current_Entity (E);
+
+ begin
+ while Present (H) loop
+ if H = E then
+ return True;
+ else
+ H := Homonym (H);
+ end if;
+ end loop;
+
+ return False;
+ end In_Chain;
+
+ -- Start of processing for Install_Limited_Withed_Unit
+
+ begin
+ if Nkind (P) = N_Defining_Program_Unit_Name then
+
+ -- Retrieve entity of child package
+
+ Is_Child_Package := True;
+ P := Defining_Identifier (P);
+ end if;
+
+ if Analyzed (Cunit (Unum))
+ and then Is_Immediately_Visible (P)
+ then
+ -- disallow naming in a limited with clause a unit (or renaming
+ -- thereof) that is mentioned in an enclosing normal with clause.
+ Error_Msg_N ("limited_with not allowed on unit already withed", N);
+
+ return;
+ end if;
+
+ if not Analyzed (Cunit (Unum)) then
+ Set_Ekind (P, E_Package);
+ Set_Etype (P, Standard_Void_Type);
+ Set_Scope (P, Standard_Standard);
+
+ -- Place entity on visibility structure
+
+ if Current_Entity (P) /= P then
+ Set_Homonym (P, Current_Entity (P));
+ Set_Current_Entity (P);
+ end if;
+
+ if Is_Child_Package then
+ Set_Is_Child_Unit (P);
+ Set_Is_Visible_Child_Unit (P);
+
+ declare
+ Parent_Comp : Node_Id;
+ Parent_Id : Entity_Id;
+
+ begin
+ Parent_Comp := Parent_Spec (Unit (Cunit (Unum)));
+ Parent_Id := Defining_Entity (Unit (Parent_Comp));
+
+ Set_Scope (P, Parent_Id);
+ end;
+ end if;
+ else
+ -- If the unit appears in a previous regular with_clause, the
+ -- regular entities must be unchained before the shadow ones
+ -- are made accessible.
+
+ declare
+ Ent : Entity_Id;
+ begin
+ Ent := First_Entity (P);
+
+ while Present (Ent) loop
+ Unchain (Ent);
+ Next_Entity (Ent);
+ end loop;
+ end;
+ end if;
+
+ -- The package must be visible while the with_type clause is active,
+ -- because references to the type P.T must resolve in the usual way.
+
+ Set_Is_Immediately_Visible (P);
+
+ -- Install each incomplete view
+
+ Lim_Elmt := First_Elmt (Limited_Views (P));
+
+ while Present (Lim_Elmt) loop
+ Lim_Typ := Node (Lim_Elmt);
+
+ if not In_Chain (Lim_Typ) then
+ Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ));
+ Set_Current_Entity (Lim_Typ);
+ end if;
+
+ Next_Elmt (Lim_Elmt);
+ end loop;
+
+ -- The context clause has installed a limited-view, mark it
+ -- accordingly, to uninstall it when the context is removed.
+
+ Set_Limited_View_Installed (N);
+ end Install_Limited_Withed_Unit;
+
-------------------------
-- Install_Withed_Unit --
-------------------------
procedure Install_Withed_Unit (With_Clause : Node_Id) is
- Uname : Entity_Id := Entity (Name (With_Clause));
+ Uname : constant Entity_Id := Entity (Name (With_Clause));
P : constant Entity_Id := Scope (Uname);
begin
@@ -2853,7 +3258,7 @@ package body Sem_Ch10 is
else
Compiler_State := Analyzing; -- reset after load
- if not Fatal_Error (Unum) then
+ if not Fatal_Error (Unum) or else Try_Semantics then
if Debug_Flag_L then
Write_Str ("*** Loaded generic body");
Write_Eol;
@@ -2868,6 +3273,357 @@ package body Sem_Ch10 is
Style_Check := Save_Style_Check;
end Load_Needed_Body;
+ -------------------------
+ -- Build_Limited_Views --
+ -------------------------
+
+ procedure Build_Limited_Views (N : Node_Id) is
+
+ Unum : Unit_Number_Type := Get_Source_Unit (Library_Unit (N));
+ P : Entity_Id := Cunit_Entity (Unum);
+
+ Spec : Node_Id; -- To denote a package specification
+ Lim_Typ : Entity_Id; -- To denote shadow entities.
+ Comp_Typ : Entity_Id; -- To denote real entities.
+
+ procedure Decorate_Incomplete_Type
+ (E : Entity_Id;
+ Scop : Entity_Id);
+ -- Add attributes of an incomplete type to a shadow entity. The same
+ -- attributes are placed on the real entity, so that gigi receives
+ -- a consistent view.
+
+ procedure Decorate_Package_Specification (P : Entity_Id);
+ -- Add attributes of a package entity to the entity in a package
+ -- declaration
+
+ procedure Decorate_Tagged_Type
+ (Loc : Source_Ptr;
+ T : Entity_Id;
+ Scop : Entity_Id);
+ -- Set basic attributes of tagged type T, including its class_wide type.
+ -- The parameters Loc, Scope are used to decorate the class_wide type.
+
+ procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id);
+ -- Construct list of shadow entities and attach it to entity of
+ -- package that is mentioned in a limited_with clause.
+
+ ------------------------------
+ -- Decorate_Incomplete_Type --
+ ------------------------------
+
+ procedure Decorate_Incomplete_Type
+ (E : Entity_Id;
+ Scop : Entity_Id)
+ is
+ begin
+ Set_Ekind (E, E_Incomplete_Type);
+ Set_Scope (E, Scop);
+ Set_Etype (E, E);
+ Set_Is_First_Subtype (E, True);
+ Set_Stored_Constraint (E, No_Elist);
+ Set_Full_View (E, Empty);
+ Init_Size_Align (E);
+ Set_Has_Unknown_Discriminants (E);
+ end Decorate_Incomplete_Type;
+
+ --------------------------
+ -- Decorate_Tagged_Type --
+ --------------------------
+
+ procedure Decorate_Tagged_Type
+ (Loc : Source_Ptr;
+ T : Entity_Id;
+ Scop : Entity_Id)
+ is
+ CW : Entity_Id;
+
+ begin
+ Decorate_Incomplete_Type (T, Scop);
+ Set_Is_Tagged_Type (T);
+
+ -- Build corresponding class_wide type, if not previously done
+
+ if No (Class_Wide_Type (T)) then
+ CW := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+
+ Set_Ekind (CW, E_Class_Wide_Type);
+ Set_Etype (CW, T);
+ Set_Scope (CW, Scop);
+ Set_Is_Tagged_Type (CW);
+ Set_Is_First_Subtype (CW, True);
+ Init_Size_Align (CW);
+ Set_Has_Unknown_Discriminants (CW, True);
+ Set_Class_Wide_Type (CW, CW);
+ Set_Equivalent_Type (CW, Empty);
+ Set_From_With_Type (CW, From_With_Type (T));
+
+ Set_Class_Wide_Type (T, CW);
+ end if;
+ end Decorate_Tagged_Type;
+
+ ------------------------------------
+ -- Decorate_Package_Specification --
+ ------------------------------------
+
+ procedure Decorate_Package_Specification (P : Entity_Id) is
+ begin
+ -- Place only the most basic attributes
+
+ Set_Ekind (P, E_Package);
+ Set_Etype (P, Standard_Void_Type);
+ end Decorate_Package_Specification;
+
+ -----------------
+ -- Build_Chain --
+ -----------------
+
+ procedure Build_Chain (Spec : Node_Id; Scope : Entity_Id) is
+ Decl : Node_Id;
+
+ begin
+ Decl := First (Visible_Declarations (Spec));
+
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Full_Type_Declaration then
+ Comp_Typ := Defining_Identifier (Decl);
+
+ if not Analyzed (Cunit (Unum)) then
+ if Tagged_Present (Type_Definition (Decl)) then
+ Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
+ else
+ Decorate_Incomplete_Type (Comp_Typ, Scope);
+ end if;
+ end if;
+
+ -- Create shadow entity for type
+
+ Lim_Typ := New_Internal_Entity
+ (Kind => Ekind (Comp_Typ),
+ Scope_Id => Scope,
+ Sloc_Value => Sloc (Comp_Typ),
+ Id_Char => 'Z');
+
+ Set_Chars (Lim_Typ, Chars (Comp_Typ));
+ Set_Parent (Lim_Typ, Parent (Comp_Typ));
+ Set_From_With_Type (Lim_Typ);
+
+ if Tagged_Present (Type_Definition (Decl)) then
+ Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
+ else
+ Decorate_Incomplete_Type (Lim_Typ, Scope);
+ end if;
+
+ Set_Non_Limited_View (Lim_Typ, Comp_Typ);
+
+ -- Add each entity to the proper list
+
+ Append_Elmt (Comp_Typ, To => Non_Limited_Views (P));
+ Append_Elmt (Lim_Typ, To => Limited_Views (P));
+
+ elsif Nkind (Decl) = N_Private_Type_Declaration
+ and then Tagged_Present (Decl)
+ then
+ Comp_Typ := Defining_Identifier (Decl);
+
+ if not Analyzed (Cunit (Unum)) then
+ Decorate_Tagged_Type (Sloc (Decl), Comp_Typ, Scope);
+ end if;
+
+ Lim_Typ := New_Internal_Entity
+ (Kind => Ekind (Comp_Typ),
+ Scope_Id => Scope,
+ Sloc_Value => Sloc (Comp_Typ),
+ Id_Char => 'Z');
+
+ Set_Chars (Lim_Typ, Chars (Comp_Typ));
+ Set_Parent (Lim_Typ, Parent (Comp_Typ));
+ Set_From_With_Type (Lim_Typ);
+
+ Decorate_Tagged_Type (Sloc (Decl), Lim_Typ, Scope);
+
+ Set_Non_Limited_View (Lim_Typ, Comp_Typ);
+
+ -- Add the entities to the proper list
+
+ Append_Elmt (Comp_Typ, To => Non_Limited_Views (P));
+ Append_Elmt (Lim_Typ, To => Limited_Views (P));
+
+ elsif Nkind (Decl) = N_Package_Declaration then
+
+ -- Local package
+
+ declare
+ Spec : Node_Id := Specification (Decl);
+
+ begin
+ Comp_Typ := Defining_Unit_Name (Spec);
+
+ if not Analyzed (Cunit (Unum)) then
+ Decorate_Package_Specification (Comp_Typ);
+ Set_Scope (Comp_Typ, Scope);
+ end if;
+
+ Lim_Typ := New_Internal_Entity
+ (Kind => Ekind (Comp_Typ),
+ Scope_Id => Scope,
+ Sloc_Value => Sloc (Comp_Typ),
+ Id_Char => 'Z');
+
+ Decorate_Package_Specification (Lim_Typ);
+ Set_Scope (Lim_Typ, Scope);
+
+ Set_Chars (Lim_Typ, Chars (Comp_Typ));
+ Set_Parent (Lim_Typ, Parent (Comp_Typ));
+ Set_From_With_Type (Lim_Typ);
+
+ -- Note: The non_limited_view attribute is not used
+ -- for local packages.
+
+ -- Add the entities to the proper list.
+ Append_Elmt (Comp_Typ, To => Non_Limited_Views (P));
+ Append_Elmt (Lim_Typ, To => Limited_Views (P));
+
+ Build_Chain (Spec, Scope => Lim_Typ);
+ end;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Build_Chain;
+
+ -- Start of processing for Build_Limited_Views
+
+ begin
+ pragma Assert (Limited_Present (N));
+
+ -- Limited withed subprograms are not allowed. Therefore, we
+ -- don't need to build the limited-view auxiliary chain.
+
+ if Nkind (Parent (P)) = N_Function_Specification
+ or else Nkind (Parent (P)) = N_Procedure_Specification
+ then
+ return;
+ end if;
+
+ -- Check if the chain is already built
+
+ Spec := Specification (Unit (Library_Unit (N)));
+
+ if Limited_View_Installed (Spec) then
+ return;
+ end if;
+
+ Set_Ekind (P, E_Package);
+ Set_Limited_Views (P, New_Elmt_List);
+ Set_Non_Limited_Views (P, New_Elmt_List);
+ -- Set_Entity (Name (N), P);
+
+ -- Create the auxiliary chain
+
+ Build_Chain (Spec, Scope => P);
+ Set_Limited_View_Installed (Spec);
+ end Build_Limited_Views;
+
+ -------------------------------
+ -- Check_Body_Needed_For_SAL --
+ -------------------------------
+
+ procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is
+
+ function Entity_Needs_Body (E : Entity_Id) return Boolean;
+ -- Determine whether use of entity E might require the presence
+ -- of its body. For a package this requires a recursive traversal
+ -- of all nested declarations.
+
+ ---------------------------
+ -- Entity_Needed_For_SAL --
+ ---------------------------
+
+ function Entity_Needs_Body (E : Entity_Id) return Boolean is
+ Ent : Entity_Id;
+
+ begin
+ if Is_Subprogram (E)
+ and then Has_Pragma_Inline (E)
+ then
+ return True;
+
+ elsif Ekind (E) = E_Generic_Function
+ or else Ekind (E) = E_Generic_Procedure
+ then
+ return True;
+
+ elsif Ekind (E) = E_Generic_Package
+ and then
+ Nkind (Unit_Declaration_Node (E)) = N_Generic_Package_Declaration
+ and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
+ then
+ return True;
+
+ elsif Ekind (E) = E_Package
+ and then
+ Nkind (Unit_Declaration_Node (E)) = N_Package_Declaration
+ and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
+ then
+ Ent := First_Entity (E);
+
+ while Present (Ent) loop
+ if Entity_Needs_Body (Ent) then
+ return True;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+
+ return False;
+
+ else
+ return False;
+ end if;
+ end Entity_Needs_Body;
+
+ -- Start of processing for Check_Body_Needed_For_SAL
+
+ begin
+ if Ekind (Unit_Name) = E_Generic_Package
+ and then
+ Nkind (Unit_Declaration_Node (Unit_Name)) =
+ N_Generic_Package_Declaration
+ and then
+ Present (Corresponding_Body (Unit_Declaration_Node (Unit_Name)))
+ then
+ Set_Body_Needed_For_SAL (Unit_Name);
+
+ elsif Ekind (Unit_Name) = E_Generic_Procedure
+ or else Ekind (Unit_Name) = E_Generic_Function
+ then
+ Set_Body_Needed_For_SAL (Unit_Name);
+
+ elsif Is_Subprogram (Unit_Name)
+ and then Nkind (Unit_Declaration_Node (Unit_Name)) =
+ N_Subprogram_Declaration
+ and then Has_Pragma_Inline (Unit_Name)
+ then
+ Set_Body_Needed_For_SAL (Unit_Name);
+
+ elsif Ekind (Unit_Name) = E_Subprogram_Body then
+ Check_Body_Needed_For_SAL
+ (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
+
+ elsif Ekind (Unit_Name) = E_Package
+ and then Entity_Needs_Body (Unit_Name)
+ then
+ Set_Body_Needed_For_SAL (Unit_Name);
+
+ elsif Ekind (Unit_Name) = E_Package_Body
+ and then Nkind (Unit_Declaration_Node (Unit_Name)) = N_Package_Body
+ then
+ Check_Body_Needed_For_SAL
+ (Corresponding_Spec (Unit_Declaration_Node (Unit_Name)));
+ end if;
+ end Check_Body_Needed_For_SAL;
+
--------------------
-- Remove_Context --
--------------------
@@ -2905,6 +3661,12 @@ package body Sem_Ch10 is
-- on entry, as indicated by their Context_Installed flag set
if Nkind (Item) = N_With_Clause
+ and then Limited_Present (Item)
+ and then Limited_View_Installed (Item)
+ then
+ Remove_Limited_With_Clause (Item);
+
+ elsif Nkind (Item) = N_With_Clause
and then Context_Installed (Item)
then
-- Remove items from one with'ed unit
@@ -2928,6 +3690,52 @@ package body Sem_Ch10 is
end Remove_Context_Clauses;
+ --------------------------------
+ -- Remove_Limited_With_Clause --
+ --------------------------------
+
+ procedure Remove_Limited_With_Clause (N : Node_Id) is
+ P_Unit : Entity_Id := Unit (Library_Unit (N));
+ P : Entity_Id := Defining_Unit_Name (Specification (P_Unit));
+
+ Lim_Elmt : Elmt_Id;
+ Lim_Typ : Entity_Id;
+
+ begin
+ if Nkind (P) = N_Defining_Program_Unit_Name then
+
+ -- Retrieve entity of Child package
+
+ P := Defining_Identifier (P);
+ end if;
+
+ -- Remove all shadow entities from visibility
+
+ Lim_Elmt := First_Elmt (Limited_Views (P));
+
+ while Present (Lim_Elmt) loop
+ Lim_Typ := Node (Lim_Elmt);
+
+ Unchain (Lim_Typ);
+ Next_Elmt (Lim_Elmt);
+ end loop;
+
+ -- If the exporting package has previously been analyzed, it
+ -- has appeared in the closure already and should be left alone.
+ -- Otherwise, remove package itself from visibility.
+
+ if not Analyzed (P_Unit) then
+ Unchain (P);
+ Set_First_Entity (P, Empty);
+ Set_Last_Entity (P, Empty);
+ Set_Ekind (P, E_Void);
+ Set_Scope (P, Empty);
+ Set_Is_Immediately_Visible (P, False);
+ end if;
+
+ Set_Limited_View_Installed (N, False);
+ end Remove_Limited_With_Clause;
+
--------------------
-- Remove_Parents --
--------------------
@@ -2942,7 +3750,7 @@ package body Sem_Ch10 is
begin
if Is_Child_Spec (Lib_Unit) then
P := Unit (Parent_Spec (Lib_Unit));
- P_Name := Defining_Entity (P);
+ P_Name := Get_Parent_Entity (P);
Remove_Context_Clauses (Parent_Spec (Lib_Unit));
End_Package_Scope (P_Name);
@@ -3005,7 +3813,7 @@ package body Sem_Ch10 is
Prev := Homonym (Prev);
end loop;
- if (Present (Prev)) then
+ if Present (Prev) then
Set_Homonym (Prev, Homonym (E));
end if;
end if;
@@ -3069,7 +3877,7 @@ package body Sem_Ch10 is
---------------------------------
procedure Remove_Unit_From_Visibility (Unit_Name : Entity_Id) is
- P : Entity_Id := Scope (Unit_Name);
+ P : constant Entity_Id := Scope (Unit_Name);
begin
@@ -3088,4 +3896,32 @@ package body Sem_Ch10 is
end Remove_Unit_From_Visibility;
+ -------------
+ -- Unchain --
+ -------------
+
+ procedure Unchain (E : Entity_Id) is
+ Prev : Entity_Id;
+
+ begin
+ Prev := Current_Entity (E);
+
+ if No (Prev) then
+ return;
+
+ elsif Prev = E then
+ Set_Name_Entity_Id (Chars (E), Homonym (E));
+
+ else
+ while Present (Prev)
+ and then Homonym (Prev) /= E
+ loop
+ Prev := Homonym (Prev);
+ end loop;
+
+ if Present (Prev) then
+ Set_Homonym (Prev, Homonym (E));
+ end if;
+ end if;
+ end Unchain;
end Sem_Ch10;
diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb
index 52a620727a0..6ce5a305718 100644
--- a/gcc/ada/sem_ch11.adb
+++ b/gcc/ada/sem_ch11.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- --
@@ -25,6 +25,7 @@
------------------------------------------------------------------------------
with Atree; use Atree;
+with Checks; use Checks;
with Einfo; use Einfo;
with Errout; use Errout;
with Lib; use Lib;
@@ -62,7 +63,6 @@ package body Sem_Ch11 is
Set_Is_Statically_Allocated (Id);
Set_Is_Pure (Id, PF);
-
end Analyze_Exception_Declaration;
--------------------------------
@@ -78,15 +78,23 @@ package body Sem_Ch11 is
procedure Check_Duplication (Id : Node_Id);
-- Iterate through the identifiers in each handler to find duplicates
+ function Others_Present return Boolean;
+ -- Returns True if others handler is present
+
-----------------------
-- Check_Duplication --
-----------------------
procedure Check_Duplication (Id : Node_Id) is
- Handler : Node_Id;
- Id1 : Node_Id;
+ Handler : Node_Id;
+ Id1 : Node_Id;
+ Id_Entity : Entity_Id := Entity (Id);
begin
+ if Present (Renamed_Entity (Id_Entity)) then
+ Id_Entity := Renamed_Entity (Id_Entity);
+ end if;
+
Handler := First_Non_Pragma (L);
while Present (Handler) loop
Id1 := First (Exception_Choices (Handler));
@@ -101,7 +109,9 @@ package body Sem_Ch11 is
return;
elsif Nkind (Id1) /= N_Others_Choice
- and then Entity (Id) = Entity (Id1)
+ and then
+ (Id_Entity = Entity (Id1)
+ or else (Id_Entity = Renamed_Entity (Entity (Id1))))
then
if Handler /= Parent (Id) then
Error_Msg_Sloc := Sloc (Id1);
@@ -123,6 +133,28 @@ package body Sem_Ch11 is
end loop;
end Check_Duplication;
+ --------------------
+ -- Others_Present --
+ --------------------
+
+ function Others_Present return Boolean is
+ H : Node_Id;
+
+ begin
+ H := First (L);
+ while Present (H) loop
+ if Nkind (H) /= N_Pragma
+ and then Nkind (First (Exception_Choices (H))) = N_Others_Choice
+ then
+ return True;
+ end if;
+
+ Next (H);
+ end loop;
+
+ return False;
+ end Others_Present;
+
-- Start processing for Analyze_Exception_Handlers
begin
@@ -130,6 +162,11 @@ package body Sem_Ch11 is
Check_Restriction (No_Exceptions, Handler);
Check_Restriction (No_Exception_Handlers, Handler);
+ -- Kill current remembered values, since we don't know where we were
+ -- when the exception was raised.
+
+ Kill_Current_Values;
+
-- Loop through handlers (which can include pragmas)
while Present (Handler) loop
@@ -153,7 +190,6 @@ package body Sem_Ch11 is
Choice := Choice_Parameter (Handler);
if Present (Choice) then
-
if No (H_Scope) then
H_Scope := New_Internal_Entity
(E_Block, Current_Scope, Sloc (Choice), 'E');
@@ -175,6 +211,11 @@ package body Sem_Ch11 is
Set_Ekind (Choice, E_Variable);
Set_Etype (Choice, RTE (RE_Exception_Occurrence));
Generate_Definition (Choice);
+
+ -- Set source assigned flag, since in effect this field
+ -- is always assigned an initial value by the exception.
+
+ Set_Never_Set_In_Source (Choice, False);
end if;
Id := First (Exception_Choices (Handler));
@@ -197,7 +238,15 @@ package body Sem_Ch11 is
else
if Present (Renamed_Entity (Entity (Id))) then
- Set_Entity (Id, Renamed_Entity (Entity (Id)));
+ if Entity (Id) = Standard_Numeric_Error
+ and then Warn_On_Obsolescent_Feature
+ then
+ Error_Msg_N
+ ("Numeric_Error is an " &
+ "obsolescent feature ('R'M 'J.6(1))?", Id);
+ Error_Msg_N
+ ("|use Constraint_Error instead?", Id);
+ end if;
end if;
Check_Duplication (Id);
@@ -207,9 +256,14 @@ package body Sem_Ch11 is
declare
Ent : Entity_Id := Entity (Id);
- Scop : Entity_Id := Scope (Ent);
+ Scop : Entity_Id;
begin
+ if Present (Renamed_Entity (Ent)) then
+ Ent := Renamed_Entity (Ent);
+ end if;
+
+ Scop := Scope (Ent);
while Scop /= Standard_Standard
and then Ekind (Scop) = E_Package
loop
@@ -244,12 +298,33 @@ package body Sem_Ch11 is
Next (Id);
end loop;
+ -- Check for redundant handler (has only raise statement) and
+ -- is either an others handler, or is a specific handler when
+ -- no others handler is present.
+
+ if Warn_On_Redundant_Constructs
+ and then List_Length (Statements (Handler)) = 1
+ and then Nkind (First (Statements (Handler))) = N_Raise_Statement
+ and then No (Name (First (Statements (Handler))))
+ and then (not Others_Present
+ or else Nkind (First (Exception_Choices (Handler))) =
+ N_Others_Choice)
+ then
+ Error_Msg_N
+ ("useless handler contains only a reraise statement?",
+ Handler);
+ end if;
+
+ -- Now analyze the statements of this handler
+
Analyze_Statements (Statements (Handler));
+ -- If a choice was present, we created a special scope for it,
+ -- so this is where we pop that special scope to get rid of it.
+
if Present (Choice) then
End_Scope;
end if;
-
end if;
Next (Handler);
@@ -264,6 +339,10 @@ package body Sem_Ch11 is
Handlers : constant List_Id := Exception_Handlers (N);
begin
+ if Present (Handlers) then
+ Kill_All_Checks;
+ end if;
+
Analyze_Statements (Statements (N));
if Present (Handlers) then
@@ -293,6 +372,38 @@ package body Sem_Ch11 is
Check_Restriction (No_Exceptions, N);
end if;
+ -- Check for useless assignment to OUT or IN OUT scalar
+ -- immediately preceding the raise. Right now we only look
+ -- at assignment statements, we could do more.
+
+ if Is_List_Member (N) then
+ declare
+ P : Node_Id;
+ L : Node_Id;
+
+ begin
+ P := Prev (N);
+
+ if Present (P)
+ and then Nkind (P) = N_Assignment_Statement
+ then
+ L := Name (P);
+
+ if Is_Scalar_Type (Etype (L))
+ and then Is_Entity_Name (L)
+ and then Is_Formal (Entity (L))
+ then
+ Error_Msg_N
+ ("?assignment to pass-by-copy formal may have no effect",
+ P);
+ Error_Msg_N
+ ("\?RAISE statement is abnormal return" &
+ " ('R'M 6.4.1(17))", P);
+ end if;
+ end if;
+ end;
+ end if;
+
-- Reraise statement
if No (Exception_Id) then
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index e7b4f364484..5c3f56b4cb2 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.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- --
@@ -56,6 +56,7 @@ with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Sinfo.CN; use Sinfo.CN;
@@ -397,6 +398,13 @@ package body Sem_Ch12 is
-- of the instance can be placed after the freeze node of the parent,
-- which it itself an instance.
+ procedure Set_Instance_Env
+ (Gen_Unit : Entity_Id;
+ Act_Unit : Entity_Id);
+ -- Save current instance on saved environment, to be used to determine
+ -- the global status of entities in nested instances. Part of Save_Env.
+ -- called after verifying that the generic unit is legal for the instance.
+
procedure Set_Instance_Of (A : Entity_Id; B : Entity_Id);
-- Associate analyzed generic parameter with corresponding
-- instance. Used for semantic checks at instantiation time.
@@ -446,6 +454,11 @@ package body Sem_Ch12 is
-- the instance and the generic, so that the back-end can establish the
-- proper order of elaboration.
+ procedure Init_Env;
+ -- Establish environment for subsequent instantiation. Separated from
+ -- Save_Env because data-structures for visibility handling must be
+ -- initialized before call to Check_Generic_Child_Unit.
+
procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False);
-- When compiling an instance of a child unit the parent (which is
-- itself an instance) is an enclosing scope that must be made
@@ -477,7 +490,8 @@ package body Sem_Ch12 is
function Instantiate_Type
(Formal : Node_Id;
Actual : Node_Id;
- Analyzed_Formal : Node_Id)
+ Analyzed_Formal : Node_Id;
+ Actual_Decls : List_Id)
return Node_Id;
function Instantiate_Formal_Subprogram
@@ -651,7 +665,12 @@ package body Sem_Ch12 is
-- Because instantiations can be recursive, the following must be saved
-- on entry and restored on exit from an instantiation (spec or body).
- -- This is done by the two procedures Save_Env and Restore_Env.
+ -- This is done by the two procedures Save_Env and Restore_Env. For
+ -- package and subprogram instantiations (but not for the body instances)
+ -- the action of Save_Env is done in two steps: Init_Env is called before
+ -- Check_Generic_Child_Unit, because setting the parent instances requires
+ -- that the visibility data structures be properly initialized. Once the
+ -- generic is unit is validated, Set_Instance_Env completes Save_Env.
type Instance_Env is record
Ada_83 : Boolean;
@@ -738,15 +757,15 @@ package body Sem_Ch12 is
F_Copy : List_Id)
return List_Id
is
- Actuals : List_Id := Generic_Associations (I_Node);
+ Actual_Types : constant Elist_Id := New_Elmt_List;
+ Assoc : constant List_Id := New_List;
+ Defaults : constant Elist_Id := New_Elmt_List;
+ Actuals : List_Id;
Actual : Node_Id;
- Actual_Types : Elist_Id := New_Elmt_List;
- Assoc : List_Id := New_List;
Formal : Node_Id;
Next_Formal : Node_Id;
Temp_Formal : Node_Id;
Analyzed_Formal : Node_Id;
- Defaults : Elist_Id := New_Elmt_List;
Match : Node_Id;
Named : Node_Id;
First_Named : Node_Id := Empty;
@@ -815,6 +834,7 @@ package body Sem_Ch12 is
Found := Explicit_Generic_Actual_Parameter (Actual);
Set_Entity (Selector_Name (Actual), A_F);
Set_Etype (Selector_Name (Actual), Etype (A_F));
+ Generate_Reference (A_F, Selector_Name (Actual));
Found_Assoc := Actual;
Num_Matched := Num_Matched + 1;
exit;
@@ -899,6 +919,8 @@ package body Sem_Ch12 is
-- If named associations are present, save the first named association
-- (it may of course be Empty) to facilitate subsequent name search.
+ Actuals := Generic_Associations (I_Node);
+
if Present (Actuals) then
First_Named := First (Actuals);
@@ -917,7 +939,14 @@ package body Sem_Ch12 is
Abandon_Instantiation (Named);
end if;
- Num_Actuals := Num_Actuals + 1;
+ -- A named association may lack an actual parameter, if it was
+ -- introduced for a default subprogram that turns out to be local
+ -- to the outer instantiation.
+
+ if Present (Explicit_Generic_Actual_Parameter (Named)) then
+ Num_Actuals := Num_Actuals + 1;
+ end if;
+
Next (Named);
end loop;
@@ -963,7 +992,8 @@ package body Sem_Ch12 is
else
Analyze (Match);
Append_To (Assoc,
- Instantiate_Type (Formal, Match, Analyzed_Formal));
+ Instantiate_Type
+ (Formal, Match, Analyzed_Formal, Assoc));
-- an instantiation is a freeze point for the actuals,
-- unless this is a rewritten formal package.
@@ -1239,8 +1269,8 @@ package body Sem_Ch12 is
Def : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Def);
+ Unk_Disc : constant Boolean := Unknown_Discriminants_Present (N);
New_N : Node_Id;
- Unk_Disc : Boolean := Unknown_Discriminants_Present (N);
begin
Set_Is_Generic_Type (T);
@@ -1389,7 +1419,7 @@ package body Sem_Ch12 is
procedure Analyze_Formal_Object_Declaration (N : Node_Id) is
E : constant Node_Id := Expression (N);
- Id : Node_Id := Defining_Identifier (N);
+ Id : constant Node_Id := Defining_Identifier (N);
K : Entity_Kind;
T : Node_Id;
@@ -1420,6 +1450,7 @@ package body Sem_Ch12 is
if Is_Limited_Type (T) then
Error_Msg_N
("generic formal of mode IN must not be of limited type", N);
+ Explain_Limited_Type (T, N);
end if;
if Is_Abstract (T) then
@@ -1428,7 +1459,7 @@ package body Sem_Ch12 is
end if;
if Present (E) then
- Analyze_Default_Expression (E, T);
+ Analyze_Per_Use_Expression (E, T);
end if;
Set_Ekind (Id, K);
@@ -1523,8 +1554,8 @@ package body Sem_Ch12 is
procedure Analyze_Formal_Package (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Formal : Entity_Id := Defining_Identifier (N);
- Gen_Id : constant Node_Id := Name (N);
+ Formal : constant Entity_Id := Defining_Identifier (N);
+ Gen_Id : constant Node_Id := Name (N);
Gen_Decl : Node_Id;
Gen_Unit : Entity_Id;
New_N : Node_Id;
@@ -1536,17 +1567,20 @@ package body Sem_Ch12 is
begin
Text_IO_Kludge (Gen_Id);
+ Init_Env;
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
if Ekind (Gen_Unit) /= E_Generic_Package then
Error_Msg_N ("expect generic package name", Gen_Id);
+ Restore_Env;
return;
elsif Gen_Unit = Current_Scope then
Error_Msg_N
("generic package cannot be used as a formal package of itself",
Gen_Id);
+ Restore_Env;
return;
end if;
@@ -1574,7 +1608,7 @@ package body Sem_Ch12 is
-- and analyze it like a regular package, except that we treat the
-- formals as additional visible components.
- Save_Env (Gen_Unit, Formal);
+ Set_Instance_Env (Gen_Unit, Formal);
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
@@ -1781,8 +1815,8 @@ package body Sem_Ch12 is
Resolve (Def, (Etype (Nam)));
- elsif (not Is_Entity_Name (Def)
- or else not Is_Overloadable (Entity (Def)))
+ elsif not Is_Entity_Name (Def)
+ or else not Is_Overloadable (Entity (Def))
then
Error_Msg_N ("expect valid subprogram name as default", Def);
return;
@@ -1967,6 +2001,8 @@ package body Sem_Ch12 is
Analyze (Gen_Parm_Decl);
Next (Gen_Parm_Decl);
end loop;
+
+ Generate_Reference_To_Generic_Formals (Current_Scope);
end Analyze_Generic_Formal_Part;
------------------------------------------
@@ -1974,11 +2010,47 @@ package body Sem_Ch12 is
------------------------------------------
procedure Analyze_Generic_Package_Declaration (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
Id : Entity_Id;
New_N : Node_Id;
Save_Parent : Node_Id;
+ Renaming : Node_Id;
+ Decls : constant List_Id :=
+ Visible_Declarations (Specification (N));
+ Decl : Node_Id;
begin
+ -- We introduce a renaming of the enclosing package, to have a usable
+ -- entity as the prefix of an expanded name for a local entity of the
+ -- form Par.P.Q, where P is the generic package. This is because a local
+ -- entity named P may hide it, so that the usual visibility rules in
+ -- the instance will not resolve properly.
+
+ Renaming :=
+ Make_Package_Renaming_Declaration (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Defining_Entity (N)), "GH")),
+ Name => Make_Identifier (Loc, Chars (Defining_Entity (N))));
+
+ if Present (Decls) then
+ Decl := First (Decls);
+ while Present (Decl)
+ and then Nkind (Decl) = N_Pragma
+ loop
+ Next (Decl);
+ end loop;
+
+ if Present (Decl) then
+ Insert_Before (Decl, Renaming);
+ else
+ Append (Renaming, Visible_Declarations (Specification (N)));
+ end if;
+
+ else
+ Set_Visible_Declarations (Specification (N), New_List (Renaming));
+ end if;
+
-- Create copy of generic unit, and save for instantiation.
-- If the unit is a child unit, do not copy the specifications
-- for the parent, which are not part of the generic tree.
@@ -2006,6 +2078,12 @@ package body Sem_Ch12 is
Set_Categorization_From_Pragmas (N);
Set_Is_Pure (Id, Is_Pure (Current_Scope));
+ -- Link the declaration of the generic homonym in the generic copy
+ -- to the package it renames, so that it is always resolved properly.
+
+ Set_Generic_Homonym (Id, Defining_Unit_Name (Renaming));
+ Set_Entity (Associated_Node (Name (Renaming)), Id);
+
-- For a library unit, we have reconstructed the entity for the
-- unit, and must reset it in the library tables.
@@ -2035,8 +2113,14 @@ package body Sem_Ch12 is
else
Set_Body_Required (Parent (N), Unit_Requires_Body (Id));
Validate_RT_RAT_Component (N);
- end if;
+ -- If this is a spec without a body, check that generic parameters
+ -- are referenced.
+
+ if not Body_Required (Parent (N)) then
+ Check_References (Id);
+ end if;
+ end if;
end Analyze_Generic_Package_Declaration;
--------------------------------------------
@@ -2116,7 +2200,7 @@ package body Sem_Ch12 is
End_Generic;
End_Scope;
Exit_Generic_Scope (Id);
-
+ Generate_Reference_To_Formals (Id);
end Analyze_Generic_Subprogram_Declaration;
-----------------------------------
@@ -2128,8 +2212,8 @@ package body Sem_Ch12 is
-- node. This should really be noted in the spec! ???
procedure Analyze_Package_Instantiation (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Gen_Id : constant Node_Id := Name (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Gen_Id : constant Node_Id := Name (N);
Act_Decl : Node_Id;
Act_Decl_Name : Node_Id;
@@ -2140,7 +2224,9 @@ package body Sem_Ch12 is
Gen_Decl : Node_Id;
Gen_Unit : Entity_Id;
- Is_Actual_Pack : Boolean := Is_Internal (Defining_Entity (N));
+ Is_Actual_Pack : constant Boolean :=
+ Is_Internal (Defining_Entity (N));
+
Parent_Installed : Boolean := False;
Renaming_List : List_Id;
Unit_Renaming : Node_Id;
@@ -2235,17 +2321,20 @@ package body Sem_Ch12 is
Generate_Definition (Act_Decl_Id);
Pre_Analyze_Actuals (N);
+ Init_Env;
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
-- Verify that it is the name of a generic package
if Etype (Gen_Unit) = Any_Type then
+ Restore_Env;
return;
elsif Ekind (Gen_Unit) /= E_Generic_Package then
Error_Msg_N
("expect name of generic package in instantiation", Gen_Id);
+ Restore_Env;
return;
end if;
@@ -2288,6 +2377,7 @@ package body Sem_Ch12 is
if In_Open_Scopes (Gen_Unit) then
Error_Msg_NE ("instantiation of & within itself", N, Gen_Unit);
+ Restore_Env;
return;
elsif Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
@@ -2295,10 +2385,11 @@ package body Sem_Ch12 is
Error_Msg_NE
("circular Instantiation: & instantiated in &!", N, Gen_Unit);
Circularity_Detected := True;
+ Restore_Env;
return;
else
- Save_Env (Gen_Unit, Act_Decl_Id);
+ Set_Instance_Env (Gen_Unit, Act_Decl_Id);
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
-- Initialize renamings map, for error checking, and the list
@@ -2310,7 +2401,7 @@ package body Sem_Ch12 is
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
- Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
+ Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation.
@@ -2379,6 +2470,11 @@ package body Sem_Ch12 is
declare
Enclosing_Body_Present : Boolean := False;
+ -- If the generic unit is not a compilation unit, then a body
+ -- may be present in its parent even if none is required. We
+ -- create a tentative pending instantiation for the body, which
+ -- will be discarded if none is actually present.
+
Scop : Entity_Id;
begin
@@ -2395,6 +2491,7 @@ package body Sem_Ch12 is
exit;
end if;
+ exit when Is_Compilation_Unit (Scop);
Scop := Scope (Scop);
end loop;
end if;
@@ -2402,14 +2499,17 @@ package body Sem_Ch12 is
-- If front-end inlining is enabled, and this is a unit for which
-- code will be generated, we instantiate the body at once.
-- This is done if the instance is not the main unit, and if the
- -- generic is not a child unit, to avoid scope problems.
+ -- generic is not a child unit of another generic, to avoid scope
+ -- problems and the reinstallation of parent instances.
if Front_End_Inlining
and then Expander_Active
- and then not Is_Child_Unit (Gen_Unit)
+ and then (not Is_Child_Unit (Gen_Unit)
+ or else not Is_Generic_Unit (Scope (Gen_Unit)))
and then Is_In_Main_Unit (N)
and then Nkind (Parent (N)) /= N_Compilation_Unit
and then Might_Inline_Subp
+ and then not Is_Actual_Pack
then
Inline_Now := True;
end if;
@@ -2425,7 +2525,7 @@ package body Sem_Ch12 is
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
- and then Tree_Output));
+ and then ASIS_Mode));
-- If front_end_inlining is enabled, do not instantiate a
-- body if within a generic context.
@@ -2436,6 +2536,31 @@ package body Sem_Ch12 is
Needs_Body := False;
end if;
+ -- If the current context is generic, and the package being
+ -- instantiated is declared within a formal package, there
+ -- is no body to instantiate until the enclosing generic is
+ -- instantiated, and there is an actual for the formal
+ -- package. If the formal package has parameters, we build a
+ -- regular package instance for it, that preceeds the original
+ -- formal package declaration.
+
+ if In_Open_Scopes (Scope (Scope (Gen_Unit))) then
+ declare
+ Decl : Node_Id :=
+ Original_Node
+ (Unit_Declaration_Node (Scope (Gen_Unit)));
+ begin
+ if Nkind (Decl) = N_Formal_Package_Declaration
+ or else (Nkind (Decl) = N_Package_Declaration
+ and then Is_List_Member (Decl)
+ and then Present (Next (Decl))
+ and then
+ Nkind (Next (Decl)) = N_Formal_Package_Declaration)
+ then
+ Needs_Body := False;
+ end if;
+ end;
+ end if;
end;
-- If we are generating the calling stubs from the instantiation
@@ -2491,8 +2616,7 @@ package body Sem_Ch12 is
elsif Ekind (Enclosing_Master) = E_Generic_Package then
Enclosing_Master := Scope (Enclosing_Master);
- elsif Ekind (Enclosing_Master) = E_Generic_Function
- or else Ekind (Enclosing_Master) = E_Generic_Procedure
+ elsif Is_Generic_Subprogram (Enclosing_Master)
or else Ekind (Enclosing_Master) = E_Void
then
-- Cleanup actions will eventually be performed on
@@ -2555,7 +2679,7 @@ package body Sem_Ch12 is
Set_Instance_Spec (N, Act_Decl);
-- If not a compilation unit, insert the package declaration
- -- after the instantiation node.
+ -- before the original instantiation node.
if Nkind (Parent (N)) /= N_Compilation_Unit then
Mark_Rewrite_Insertion (Act_Decl);
@@ -2596,7 +2720,7 @@ package body Sem_Ch12 is
-- same time as the spec instantiation.
Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
- Set_Suppress_Elaboration_Checks (Act_Decl_Id);
+ Set_Kill_Elaboration_Checks (Act_Decl_Id);
end if;
Check_Elab_Instantiation (N);
@@ -2609,6 +2733,11 @@ package body Sem_Ch12 is
Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming),
First_Private_Entity (Act_Decl_Id));
+ -- If the instantiation will receive a body, the unit will
+ -- be transformed into a package body, and receive its own
+ -- elaboration entity. Otherwise, the nature of the unit is
+ -- now a package declaration.
+
if Nkind (Parent (N)) = N_Compilation_Unit
and then not Needs_Body
then
@@ -2656,7 +2785,6 @@ package body Sem_Ch12 is
if Parent_Installed then
Remove_Parent;
end if;
-
end Analyze_Package_Instantiation;
---------------------------
@@ -2685,11 +2813,11 @@ package body Sem_Ch12 is
S : Entity_Id;
begin
- -- Case of generic unit defined in another unit
+ -- Case of generic unit defined in another unit. We must remove
+ -- the complete context of the current unit to install that of
+ -- the generic.
if Gen_Comp /= Cunit_Entity (Current_Sem_Unit) then
- Vis := Is_Immediately_Visible (Gen_Comp);
-
S := Current_Scope;
while Present (S)
@@ -2710,6 +2838,8 @@ package body Sem_Ch12 is
S := Scope (S);
end loop;
+ Vis := Is_Immediately_Visible (Gen_Comp);
+
-- Find and save all enclosing instances
S := Current_Scope;
@@ -2720,6 +2850,8 @@ package body Sem_Ch12 is
if Is_Generic_Instance (S) then
N_Instances := N_Instances + 1;
Instances (N_Instances) := S;
+
+ exit when In_Package_Body (S);
end if;
S := Scope (S);
@@ -2745,6 +2877,10 @@ package body Sem_Ch12 is
if S = Curr_Unit
or else (Ekind (Curr_Unit) = E_Package_Body
and then S = Spec_Entity (Curr_Unit))
+ or else (Ekind (Curr_Unit) = E_Subprogram_Body
+ and then S =
+ Corresponding_Spec
+ (Unit_Declaration_Node (Curr_Unit)))
then
Removed := True;
@@ -2782,8 +2918,9 @@ package body Sem_Ch12 is
end loop;
New_Scope (Standard_Standard);
+ Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True;
Instantiate_Package_Body
- ((N, Act_Decl, Expander_Active, Current_Sem_Unit));
+ ((N, Act_Decl, Expander_Active, Current_Sem_Unit), True);
Pop_Scope;
-- Restore context
@@ -2817,11 +2954,27 @@ package body Sem_Ch12 is
Restore_Scope_Stack;
end if;
- for J in reverse 1 .. Num_Scopes loop
- Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
- Use_Clauses (J);
- Install_Use_Clauses (Use_Clauses (J));
- end loop;
+ -- Restore use clauses. For a child unit, use clauses in the
+ -- parents are restored when installing the context, so only
+ -- those in inner scopes (and those local to the child unit itself)
+ -- need to be installed explicitly.
+
+ if Is_Child_Unit (Curr_Unit)
+ and then Removed
+ then
+ for J in reverse 1 .. Num_Inner + 1 loop
+ Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
+ Use_Clauses (J);
+ Install_Use_Clauses (Use_Clauses (J));
+ end loop;
+
+ else
+ for J in reverse 1 .. Num_Scopes loop
+ Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause :=
+ Use_Clauses (J);
+ Install_Use_Clauses (Use_Clauses (J));
+ end loop;
+ end if;
for J in 1 .. N_Instances loop
Set_Is_Generic_Instance (Instances (J), True);
@@ -2831,7 +2984,7 @@ package body Sem_Ch12 is
else
Instantiate_Package_Body
- ((N, Act_Decl, Expander_Active, Current_Sem_Unit));
+ ((N, Act_Decl, Expander_Active, Current_Sem_Unit), True);
end if;
end Inline_Instance_Body;
@@ -2852,25 +3005,24 @@ package body Sem_Ch12 is
(N : Node_Id;
K : Entity_Kind)
is
- Loc : constant Source_Ptr := Sloc (N);
- Gen_Id : constant Node_Id := Name (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Gen_Id : constant Node_Id := Name (N);
- Act_Decl_Id : Entity_Id;
- Anon_Id : Entity_Id :=
- Make_Defining_Identifier
- (Sloc (Defining_Entity (N)),
- New_External_Name
+ Anon_Id : constant Entity_Id :=
+ Make_Defining_Identifier (Sloc (Defining_Entity (N)),
+ Chars => New_External_Name
(Chars (Defining_Entity (N)), 'R'));
- Act_Decl : Node_Id;
- Act_Spec : Node_Id;
- Act_Tree : Node_Id;
+
+ Act_Decl_Id : Entity_Id;
+ Act_Decl : Node_Id;
+ Act_Spec : Node_Id;
+ Act_Tree : Node_Id;
Gen_Unit : Entity_Id;
Gen_Decl : Node_Id;
Pack_Id : Entity_Id;
Parent_Installed : Boolean := False;
Renaming_List : List_Id;
- Spec : Node_Id;
procedure Analyze_Instance_And_Renamings;
-- The instance must be analyzed in a context that includes the
@@ -2894,7 +3046,7 @@ package body Sem_Ch12 is
-- has the same name as the instantiation, to insure that the
-- binder calls the elaboration procedure with the right name.
-- Copy the entity of the instance, which may have compilation
- -- level flags (eg. is_child_unit) set.
+ -- level flags (e.g. Is_Child_Unit) set.
Pack_Id := New_Copy (Def_Ent);
@@ -2919,6 +3071,7 @@ package body Sem_Ch12 is
Set_Instance_Spec (N, Pack_Decl);
Set_Is_Generic_Instance (Pack_Id);
+ Set_Needs_Debug_Info (Pack_Id);
-- Case of not a compilation unit
@@ -2954,13 +3107,22 @@ package body Sem_Ch12 is
-- Set name and scope of internal subprogram so that the
-- proper external name will be generated. The proper scope
- -- is the scope of the wrapper package.
+ -- is the scope of the wrapper package. We need to generate
+ -- debugging information for the internal subprogram, so set
+ -- flag accordingly.
Set_Chars (Anon_Id, Chars (Defining_Entity (N)));
Set_Scope (Anon_Id, Scope (Pack_Id));
+
+ -- Mark wrapper package as referenced, to avoid spurious
+ -- warnings if the instantiation appears in various with_
+ -- clauses of subunits of the main unit.
+
+ Set_Referenced (Pack_Id);
end if;
Set_Is_Generic_Instance (Anon_Id);
+ Set_Needs_Debug_Info (Anon_Id);
Act_Decl_Id := New_Copy (Anon_Id);
Set_Parent (Act_Decl_Id, Parent (Anon_Id));
@@ -2991,7 +3153,7 @@ package body Sem_Ch12 is
if Nkind (Parent (N)) = N_Compilation_Unit then
Set_Suppress_Elaboration_Warnings (Act_Decl_Id);
- Set_Suppress_Elaboration_Checks (Act_Decl_Id);
+ Set_Kill_Elaboration_Checks (Act_Decl_Id);
Set_Is_Compilation_Unit (Anon_Id);
Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
@@ -3031,6 +3193,7 @@ package body Sem_Ch12 is
Instantiation_Node := N;
Pre_Analyze_Actuals (N);
+ Init_Env;
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
@@ -3043,7 +3206,10 @@ package body Sem_Ch12 is
("& is hidden within declaration of instance", Gen_Id, Gen_Unit);
end if;
- if Etype (Gen_Unit) = Any_Type then return; end if;
+ if Etype (Gen_Unit) = Any_Type then
+ Restore_Env;
+ return;
+ end if;
-- Verify that it is a generic subprogram of the right kind, and that
-- it does not lead to a circular instantiation.
@@ -3080,8 +3246,13 @@ package body Sem_Ch12 is
else
Set_Entity (Gen_Id, Gen_Unit);
+ Set_Is_Instantiated (Gen_Unit);
+
+ if In_Extended_Main_Source_Unit (N) then
+ Generate_Reference (Gen_Unit, N);
+ end if;
- -- If renaming, get original unit.
+ -- If renaming, get original unit
if Present (Renamed_Object (Gen_Unit))
and then (Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Procedure
@@ -3089,6 +3260,8 @@ package body Sem_Ch12 is
Ekind (Renamed_Object (Gen_Unit)) = E_Generic_Function)
then
Gen_Unit := Renamed_Object (Gen_Unit);
+ Set_Is_Instantiated (Gen_Unit);
+ Generate_Reference (Gen_Unit, N);
end if;
if Contains_Instance_Of (Gen_Unit, Current_Scope, Gen_Id) then
@@ -3099,25 +3272,19 @@ package body Sem_Ch12 is
return;
end if;
- if In_Extended_Main_Source_Unit (N) then
- Set_Is_Instantiated (Gen_Unit);
- Generate_Reference (Gen_Unit, N);
- end if;
-
Gen_Decl := Unit_Declaration_Node (Gen_Unit);
- Spec := Specification (Gen_Decl);
-- The subprogram itself cannot contain a nested instance, so
-- the current parent is left empty.
- Save_Env (Gen_Unit, Empty);
+ Set_Instance_Env (Gen_Unit, Empty);
-- Initialize renamings map, for error checking.
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
- Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
+ Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation.
@@ -3174,7 +3341,10 @@ package body Sem_Ch12 is
Set_Is_Inlined (Act_Decl_Id, Is_Inlined (Gen_Unit));
Set_Is_Inlined (Anon_Id, Is_Inlined (Gen_Unit));
- Check_Elab_Instantiation (N);
+ if not Is_Intrinsic_Subprogram (Gen_Unit) then
+ Check_Elab_Instantiation (N);
+ end if;
+
Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id);
-- Subject to change, pending on if other pragmas are inherited ???
@@ -3196,8 +3366,8 @@ package body Sem_Ch12 is
or else Is_Inlined (Act_Decl_Id))
and then (Operating_Mode = Generate_Code
or else (Operating_Mode = Check_Semantics
- and then Tree_Output))
- and then (Expander_Active or else Tree_Output)
+ and then ASIS_Mode))
+ and then (Expander_Active or else ASIS_Mode)
and then not ABE_Is_Certain (N)
and then not Is_Eliminated (Act_Decl_Id)
then
@@ -3334,6 +3504,10 @@ package body Sem_Ch12 is
Set_Library_Unit (Decl_Cunit, Body_Cunit);
Set_Library_Unit (Body_Cunit, Decl_Cunit);
+ -- Preserve the private nature of the package if needed.
+
+ Set_Private_Present (Decl_Cunit, Private_Present (Body_Cunit));
+
-- If the instance is not the main unit, its context, categorization,
-- and elaboration entity are not relevant to the compilation.
@@ -3458,17 +3632,16 @@ package body Sem_Ch12 is
elsif Is_Integer_Type (Etype (E1)) then
declare
- V1 : Uint := Expr_Value (Expr1);
- V2 : Uint := Expr_Value (Expr2);
+ V1 : constant Uint := Expr_Value (Expr1);
+ V2 : constant Uint := Expr_Value (Expr2);
begin
Check_Mismatch (V1 /= V2);
end;
elsif Is_Real_Type (Etype (E1)) then
-
declare
- V1 : Ureal := Expr_Value_R (Expr1);
- V2 : Ureal := Expr_Value_R (Expr2);
+ V1 : constant Ureal := Expr_Value_R (Expr1);
+ V2 : constant Ureal := Expr_Value_R (Expr2);
begin
Check_Mismatch (V1 /= V2);
end;
@@ -3689,13 +3862,18 @@ package body Sem_Ch12 is
Set_Is_Hidden (E, False);
end if;
+ -- If this is a subprogram instance (in a wrapper package) the
+ -- actual is fully visible.
+
+ elsif Is_Wrapper_Package (Instance) then
+ Set_Is_Hidden (E, False);
+
else
Set_Is_Hidden (E, not Is_Formal_Box);
end if;
Next_Entity (E);
end loop;
-
end Check_Generic_Actuals;
------------------------------
@@ -3716,12 +3894,16 @@ package body Sem_Ch12 is
(Scop : Entity_Id;
Id : Node_Id)
return Entity_Id;
- -- Search generic parent for possible child unit.
+ -- Search generic parent for possible child unit with the given name.
function In_Enclosing_Instance return Boolean;
-- Within an instance of the parent, the child unit may be denoted
- -- by a simple name. Examine enclosing scopes to locate a possible
- -- parent instantiation.
+ -- by a simple name, or an abbreviated expanded name. Examine enclosing
+ -- scopes to locate a possible parent instantiation.
+
+ ------------------------
+ -- Find_Generic_Child --
+ ------------------------
function Find_Generic_Child
(Scop : Entity_Id;
@@ -3765,30 +3947,47 @@ package body Sem_Ch12 is
end if;
end Find_Generic_Child;
+ ---------------------------
+ -- In_Enclosing_Instance --
+ ---------------------------
+
function In_Enclosing_Instance return Boolean is
Enclosing_Instance : Node_Id;
+ Instance_Decl : Node_Id;
begin
Enclosing_Instance := Current_Scope;
while Present (Enclosing_Instance) loop
- exit when Ekind (Enclosing_Instance) = E_Package
- and then Nkind (Parent (Enclosing_Instance)) =
- N_Package_Specification
+ Instance_Decl := Unit_Declaration_Node (Enclosing_Instance);
+
+ if Ekind (Enclosing_Instance) = E_Package
+ and then Is_Generic_Instance (Enclosing_Instance)
and then Present
- (Generic_Parent (Parent (Enclosing_Instance)));
+ (Generic_Parent (Specification (Instance_Decl)))
+ then
+ -- Check whether the generic we are looking for is a child
+ -- of this instance.
+
+ E := Find_Generic_Child
+ (Generic_Parent (Specification (Instance_Decl)), Gen_Id);
+ exit when Present (E);
+
+ else
+ E := Empty;
+ end if;
Enclosing_Instance := Scope (Enclosing_Instance);
end loop;
- if Present (Enclosing_Instance) then
- E := Find_Generic_Child
- (Generic_Parent (Parent (Enclosing_Instance)), Gen_Id);
- else
+ if No (E) then
+
+ -- Not a child unit
+
+ Analyze (Gen_Id);
return False;
- end if;
- if Present (E) then
+ else
Rewrite (Gen_Id,
Make_Expanded_Name (Loc,
Chars => Chars (E),
@@ -3799,9 +3998,6 @@ package body Sem_Ch12 is
Set_Etype (Gen_Id, Etype (E));
Parent_Installed := False; -- Already in scope.
return True;
- else
- Analyze (Gen_Id);
- return False;
end if;
end In_Enclosing_Instance;
@@ -3845,7 +4041,6 @@ package body Sem_Ch12 is
elsif Ekind (Inst_Par) = E_Generic_Package
and then Nkind (Parent (Gen_Id)) = N_Formal_Package_Declaration
then
-
-- A formal package may be a real child package, and not the
-- implicit instance within a parent. In this case the child is
-- not visible and has to be retrieved explicitly as well.
@@ -3876,7 +4071,7 @@ package body Sem_Ch12 is
-- A common mistake is to replicate the naming scheme of
-- a hierarchy by instantiating a generic child directly,
-- rather than the implicit child in a parent instance:
- --
+
-- generic .. package Gpar is ..
-- generic .. package Gpar.Child is ..
-- package Par is new Gpar ();
@@ -3884,7 +4079,7 @@ package body Sem_Ch12 is
-- with Gpar.Child;
-- package Par.Child is new Gpar.Child ();
-- rather than Par.Child
- --
+
-- In this case the instantiation is within Par, which is
-- an instance, but Gpar does not denote Par because we are
-- not IN the instance of Gpar, so this is illegal. The test
@@ -3902,8 +4097,8 @@ package body Sem_Ch12 is
end if;
if not In_Open_Scopes (Inst_Par)
- and then Nkind (Parent (Gen_Id))
- not in N_Generic_Renaming_Declaration
+ and then Nkind (Parent (Gen_Id)) not in
+ N_Generic_Renaming_Declaration
then
Install_Parent (Inst_Par);
Parent_Installed := True;
@@ -3923,8 +4118,8 @@ package body Sem_Ch12 is
Analyze (Gen_Id);
if Is_Child_Unit (Entity (Gen_Id))
- and then Nkind (Parent (Gen_Id))
- not in N_Generic_Renaming_Declaration
+ and then
+ Nkind (Parent (Gen_Id)) not in N_Generic_Renaming_Declaration
and then not In_Open_Scopes (Inst_Par)
then
Install_Parent (Inst_Par);
@@ -3954,7 +4149,9 @@ package body Sem_Ch12 is
end if;
elsif In_Enclosing_Instance then
- -- The child unit is found in some enclosing scope.
+
+ -- The child unit is found in some enclosing scope
+
null;
else
@@ -4009,7 +4206,7 @@ package body Sem_Ch12 is
Gen_Unit : Entity_Id;
Act_Decl_Id : Entity_Id)
is
- Gen_Id : Node_Id := Name (N);
+ Gen_Id : constant Node_Id := Name (N);
begin
if Is_Child_Unit (Gen_Unit)
@@ -4086,6 +4283,7 @@ package body Sem_Ch12 is
elsif Is_Access_Type (T)
and then Is_Private_Type (Designated_Type (T))
+ and then not Has_Private_View (N)
and then Present (Full_View (Designated_Type (T)))
then
Switch_View (Designated_Type (T));
@@ -4106,9 +4304,9 @@ package body Sem_Ch12 is
-- Finally, a non-private subtype may have a private base type,
-- which must be exchanged for consistency. This can happen when
- -- instantiating a package body, when the scope stack is empty but
- -- in fact the subtype and the base type are declared in an enclosing
- -- scope.
+ -- instantiating a package body, when the scope stack is empty
+ -- but in fact the subtype and the base type are declared in an
+ -- enclosing scope.
elsif not Is_Private_Type (T)
and then not Has_Private_View (N)
@@ -4369,11 +4567,11 @@ package body Sem_Ch12 is
-- Special casing for identifiers and other entity names and operators
- elsif (Nkind (New_N) = N_Identifier
+ elsif Nkind (New_N) = N_Identifier
or else Nkind (New_N) = N_Character_Literal
or else Nkind (New_N) = N_Expanded_Name
or else Nkind (New_N) = N_Operator_Symbol
- or else Nkind (New_N) in N_Op)
+ or else Nkind (New_N) in N_Op
then
if not Instantiating then
@@ -4454,7 +4652,6 @@ package body Sem_Ch12 is
-- For expanded name, we must copy the Prefix and Selector_Name
if Nkind (N) = N_Expanded_Name then
-
Set_Prefix
(New_N, Copy_Generic_Node (Prefix (N), New_N, Instantiating));
@@ -4464,7 +4661,6 @@ package body Sem_Ch12 is
-- For operators, we must copy the right operand
elsif Nkind (N) in N_Op then
-
Set_Right_Opnd (New_N,
Copy_Generic_Node (Right_Opnd (N), New_N, Instantiating));
@@ -4524,6 +4720,14 @@ package body Sem_Ch12 is
Subunit := Cunit (Unum);
+ if Nkind (Unit (Subunit)) /= N_Subunit then
+ Error_Msg_Sloc := Sloc (N);
+ Error_Msg_N
+ ("expected SEPARATE subunit to complete stub at#,"
+ & " found child unit", Subunit);
+ goto Subunit_Not_Found;
+ end if;
+
-- We must create a generic copy of the subunit, in order
-- to perform semantic analysis on it, and we must replace
-- the stub in the original generic unit with the subunit,
@@ -4554,7 +4758,6 @@ package body Sem_Ch12 is
Set_Proper_Body (Unit (Subunit), New_Body);
Set_Library_Unit (New_N, Subunit);
Inherit_Context (Unit (Subunit), N);
-
end;
-- If we are instantiating, this must be an error case, since
@@ -4629,10 +4832,9 @@ package body Sem_Ch12 is
if Present (Get_Associated_Node (N))
and then Nkind (Get_Associated_Node (N)) = Nkind (N)
then
- -- In the generic the aggregate has some composite type.
- -- If at the point of instantiation the type has a private
- -- view, install the full view (and that of its ancestors,
- -- if any).
+ -- In the generic the aggregate has some composite type. If at
+ -- the point of instantiation the type has a private view,
+ -- install the full view (and that of its ancestors, if any).
declare
T : Entity_Id := (Etype (Get_Associated_Node (New_N)));
@@ -4690,8 +4892,9 @@ package body Sem_Ch12 is
and then Instantiating
then
declare
- T : Node_Id := Get_Associated_Node (Subtype_Mark (Expression (N)));
- Acc_T : Entity_Id;
+ T : constant Node_Id :=
+ Get_Associated_Node (Subtype_Mark (Expression (N)));
+ Acc_T : Entity_Id;
begin
if Present (T) then
@@ -4716,14 +4919,16 @@ package body Sem_Ch12 is
-- adjusted using this new source instantiation entry.
elsif Nkind (N) in N_Proper_Body then
-
declare
Save_Adjustment : constant Sloc_Adjustment := S_Adjustment;
begin
if Instantiating and then Was_Originally_Stub (N) then
Create_Instantiation_Source
- (Instantiation_Node, Defining_Entity (N), S_Adjustment);
+ (Instantiation_Node,
+ Defining_Entity (N),
+ False,
+ S_Adjustment);
end if;
-- Now copy the fields of the proper body, using the new
@@ -4756,7 +4961,14 @@ package body Sem_Ch12 is
end if;
end;
- -- For the remaining nodes, copy recursively their descendants.
+ elsif Nkind (N) = N_Integer_Literal
+ or else Nkind (N) = N_Real_Literal
+ then
+ -- No descendant fields need traversing
+
+ null;
+
+ -- For the remaining nodes, copy recursively their descendants
else
Copy_Descendants;
@@ -4777,13 +4989,13 @@ package body Sem_Ch12 is
function Denotes_Formal_Package (Pack : Entity_Id) return Boolean is
Par : constant Entity_Id := Current_Instantiated_Parent.Act_Id;
- Scop : Entity_Id := Scope (Pack);
+ Scop : constant Entity_Id := Scope (Pack);
E : Entity_Id;
begin
if Ekind (Scop) = E_Generic_Package
- or else Nkind (Unit_Declaration_Node (Scop))
- = N_Generic_Subprogram_Declaration
+ or else Nkind (Unit_Declaration_Node (Scop)) =
+ N_Generic_Subprogram_Declaration
then
return True;
@@ -4800,7 +5012,6 @@ package body Sem_Ch12 is
E := First_Entity (Par);
while Present (E) loop
-
if Ekind (E) /= E_Package
or else Nkind (Parent (E)) /= N_Package_Renaming_Declaration
then
@@ -4915,6 +5126,10 @@ package body Sem_Ch12 is
procedure Find_Depth (P : in out Node_Id; D : in out Integer);
-- Find distance from given node to enclosing compilation unit.
+ ----------------
+ -- Find_Depth --
+ ----------------
+
procedure Find_Depth (P : in out Node_Id; D : in out Integer) is
begin
while Present (P)
@@ -4925,6 +5140,8 @@ package body Sem_Ch12 is
end loop;
end Find_Depth;
+ -- Start of procesing for Earlier
+
begin
Find_Depth (P1, D1);
Find_Depth (P2, D2);
@@ -5040,7 +5257,7 @@ package body Sem_Ch12 is
begin
-- If the instance and the generic body appear within the same
- -- unit, and the instance precedes the generic, the freeze node for
+ -- unit, and the instance preceeds the generic, the freeze node for
-- the instance must appear after that of the generic. If the generic
-- is nested within another instance I2, then current instance must
-- be frozen after I2. In both cases, the freeze nodes are those of
@@ -5058,6 +5275,7 @@ package body Sem_Ch12 is
In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
then
if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
+
-- The parent was a premature instantiation. Insert freeze
-- node at the end the current declarative part.
@@ -5084,7 +5302,6 @@ package body Sem_Ch12 is
and then
In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
then
-
-- The enclosing package may contain several instances. Rather
-- than computing the earliest point at which to insert its
-- freeze node, we place it at the end of the declarative part
@@ -5126,7 +5343,6 @@ package body Sem_Ch12 is
Insert_After_Last_Decl (Inst_Node, F_Node);
else
-
-- If none of the above, insert freeze node at the end of the
-- current declarative part.
@@ -5148,7 +5364,8 @@ package body Sem_Ch12 is
---------------------
function Get_Instance_Of (A : Entity_Id) return Entity_Id is
- Res : Assoc_Ptr := Generic_Renamings_HTable.Get (A);
+ Res : constant Assoc_Ptr := Generic_Renamings_HTable.Get (A);
+
begin
if Res /= Assoc_Null then
return Generic_Renamings.Table (Res).Act_Id;
@@ -5279,6 +5496,32 @@ package body Sem_Ch12 is
end Hide_Current_Scope;
+ --------------
+ -- Init_Env --
+ --------------
+
+ procedure Init_Env is
+ Saved : Instance_Env;
+
+ begin
+ Saved.Ada_83 := Ada_83;
+ Saved.Instantiated_Parent := Current_Instantiated_Parent;
+ Saved.Exchanged_Views := Exchanged_Views;
+ Saved.Hidden_Entities := Hidden_Entities;
+ Saved.Current_Sem_Unit := Current_Sem_Unit;
+ Instance_Envs.Increment_Last;
+ Instance_Envs.Table (Instance_Envs.Last) := Saved;
+
+ Exchanged_Views := New_Elmt_List;
+ Hidden_Entities := New_Elmt_List;
+
+ -- Make dummy entry for Instantiated parent. If generic unit is
+ -- legal, this is set properly in Set_Instance_Env.
+
+ Current_Instantiated_Parent :=
+ (Current_Scope, Current_Scope, Assoc_Null);
+ end Init_Env;
+
------------------------------
-- In_Same_Declarative_Part --
------------------------------
@@ -5288,7 +5531,7 @@ package body Sem_Ch12 is
Inst : Node_Id)
return Boolean
is
- Decls : Node_Id := Parent (F_Node);
+ Decls : constant Node_Id := Parent (F_Node);
Nod : Node_Id := Parent (Inst);
begin
@@ -5332,7 +5575,7 @@ package body Sem_Ch12 is
-- The inherited context is attached to the enclosing compilation
-- unit. This is either the main unit, or the declaration for the
- -- main unit (in case the instantiation appears within the package
+ -- main unit (in case the instantation appears within the package
-- declaration and the main unit is its body).
Current_Unit := Parent (Inst);
@@ -5357,13 +5600,26 @@ package body Sem_Ch12 is
end if;
end Inherit_Context;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Generic_Renamings.Init;
+ Instance_Envs.Init;
+ Generic_Flags.Init;
+ Generic_Renamings_HTable.Reset;
+ Circularity_Detected := False;
+ end Initialize;
+
----------------------------
-- Insert_After_Last_Decl --
----------------------------
procedure Insert_After_Last_Decl (N : Node_Id; F_Node : Node_Id) is
- L : List_Id := List_Containing (N);
- P : Node_Id := Parent (L);
+ L : List_Id := List_Containing (N);
+ P : constant Node_Id := Parent (L);
begin
if not Is_List_Member (F_Node) then
@@ -5389,15 +5645,14 @@ package body Sem_Ch12 is
Gen_Body : Node_Id;
Gen_Decl : Node_Id)
is
- Act_Id : Entity_Id := Corresponding_Spec (Act_Body);
- Act_Unit : constant Node_Id :=
- Unit (Cunit (Get_Source_Unit (N)));
- F_Node : Node_Id;
- Gen_Id : Entity_Id := Corresponding_Spec (Gen_Body);
+ Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body);
+ Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N)));
+ Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body);
+ Par : constant Entity_Id := Scope (Gen_Id);
Gen_Unit : constant Node_Id :=
Unit (Cunit (Get_Source_Unit (Gen_Decl)));
Orig_Body : Node_Id := Gen_Body;
- Par : constant Entity_Id := Scope (Gen_Id);
+ F_Node : Node_Id;
Body_Unit : Node_Id;
Must_Delay : Boolean;
@@ -5515,7 +5770,8 @@ package body Sem_Ch12 is
then
declare
- Enclosing : Entity_Id := Corresponding_Spec (Parent (N));
+ Enclosing : constant Entity_Id :=
+ Corresponding_Spec (Parent (N));
begin
Insert_After_Last_Decl (N, F_Node);
@@ -5545,13 +5801,13 @@ package body Sem_Ch12 is
--------------------
procedure Install_Parent (P : Entity_Id; In_Body : Boolean := False) is
- S : Entity_Id := Current_Scope;
+ Ancestors : constant Elist_Id := New_Elmt_List;
+ S : constant Entity_Id := Current_Scope;
Inst_Par : Entity_Id;
First_Par : Entity_Id;
Inst_Node : Node_Id;
Gen_Par : Entity_Id;
First_Gen : Entity_Id;
- Ancestors : Elist_Id := New_Elmt_List;
Elmt : Elmt_Id;
procedure Install_Formal_Packages (Par : Entity_Id);
@@ -5672,7 +5928,7 @@ package body Sem_Ch12 is
while Present (Gen_Par)
and then Is_Child_Unit (Gen_Par)
loop
- -- Load grandparent instance as well.
+ -- Load grandparent instance as well
Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
@@ -5691,7 +5947,7 @@ package body Sem_Ch12 is
Prepend_Elmt (Inst_Par, Ancestors);
else
- -- Parent is not the name of an instantiation.
+ -- Parent is not the name of an instantiation
Install_Noninstance_Specs (Inst_Par);
@@ -5699,7 +5955,7 @@ package body Sem_Ch12 is
end if;
else
- -- Previous error.
+ -- Previous error
exit;
end if;
@@ -5746,6 +6002,19 @@ package body Sem_Ch12 is
Nod : Node_Id;
Parent_Spec : Node_Id;
+ procedure Find_Matching_Actual
+ (F : Node_Id;
+ Act : in out Entity_Id);
+ -- We need to associate each formal entity in the formal package
+ -- with the corresponding entity in the actual package. The actual
+ -- package has been analyzed and possibly expanded, and as a result
+ -- there is no one-to-one correspondence between the two lists (for
+ -- example, the actual may include subtypes, itypes, and inherited
+ -- primitive operations, interspersed among the renaming declarations
+ -- for the actuals) . We retrieve the corresponding actual by name
+ -- because each actual has the same name as the formal, and they do
+ -- appear in the same order.
+
function Formal_Entity
(F : Node_Id;
Act_Ent : Entity_Id)
@@ -5758,6 +6027,15 @@ package body Sem_Ch12 is
-- parameters. This function is called recursively for arbitrary
-- levels of formal packages.
+ function Is_Instance_Of
+ (Act_Spec : Entity_Id;
+ Gen_Anc : Entity_Id)
+ return Boolean;
+ -- The actual can be an instantiation of a generic within another
+ -- instance, in which case there is no direct link from it to the
+ -- original generic ancestor. In that case, we recognize that the
+ -- ultimate ancestor is the same by examining names and scopes.
+
procedure Map_Entities (Form : Entity_Id; Act : Entity_Id);
-- Within the generic part, entities in the formal package are
-- visible. To validate subsequent type declarations, indicate
@@ -5771,6 +6049,42 @@ package body Sem_Ch12 is
-- that the entities in P2 are mapped into those of P3. The mapping of
-- entities has to be done recursively for nested packages.
+ --------------------------
+ -- Find_Matching_Actual --
+ --------------------------
+
+ procedure Find_Matching_Actual
+ (F : Node_Id;
+ Act : in out Entity_Id)
+ is
+ Formal_Ent : Entity_Id;
+
+ begin
+ case Nkind (Original_Node (F)) is
+ when N_Formal_Object_Declaration |
+ N_Formal_Type_Declaration =>
+ Formal_Ent := Defining_Identifier (F);
+
+ while Chars (Act) /= Chars (Formal_Ent) loop
+ Next_Entity (Act);
+ end loop;
+
+ when N_Formal_Subprogram_Declaration |
+ N_Formal_Package_Declaration |
+ N_Package_Declaration |
+ N_Generic_Package_Declaration =>
+ Formal_Ent := Defining_Entity (F);
+
+ while Chars (Act) /= Chars (Formal_Ent) loop
+ Next_Entity (Act);
+ end loop;
+
+ when others =>
+ null;
+ pragma Assert (False);
+ end case;
+ end Find_Matching_Actual;
+
-------------------
-- Formal_Entity --
-------------------
@@ -5781,35 +6095,51 @@ package body Sem_Ch12 is
return Entity_Id
is
Orig_Node : Node_Id := F;
+ Act_Pkg : Entity_Id;
begin
- case Nkind (F) is
- when N_Formal_Object_Declaration =>
+ case Nkind (Original_Node (F)) is
+ when N_Formal_Object_Declaration =>
return Defining_Identifier (F);
- when N_Formal_Type_Declaration =>
+ when N_Formal_Type_Declaration =>
return Defining_Identifier (F);
when N_Formal_Subprogram_Declaration =>
return Defining_Unit_Name (Specification (F));
+ when N_Package_Declaration =>
+ return Defining_Unit_Name (Specification (F));
+
when N_Formal_Package_Declaration |
- N_Generic_Package_Declaration =>
+ N_Generic_Package_Declaration =>
if Nkind (F) = N_Generic_Package_Declaration then
Orig_Node := Original_Node (F);
end if;
+ Act_Pkg := Act_Ent;
+
+ -- Find matching actual package, skipping over itypes and
+ -- other entities generated when analyzing the formal. We
+ -- know that if the instantiation is legal then there is
+ -- a matching package for the formal.
+
+ while Ekind (Act_Pkg) /= E_Package loop
+ Act_Pkg := Next_Entity (Act_Pkg);
+ end loop;
+
declare
- Actual_Ent : Entity_Id := First_Entity (Act_Ent);
+ Actual_Ent : Entity_Id := First_Entity (Act_Pkg);
Formal_Node : Node_Id;
Formal_Ent : Entity_Id;
- Gen_Decl : Node_Id :=
+ Gen_Decl : constant Node_Id :=
Unit_Declaration_Node
(Entity (Name (Orig_Node)));
- Formals : List_Id :=
- Generic_Formal_Declarations (Gen_Decl);
+
+ Formals : constant List_Id :=
+ Generic_Formal_Declarations (Gen_Decl);
begin
if Present (Formals) then
@@ -5818,17 +6148,6 @@ package body Sem_Ch12 is
Formal_Node := Empty;
end if;
- -- As for the loop further below, this loop is making
- -- a probably invalid assumption about the correspondence
- -- between formals and actuals and eventually needs to
- -- corrected to account for cases where the formals are
- -- not synchronized and in one-to-one correspondence
- -- with actuals. ???
-
- -- What is certain is that for a legal program the
- -- presence of actual entities guarantees the existing
- -- of formal ones.
-
while Present (Actual_Ent)
and then Present (Formal_Node)
and then Actual_Ent /= First_Private_Entity (Act_Ent)
@@ -5869,6 +6188,41 @@ package body Sem_Ch12 is
end case;
end Formal_Entity;
+ --------------------
+ -- Is_Instance_Of --
+ --------------------
+
+ function Is_Instance_Of
+ (Act_Spec : Entity_Id;
+ Gen_Anc : Entity_Id)
+ return Boolean
+ is
+ Gen_Par : Entity_Id := Generic_Parent (Act_Spec);
+
+ begin
+ if No (Gen_Par) then
+ return False;
+
+ -- Simplest case: the generic parent of the actual is the formal.
+
+ elsif Gen_Par = Gen_Anc then
+ return True;
+
+ elsif Chars (Gen_Par) /= Chars (Gen_Anc) then
+ return False;
+
+ -- The actual may be obtained through several instantiations. Its
+ -- scope must itself be an instance of a generic declared in the
+ -- same scope as the formal. Any other case is detected above.
+
+ elsif not Is_Generic_Instance (Scope (Gen_Par)) then
+ return False;
+
+ else
+ return Generic_Parent (Parent (Scope (Gen_Par))) = Scope (Gen_Anc);
+ end if;
+ end Is_Instance_Of;
+
------------------
-- Map_Entities --
------------------
@@ -5880,6 +6234,11 @@ package body Sem_Ch12 is
begin
Set_Instance_Of (Form, Act);
+ -- Traverse formal and actual package to map the corresponding
+ -- entities. We skip over internal entities that may be generated
+ -- during semantic analysis, and find the matching entities by
+ -- name, given that they must appear in the same order.
+
E1 := First_Entity (Form);
E2 := First_Entity (Act);
while Present (E1)
@@ -5887,8 +6246,8 @@ package body Sem_Ch12 is
loop
if not Is_Internal (E1)
and then not Is_Class_Wide_Type (E1)
+ and then Present (Parent (E1))
then
-
while Present (E2)
and then Chars (E2) /= Chars (E1)
loop
@@ -5965,8 +6324,11 @@ package body Sem_Ch12 is
Abandon_Instantiation (Actual);
elsif
- Generic_Parent (Parent_Spec) /= Get_Instance_Of (Gen_Parent)
+ Is_Instance_Of (Parent_Spec, Get_Instance_Of (Gen_Parent))
then
+ null;
+
+ else
Error_Msg_NE
("actual parameter must be instance of&", Actual, Gen_Parent);
Abandon_Instantiation (Actual);
@@ -5997,26 +6359,26 @@ package body Sem_Ch12 is
-- actuals into the renaming map. This is necessary to properly
-- handle checking of actual parameter associations for later
-- formals that depend on actuals declared in the formal package.
- --
- -- This processing needs to be reviewed at some point because
- -- it is probably not entirely correct as written. For example
- -- there may not be a strict one-to-one correspondence between
- -- actuals and formals and this loop is currently assuming that
- -- there is. ???
if Box_Present (Formal) then
declare
- Actual_Ent : Entity_Id := First_Entity (Actual_Pack);
- Formal_Node : Node_Id := Empty;
+ Gen_Decl : constant Node_Id :=
+ Unit_Declaration_Node (Gen_Parent);
+ Formals : constant List_Id :=
+ Generic_Formal_Declarations (Gen_Decl);
+ Actual_Ent : Entity_Id;
+ Formal_Node : Node_Id;
Formal_Ent : Entity_Id;
- Gen_Decl : Node_Id := Unit_Declaration_Node (Gen_Parent);
- Formals : List_Id := Generic_Formal_Declarations (Gen_Decl);
begin
if Present (Formals) then
Formal_Node := First_Non_Pragma (Formals);
+ else
+ Formal_Node := Empty;
end if;
+ Actual_Ent := First_Entity (Actual_Pack);
+
while Present (Actual_Ent)
and then Actual_Ent /= First_Private_Entity (Actual_Pack)
loop
@@ -6028,13 +6390,18 @@ package body Sem_Ch12 is
Formal_Ent := Formal_Entity (Formal_Node, Actual_Ent);
if Present (Formal_Ent) then
+ Find_Matching_Actual (Formal_Node, Actual_Ent);
Set_Instance_Of (Formal_Ent, Actual_Ent);
end if;
Next_Non_Pragma (Formal_Node);
+
+ else
+ -- No further formals to match.
+
+ exit;
end if;
- Next_Entity (Actual_Ent);
end loop;
end;
@@ -6063,7 +6430,6 @@ package body Sem_Ch12 is
return Decls;
end if;
-
end Instantiate_Formal_Package;
-----------------------------------
@@ -6074,7 +6440,7 @@ package body Sem_Ch12 is
(Formal : Node_Id;
Actual : Node_Id;
Analyzed_Formal : Node_Id)
- return Node_Id
+ return Node_Id
is
Loc : Source_Ptr := Sloc (Instantiation_Node);
Formal_Sub : constant Entity_Id :=
@@ -6123,25 +6489,31 @@ package body Sem_Ch12 is
-----------------------------
procedure Valid_Actual_Subprogram (Act : Node_Id) is
+ Act_E : Entity_Id := Empty;
+
begin
- if not Is_Entity_Name (Act)
- and then Nkind (Act) /= N_Operator_Symbol
- and then Nkind (Act) /= N_Attribute_Reference
- and then Nkind (Act) /= N_Selected_Component
- and then Nkind (Act) /= N_Indexed_Component
- and then Nkind (Act) /= N_Character_Literal
- and then Nkind (Act) /= N_Explicit_Dereference
+ if Is_Entity_Name (Act) then
+ Act_E := Entity (Act);
+ elsif Nkind (Act) = N_Selected_Component
+ and then Is_Entity_Name (Selector_Name (Act))
then
- if Etype (Act) /= Any_Type then
- Error_Msg_NE
- ("Expect subprogram name to instantiate &",
- Instantiation_Node, Formal_Sub);
- end if;
-
- -- In any case, instantiation cannot continue.
+ Act_E := Entity (Selector_Name (Act));
+ end if;
- Abandon_Instantiation (Instantiation_Node);
+ if (Present (Act_E) and then Is_Overloadable (Act_E))
+ or else Nkind (Act) = N_Attribute_Reference
+ or else Nkind (Act) = N_Indexed_Component
+ or else Nkind (Act) = N_Character_Literal
+ or else Nkind (Act) = N_Explicit_Dereference
+ then
+ return;
end if;
+
+ Error_Msg_NE
+ ("expect subprogram or entry name in instantiation of&",
+ Instantiation_Node, Formal_Sub);
+ Abandon_Instantiation (Instantiation_Node);
+
end Valid_Actual_Subprogram;
-- Start of processing for Instantiate_Formal_Subprogram
@@ -6180,7 +6552,6 @@ package body Sem_Ch12 is
Nam := Actual;
elsif Present (Default_Name (Formal)) then
-
if Nkind (Default_Name (Formal)) /= N_Attribute_Reference
and then Nkind (Default_Name (Formal)) /= N_Selected_Component
and then Nkind (Default_Name (Formal)) /= N_Indexed_Component
@@ -6265,9 +6636,9 @@ package body Sem_Ch12 is
-- The generic instantiation freezes the actual. This can only be
-- done once the actual is resolved, in the analysis of the renaming
-- declaration. To indicate that must be done, we set the corresponding
- -- spec of the node to point to the formal subprogram declaration.
+ -- spec of the node to point to the formal subprogram entity.
- Set_Corresponding_Spec (Decl_Node, Analyzed_Formal);
+ Set_Corresponding_Spec (Decl_Node, Analyzed_S);
-- We cannot analyze the renaming declaration, and thus find the
-- actual, until the all the actuals are assembled in the instance.
@@ -6294,7 +6665,7 @@ package body Sem_Ch12 is
Insert_Before (Instantiation_Node, Decl_Node);
Analyze (Decl_Node);
- -- Now create renaming within the instance.
+ -- Now create renaming within the instance
Decl_Node :=
Make_Subprogram_Renaming_Declaration (Loc,
@@ -6325,10 +6696,10 @@ package body Sem_Ch12 is
Act_Assoc : constant Node_Id := Parent (Actual);
Orig_Ftyp : constant Entity_Id :=
Etype (Defining_Identifier (Analyzed_Formal));
+ List : constant List_Id := New_List;
Ftyp : Entity_Id;
Decl_Node : Node_Id;
Subt_Decl : Node_Id := Empty;
- List : List_Id := New_List;
begin
if Get_Instance_Of (Formal_Id) /= Formal_Id then
@@ -6473,12 +6844,19 @@ package body Sem_Ch12 is
end if;
Append (Decl_Node, List);
- Analyze (Actual);
+
+ -- No need to repeat (pre-)analysis of some expression nodes
+ -- already handled in Pre_Analyze_Actuals.
+
+ if Nkind (Actual) /= N_Allocator then
+ Analyze (Actual);
+ end if;
declare
- Typ : Entity_Id
- := Get_Instance_Of
- (Etype (Defining_Identifier (Analyzed_Formal)));
+ Typ : constant Entity_Id :=
+ Get_Instance_Of
+ (Etype (Defining_Identifier (Analyzed_Formal)));
+
begin
Freeze_Before (Instantiation_Node, Typ);
@@ -6510,7 +6888,28 @@ package body Sem_Ch12 is
Error_Msg_NE
("missing actual for instantiation of &",
Instantiation_Node, Formal_Id);
- Abandon_Instantiation (Instantiation_Node);
+
+ if Is_Scalar_Type
+ (Etype (Defining_Identifier (Analyzed_Formal)))
+ then
+ -- Create dummy constant declaration so that instance can
+ -- be analyzed, to minimize cascaded visibility errors.
+
+ Decl_Node :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => New_Copy (Formal_Id),
+ Constant_Present => True,
+ Object_Definition => New_Copy (Type_Id),
+ Expression =>
+ Make_Attribute_Reference (Sloc (Formal_Id),
+ Attribute_Name => Name_First,
+ Prefix => New_Copy (Type_Id)));
+
+ Append (Decl_Node, List);
+
+ else
+ Abandon_Instantiation (Instantiation_Node);
+ end if;
end if;
end if;
@@ -6523,7 +6922,8 @@ package body Sem_Ch12 is
------------------------------
procedure Instantiate_Package_Body
- (Body_Info : Pending_Body_Info)
+ (Body_Info : Pending_Body_Info;
+ Inlined_Body : Boolean := False)
is
Act_Decl : constant Node_Id := Body_Info.Act_Decl;
Inst_Node : constant Node_Id := Body_Info.Inst_Node;
@@ -6542,7 +6942,7 @@ package body Sem_Ch12 is
Act_Body_Id : Entity_Id;
Parent_Installed : Boolean := False;
- Save_Style_Check : Boolean := Style_Check;
+ Save_Style_Check : constant Boolean := Style_Check;
begin
Gen_Body_Id := Corresponding_Body (Gen_Decl);
@@ -6574,13 +6974,13 @@ package body Sem_Ch12 is
Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
Create_Instantiation_Source
- (Inst_Node, Gen_Body_Id, S_Adjustment);
+ (Inst_Node, Gen_Body_Id, False, S_Adjustment);
Act_Body :=
Copy_Generic_Node
(Original_Node (Gen_Body), Empty, Instantiating => True);
- -- Build new name (possibly qualified) for body declaration.
+ -- Build new name (possibly qualified) for body declaration
Act_Body_Id := New_Copy (Act_Decl_Id);
@@ -6692,6 +7092,14 @@ package body Sem_Ch12 is
end if;
Restore_Private_Views (Act_Decl_Id);
+
+ -- Remove the current unit from visibility if this is an instance
+ -- that is not elaborated on the fly for inlining purposes.
+
+ if not Inlined_Body then
+ Set_Is_Immediately_Visible (Act_Decl_Id, False);
+ end if;
+
Restore_Env;
Style_Check := Save_Style_Check;
@@ -6722,6 +7130,13 @@ package body Sem_Ch12 is
Set_Parent_Spec (Act_Decl, Parent_Spec (Inst_Node));
Rewrite (Inst_Node, Act_Decl);
+ -- Generate elaboration entity, in case spec has elaboration
+ -- code. This cannot be done when the instance is analyzed,
+ -- because it is not known yet whether the body exists.
+
+ Set_Elaboration_Entity_Required (Act_Decl_Id, False);
+ Build_Elaboration_Entity (Parent (Inst_Node), Act_Decl_Id);
+
-- If the instantiation is not a library unit, then append the
-- declaration to the list of implicitly generated entities.
-- unless it is already a list member which means that it was
@@ -6746,24 +7161,24 @@ package body Sem_Ch12 is
Act_Decl : constant Node_Id := Body_Info.Act_Decl;
Inst_Node : constant Node_Id := Body_Info.Inst_Node;
Loc : constant Source_Ptr := Sloc (Inst_Node);
-
- Decls : List_Id;
Gen_Id : constant Node_Id := Name (Inst_Node);
Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
Anon_Id : constant Entity_Id :=
Defining_Unit_Name (Specification (Act_Decl));
+ Pack_Id : constant Entity_Id :=
+ Defining_Unit_Name (Parent (Act_Decl));
+ Decls : List_Id;
Gen_Body : Node_Id;
Gen_Body_Id : Node_Id;
Act_Body : Node_Id;
Act_Body_Id : Entity_Id;
- Pack_Id : Entity_Id := Defining_Unit_Name (Parent (Act_Decl));
Pack_Body : Node_Id;
Prev_Formal : Entity_Id;
Unit_Renaming : Node_Id;
Parent_Installed : Boolean := False;
- Save_Style_Check : Boolean := Style_Check;
+ Save_Style_Check : constant Boolean := Style_Check;
begin
Gen_Body_Id := Corresponding_Body (Gen_Decl);
@@ -6792,7 +7207,11 @@ package body Sem_Ch12 is
Save_Env (Gen_Unit, Anon_Id);
Style_Check := False;
Current_Sem_Unit := Body_Info.Current_Sem_Unit;
- Create_Instantiation_Source (Inst_Node, Gen_Body_Id, S_Adjustment);
+ Create_Instantiation_Source
+ (Inst_Node,
+ Gen_Body_Id,
+ False,
+ S_Adjustment);
Act_Body :=
Copy_Generic_Node
@@ -6870,7 +7289,6 @@ package body Sem_Ch12 is
-- of the corresponding compilation.
if Nkind (Parent (Inst_Node)) = N_Compilation_Unit then
-
if Parent (Inst_Node) = Cunit (Main_Unit) then
Set_Unit (Parent (Inst_Node), Inst_Node);
Build_Instance_Compilation_Unit_Nodes
@@ -6974,13 +7392,14 @@ package body Sem_Ch12 is
function Instantiate_Type
(Formal : Node_Id;
Actual : Node_Id;
- Analyzed_Formal : Node_Id)
+ Analyzed_Formal : Node_Id;
+ Actual_Decls : List_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Actual);
Gen_T : constant Entity_Id := Defining_Identifier (Formal);
A_Gen_T : constant Entity_Id := Defining_Identifier (Analyzed_Formal);
- Ancestor : Entity_Id;
+ Ancestor : Entity_Id := Empty;
Def : constant Node_Id := Formal_Type_Definition (Formal);
Act_T : Entity_Id;
Decl_Node : Node_Id;
@@ -7056,8 +7475,9 @@ package body Sem_Ch12 is
-----------------------------------
procedure Validate_Access_Type_Instance is
- Desig_Type : Entity_Id :=
- Find_Actual_Type (Designated_Type (A_Gen_T), Scope (A_Gen_T));
+ Desig_Type : constant Entity_Id :=
+ Find_Actual_Type
+ (Designated_Type (A_Gen_T), Scope (A_Gen_T));
begin
if not Is_Access_Type (Act_T) then
@@ -7233,20 +7653,23 @@ package body Sem_Ch12 is
-- a previous formal type, then it is local to the generic
-- and absent from the analyzed generic definition. In that
-- case the ancestor is the instance of the formal (which must
- -- have been instantiated previously). Otherwise, the analyzed
+ -- have been instantiated previously), unless the ancestor is
+ -- itself a formal derived type. In this latter case (which is the
+ -- subject of Corrigendum 8652/0038 (AI-202) the ancestor of the
+ -- formals is the ancestor of its parent. Otherwise, the analyzed
-- generic carries the parent type. If the parent type is defined
-- in a previous formal package, then the scope of that formal
-- package is that of the generic type itself, and it has already
-- been mapped into the corresponding type in the actual package.
- -- Common case: parent type defined outside of the generic.
+ -- Common case: parent type defined outside of the generic
if Is_Entity_Name (Subtype_Mark (Def))
and then Present (Entity (Subtype_Mark (Def)))
then
Ancestor := Get_Instance_Of (Entity (Subtype_Mark (Def)));
- -- Check whether parent is defined in a previous formal package.
+ -- Check whether parent is defined in a previous formal package
elsif
Scope (Scope (Base_Type (Etype (A_Gen_T)))) = Scope (A_Gen_T)
@@ -7261,8 +7684,43 @@ package body Sem_Ch12 is
or else
Ekind (Get_Instance_Of (A_Gen_T)) = E_Record_Type_With_Private
then
- Ancestor :=
- Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
+
+ -- Check whether the parent is another derived formal type
+ -- in the same generic unit.
+
+ if Etype (A_Gen_T) /= A_Gen_T
+ and then Is_Generic_Type (Etype (A_Gen_T))
+ and then Scope (Etype (A_Gen_T)) = Scope (A_Gen_T)
+ and then Etype (Etype (A_Gen_T)) /= Etype (A_Gen_T)
+ then
+
+ -- Locate ancestor of parent from the subtype declaration
+ -- created for the actual.
+
+ declare
+ Decl : Node_Id;
+ begin
+ Decl := First (Actual_Decls);
+
+ while (Present (Decl)) loop
+ if Nkind (Decl) = N_Subtype_Declaration
+ and then Chars (Defining_Identifier (Decl))
+ = Chars (Etype (A_Gen_T))
+ then
+ Ancestor := Generic_Parent_Type (Decl);
+ exit;
+ else
+ Next (Decl);
+ end if;
+ end loop;
+ end;
+
+ pragma Assert (Present (Ancestor));
+
+ else
+ Ancestor :=
+ Get_Instance_Of (Base_Type (Get_Instance_Of (A_Gen_T)));
+ end if;
else
Ancestor := Get_Instance_Of (Etype (Base_Type (A_Gen_T)));
@@ -7387,7 +7845,6 @@ package body Sem_Ch12 is
Abandon_Instantiation (Actual);
end if;
end if;
-
end Validate_Derived_Type_Instance;
------------------------------------
@@ -7400,13 +7857,13 @@ package body Sem_Ch12 is
Formal_Subt : Entity_Id;
begin
- if (Is_Limited_Type (Act_T)
- or else Is_Limited_Composite (Act_T))
+ if Is_Limited_Type (Act_T)
and then not Is_Limited_Type (A_Gen_T)
then
Error_Msg_NE
("actual for non-limited & cannot be a limited type", Actual,
Gen_T);
+ Explain_Limited_Type (Act_T, Actual);
Abandon_Instantiation (Actual);
elsif Is_Indefinite_Subtype (Act_T)
@@ -7646,6 +8103,11 @@ package body Sem_Ch12 is
if Is_Private_Type (Act_T) then
Set_Has_Private_View (Subtype_Indication (Decl_Node));
+
+ elsif Is_Access_Type (Act_T)
+ and then Is_Private_Type (Designated_Type (Act_T))
+ then
+ Set_Has_Private_View (Subtype_Indication (Decl_Node));
end if;
-- Flag actual derived types so their elaboration produces the
@@ -7707,10 +8169,10 @@ package body Sem_Ch12 is
procedure Load_Parent_Of_Generic (N : Node_Id; Spec : Node_Id) is
Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec));
+ Save_Style_Check : constant Boolean := Style_Check;
True_Parent : Node_Id;
Inst_Node : Node_Id;
OK : Boolean;
- Save_Style_Check : Boolean := Style_Check;
begin
if not In_Same_Source_Unit (N, Spec)
@@ -7775,8 +8237,9 @@ package body Sem_Ch12 is
end if;
end loop;
- if Present (Inst_Node) then
+ -- Case where we are currently instantiating a nested generic
+ if Present (Inst_Node) then
if Nkind (Parent (True_Parent)) = N_Compilation_Unit then
-- Instantiation node and declaration of instantiated package
@@ -7791,16 +8254,49 @@ package body Sem_Ch12 is
-- body will have been instantiated already.
if No (Corresponding_Body (Instance_Spec (Inst_Node))) then
- Instantiate_Package_Body
- (Pending_Body_Info'(
- Inst_Node, True_Parent, Expander_Active,
- Get_Code_Unit (Sloc (Inst_Node))));
+
+ -- We need to determine the expander mode to instantiate
+ -- the enclosing body. Because the generic body we need
+ -- may use global entities declared in the enclosing package
+ -- (including aggregates) it is in general necessary to
+ -- compile this body with expansion enabled. The exception
+ -- is if we are within a generic package, in which case
+ -- the usual generic rule applies.
+
+ declare
+ Exp_Status : Boolean := True;
+ Scop : Entity_Id;
+
+ begin
+ -- Loop through scopes looking for generic package
+
+ Scop := Scope (Defining_Entity (Instance_Spec (Inst_Node)));
+ while Present (Scop)
+ and then Scop /= Standard_Standard
+ loop
+ if Ekind (Scop) = E_Generic_Package then
+ Exp_Status := False;
+ exit;
+ end if;
+
+ Scop := Scope (Scop);
+ end loop;
+
+ Instantiate_Package_Body
+ (Pending_Body_Info'(
+ Inst_Node, True_Parent, Exp_Status,
+ Get_Code_Unit (Sloc (Inst_Node))));
+ end;
end if;
+ -- Case where we are not instantiating a nested generic
+
else
Opt.Style_Check := False;
+ Expander_Mode_Save_And_Set (True);
Load_Needed_Body (Comp_Unit, OK);
Opt.Style_Check := Save_Style_Check;
+ Expander_Mode_Restore;
if not OK
and then Unit_Requires_Body (Defining_Entity (Spec))
@@ -7829,7 +8325,6 @@ package body Sem_Ch12 is
if Circularity_Detected then
raise Unrecoverable_Error;
end if;
-
end Load_Parent_Of_Generic;
-----------------------
@@ -7955,7 +8450,7 @@ package body Sem_Ch12 is
procedure Pre_Analyze_Actuals (N : Node_Id) is
Assoc : Node_Id;
Act : Node_Id;
- Errs : Int := Serious_Errors_Detected;
+ Errs : constant Int := Serious_Errors_Detected;
begin
Assoc := First (Generic_Associations (N));
@@ -7967,6 +8462,12 @@ package body Sem_Ch12 is
-- empty association, so nothing to analyze. If the actual for
-- a subprogram is an attribute, analyze prefix only, because
-- actual is not a complete attribute reference.
+
+ -- If actual is an allocator, analyze expression only. The full
+ -- analysis can generate code, and if the instance is a compilation
+ -- unit we have to wait until the package instance is installed to
+ -- have a proper place to insert this code.
+
-- String literals may be operators, but at this point we do not
-- know whether the actual is a formal subprogram or a string.
@@ -7979,6 +8480,19 @@ package body Sem_Ch12 is
elsif Nkind (Act) = N_Explicit_Dereference then
Analyze (Prefix (Act));
+ elsif Nkind (Act) = N_Allocator then
+ declare
+ Expr : constant Node_Id := Expression (Act);
+
+ begin
+ if Nkind (Expr) = N_Subtype_Indication then
+ Analyze (Subtype_Mark (Expr));
+ Analyze_List (Constraints (Constraint (Expr)));
+ else
+ Analyze (Expr);
+ end if;
+ end;
+
elsif Nkind (Act) /= N_Operator_Symbol then
Analyze (Act);
end if;
@@ -8052,6 +8566,7 @@ package body Sem_Ch12 is
while Present (S) loop
End_Package_Scope (S);
+ Set_Is_Immediately_Visible (S, False);
S := Current_Scope;
exit when S = Standard_Standard;
end loop;
@@ -8172,7 +8687,7 @@ package body Sem_Ch12 is
-- package itself. If the instance is a subprogram, all entities
-- in the corresponding package are renamings. If this entity is
-- a formal package, make its own formals private as well. The
- -- actual in this case is itself the renaming of an instantiation.
+ -- actual in this case is itself the renaming of an instantation.
-- If the entity is not a package renaming, it is the entity
-- created to validate formal package actuals: ignore.
@@ -8194,10 +8709,11 @@ package body Sem_Ch12 is
else
declare
- Act_P : Entity_Id := Renamed_Object (E);
- Id : Entity_Id := First_Entity (Act_P);
+ Act_P : constant Entity_Id := Renamed_Object (E);
+ Id : Entity_Id;
begin
+ Id := First_Entity (Act_P);
while Present (Id)
and then Id /= First_Private_Entity (Act_P)
loop
@@ -8225,29 +8741,9 @@ package body Sem_Ch12 is
(Gen_Unit : Entity_Id;
Act_Unit : Entity_Id)
is
- Saved : Instance_Env;
-
begin
- Saved.Ada_83 := Ada_83;
- Saved.Instantiated_Parent := Current_Instantiated_Parent;
- Saved.Exchanged_Views := Exchanged_Views;
- Saved.Hidden_Entities := Hidden_Entities;
- Saved.Current_Sem_Unit := Current_Sem_Unit;
- Instance_Envs.Increment_Last;
- Instance_Envs.Table (Instance_Envs.Last) := Saved;
-
- -- Regardless of the current mode, predefined units are analyzed in
- -- Ada95 mode, and Ada83 checks don't apply.
-
- if Is_Internal_File_Name
- (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
- Renamings_Included => True) then
- Ada_83 := False;
- end if;
-
- Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
- Exchanged_Views := New_Elmt_List;
- Hidden_Entities := New_Elmt_List;
+ Init_Env;
+ Set_Instance_Env (Gen_Unit, Act_Unit);
end Save_Env;
----------------------------
@@ -8368,6 +8864,13 @@ package body Sem_Ch12 is
-- The type of N2 is global to the generic unit. Save the
-- type in the generic node.
+ function Top_Ancestor (E : Entity_Id) return Entity_Id;
+ -- Find the ultimate ancestor of the current unit. If it is
+ -- not a generic unit, then the name of the current unit
+ -- in the prefix of an expanded name must be replaced with
+ -- its generic homonym to ensure that it will be properly
+ -- resolved in an instance.
+
---------------------
-- Set_Global_Type --
---------------------
@@ -8416,6 +8919,21 @@ package body Sem_Ch12 is
end if;
end Set_Global_Type;
+ ------------------
+ -- Top_Ancestor --
+ ------------------
+
+ function Top_Ancestor (E : Entity_Id) return Entity_Id is
+ Par : Entity_Id := E;
+
+ begin
+ while Is_Child_Unit (Par) loop
+ Par := Scope (Par);
+ end loop;
+
+ return Par;
+ end Top_Ancestor;
+
-- Start of processing for Reset_Entity
begin
@@ -8461,19 +8979,28 @@ package body Sem_Ch12 is
Set_Global_Type (Parent (N), Parent (N2));
Save_Entity_Descendants (N);
- -- If this is a reference to the current generic entity,
- -- replace it with a simple name. This is to avoid anomalies
- -- when the enclosing scope is also a generic unit, in which
- -- case the selected component will not resolve to the current
- -- unit within an instance of the outer one. Ditto if the
- -- entity is an enclosing scope, e.g. a parent unit.
+ -- If this is a reference to the current generic entity,
+ -- replace by the name of the generic homonym of the current
+ -- package. This is because in an instantiation Par.P.Q will
+ -- not resolve to the name of the instance, whose enclosing
+ -- scope is not necessarily Par. We use the generic homonym
+ -- rather that the name of the generic itself, because it may
+ -- be hidden by a local declaration.
elsif In_Open_Scopes (Entity (Parent (N2)))
- and then not Is_Generic_Unit (Entity (Prefix (Parent (N2))))
+ and then not
+ Is_Generic_Unit (Top_Ancestor (Entity (Prefix (Parent (N2)))))
then
- Rewrite (Parent (N),
- Make_Identifier (Sloc (N),
- Chars => Chars (Selector_Name (Parent (N2)))));
+ if Ekind (Entity (Parent (N2))) = E_Generic_Package then
+ Rewrite (Parent (N),
+ Make_Identifier (Sloc (N),
+ Chars =>
+ Chars (Generic_Homonym (Entity (Parent (N2))))));
+ else
+ Rewrite (Parent (N),
+ Make_Identifier (Sloc (N),
+ Chars => Chars (Selector_Name (Parent (N2)))));
+ end if;
end if;
if (Nkind (Parent (Parent (N))) = N_Package_Instantiation
@@ -8553,17 +9080,19 @@ package body Sem_Ch12 is
procedure Save_Global_Defaults (N1, N2 : Node_Id) is
Loc : constant Source_Ptr := Sloc (N1);
- Assoc1 : List_Id := Generic_Associations (N1);
- Assoc2 : List_Id := Generic_Associations (N2);
+ Assoc2 : constant List_Id := Generic_Associations (N2);
+ Gen_Id : constant Entity_Id := Get_Generic_Entity (N2);
+ Assoc1 : List_Id;
Act1 : Node_Id;
Act2 : Node_Id;
Def : Node_Id;
- Gen_Id : Entity_Id := Get_Generic_Entity (N2);
Ndec : Node_Id;
Subp : Entity_Id;
Actual : Entity_Id;
begin
+ Assoc1 := Generic_Associations (N1);
+
if Present (Assoc1) then
Act1 := First (Assoc1);
else
@@ -8732,8 +9261,8 @@ package body Sem_Ch12 is
if N = Empty then
null;
- elsif (Nkind (N) = N_Character_Literal
- or else Nkind (N) = N_Operator_Symbol)
+ elsif Nkind (N) = N_Character_Literal
+ or else Nkind (N) = N_Operator_Symbol
then
if Nkind (N) = Nkind (Get_Associated_Node (N)) then
Reset_Entity (N);
@@ -8777,28 +9306,23 @@ package body Sem_Ch12 is
elsif Nkind (N2) = N_Integer_Literal
or else Nkind (N2) = N_Real_Literal
or else Nkind (N2) = N_String_Literal
- or else (Nkind (N2) = N_Identifier
- and then
- Ekind (Entity (N2)) = E_Enumeration_Literal)
then
-- Operation was constant-folded, perform the same
-- replacement in generic.
- -- Note: we do a Replace here rather than a Rewrite,
- -- which is a definite violation of the standard rules
- -- with regard to retrievability of the original tree,
- -- and likely ASIS bugs or at least irregularities are
- -- caused by this choice.
-
- -- The reason we do this is that the appropriate original
- -- nodes are never constructed (we don't go applying the
- -- generic instantiation to rewritten nodes in general).
- -- We could try to create an appropriate copy but it would
- -- be hard work and does not seem worth while, because
- -- the original expression is accessible in the generic,
- -- and ASIS rules for traversing instances are fuzzy.
-
- Replace (N, New_Copy (N2));
+ Rewrite (N, New_Copy (N2));
+ Set_Analyzed (N, False);
+
+ elsif Nkind (N2) = N_Identifier
+ and then Ekind (Entity (N2)) = E_Enumeration_Literal
+ then
+ -- Same if call was folded into a literal, but in this
+ -- case retain the entity to avoid spurious ambiguities
+ -- if id is overloaded at the point of instantiation or
+ -- inlining.
+
+ Rewrite (N, New_Copy (N2));
+ Set_Associated_Node (N, N2);
Set_Analyzed (N, False);
end if;
end if;
@@ -8962,14 +9486,14 @@ package body Sem_Ch12 is
Save_References (N);
end Save_Global_References;
- ---------------------
- -- Set_Copied_Sloc --
- ---------------------
+ --------------------------------------
+ -- Set_Copied_Sloc_For_Inlined_Body --
+ --------------------------------------
- procedure Set_Copied_Sloc (N : Node_Id; E : Entity_Id) is
+ procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is
begin
- Create_Instantiation_Source (N, E, S_Adjustment);
- end Set_Copied_Sloc;
+ Create_Instantiation_Source (N, E, True, S_Adjustment);
+ end Set_Copied_Sloc_For_Inlined_Body;
---------------------
-- Set_Instance_Of --
@@ -9007,14 +9531,36 @@ package body Sem_Ch12 is
Expander_Mode_Save_And_Set (False);
end Start_Generic;
+ ----------------------
+ -- Set_Instance_Env --
+ ----------------------
+
+ procedure Set_Instance_Env
+ (Gen_Unit : Entity_Id;
+ Act_Unit : Entity_Id)
+ is
+
+ begin
+ -- Regardless of the current mode, predefined units are analyzed in
+ -- Ada95 mode, and Ada83 checks don't apply.
+
+ if Is_Internal_File_Name
+ (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)),
+ Renamings_Included => True) then
+ Ada_83 := False;
+ end if;
+
+ Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);
+ end Set_Instance_Env;
+
-----------------
-- Switch_View --
-----------------
procedure Switch_View (T : Entity_Id) is
+ BT : constant Entity_Id := Base_Type (T);
Priv_Elmt : Elmt_Id := No_Elmt;
Priv_Sub : Entity_Id;
- BT : Entity_Id := Base_Type (T);
begin
-- T may be private but its base type may have been exchanged through
@@ -9061,11 +9607,11 @@ package body Sem_Ch12 is
procedure Valid_Default_Attribute (Nam : Entity_Id; Def : Node_Id) is
Attr_Id : constant Attribute_Id :=
Get_Attribute_Id (Attribute_Name (Def));
+ T : constant Entity_Id := Entity (Prefix (Def));
+ Is_Fun : constant Boolean := (Ekind (Nam) = E_Function);
F : Entity_Id;
Num_F : Int;
- T : Entity_Id := Entity (Prefix (Def));
OK : Boolean;
- Is_Fun : constant Boolean := (Ekind (Nam) = E_Function);
begin
if No (T)
@@ -9082,27 +9628,30 @@ package body Sem_Ch12 is
end loop;
case Attr_Id is
- when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
- Attribute_Floor | Attribute_Fraction | Attribute_Machine |
- Attribute_Model | Attribute_Remainder | Attribute_Rounding |
- Attribute_Unbiased_Rounding =>
- OK := (Is_Fun and then Num_F = 1 and then Is_Floating_Point_Type (T));
+ when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
+ Attribute_Floor | Attribute_Fraction | Attribute_Machine |
+ Attribute_Model | Attribute_Remainder | Attribute_Rounding |
+ Attribute_Unbiased_Rounding =>
+ OK := Is_Fun
+ and then Num_F = 1
+ and then Is_Floating_Point_Type (T);
- when Attribute_Image | Attribute_Pred | Attribute_Succ |
- Attribute_Value | Attribute_Wide_Image |
- Attribute_Wide_Value =>
- OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
+ when Attribute_Image | Attribute_Pred | Attribute_Succ |
+ Attribute_Value | Attribute_Wide_Image |
+ Attribute_Wide_Value =>
+ OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
- when Attribute_Max | Attribute_Min =>
- OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
+ when Attribute_Max | Attribute_Min =>
+ OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
- when Attribute_Input =>
- OK := (Is_Fun and then Num_F = 1);
+ when Attribute_Input =>
+ OK := (Is_Fun and then Num_F = 1);
- when Attribute_Output | Attribute_Read | Attribute_Write =>
- OK := (not Is_Fun and then Num_F = 2);
+ when Attribute_Output | Attribute_Read | Attribute_Write =>
+ OK := (not Is_Fun and then Num_F = 2);
- when others => OK := False;
+ when others =>
+ OK := False;
end case;
if not OK then
diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads
index a39a2895fc8..de7d164df5c 100644
--- a/gcc/ada/sem_ch12.ads
+++ b/gcc/ada/sem_ch12.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 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- --
@@ -71,9 +71,11 @@ package Sem_Ch12 is
-- If A is uninstantiated or not a generic parameter, return A.
procedure Instantiate_Package_Body
- (Body_Info : Pending_Body_Info);
+ (Body_Info : Pending_Body_Info;
+ Inlined_Body : Boolean := False);
-- Called after semantic analysis, to complete the instantiation of
- -- package instances.
+ -- package instances. The flag Inlined_Body is set if the body is
+ -- being instantiated on the fly for inlined purposes.
procedure Instantiate_Subprogram_Body
(Body_Info : Pending_Body_Info);
@@ -84,7 +86,7 @@ package Sem_Ch12 is
-- Traverse the original generic unit, and capture all references to
-- entities that are defined outside of the generic in the analyzed
-- tree for the template. These references are copied into the original
- -- tree, so that they appear automatically in every instantiation.
+ -- tree, so that they appear automatically in every instantiation.
-- A critical invariant in this approach is that if an id in the generic
-- resolves to a local entity, the corresponding id in the instance
-- will resolve to the homologous entity in the instance, even though
@@ -96,12 +98,27 @@ package Sem_Ch12 is
-- restored in stack-like fashion. Front-end inlining also uses these
-- structures for the management of private/full views.
- procedure Set_Copied_Sloc (N : Node_Id; E : Entity_Id);
+ procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id);
+ -- This procedure is used when a subprogram body is inlined. This process
+ -- shares the same circuitry as the creation of an instantiated copy of
+ -- a generic template. The call to this procedure establishes a new source
+ -- file entry representing the inlined body as an instantiation, marked as
+ -- an inlined body (so that errout can distinguish cases for generating
+ -- error messages, otherwise the treatment is identical). In this call
+ -- N is the subprogram body and E is the defining identifier of the
+ -- subprogram in quiestion. The resulting Sloc adjustment factor is
+ -- saved as part of the internal state of the Sem_Ch12 package for use
+ -- in subsequent calls to copy nodes.
procedure Save_Env
(Gen_Unit : Entity_Id;
Act_Unit : Entity_Id);
+ -- ??? comment needed
procedure Restore_Env;
+ -- ??? comment needed
+
+ procedure Initialize;
+ -- Initializes internal data structures
end Sem_Ch12;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 776aeb8342e..83b209570ed 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,7 +42,7 @@ with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
-with Snames; use Snames;
+with Snames; use Snames;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Table;
@@ -82,19 +82,28 @@ package body Sem_Ch13 is
-- Attributes that do not specify a representation characteristic are
-- operational attributes.
+ function Address_Aliased_Entity (N : Node_Id) return Entity_Id;
+ -- If expression N is of the form E'Address, return E.
+
+ procedure Mark_Aliased_Address_As_Volatile (N : Node_Id);
+ -- This is used for processing of an address representation clause. If
+ -- the expression N is of the form of K'Address, then the entity that
+ -- is associated with K is marked as volatile.
+
procedure New_Stream_Function
(N : Node_Id;
Ent : Entity_Id;
Subp : Entity_Id;
- Nam : Name_Id);
+ Nam : TSS_Name_Type);
-- Create a function renaming of a given stream attribute to the
-- designated subprogram and then in the tagged case, provide this as
-- a primitive operation, or in the non-tagged case make an appropriate
-- TSS entry. Used for Input. This is more properly an expansion activity
-- than just semantics, but the presence of user-defined stream functions
-- for limited types is a legality check, which is why this takes place
- -- here rather than in exp_ch13, where it was previously.
-
+ -- here rather than in exp_ch13, where it was previously. Nam indicates
+ -- the name of the TSS function to be generated.
+ --
-- To avoid elaboration anomalies with freeze nodes, for untagged types
-- we generate both a subprogram declaration and a subprogram renaming
-- declaration, so that the attribute specification is handled as a
@@ -105,30 +114,13 @@ package body Sem_Ch13 is
(N : Node_Id;
Ent : Entity_Id;
Subp : Entity_Id;
- Nam : Name_Id;
+ Nam : TSS_Name_Type;
Out_P : Boolean := False);
-- Create a procedure renaming of a given stream attribute to the
-- designated subprogram and then in the tagged case, provide this as
-- a primitive operation, or in the non-tagged case make an appropriate
- -- TSS entry. Used for Read, Output, Write.
-
- procedure Check_Constant_Address_Clause (Expr : Node_Id; U_Ent : Entity_Id);
- -- Expr is an expression for an address clause. This procedure checks
- -- that the expression is constant, in the limited sense that it is safe
- -- to evaluate it at the point the object U_Ent is declared, rather than
- -- at the point of the address clause. The condition for this to be true
- -- is that the expression has no variables, no constants declared after
- -- U_Ent, and no calls to non-pure functions. If this condition is not
- -- met, then an appropriate error message is posted.
-
- procedure Warn_Overlay
- (Expr : Node_Id;
- Typ : Entity_Id;
- Nam : Node_Id);
- -- Expr is the expression for an address clause for entity Nam whose type
- -- is Typ. If Typ has a default initialization, check whether the address
- -- clause might overlay two entities, and emit a warning on the side effect
- -- that the initialization will cause.
+ -- TSS entry. Used for Read, Output, Write. Nam indicates the name of
+ -- the TSS procedure to be generated.
----------------------------------------------
-- Table for Validate_Unchecked_Conversions --
@@ -155,6 +147,34 @@ package body Sem_Ch13 is
Table_Increment => 200,
Table_Name => "Unchecked_Conversions");
+ ----------------------------
+ -- Address_Aliased_Entity --
+ ----------------------------
+
+ function Address_Aliased_Entity (N : Node_Id) return Entity_Id is
+ begin
+ if Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Address
+ then
+ declare
+ Nam : Node_Id := Prefix (N);
+ begin
+ while False
+ or else Nkind (Nam) = N_Selected_Component
+ or else Nkind (Nam) = N_Indexed_Component
+ loop
+ Nam := Prefix (Nam);
+ end loop;
+
+ if Is_Entity_Name (Nam) then
+ return Entity (Nam);
+ end if;
+ end;
+ end if;
+
+ return Empty;
+ end Address_Aliased_Entity;
+
--------------------------------------
-- Alignment_Check_For_Esize_Change --
--------------------------------------
@@ -183,6 +203,13 @@ package body Sem_Ch13 is
procedure Analyze_At_Clause (N : Node_Id) is
begin
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("at clause is an obsolescent feature ('R'M 'J.7(2))?", N);
+ Error_Msg_N
+ ("|use address attribute definition clause instead?", N);
+ end if;
+
Rewrite (N,
Make_Attribute_Definition_Clause (Sloc (N),
Name => Identifier (N),
@@ -286,7 +313,6 @@ package body Sem_Ch13 is
-- Case of address clause for subprogram
elsif Is_Subprogram (U_Ent) then
-
if Has_Homonym (U_Ent) then
Error_Msg_N
("address clause cannot be given " &
@@ -305,7 +331,6 @@ package body Sem_Ch13 is
-- Case of address clause for entry
elsif Ekind (U_Ent) = E_Entry then
-
if Nkind (Parent (N)) = N_Task_Body then
Error_Msg_N
("entry address must be specified in task spec", Nam);
@@ -324,7 +349,27 @@ package body Sem_Ch13 is
("\?only one task can be declared of this type", N);
end if;
- -- Case of address clause for an object
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("attaching interrupt to task entry is an " &
+ "obsolescent feature ('R'M 'J.7.1)?", N);
+ Error_Msg_N
+ ("|use interrupt procedure instead?", N);
+ end if;
+
+ -- Case of an address clause for a controlled object:
+ -- erroneous execution.
+
+ elsif Is_Controlled (Etype (U_Ent)) then
+ Error_Msg_NE
+ ("?controlled object& must not be overlaid", Nam, U_Ent);
+ Error_Msg_N
+ ("\?Program_Error will be raised at run time", Nam);
+ Insert_Action (Declaration_Node (U_Ent),
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Overlaid_Controlled_Object));
+
+ -- Case of address clause for a (non-controlled) object
elsif
Ekind (U_Ent) = E_Variable
@@ -332,9 +377,8 @@ package body Sem_Ch13 is
Ekind (U_Ent) = E_Constant
then
declare
- Decl : constant Node_Id := Declaration_Node (U_Ent);
Expr : constant Node_Id := Expression (N);
- Typ : constant Entity_Id := Etype (U_Ent);
+ Aent : constant Entity_Id := Address_Aliased_Entity (Expr);
begin
-- Exported variables cannot have an address clause,
@@ -344,6 +388,30 @@ package body Sem_Ch13 is
Error_Msg_N
("cannot export object with address clause", Nam);
+ -- Overlaying controlled objects is erroneous
+
+ elsif Present (Aent)
+ and then Is_Controlled (Etype (Aent))
+ then
+ Error_Msg_N
+ ("?controlled object must not be overlaid", Expr);
+ Error_Msg_N
+ ("\?Program_Error will be raised at run time", Expr);
+ Insert_Action (Declaration_Node (U_Ent),
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Overlaid_Controlled_Object));
+
+ elsif Present (Aent)
+ and then Ekind (U_Ent) = E_Constant
+ and then Ekind (Aent) /= E_Constant
+ then
+ Error_Msg_N ("constant overlays a variable?", Expr);
+
+ elsif Present (Renamed_Object (U_Ent)) then
+ Error_Msg_N
+ ("address clause not allowed"
+ & " for a renaming declaration ('R'M 13.1(6))", Nam);
+
-- Imported variables can have an address clause, but then
-- the import is pretty meaningless except to suppress
-- initializations, so we do not need such variables to
@@ -359,40 +427,50 @@ package body Sem_Ch13 is
Note_Possible_Modification (Nam);
- -- If we have no initialization of any kind, then we can
- -- safely defer the elaboration of the variable to its
- -- freezing point, so that the address clause will be
- -- computed at the proper point.
+ -- Here we are checking for explicit overlap of one
+ -- variable by another, and if we find this, then we
+ -- mark the overlapped variable as also being aliased.
- -- The same processing applies to all initialized scalar
- -- types and all access types. Packed bit arrays of size
- -- up to 64 are represented using a modular type with an
- -- initialization (to zero) and can be processed like
- -- other initialized scalar types.
+ -- First case is where we have an explicit
- if (No (Expression (Decl))
- and then not Has_Non_Null_Base_Init_Proc (Typ))
+ -- for J'Address use K'Address;
- or else
- (Present (Expression (Decl))
- and then Is_Scalar_Type (Typ))
+ -- In this case, we mark K as volatile
- or else
- Is_Access_Type (Typ)
+ Mark_Aliased_Address_As_Volatile (Expr);
- or else
- (Is_Bit_Packed_Array (Base_Type (Typ))
- and then
- Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
- then
- Set_Has_Delayed_Freeze (U_Ent);
+ -- Second case is where we have a constant whose
+ -- definition is of the form of an adress as in:
- -- Otherwise, we require the address clause to be constant
+ -- A : constant Address := K'Address;
+ -- ...
+ -- for B'Address use A;
- else
- Check_Constant_Address_Clause (Expr, U_Ent);
+ -- In this case we also mark K as volatile
+
+ if Is_Entity_Name (Expr) then
+ declare
+ Ent : constant Entity_Id := Entity (Expr);
+ Decl : constant Node_Id := Declaration_Node (Ent);
+
+ begin
+ if Ekind (Ent) = E_Constant
+ and then Nkind (Decl) = N_Object_Declaration
+ and then Present (Expression (Decl))
+ then
+ Mark_Aliased_Address_As_Volatile
+ (Expression (Decl));
+ end if;
+ end;
end if;
+ -- Legality checks on the address clause for initialized
+ -- objects is deferred until the freeze point, because
+ -- a subsequent pragma might indicate that the object is
+ -- imported and thus not initialized.
+
+ Set_Has_Delayed_Freeze (U_Ent);
+
if Is_Exported (U_Ent) then
Error_Msg_N
("& cannot be exported if an address clause is given",
@@ -403,17 +481,11 @@ package body Sem_Ch13 is
Nam);
end if;
- if not Error_Posted (Expr) then
- Warn_Overlay (Expr, Typ, Nam);
- end if;
-
- -- If entity has delayed freeze then we will generate
- -- an alignment check at the freeze point. If there is
- -- no delayed freeze we can do it right now.
+ -- Entity has delayed freeze, so we will generate
+ -- an alignment check at the freeze point.
- if not Has_Delayed_Freeze (U_Ent) then
- Apply_Alignment_Check (U_Ent, N);
- end if;
+ Set_Check_Address_Alignment
+ (N, not Range_Checks_Suppressed (U_Ent));
-- Kill the size check code, since we are not allocating
-- the variable, it is somewhere else.
@@ -435,7 +507,7 @@ package body Sem_Ch13 is
-- Alignment attribute definition clause
when Attribute_Alignment => Alignment_Block : declare
- Align : Uint := Get_Alignment_Value (Expr);
+ Align : constant Uint := Get_Alignment_Value (Expr);
begin
FOnly := True;
@@ -475,7 +547,8 @@ package body Sem_Ch13 is
return;
elsif not Is_Static_Expression (Expr) then
- Error_Msg_N ("Bit_Order requires static expression", Expr);
+ Flag_Non_Static_Expr
+ ("Bit_Order requires static expression!", Expr);
else
if (Expr_Value (Expr) = 0) /= Bytes_Big_Endian then
@@ -573,7 +646,8 @@ package body Sem_Ch13 is
Analyze_And_Resolve (Expr, Standard_String);
if not Is_Static_Expression (Expr) then
- Error_Msg_N ("must be a static string", Nam);
+ Flag_Non_Static_Expr
+ ("static string required for tag name!", Nam);
end if;
Set_Has_External_Tag_Rep_Clause (U_Ent);
@@ -593,6 +667,10 @@ package body Sem_Ch13 is
-- Return true if the entity is a function with an appropriate
-- profile for the Input attribute.
+ ----------------------
+ -- Has_Good_Profile --
+ ----------------------
+
function Has_Good_Profile (Subp : Entity_Id) return Boolean is
F : Entity_Id;
Ok : Boolean := False;
@@ -625,7 +703,7 @@ package body Sem_Ch13 is
return;
else
- Pnam := TSS (Base_Type (U_Ent), Name_uInput);
+ Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Input);
if Present (Pnam)
and then Base_Type (Etype (Pnam)) = Base_Type (U_Ent)
@@ -661,7 +739,7 @@ package body Sem_Ch13 is
if Present (Subp) then
Set_Entity (Expr, Subp);
Set_Etype (Expr, Etype (Subp));
- New_Stream_Function (N, U_Ent, Subp, Name_uInput);
+ New_Stream_Function (N, U_Ent, Subp, TSS_Stream_Input);
else
Error_Msg_N ("incorrect expression for input attribute", Expr);
return;
@@ -752,6 +830,10 @@ package body Sem_Ch13 is
-- Return true if the entity is a procedure with an
-- appropriate profile for the output attribute.
+ ----------------------
+ -- Has_Good_Profile --
+ ----------------------
+
function Has_Good_Profile (Subp : Entity_Id) return Boolean is
F : Entity_Id;
Ok : Boolean := False;
@@ -778,6 +860,8 @@ package body Sem_Ch13 is
return Ok;
end Has_Good_Profile;
+ -- Start of processing for Output attribute definition
+
begin
FOnly := True;
@@ -786,7 +870,7 @@ package body Sem_Ch13 is
return;
else
- Pnam := TSS (Base_Type (U_Ent), Name_uOutput);
+ Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Output);
if Present (Pnam)
and then
@@ -824,7 +908,7 @@ package body Sem_Ch13 is
if Present (Subp) then
Set_Entity (Expr, Subp);
Set_Etype (Expr, Etype (Subp));
- New_Stream_Procedure (N, U_Ent, Subp, Name_uOutput);
+ New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Output);
else
Error_Msg_N ("incorrect expression for output attribute", Expr);
return;
@@ -845,6 +929,10 @@ package body Sem_Ch13 is
-- Return true if the entity is a procedure with an appropriate
-- profile for the Read attribute.
+ ----------------------
+ -- Has_Good_Profile --
+ ----------------------
+
function Has_Good_Profile (Subp : Entity_Id) return Boolean is
F : Entity_Id;
Ok : Boolean := False;
@@ -881,7 +969,7 @@ package body Sem_Ch13 is
return;
else
- Pnam := TSS (Base_Type (U_Ent), Name_uRead);
+ Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Read);
if Present (Pnam)
and then Base_Type (Etype (Next_Formal (First_Formal (Pnam))))
@@ -918,7 +1006,7 @@ package body Sem_Ch13 is
if Present (Subp) then
Set_Entity (Expr, Subp);
Set_Etype (Expr, Etype (Subp));
- New_Stream_Procedure (N, U_Ent, Subp, Name_uRead, True);
+ New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Read, True);
else
Error_Msg_N ("incorrect expression for read attribute", Expr);
return;
@@ -955,7 +1043,6 @@ package body Sem_Ch13 is
("size cannot be given for unconstrained array", Nam);
elsif Size /= No_Uint then
-
if Is_Type (U_Ent) then
Etyp := U_Ent;
else
@@ -1008,6 +1095,20 @@ package body Sem_Ch13 is
-- For objects, set Esize only
else
+ if Is_Elementary_Type (Etyp) then
+ if Size /= System_Storage_Unit
+ and then
+ Size /= System_Storage_Unit * 2
+ and then
+ Size /= System_Storage_Unit * 4
+ and then
+ Size /= System_Storage_Unit * 8
+ then
+ Error_Msg_N
+ ("size for primitive object must be power of 2", N);
+ end if;
+ end if;
+
Set_Esize (U_Ent, Size);
end if;
@@ -1032,7 +1133,8 @@ package body Sem_Ch13 is
return;
elsif not Is_Static_Expression (Expr) then
- Error_Msg_N ("small requires static expression", Expr);
+ Flag_Non_Static_Expr
+ ("small requires static expression!", Expr);
return;
else
@@ -1077,6 +1179,14 @@ package body Sem_Ch13 is
begin
if Is_Task_Type (U_Ent) then
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("storage size clause for task is an " &
+ "obsolescent feature ('R'M 'J.9)?", N);
+ Error_Msg_N
+ ("|use Storage_Size pragma instead?", N);
+ end if;
+
FOnly := True;
end if;
@@ -1319,7 +1429,7 @@ package body Sem_Ch13 is
return;
end if;
- Pnam := TSS (Base_Type (U_Ent), Name_uWrite);
+ Pnam := TSS (Base_Type (U_Ent), TSS_Stream_Write);
if Present (Pnam)
and then Base_Type (Etype (Next_Formal (First_Formal (Pnam))))
@@ -1355,7 +1465,7 @@ package body Sem_Ch13 is
if Present (Subp) then
Set_Entity (Expr, Subp);
Set_Etype (Expr, Etype (Subp));
- New_Stream_Procedure (N, U_Ent, Subp, Name_uWrite);
+ New_Stream_Procedure (N, U_Ent, Subp, TSS_Stream_Write);
else
Error_Msg_N ("incorrect expression for write attribute", Expr);
return;
@@ -1469,7 +1579,6 @@ package body Sem_Ch13 is
Next (Stmt);
end loop;
end if;
-
end Analyze_Code_Statement;
-----------------------------------------------
@@ -1513,22 +1622,40 @@ package body Sem_Ch13 is
return;
end if;
- if Scope (Enumtype) /= Current_Scope then
+ -- Ignore rep clause on generic actual type. This will already have
+ -- been flagged on the template as an error, and this is the safest
+ -- way to ensure we don't get a junk cascaded message in the instance.
+
+ if Is_Generic_Actual_Type (Enumtype) then
+ return;
+
+ -- Type must be in current scope
+
+ elsif Scope (Enumtype) /= Current_Scope then
Error_Msg_N ("type must be declared in this scope", Ident);
return;
+ -- Type must be a first subtype
+
elsif not Is_First_Subtype (Enumtype) then
Error_Msg_N ("cannot give enumeration rep clause for subtype", N);
return;
+ -- Ignore duplicate rep clause
+
elsif Has_Enumeration_Rep_Clause (Enumtype) then
Error_Msg_N ("duplicate enumeration rep clause ignored", N);
return;
+ -- Don't allow rep clause if root type is standard [wide_]character
+
elsif Root_Type (Enumtype) = Standard_Character
or else Root_Type (Enumtype) = Standard_Wide_Character
then
Error_Msg_N ("enumeration rep clause not allowed for this type", N);
+ return;
+
+ -- All tests passed, so set rep clause in place
else
Set_Has_Enumeration_Rep_Clause (Enumtype);
@@ -1607,8 +1734,8 @@ package body Sem_Ch13 is
elsif Etype (Choice) = Base_Type (Enumtype) then
if not Is_Static_Expression (Choice) then
- Error_Msg_N
- ("non-static expression used for choice", Choice);
+ Flag_Non_Static_Expr
+ ("non-static expression used for choice!", Choice);
Err := True;
else
@@ -1724,7 +1851,6 @@ package body Sem_Ch13 is
if Rep_Item_Too_Late (Enumtype, N) then
null;
end if;
-
end Analyze_Enumeration_Representation_Clause;
----------------------------
@@ -1809,21 +1935,30 @@ package body Sem_Ch13 is
Loc : constant Source_Ptr := Sloc (N);
M : constant Node_Id := Mod_Clause (N);
P : constant List_Id := Pragmas_Before (M);
- Mod_Val : Uint;
AtM_Nod : Node_Id;
+ Mod_Val : Uint;
+ pragma Warnings (Off, Mod_Val);
+
begin
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("mod clause is an obsolescent feature ('R'M 'J.8)?", N);
+ Error_Msg_N
+ ("|use alignment attribute definition clause instead?", N);
+ end if;
+
if Present (P) then
Analyze_List (P);
end if;
- -- In Tree_Output mode, expansion is disabled, but we must
+ -- In ASIS_Mode mode, expansion is disabled, but we must
-- convert the Mod clause into an alignment clause anyway, so
-- that the back-end can compute and back-annotate properly the
-- size and alignment of types that may include this record.
if Operating_Mode = Check_Semantics
- and then Tree_Output
+ and then ASIS_Mode
then
AtM_Nod :=
Make_Attribute_Definition_Clause (Loc,
@@ -2018,7 +2153,7 @@ package body Sem_Ch13 is
CC, Rectype);
end if;
- -- Test for large object that is not on a byte
+ -- Test for large object that is not on a storage unit
-- boundary, defined as a large packed array not
-- represented by a modular type, or an object for
-- which a size of greater than 64 bits is specified.
@@ -2027,11 +2162,17 @@ package body Sem_Ch13 is
if (Is_Packed_Array_Type (Etype (Comp))
and then Is_Array_Type
(Packed_Array_Type (Etype (Comp))))
- or else Esize (Etype (Comp)) > 64
+ or else Esize (Etype (Comp)) > Max_Unaligned_Field
then
- Error_Msg_N
- ("large component must be on byte boundary",
- First_Bit (CC));
+ if SSU = 8 then
+ Error_Msg_N
+ ("large component must be on byte boundary",
+ First_Bit (CC));
+ else
+ Error_Msg_N
+ ("large component must be on word boundary",
+ First_Bit (CC));
+ end if;
end if;
end if;
@@ -2326,7 +2467,6 @@ package body Sem_Ch13 is
Set_RM_Size (Rectype, Hbit + 1);
end if;
-
end Analyze_Record_Representation_Clause;
-----------------------------
@@ -2474,6 +2614,34 @@ package body Sem_Ch13 is
return;
when N_Identifier | N_Expanded_Name =>
+
+ -- We need to look at the original node if it is different
+ -- from the node, since we may have rewritten things and
+ -- substituted an identifier representing the rewrite.
+
+ if Original_Node (Nod) /= Nod then
+ Check_Expr_Constants (Original_Node (Nod));
+
+ -- If the node is an object declaration without initial
+ -- value, some code has been expanded, and the expression
+ -- is not constant, even if the constituents might be
+ -- acceptable, as in A'Address + offset.
+
+ if Ekind (Entity (Nod)) = E_Variable
+ and then Nkind (Declaration_Node (Entity (Nod)))
+ = N_Object_Declaration
+ and then
+ No (Expression (Declaration_Node (Entity (Nod))))
+ then
+ Error_Msg_NE
+ ("invalid address clause for initialized object &!",
+ Nod, U_Ent);
+ end if;
+ return;
+ end if;
+
+ -- Otherwise look at the identifier and see if it is OK.
+
declare
Ent : constant Entity_Id := Entity (Nod);
Loc_Ent : constant Source_Ptr := Sloc (Ent);
@@ -2525,10 +2693,17 @@ package body Sem_Ch13 is
Error_Msg_NE
("invalid address clause for initialized object &!",
Nod, U_Ent);
- Error_Msg_Name_1 := Chars (Ent);
- Error_Msg_N
- ("\reference to variable% not allowed ('R'M 13.1(22))!",
- Nod);
+
+ if Comes_From_Source (Ent) then
+ Error_Msg_Name_1 := Chars (Ent);
+ Error_Msg_N
+ ("\reference to variable% not allowed"
+ & " ('R'M 13.1(22))!", Nod);
+ else
+ Error_Msg_N
+ ("non-static expression not allowed"
+ & " ('R'M 13.1(22))!", Nod);
+ end if;
end if;
end;
@@ -2558,13 +2733,13 @@ package body Sem_Ch13 is
when N_Attribute_Reference =>
- if (Attribute_Name (Nod) = Name_Address
- or else
- Attribute_Name (Nod) = Name_Access
+ if Attribute_Name (Nod) = Name_Address
+ or else
+ Attribute_Name (Nod) = Name_Access
or else
- Attribute_Name (Nod) = Name_Unchecked_Access
+ Attribute_Name (Nod) = Name_Unchecked_Access
or else
- Attribute_Name (Nod) = Name_Unrestricted_Access)
+ Attribute_Name (Nod) = Name_Unrestricted_Access
then
Check_At_Constant_Address (Prefix (Nod));
@@ -2795,6 +2970,19 @@ package body Sem_Ch13 is
end if;
end Is_Operational_Item;
+ --------------------------------------
+ -- Mark_Aliased_Address_As_Volatile --
+ --------------------------------------
+
+ procedure Mark_Aliased_Address_As_Volatile (N : Node_Id) is
+ Ent : constant Entity_Id := Address_Aliased_Entity (N);
+
+ begin
+ if Present (Ent) then
+ Set_Treat_As_Volatile (Ent);
+ end if;
+ end Mark_Aliased_Address_As_Volatile;
+
------------------
-- Minimum_Size --
------------------
@@ -3002,9 +3190,10 @@ package body Sem_Ch13 is
(N : Node_Id;
Ent : Entity_Id;
Subp : Entity_Id;
- Nam : Name_Id)
+ Nam : TSS_Name_Type)
is
Loc : constant Source_Ptr := Sloc (N);
+ Sname : constant Name_Id := Make_TSS_Name (Base_Type (Ent), Nam);
Subp_Id : Entity_Id;
Subp_Decl : Node_Id;
F : Entity_Id;
@@ -3020,7 +3209,7 @@ package body Sem_Ch13 is
function Build_Spec return Node_Id is
begin
- Subp_Id := Make_Defining_Identifier (Loc, Nam);
+ Subp_Id := Make_Defining_Identifier (Loc, Sname);
return
Make_Function_Specification (Loc,
@@ -3064,7 +3253,6 @@ package body Sem_Ch13 is
Insert_Action (N, Subp_Decl);
Copy_TSS (Subp_Id, Base_Type (Ent));
end if;
-
end New_Stream_Function;
--------------------------
@@ -3075,10 +3263,11 @@ package body Sem_Ch13 is
(N : Node_Id;
Ent : Entity_Id;
Subp : Entity_Id;
- Nam : Name_Id;
+ Nam : TSS_Name_Type;
Out_P : Boolean := False)
is
Loc : constant Source_Ptr := Sloc (N);
+ Sname : constant Name_Id := Make_TSS_Name (Base_Type (Ent), Nam);
Subp_Id : Entity_Id;
Subp_Decl : Node_Id;
F : Entity_Id;
@@ -3088,9 +3277,13 @@ package body Sem_Ch13 is
-- Used for declaration and renaming declaration, so that this is
-- treated as a renaming_as_body.
+ ----------------
+ -- Build_Spec --
+ ----------------
+
function Build_Spec return Node_Id is
begin
- Subp_Id := Make_Defining_Identifier (Loc, Nam);
+ Subp_Id := Make_Defining_Identifier (Loc, Sname);
return
Make_Procedure_Specification (Loc,
@@ -3114,7 +3307,7 @@ package body Sem_Ch13 is
New_Reference_To (Etyp, Loc))));
end Build_Spec;
- -- Start of processing for New_Stream_Function
+ -- Start of processing for New_Stream_Procedure
begin
F := First_Formal (Subp);
@@ -3138,7 +3331,6 @@ package body Sem_Ch13 is
Insert_Action (N, Subp_Decl);
Copy_TSS (Subp_Id, Base_Type (Ent));
end if;
-
end New_Stream_Procedure;
---------------------
@@ -3403,7 +3595,15 @@ package body Sem_Ch13 is
CD1 := First_Discriminant (T1);
CD2 := First_Discriminant (T2);
- while Present (CD1) loop
+ -- The number of discriminants may be different if the
+ -- derived type has fewer (constrained by values). The
+ -- invisible discriminants retain the representation of
+ -- the original, so the discrepancy does not per se
+ -- indicate a different representation.
+
+ while Present (CD1)
+ and then Present (CD2)
+ loop
if not Same_Rep then
return False;
else
@@ -3431,7 +3631,7 @@ package body Sem_Ch13 is
-- For enumeration types, we must check each literal to see if the
-- representation is the same. Note that we do not permit enumeration
- -- representation clauses for Character and Wide_Character, so these
+ -- reprsentation clauses for Character and Wide_Character, so these
-- cases were already dealt with.
elsif Is_Enumeration_Type (T1) then
@@ -3461,7 +3661,6 @@ package body Sem_Ch13 is
else
return True;
end if;
-
end Same_Representation;
--------------------
@@ -3523,7 +3722,6 @@ package body Sem_Ch13 is
else
Init_Esize (T, Sz);
end if;
-
end Set_Enum_Esize;
-----------------------------------
@@ -3584,12 +3782,27 @@ package body Sem_Ch13 is
-- Make entry in unchecked conversion table for later processing
-- by Validate_Unchecked_Conversions, which will check sizes and
-- alignments (using values set by the back-end where possible).
+ -- This is only done if the appropriate warning is active
- Unchecked_Conversions.Append
- (New_Val => UC_Entry'
- (Enode => N,
- Source => Source,
- Target => Target));
+ if Warn_On_Unchecked_Conversion then
+ Unchecked_Conversions.Append
+ (New_Val => UC_Entry'
+ (Enode => N,
+ Source => Source,
+ Target => Target));
+
+ -- If both sizes are known statically now, then back end annotation
+ -- is not required to do a proper check but if either size is not
+ -- known statically, then we need the annotation.
+
+ if Known_Static_RM_Size (Source)
+ and then Known_Static_RM_Size (Target)
+ then
+ null;
+ else
+ Back_Annotate_Rep_Info := True;
+ end if;
+ end if;
-- Generate N_Validate_Unchecked_Conversion node for back end if
-- the back end needs to perform special validation checks. At the
@@ -3636,7 +3849,6 @@ package body Sem_Ch13 is
Target_Siz := RM_Size (Target);
if Source_Siz /= Target_Siz then
- Warn_On_Instance := True;
Error_Msg_N
("types for unchecked conversion have different sizes?",
Enode);
@@ -3659,7 +3871,7 @@ package body Sem_Ch13 is
("\^ high order bits of source will be ignored?",
Enode);
- elsif Is_Modular_Integer_Type (Source) then
+ elsif Is_Unsigned_Type (Source) then
Error_Msg_N
("\source will be extended with ^ high order " &
"zero bits?", Enode);
@@ -3697,8 +3909,6 @@ package body Sem_Ch13 is
Enode);
end if;
end if;
-
- Warn_On_Instance := False;
end if;
end if;
@@ -3728,7 +3938,6 @@ package body Sem_Ch13 is
if Source_Align < Target_Align
and then not Is_Tagged_Type (D_Source)
then
- Warn_On_Instance := True;
Error_Msg_Uint_1 := Target_Align;
Error_Msg_Uint_2 := Source_Align;
Error_Msg_Node_2 := D_Source;
@@ -3741,8 +3950,6 @@ package body Sem_Ch13 is
("\resulting access value may have invalid " &
"alignment?", Enode);
end if;
-
- Warn_On_Instance := False;
end if;
end;
end if;
@@ -3752,114 +3959,4 @@ package body Sem_Ch13 is
end loop;
end Validate_Unchecked_Conversions;
- ------------------
- -- Warn_Overlay --
- ------------------
-
- procedure Warn_Overlay
- (Expr : Node_Id;
- Typ : Entity_Id;
- Nam : Node_Id)
- is
- Old : Entity_Id := Empty;
- Decl : Node_Id;
-
- begin
- if not Address_Clause_Overlay_Warnings then
- return;
- end if;
-
- if Present (Expr)
- and then (Has_Non_Null_Base_Init_Proc (Typ)
- or else Is_Access_Type (Typ))
- and then not Is_Imported (Entity (Nam))
- then
- if Nkind (Expr) = N_Attribute_Reference
- and then Is_Entity_Name (Prefix (Expr))
- then
- Old := Entity (Prefix (Expr));
-
- elsif Is_Entity_Name (Expr)
- and then Ekind (Entity (Expr)) = E_Constant
- then
- Decl := Declaration_Node (Entity (Expr));
-
- if Nkind (Decl) = N_Object_Declaration
- and then Present (Expression (Decl))
- and then Nkind (Expression (Decl)) = N_Attribute_Reference
- and then Is_Entity_Name (Prefix (Expression (Decl)))
- then
- Old := Entity (Prefix (Expression (Decl)));
-
- elsif Nkind (Expr) = N_Function_Call then
- return;
- end if;
-
- -- A function call (most likely to To_Address) is probably not
- -- an overlay, so skip warning. Ditto if the function call was
- -- inlined and transformed into an entity.
-
- elsif Nkind (Original_Node (Expr)) = N_Function_Call then
- return;
- end if;
-
- Decl := Next (Parent (Expr));
-
- -- If a pragma Import follows, we assume that it is for the current
- -- target of the address clause, and skip the warning.
-
- if Present (Decl)
- and then Nkind (Decl) = N_Pragma
- and then Chars (Decl) = Name_Import
- then
- return;
- end if;
-
- if Present (Old) then
- Error_Msg_Node_2 := Old;
- Error_Msg_N
- ("default initialization of & may modify &?",
- Nam);
- else
- Error_Msg_N
- ("default initialization of & may modify overlaid storage?",
- Nam);
- end if;
-
- -- Add friendly warning if initialization comes from a packed array
- -- component.
-
- if Is_Record_Type (Typ) then
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Component (Typ);
-
- while Present (Comp) loop
- if Nkind (Parent (Comp)) = N_Component_Declaration
- and then Present (Expression (Parent (Comp)))
- then
- exit;
- elsif Is_Array_Type (Etype (Comp))
- and then Present (Packed_Array_Type (Etype (Comp)))
- then
- Error_Msg_NE
- ("packed array component& will be initialized to zero?",
- Nam, Comp);
- exit;
- else
- Next_Component (Comp);
- end if;
- end loop;
- end;
- end if;
-
- Error_Msg_N
- ("use pragma Import for & to " &
- "suppress initialization ('R'M B.1(24))?",
- Nam);
- end if;
- end Warn_Overlay;
-
end Sem_Ch13;
diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads
index 3eab365915c..2f520cd5e3a 100644
--- a/gcc/ada/sem_ch13.ads
+++ b/gcc/ada/sem_ch13.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -61,6 +61,17 @@ package Sem_Ch13 is
-- regardless of the setting of Biased. Also, fixed-point types are never
-- biased in the current implementation.
+ procedure Check_Constant_Address_Clause (Expr : Node_Id; U_Ent : Entity_Id);
+ -- Expr is an expression for an address clause. This procedure checks
+ -- that the expression is constant, in the limited sense that it is safe
+ -- to evaluate it at the point the object U_Ent is declared, rather than
+ -- at the point of the address clause. The condition for this to be true
+ -- is that the expression has no variables, no constants declared after
+ -- U_Ent, and no calls to non-pure functions. If this condition is not
+ -- met, then an appropriate error message is posted. This check is applied
+ -- at the point an object with an address clause is frozen, as well as for
+ -- address clauses for tasks and entries.
+
procedure Check_Size
(N : Node_Id;
T : Entity_Id;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index e57ddc7e780..f66e28e1655 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,6 +32,7 @@ with Errout; use Errout;
with Eval_Fat; use Eval_Fat;
with Exp_Ch3; use Exp_Ch3;
with Exp_Dist; use Exp_Dist;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Itypes; use Itypes;
@@ -59,6 +60,7 @@ with Sem_Res; use Sem_Res;
with Sem_Smem; use Sem_Smem;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Snames; use Snames;
@@ -142,7 +144,7 @@ package body Sem_Ch3 is
Derived_Type : Entity_Id;
Is_Completion : Boolean;
Derive_Subps : Boolean := True);
- -- Substidiary procedure to Build_Derived_Type. This procedure is complex
+ -- Subsidiary procedure to Build_Derived_Type. This procedure is complex
-- because the parent may or may not have a completion, and the derivation
-- may itself be a completion.
@@ -174,27 +176,35 @@ package body Sem_Ch3 is
-- For more information on derived types and component inheritance please
-- consult the comment above the body of Build_Derived_Record_Type.
--
- -- N is the original derived type declaration.
- -- Is_Tagged is set if we are dealing with tagged types.
- -- If Inherit_Discr is set, Derived_Base inherits its discriminants from
- -- Parent_Base, otherwise no discriminants are inherited.
- -- Discs gives the list of constraints that apply to Parent_Base in the
- -- derived type declaration. If Discs is set to No_Elist, then we have the
- -- following situation:
+ -- N is the original derived type declaration.
--
- -- type Parent (D1..Dn : ..) is [tagged] record ...;
- -- type Derived is new Parent [with ...];
+ -- Is_Tagged is set if we are dealing with tagged types.
--
- -- which gets treated as
+ -- If Inherit_Discr is set, Derived_Base inherits its discriminants
+ -- from Parent_Base, otherwise no discriminants are inherited.
--
- -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
+ -- Discs gives the list of constraints that apply to Parent_Base in the
+ -- derived type declaration. If Discs is set to No_Elist, then we have
+ -- the following situation:
--
- -- For untagged types the returned value is an association list:
- -- (Old_Component => New_Component), where Old_Component is the Entity_Id
- -- of a component in Parent_Base and New_Component is the Entity_Id of the
- -- corresponding component in Derived_Base. For untagged records, this
- -- association list is needed when copying the record declaration for the
- -- derived base. In the tagged case the value returned is irrelevant.
+ -- type Parent (D1..Dn : ..) is [tagged] record ...;
+ -- type Derived is new Parent [with ...];
+ --
+ -- which gets treated as
+ --
+ -- type Derived (D1..Dn : ..) is new Parent (D1,..,Dn) [with ...];
+ --
+ -- For untagged types the returned value is an association list. The list
+ -- starts from the association (Parent_Base => Derived_Base), and then it
+ -- contains a sequence of the associations of the form
+ --
+ -- (Old_Component => New_Component),
+ --
+ -- where Old_Component is the Entity_Id of a component in Parent_Base
+ -- and New_Component is the Entity_Id of the corresponding component
+ -- in Derived_Base. For untagged records, this association list is
+ -- needed when copying the record declaration for the derived base.
+ -- In the tagged case the value returned is irrelevant.
procedure Build_Discriminal (Discrim : Entity_Id);
-- Create the discriminal corresponding to discriminant Discrim, that is
@@ -273,23 +283,24 @@ package body Sem_Ch3 is
-- the reserved word 'limited' in its declaration.
procedure Check_Delta_Expression (E : Node_Id);
- -- Check that the expression represented by E is suitable for use as
- -- a delta expression, i.e. it is of real type and is static.
+ -- Check that the expression represented by E is suitable for use
+ -- as a delta expression, i.e. it is of real type and is static.
procedure Check_Digits_Expression (E : Node_Id);
-- Check that the expression represented by E is suitable for use as
-- a digits expression, i.e. it is of integer type, positive and static.
- procedure Check_Incomplete (T : Entity_Id);
- -- Called to verify that an incomplete type is not used prematurely
-
procedure Check_Initialization (T : Entity_Id; Exp : Node_Id);
-- Validate the initialization of an object declaration. T is the
-- required type, and Exp is the initialization expression.
- procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id);
+ procedure Check_Or_Process_Discriminants
+ (N : Node_Id;
+ T : Entity_Id;
+ Prev : Entity_Id := Empty);
-- If T is the full declaration of an incomplete or private type, check
- -- the conformance of the discriminants, otherwise process them.
+ -- the conformance of the discriminants, otherwise process them. Prev
+ -- is the entity of the partial declaration, if any.
procedure Check_Real_Bound (Bound : Node_Id);
-- Check given bound for being of real type and static. If not, post an
@@ -309,7 +320,14 @@ package body Sem_Ch3 is
Derived_Type : Entity_Id;
Loc : Source_Ptr);
-- For derived scalar types, convert the bounds in the type definition
- -- to the derived type, and complete their analysis.
+ -- to the derived type, and complete their analysis. Given a constraint
+ -- of the form:
+ -- .. new T range Lo .. Hi;
+ -- Lo and Hi are analyzed and resolved with T'Base, the parent_type.
+ -- The bounds of the derived type (the anonymous base) are copies of
+ -- Lo and Hi. Finally, the bounds of the derived subtype are conversions
+ -- of those bounds to the derived_type, so that their typing is
+ -- consistent.
procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id);
-- Copies attributes from array base type T2 to array base type T1.
@@ -344,7 +362,7 @@ package body Sem_Ch3 is
-- Constraints for Typ and the type of a component of Typ, Compon_Type,
-- create and return the type corresponding to Compon_type where all
-- discriminant references are replaced with the corresponding
- -- constraint. If no discriminant references occurr in Compon_Typ then
+ -- constraint. If no discriminant references occur in Compon_Typ then
-- return it as is. Constrained_Typ is the final constrained subtype to
-- which the constrained Compon_Type belongs. Related_Node is the node
-- where we will attach all the itypes created.
@@ -419,7 +437,7 @@ package body Sem_Ch3 is
-- have been provided for all discriminants, that the original type is
-- unconstrained, and that the types of the supplied expressions match
-- the discriminant types. The first three parameters are like in routine
- -- Constrain_Concurrent. See Build_Discrimated_Subtype for an explanation
+ -- Constrain_Concurrent. See Build_Discriminated_Subtype for an explanation
-- of For_Access.
procedure Constrain_Enumeration (Def_Id : Node_Id; S : Node_Id);
@@ -451,15 +469,11 @@ package body Sem_Ch3 is
-- Constrain an ordinary fixed point type with a range constraint, and
-- build an E_Ordinary_Fixed_Point_Subtype entity.
- procedure Copy_And_Swap (Privat, Full : Entity_Id);
- -- Copy the Privat entity into the entity of its full declaration
+ procedure Copy_And_Swap (Priv, Full : Entity_Id);
+ -- Copy the Priv entity into the entity of its full declaration
-- then swap the two entities in such a manner that the former private
-- type is now seen as a full type.
- procedure Copy_Private_To_Full (Priv, Full : Entity_Id);
- -- Initialize the full view declaration with the relevant fields
- -- from the private view.
-
procedure Decimal_Fixed_Point_Type_Declaration
(T : Entity_Id;
Def : Node_Id);
@@ -505,15 +519,14 @@ package body Sem_Ch3 is
-- type, which means that strings are legal aggregates for arrays of
-- components of the type.
- procedure Expand_Others_Choice
- (Case_Table : Choice_Table_Type;
- Others_Choice : Node_Id;
- Choice_Type : Entity_Id);
- -- In the case of a variant part of a record type that has an OTHERS
- -- choice, this procedure expands the OTHERS into the actual choices
- -- that it represents. This new list of choice nodes is attached to
- -- the OTHERS node via the Others_Discrete_Choices field. The Case_Table
- -- contains all choices that have been given explicitly in the variant.
+ function Expand_To_Stored_Constraint
+ (Typ : Entity_Id;
+ Constraint : Elist_Id)
+ return Elist_Id;
+ -- Given a Constraint (ie a list of expressions) on the discriminants of
+ -- Typ, expand it into a constraint on the stored discriminants and
+ -- return the new list of expressions constraining the stored
+ -- discriminants.
function Find_Type_Of_Object
(Obj_Def : Node_Id;
@@ -594,19 +607,26 @@ package body Sem_Ch3 is
-- one is present. If errors are found, error messages are posted, and
-- the Real_Range_Specification of Def is reset to Empty.
- procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id);
+ procedure Record_Type_Declaration
+ (T : Entity_Id;
+ N : Node_Id;
+ Prev : Entity_Id);
-- Process a record type declaration (for both untagged and tagged
-- records). Parameters T and N are exactly like in procedure
-- Derived_Type_Declaration, except that no flag Is_Completion is
- -- needed for this routine.
+ -- needed for this routine. If this is the completion of an incomplete
+ -- type declaration, Prev is the entity of the incomplete declaration,
+ -- used for cross-referencing. Otherwise Prev = T.
- procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id);
+ procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id);
-- This routine is used to process the actual record type definition
-- (both for untagged and tagged records). Def is a record type
-- definition node. This procedure analyzes the components in this
- -- record type definition. T is the entity for the enclosing record
+ -- record type definition. Prev_T is the entity for the enclosing record
-- type. It is provided so that its Has_Task flag can be set if any of
- -- the component have Has_Task set.
+ -- the component have Has_Task set. If the declaration is the completion
+ -- of an incomplete type declaration, Prev_T is the original incomplete
+ -- type, whose full view is the record type.
procedure Replace_Components (Typ : Entity_Id; Decl : Node_Id);
-- Subsidiary to Build_Derived_Record_Type. For untagged records, we
@@ -639,6 +659,11 @@ package body Sem_Ch3 is
-- Create a new signed integer entity, and apply the constraint to obtain
-- the required first named subtype of this type.
+ procedure Set_Stored_Constraint_From_Discriminant_Constraint
+ (E : Entity_Id);
+ -- E is some record type. This routine computes E's Stored_Constraint
+ -- from its Discriminant_Constraint.
+
-----------------------
-- Access_Definition --
-----------------------
@@ -783,6 +808,12 @@ package body Sem_Ch3 is
S : constant Node_Id := Subtype_Indication (Def);
P : constant Node_Id := Parent (Def);
+ Desig : Entity_Id;
+ -- Designated type
+
+ N_Desig : Entity_Id;
+ -- Non-limited view, when needed
+
begin
-- Check for permissible use of incomplete type
@@ -811,7 +842,7 @@ package body Sem_Ch3 is
Error_Msg_N ("access type cannot designate itself", S);
end if;
- Set_Etype (T, T);
+ Set_Etype (T, T);
-- If the type has appeared already in a with_type clause, it is
-- frozen and the pointer size is already set. Else, initialize.
@@ -822,12 +853,35 @@ package body Sem_Ch3 is
Set_Is_Access_Constant (T, Constant_Present (Def));
+ Desig := Designated_Type (T);
+
-- If designated type is an imported tagged type, indicate that the
-- access type is also imported, and therefore restricted in its use.
-- The access type may already be imported, so keep setting otherwise.
- if From_With_Type (Designated_Type (T)) then
+ -- If the non-limited view of the designated type is available, use
+ -- it as the designated type of the access type, so that the back-end
+ -- gets a usable entity.
+
+ if From_With_Type (Desig) then
Set_From_With_Type (T);
+
+ if Ekind (Desig) = E_Incomplete_Type then
+ N_Desig := Non_Limited_View (Desig);
+
+ elsif Ekind (Desig) = E_Class_Wide_Type then
+ if From_With_Type (Etype (Desig)) then
+ N_Desig := Non_Limited_View (Etype (Desig));
+ else
+ N_Desig := Etype (Desig);
+ end if;
+ else
+ null;
+ pragma Assert (False);
+ end if;
+
+ pragma Assert (Present (N_Desig));
+ Set_Directly_Designated_Type (T, N_Desig);
end if;
-- Note that Has_Task is always false, since the access type itself
@@ -852,13 +906,33 @@ package body Sem_Ch3 is
Enter_Name (Id);
T := Find_Type_Of_Object (Subtype_Indication (N), N);
+ -- If the subtype is a constrained subtype of the enclosing record,
+ -- (which must have a partial view) the back-end does not handle
+ -- properly the recursion. Rewrite the component declaration with
+ -- an explicit subtype indication, which is acceptable to Gigi. We
+ -- can copy the tree directly because side effects have already been
+ -- removed from discriminant constraints.
+
+ if Ekind (T) = E_Access_Subtype
+ and then Is_Entity_Name (Subtype_Indication (N))
+ and then Comes_From_Source (T)
+ and then Nkind (Parent (T)) = N_Subtype_Declaration
+ and then Etype (Directly_Designated_Type (T)) = Current_Scope
+ then
+ Rewrite
+ (Subtype_Indication (N),
+ New_Copy_Tree (Subtype_Indication (Parent (T))));
+ T := Find_Type_Of_Object (Subtype_Indication (N), N);
+ end if;
+
-- If the component declaration includes a default expression, then we
-- check that the component is not of a limited type (RM 3.7(5)),
-- and do the special preanalysis of the expression (see section on
- -- "Handling of Default Expressions" in the spec of package Sem).
+ -- "Handling of Default and Per-Object Expressions" in the spec of
+ -- package Sem).
if Present (Expression (N)) then
- Analyze_Default_Expression (Expression (N), T);
+ Analyze_Per_Use_Expression (Expression (N), T);
Check_Initialization (T, Expression (N));
end if;
@@ -917,13 +991,16 @@ package body Sem_Ch3 is
Error_Msg_N
("extension of nonlimited type cannot have limited components",
N);
+ Explain_Limited_Type (T, N);
Set_Etype (Id, Any_Type);
Set_Is_Limited_Composite (Current_Scope, False);
elsif not Is_Derived_Type (Current_Scope)
and then not Is_Limited_Record (Current_Scope)
then
- Error_Msg_N ("nonlimited type cannot have limited components", N);
+ Error_Msg_N
+ ("nonlimited tagged type cannot have limited components", N);
+ Explain_Limited_Type (T, N);
Set_Etype (Id, Any_Type);
Set_Is_Limited_Composite (Current_Scope, False);
end if;
@@ -944,6 +1021,12 @@ package body Sem_Ch3 is
procedure Adjust_D;
-- Adjust D not to include implicit label declarations, since these
-- have strange Sloc values that result in elaboration check problems.
+ -- (They have the sloc of the label as found in the source, and that
+ -- is ahead of the current declarative part).
+
+ --------------
+ -- Adjust_D --
+ --------------
procedure Adjust_D is
begin
@@ -993,7 +1076,6 @@ package body Sem_Ch3 is
null;
elsif Nkind (Parent (L)) /= N_Package_Specification then
-
if Nkind (Parent (L)) = N_Package_Body then
Freeze_From := First_Entity (Current_Scope);
end if;
@@ -1039,22 +1121,8 @@ package body Sem_Ch3 is
D := Next_Node;
end loop;
-
end Analyze_Declarations;
- --------------------------------
- -- Analyze_Default_Expression --
- --------------------------------
-
- procedure Analyze_Default_Expression (N : Node_Id; T : Entity_Id) is
- Save_In_Default_Expression : constant Boolean := In_Default_Expression;
-
- begin
- In_Default_Expression := True;
- Pre_Analyze_And_Resolve (N, T);
- In_Default_Expression := Save_In_Default_Expression;
- end Analyze_Default_Expression;
-
----------------------------------
-- Analyze_Incomplete_Type_Decl --
----------------------------------
@@ -1081,7 +1149,7 @@ package body Sem_Ch3 is
Set_Etype (T, T);
New_Scope (T);
- Set_Girder_Constraint (T, No_Elist);
+ Set_Stored_Constraint (T, No_Elist);
if Present (Discriminant_Specifications (N)) then
Process_Discriminants (N);
@@ -1225,9 +1293,10 @@ package body Sem_Ch3 is
else
Wrong_Type (E, Any_Numeric);
Resolve (E, T);
+
Set_Etype (Id, T);
Set_Ekind (Id, E_Constant);
- Set_Not_Source_Assigned (Id, True);
+ Set_Never_Set_In_Source (Id, True);
Set_Is_True_Constant (Id, True);
return;
end if;
@@ -1239,11 +1308,11 @@ package body Sem_Ch3 is
end if;
if not Is_OK_Static_Expression (E) then
- Error_Msg_N ("non-static expression used in number declaration", E);
+ Flag_Non_Static_Expr
+ ("non-static expression used in number declaration!", E);
Rewrite (E, Make_Integer_Literal (Sloc (N), 1));
Set_Etype (E, Any_Type);
end if;
-
end Analyze_Number_Declaration;
--------------------------------
@@ -1273,8 +1342,8 @@ package body Sem_Ch3 is
---------------------------
function Build_Default_Subtype return Entity_Id is
+ Constraints : constant List_Id := New_List;
Act : Entity_Id;
- Constraints : List_Id := New_List;
Decl : Node_Id;
Disc : Entity_Id;
@@ -1383,7 +1452,11 @@ package body Sem_Ch3 is
then
if not Is_Package (Current_Scope) then
Error_Msg_N
- ("invalid context for deferred constant declaration", N);
+ ("invalid context for deferred constant declaration ('R'M 7.4)",
+ N);
+ Error_Msg_N
+ ("\declaration requires an initialization expression",
+ N);
Set_Constant_Present (N, False);
-- In Ada 83, deferred constant must be of private type
@@ -1438,33 +1511,22 @@ package body Sem_Ch3 is
if Present (E) and then E /= Error then
Analyze (E);
+ -- If an initialization expression is present, then we set the
+ -- Is_True_Constant flag. It will be reset if this is a variable
+ -- and it is indeed modified.
+
+ Set_Is_True_Constant (Id, True);
+
if not Assignment_OK (N) then
Check_Initialization (T, E);
end if;
+ Set_Etype (Id, T); -- may be overridden later on.
Resolve (E, T);
+ Check_Unset_Reference (E);
- -- Check for library level object that will require implicit
- -- heap allocation.
-
- if Is_Array_Type (T)
- and then not Size_Known_At_Compile_Time (T)
- and then Is_Library_Level_Entity (Id)
- then
- -- String literals are always allowed
-
- if T = Standard_String
- and then Nkind (E) = N_String_Literal
- then
- null;
-
- -- Otherwise we do not allow this since it may cause an
- -- implicit heap allocation.
-
- else
- Check_Restriction
- (No_Implicit_Heap_Allocations, Object_Definition (N));
- end if;
+ if Compile_Time_Known_Value (E) then
+ Set_Current_Value (Id, E);
end if;
-- Check incorrect use of dynamically tagged expressions. Note
@@ -1577,6 +1639,7 @@ package body Sem_Ch3 is
then
if not Is_Entity_Name (Object_Definition (N)) then
Act_T := Etype (E);
+ Check_Compile_Time_Size (Act_T);
if Aliased_Present (N) then
Set_Is_Constr_Subt_For_UN_Aliased (Act_T);
@@ -1643,7 +1706,7 @@ package body Sem_Ch3 is
if Constant_Present (N) then
Set_Ekind (Id, E_Constant);
- Set_Not_Source_Assigned (Id, True);
+ Set_Never_Set_In_Source (Id, True);
Set_Is_True_Constant (Id, True);
else
@@ -1662,37 +1725,22 @@ package body Sem_Ch3 is
Check_Shared_Var (Id, T, N);
end if;
- -- If an initializing expression is present, then the variable
- -- is potentially a true constant if no further assignments are
- -- present. The code generator can use this for optimization.
- -- The flag will be reset if there are any assignments. We only
- -- set this flag for non library level entities, since for any
- -- library level entities, assignments could exist in other units.
-
- if Present (E) then
- if not Is_Library_Level_Entity (Id) then
-
- -- For now we omit this, because it seems to cause some
- -- problems. In particular, if you uncomment this out, then
- -- test case 4427-002 will fail for unclear reasons ???
-
- if False then
- Set_Is_True_Constant (Id);
- end if;
- end if;
-
-- Case of no initializing expression present. If the type is not
- -- fully initialized, then we set Not_Source_Assigned, since this
+ -- fully initialized, then we set Never_Set_In_Source, since this
-- is a case of a potentially uninitialized object. Note that we
-- do not consider access variables to be fully initialized for
-- this purpose, since it still seems dubious if someone declares
- -- an access variable and never assigns to it.
- else
- if Is_Access_Type (T)
- or else not Is_Fully_Initialized_Type (T)
+ -- Note that we only do this for source declarations. If the object
+ -- is declared by a generated declaration, we assume that it is not
+ -- appropriate to generate warnings in that case.
+
+ if No (E) then
+ if (Is_Access_Type (T)
+ or else not Is_Fully_Initialized_Type (T))
+ and then Comes_From_Source (N)
then
- Set_Not_Source_Assigned (Id);
+ Set_Never_Set_In_Source (Id);
end if;
end if;
end if;
@@ -1736,12 +1784,19 @@ package body Sem_Ch3 is
and then Comes_From_Source (Id)
then
declare
- BT : constant Entity_Id := Base_Type (Etype (Id));
+ BT : constant Entity_Id := Base_Type (Etype (Id));
+
Implicit_Call : Entity_Id;
+ pragma Warnings (Off, Implicit_Call);
+ -- What is this about, it is never referenced ???
function Is_Aggr (N : Node_Id) return Boolean;
-- Check that N is an aggregate
+ -------------
+ -- Is_Aggr --
+ -------------
+
function Is_Aggr (N : Node_Id) return Boolean is
begin
case Nkind (Original_Node (N)) is
@@ -1792,6 +1847,8 @@ package body Sem_Ch3 is
end if;
if Has_Task (Etype (Id)) then
+ Check_Restriction (Max_Tasks, N);
+
if not Is_Library_Level_Entity (Id) then
Check_Restriction (No_Task_Hierarchy, N);
Check_Potentially_Blocking_Operation (N);
@@ -1854,8 +1911,8 @@ package body Sem_Ch3 is
end if;
-- Another optimization: if the nominal subtype is unconstrained and
- -- the expression is a function call that returns and unconstrained
- -- type, rewrite the declararation as a renaming of the result of the
+ -- the expression is a function call that returns an unconstrained
+ -- type, rewrite the declaration as a renaming of the result of the
-- call. The exceptions below are cases where the copy is expected,
-- either by the back end (Aliased case) or by the semantics, as for
-- initializing controlled types or copying tags for classwide types.
@@ -1879,6 +1936,12 @@ package body Sem_Ch3 is
Name => E));
Set_Renamed_Object (Id, E);
+
+ -- Force generation of debugging information for the constant
+ -- and for the renamed function call.
+
+ Set_Needs_Debug_Info (Id);
+ Set_Needs_Debug_Info (Entity (Prefix (E)));
end if;
if Present (Prev_Entity)
@@ -1905,13 +1968,26 @@ package body Sem_Ch3 is
null;
end Analyze_Others_Choice;
+ --------------------------------
+ -- Analyze_Per_Use_Expression --
+ --------------------------------
+
+ procedure Analyze_Per_Use_Expression (N : Node_Id; T : Entity_Id) is
+ Save_In_Default_Expression : constant Boolean := In_Default_Expression;
+
+ begin
+ In_Default_Expression := True;
+ Pre_Analyze_And_Resolve (N, T);
+ In_Default_Expression := Save_In_Default_Expression;
+ end Analyze_Per_Use_Expression;
+
-------------------------------------------
-- Analyze_Private_Extension_Declaration --
-------------------------------------------
procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
- T : Entity_Id := Defining_Identifier (N);
- Indic : constant Node_Id := Subtype_Indication (N);
+ T : constant Entity_Id := Defining_Identifier (N);
+ Indic : constant Node_Id := Subtype_Indication (N);
Parent_Type : Entity_Id;
Parent_Base : Entity_Id;
@@ -2021,9 +2097,10 @@ package body Sem_Ch3 is
-- Inherit common attributes
- Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T)));
- Set_Is_Volatile (Id, Is_Volatile (T));
- Set_Is_Atomic (Id, Is_Atomic (T));
+ Set_Is_Generic_Type (Id, Is_Generic_Type (Base_Type (T)));
+ Set_Is_Volatile (Id, Is_Volatile (T));
+ Set_Treat_As_Volatile (Id, Treat_As_Volatile (T));
+ Set_Is_Atomic (Id, Is_Atomic (T));
-- In the case where there is no constraint given in the subtype
-- indication, Process_Subtype just returns the Subtype_Mark,
@@ -2123,7 +2200,7 @@ package body Sem_Ch3 is
if Has_Discriminants (T) then
Set_Discriminant_Constraint
(Id, Discriminant_Constraint (T));
- Set_Girder_Constraint_From_Discriminant_Constraint (Id);
+ Set_Stored_Constraint_From_Discriminant_Constraint (Id);
elsif Has_Unknown_Discriminants (Id) then
Set_Discriminant_Constraint (Id, No_Elist);
@@ -2151,6 +2228,8 @@ package body Sem_Ch3 is
if Is_Tagged_Type (T) then
Set_Is_Tagged_Type (Id);
Set_Is_Abstract (Id, Is_Abstract (T));
+ Set_Primitive_Operations
+ (Id, Primitive_Operations (T));
Set_Class_Wide_Type (Id, Class_Wide_Type (T));
end if;
@@ -2163,14 +2242,14 @@ package body Sem_Ch3 is
if Has_Discriminants (T) then
Set_Discriminant_Constraint
(Id, Discriminant_Constraint (T));
- Set_Girder_Constraint_From_Discriminant_Constraint (Id);
+ Set_Stored_Constraint_From_Discriminant_Constraint (Id);
elsif Present (Full_View (T))
and then Has_Discriminants (Full_View (T))
then
Set_Discriminant_Constraint
(Id, Discriminant_Constraint (Full_View (T)));
- Set_Girder_Constraint_From_Discriminant_Constraint (Id);
+ Set_Stored_Constraint_From_Discriminant_Constraint (Id);
-- This would seem semantically correct, but apparently
-- confuses the back-end (4412-009). To be explained ???
@@ -2213,7 +2292,7 @@ package body Sem_Ch3 is
if Has_Discriminants (T) then
Set_Discriminant_Constraint (Id,
Discriminant_Constraint (T));
- Set_Girder_Constraint_From_Discriminant_Constraint (Id);
+ Set_Stored_Constraint_From_Discriminant_Constraint (Id);
end if;
-- If the subtype name denotes an incomplete type
@@ -2306,10 +2385,10 @@ package body Sem_Ch3 is
Nkind (Scalar_Range (Etype (First_Index (Id)))) = N_Range
then
declare
- Target_Typ : Entity_Id :=
- Etype
- (First_Index
- (Etype (Subtype_Mark (Subtype_Indication (N)))));
+ Target_Typ : constant Entity_Id :=
+ Etype
+ (First_Index (Etype
+ (Subtype_Mark (Subtype_Indication (N)))));
begin
R_Checks :=
Range_Check
@@ -2361,10 +2440,23 @@ package body Sem_Ch3 is
T : Entity_Id;
Prev : Entity_Id;
+ Is_Remote : constant Boolean :=
+ (Is_Remote_Types (Current_Scope)
+ or else Is_Remote_Call_Interface (Current_Scope))
+ and then not (In_Private_Part (Current_Scope)
+ or else
+ In_Package_Body (Current_Scope));
+
begin
Prev := Find_Type_Name (N);
- if Ekind (Prev) = E_Incomplete_Type then
+ -- The full view, if present, now points to the current type. If the
+ -- type was previously decorated when imported through a LIMITED WITH
+ -- clause, it appears as incomplete but has no full view.
+
+ if Ekind (Prev) = E_Incomplete_Type
+ and then Present (Full_View (Prev))
+ then
T := Full_View (Prev);
else
T := Prev;
@@ -2404,7 +2496,7 @@ package body Sem_Ch3 is
end case;
-- Elaborate the type definition according to kind, and generate
- -- susbsidiary (implicit) subtypes where needed. We skip this if
+ -- subsidiary (implicit) subtypes where needed. We skip this if
-- it was already done (this happens during the reanalysis that
-- follows a call to the high level optimizer).
@@ -2419,10 +2511,7 @@ package body Sem_Ch3 is
-- If this is a remote access to subprogram, we must create
-- the equivalent fat pointer type, and related subprograms.
- if Is_Remote_Types (Current_Scope)
- or else Is_Remote_Call_Interface (Current_Scope)
- then
- Validate_Remote_Access_To_Subprogram_Type (N);
+ if Is_Remote then
Process_Remote_AST_Declaration (N);
end if;
@@ -2442,8 +2531,7 @@ package body Sem_Ch3 is
-- If we are in a Remote_Call_Interface package and define
-- a RACW, Read and Write attribute must be added.
- if (Is_Remote_Call_Interface (Current_Scope)
- or else Is_Remote_Types (Current_Scope))
+ if Is_Remote
and then Is_Remote_Access_To_Class_Wide_Type (Def_Id)
then
Add_RACW_Features (Def_Id);
@@ -2474,7 +2562,7 @@ package body Sem_Ch3 is
Modular_Type_Declaration (T, Def);
when N_Record_Definition =>
- Record_Type_Declaration (T, N);
+ Record_Type_Declaration (T, N, Prev);
when others =>
raise Program_Error;
@@ -2576,7 +2664,8 @@ package body Sem_Ch3 is
procedure Non_Static_Choice_Error (Choice : Node_Id) is
begin
- Error_Msg_N ("choice given in variant part is not static", Choice);
+ Flag_Non_Static_Expr
+ ("choice given in variant part is not static!", Choice);
end Non_Static_Choice_Error;
--------------------------
@@ -2596,8 +2685,6 @@ package body Sem_Ch3 is
-- Variables local to Analyze_Case_Statement.
- Others_Choice : Node_Id;
-
Discr_Name : Node_Id;
Discr_Type : Entity_Id;
@@ -2629,15 +2716,6 @@ package body Sem_Ch3 is
Analyze_Choices
(N, Discr_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
-
- if Others_Present then
- -- Fill in Others_Discrete_Choices field of the OTHERS choice
-
- Others_Choice := First (Discrete_Choices (Last (Variants (N))));
- Expand_Others_Choice
- (Case_Table (1 .. Last_Choice), Others_Choice, Discr_Type);
- end if;
-
end Analyze_Variant_Part;
----------------------------
@@ -2761,7 +2839,7 @@ package body Sem_Ch3 is
if Priv = Any_Type then
Set_Component_Type (Etype (T), Any_Type);
- -- There is a gap in the visiblity of operations on the composite
+ -- There is a gap in the visibility of operations on the composite
-- type only if the component type is defined in a different scope.
elsif Scope (Priv) = Current_Scope then
@@ -3009,7 +3087,7 @@ package body Sem_Ch3 is
= N_Subtype_Indication;
begin
- Set_Girder_Constraint (Derived_Type, No_Elist);
+ Set_Stored_Constraint (Derived_Type, No_Elist);
if Is_Task_Type (Parent_Type) then
Set_Storage_Size_Variable (Derived_Type,
@@ -3027,7 +3105,7 @@ package body Sem_Ch3 is
declare
Loc : constant Source_Ptr := Sloc (N);
- Anon : Entity_Id :=
+ Anon : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_External_Name (Chars (Derived_Type), 'T'));
Decl : Node_Id;
@@ -3391,7 +3469,6 @@ package body Sem_Ch3 is
Source_Typ => Entity (Subtype_Mark (Indic)));
end if;
end if;
-
end Build_Derived_Enumeration_Type;
--------------------------------
@@ -3413,13 +3490,12 @@ package body Sem_Ch3 is
Lo : Node_Id;
Hi : Node_Id;
- T : Entity_Id;
begin
-- Process the subtype indication including a validation check on
-- the constraint if any.
- T := Process_Subtype (Indic, N);
+ Discard_Node (Process_Subtype (Indic, N));
-- Introduce an implicit base type for the derived type even if
-- there is no constraint attached to it, since this seems closer
@@ -3567,7 +3643,6 @@ package body Sem_Ch3 is
else
Freeze_Before (N, Implicit_Base);
end if;
-
end Build_Derived_Numeric_Type;
--------------------------------
@@ -3632,10 +3707,13 @@ package body Sem_Ch3 is
if Present (Full_View (Parent_Type)) then
if not Is_Completion then
- -- Copy declaration for subsequent analysis.
+ -- Copy declaration for subsequent analysis, to
+ -- provide a completion for what is a private
+ -- declaration.
Full_Decl := New_Copy_Tree (N);
Full_Der := New_Copy (Derived_Type);
+
Insert_After (N, Full_Decl);
else
@@ -3668,6 +3746,8 @@ package body Sem_Ch3 is
end if;
end if;
+ -- Build partial view of derived type from partial view of parent.
+
Build_Derived_Record_Type
(N, Parent_Type, Derived_Type, Derive_Subps);
@@ -3684,11 +3764,24 @@ package body Sem_Ch3 is
Swapped := True;
end if;
- -- Subprograms have been derived on the private view,
+ -- Build full view of derived type from full view of
+ -- parent which is now installed.
+ -- Subprograms have been derived on the partial view,
-- the completion does not derive them anew.
- Build_Derived_Record_Type
- (Full_Decl, Parent_Type, Full_Der, False);
+ if not Is_Tagged_Type (Parent_Type) then
+ Build_Derived_Record_Type
+ (Full_Decl, Parent_Type, Full_Der, False);
+ else
+
+ -- If full view of parent is tagged, the completion
+ -- inherits the proper primitive operations.
+
+ Set_Defining_Identifier (Full_Decl, Full_Der);
+ Build_Derived_Record_Type
+ (Full_Decl, Parent_Type, Full_Der, Derive_Subps);
+ Set_Analyzed (Full_Decl);
+ end if;
if Swapped then
Uninstall_Declarations (Par_Scope);
@@ -3710,7 +3803,7 @@ package body Sem_Ch3 is
-- to discriminants in the full view, their scope
-- will be that of the full view. This might
-- cause some front end problems and need
- -- adustment?
+ -- adjustment?
Discr := First_Discriminant (Base_Type (Full_Der));
Set_First_Entity (Der_Base, Discr);
@@ -3750,9 +3843,16 @@ package body Sem_Ch3 is
-- If full view of parent is a record type, Build full view as
-- a derivation from the parent's full view. Partial view remains
- -- private.
-
- if not Is_Private_Type (Full_View (Parent_Type)) then
+ -- private. For code generation and linking, the full view must
+ -- have the same public status as the partial one. This full view
+ -- is only needed if the parent type is in an enclosing scope, so
+ -- that the full view may actually become visible, e.g. in a child
+ -- unit. This is both more efficient, and avoids order of freezing
+ -- problems with the added entities.
+
+ if not Is_Private_Type (Full_View (Parent_Type))
+ and then (In_Open_Scopes (Scope (Parent_Type)))
+ then
Full_Der := Make_Defining_Identifier (Sloc (Derived_Type),
Chars (Derived_Type));
Set_Is_Itype (Full_Der);
@@ -3761,7 +3861,7 @@ package body Sem_Ch3 is
Set_Associated_Node_For_Itype (Full_Der, N);
Set_Parent (Full_Der, Parent (Derived_Type));
Set_Full_View (Derived_Type, Full_Der);
-
+ Set_Is_Public (Full_Der, Is_Public (Derived_Type));
Full_P := Full_View (Parent_Type);
Exchange_Declarations (Parent_Type);
Copy_And_Build;
@@ -3800,7 +3900,7 @@ package body Sem_Ch3 is
("cannot add discriminants to untagged type", N);
end if;
- Set_Girder_Constraint (Derived_Type, No_Elist);
+ Set_Stored_Constraint (Derived_Type, No_Elist);
Set_Is_Constrained (Derived_Type, Is_Constrained (Parent_Type));
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
Set_Has_Controlled_Component
@@ -3815,7 +3915,7 @@ package body Sem_Ch3 is
end if;
-- Construct the implicit full view by deriving from full
- -- view of the parent type. In order to get proper visiblity,
+ -- view of the parent type. In order to get proper visibility,
-- we install the parent scope and its declarations.
-- ??? if the parent is untagged private and its
@@ -3954,13 +4054,13 @@ package body Sem_Ch3 is
-- This has two implications. The first is that the entire tree for R's
-- declaration needs to be copied for T in the untagged case, so that
- -- T can be viewd as a record type of its own with its own derivation
+ -- T can be viewed as a record type of its own with its own representation
-- clauses. The second implication is the way we handle discriminants.
-- Specifically, in the untagged case we need a way to communicate to Gigi
-- what are the real discriminants in the record, while for the semantics
-- we need to consider those introduced by the user to rename the
-- discriminants in the parent type. This is handled by introducing the
- -- notion of girder discriminants. See below for more.
+ -- notion of stored discriminants. See below for more.
-- Fortunately the way regular components are inherited can be handled in
-- the same way in tagged and untagged types.
@@ -4012,15 +4112,15 @@ package body Sem_Ch3 is
-- 3. DISCRIMINANTS IN DERIVED UNTAGGED RECORD TYPES.
- -- We have spoken about girder discriminants in the point 1 (introduction)
- -- above. There are two sort of girder discriminants: implicit and
+ -- We have spoken about stored discriminants in point 1 (introduction)
+ -- above. There are two sort of stored discriminants: implicit and
-- explicit. As long as the derived type inherits the same discriminants as
- -- the root record type, girder discriminants are the same as regular
+ -- the root record type, stored discriminants are the same as regular
-- discriminants, and are said to be implicit. However, if any discriminant
-- in the root type was renamed in the derived type, then the derived
- -- type will contain explicit girder discriminants. Explicit girder
+ -- type will contain explicit stored discriminants. Explicit stored
-- discriminants are discriminants in addition to the semantically visible
- -- discriminants defined for the derived type. Girder discriminants are
+ -- discriminants defined for the derived type. Stored discriminants are
-- used by Gigi to figure out what are the physical discriminants in
-- objects of the derived type (see precise definition in einfo.ads).
-- As an example, consider the following:
@@ -4031,10 +4131,10 @@ package body Sem_Ch3 is
-- type T3 is new T2;
-- type T4 (Y : Int) is new T3 (Y, 99);
- -- The following table summarizes the discriminants and girder
+ -- The following table summarizes the discriminants and stored
-- discriminants in R and T1 through T4.
- -- Type Discrim Girder Discrim Comment
+ -- Type Discrim Stored Discrim Comment
-- R (D1, D2, D3) (D1, D2, D3) Gider discrims are implicit in R
-- T1 (D1, D2, D3) (D1, D2, D3) Gider discrims are implicit in T1
-- T2 (X1, X2) (D1, D2, D3) Gider discrims are EXPLICIT in T2
@@ -4045,7 +4145,7 @@ package body Sem_Ch3 is
-- the corresponding discriminant in the parent type, while
-- Original_Record_Component (abbreviated ORC below), the actual physical
-- component that is renamed. Finally the field Is_Completely_Hidden
- -- (abbreaviated ICH below) is set for all explicit girder discriminants
+ -- (abbreviated ICH below) is set for all explicit stored discriminants
-- (see einfo.ads for more info). For the above example this gives:
-- Discrim CD ORC ICH
@@ -4079,7 +4179,7 @@ package body Sem_Ch3 is
-- Type derivation for tagged types is fairly straightforward. if no
-- discriminants are specified by the derived type, these are inherited
- -- from the parent. No explicit girder discriminants are ever necessary.
+ -- from the parent. No explicit stored discriminants are ever necessary.
-- The only manipulation that is done to the tree is that of adding a
-- _parent field with parent type and constrained to the same constraint
-- specified for the parent in the derived type definition. For instance:
@@ -4132,7 +4232,7 @@ package body Sem_Ch3 is
-- assumes that a base type with discriminants is unconstrained.
--
-- Note that, strictly speaking, the above transformation is not always
- -- correct. Consider for instance the following exercpt from ACVC b34011a:
+ -- correct. Consider for instance the following excerpt from ACVC b34011a:
--
-- procedure B34011A is
-- type REC (D : integer := 0) is record
@@ -4183,11 +4283,11 @@ package body Sem_Ch3 is
-- To get around this problem, after having semantically processed Der_Base
-- and the rewritten subtype declaration for Der, we copy Der_Base field
-- Discriminant_Constraint from Der so that when parameter conformance is
- -- checked when P is overridden, no sematic errors are flagged.
+ -- checked when P is overridden, no semantic errors are flagged.
-- 6. SECOND TRANSFORMATION FOR DERIVED RECORDS.
- -- Regardless of the fact that we dealing with a tagged or untagged type
+ -- Regardless of whether we are dealing with a tagged or untagged type
-- we will transform all derived type declarations of the form
-- type R (D1, .., Dn : ...) is [tagged] record ...;
@@ -4229,7 +4329,7 @@ package body Sem_Ch3 is
-- replaced with references to their correct constraints, ie D1 and D2 in
-- T1 and 1 and X in T2. So all R's discriminant references are replaced
-- with either discriminant references in the derived type or expressions.
- -- This replacement is acheived as follows: before inheriting R's
+ -- This replacement is achieved as follows: before inheriting R's
-- components, a subtype R (D1, D2) for T1 (resp. R (1, X) for T2) is
-- created in the scope of T1 (resp. scope of T2) so that discriminants D1
-- and D2 of T1 are visible (resp. discriminant X of T2 is visible).
@@ -4264,7 +4364,7 @@ package body Sem_Ch3 is
-- the full view shall define a definite subtype.
-- o If the ancestor subtype of a private extension has constrained
- -- discrimiants, then the parent subtype of the full view shall impose a
+ -- discriminants, then the parent subtype of the full view shall impose a
-- statically matching constraint on those discriminants.
-- This means that only the following forms of private extensions are
@@ -4309,7 +4409,7 @@ package body Sem_Ch3 is
-- is the same for what concerns discriminants (ie they receive the same
-- treatment as in the tagged case). However, the private view of the
-- private extension always inherits the components of the parent base,
- -- without replacing any discriminant reference. Strictly speacking this
+ -- without replacing any discriminant reference. Strictly speaking this
-- is incorrect. However, Gigi never uses this view to generate code so
-- this is a purely semantic issue. In theory, a set of transformations
-- similar to those given in 5. and 6. above could be applied to private
@@ -4356,7 +4456,7 @@ package body Sem_Ch3 is
-- a private extension such as T, we first mark T as unconstrained, we
-- process it, we perform program derivation and just before returning from
-- Build_Derived_Record_Type we mark T as constrained.
- -- ??? Are there are other unconfortable cases that we will have to
+ -- ??? Are there are other uncomfortable cases that we will have to
-- deal with.
-- 10. RECORD_TYPE_WITH_PRIVATE complications.
@@ -4572,9 +4672,9 @@ package body Sem_Ch3 is
else
declare
- Expr : Node_Id;
- Constr_List : List_Id := New_List;
+ Constr_List : constant List_Id := New_List;
C : Elmt_Id;
+ Expr : Node_Id;
begin
C := First_Elmt (Discriminant_Constraint (Parent_Type));
@@ -4663,9 +4763,10 @@ package body Sem_Ch3 is
if Present (GB)
and then GB /= Enclosing_Generic_Body (Parent_Base)
then
- Error_Msg_N
- ("parent type must not be outside generic body",
- Indic);
+ Error_Msg_NE
+ ("parent type of& must not be outside generic body"
+ & " ('R'M 3.9.1(4))",
+ Indic, Derived_Type);
end if;
end;
end if;
@@ -4678,7 +4779,7 @@ package body Sem_Ch3 is
-- retain the discriminants from the partial view if the current
-- declaration has Discriminant_Specifications so that we can verify
-- conformance. However, we must remove any existing components that
- -- were inherited from the parent (and attached in Copy_Private_To_Full)
+ -- were inherited from the parent (and attached in Copy_And_Swap)
-- because the full type inherits all appropriate components anyway, and
-- we don't want the partial view's components interfering.
@@ -4768,9 +4869,8 @@ package body Sem_Ch3 is
and then Present (Corresponding_Discriminant (Discrim))
then
Error_Msg_N
- ("Only static constraints allowed for parent"
+ ("only static constraints allowed for parent"
& " discriminants in the partial view", Indic);
-
exit;
end if;
@@ -4823,7 +4923,7 @@ package body Sem_Ch3 is
Discs := Build_Discriminant_Constraints (Parent_Type, Indic);
end if;
- -- For now mark a new derived type as cosntrained only if it has no
+ -- For now mark a new derived type as constrained only if it has no
-- discriminants. At the end of Build_Derived_Record_Type we properly
-- set this flag in the case of private extensions. See comments in
-- point 9. just before body of Build_Derived_Record_Type.
@@ -4837,7 +4937,7 @@ package body Sem_Ch3 is
-- STEP 3: initialize fields of derived type.
Set_Is_Tagged_Type (Derived_Type, Is_Tagged);
- Set_Girder_Constraint (Derived_Type, No_Elist);
+ Set_Stored_Constraint (Derived_Type, No_Elist);
-- Fields inherited from the Parent_Type
@@ -4896,7 +4996,7 @@ package body Sem_Ch3 is
end if;
end if;
- -- Set fields for tagged types.
+ -- Set fields for tagged types
if Is_Tagged then
Set_Primitive_Operations (Derived_Type, New_Elmt_List);
@@ -4918,8 +5018,8 @@ package body Sem_Ch3 is
if Has_Discriminants (Derived_Type)
and then Constraint_Present
then
- Set_Girder_Constraint
- (Derived_Type, Expand_To_Girder_Constraint (Parent_Base, Discs));
+ Set_Stored_Constraint
+ (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs));
end if;
else
@@ -4965,9 +5065,9 @@ package body Sem_Ch3 is
Save_Etype := Etype (Derived_Type);
Save_Next_Entity := Next_Entity (Derived_Type);
- -- Assoc_List maps all girder discriminants in the Parent_Base to
- -- girder discriminants in the Derived_Type. It is fundamental that
- -- no types or itypes with discriminants other than the girder
+ -- Assoc_List maps all stored discriminants in the Parent_Base to
+ -- stored discriminants in the Derived_Type. It is fundamental that
+ -- no types or itypes with discriminants other than the stored
-- discriminants appear in the entities declared inside
-- Derived_Type. Gigi won't like it.
@@ -4976,7 +5076,7 @@ package body Sem_Ch3 is
(Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc);
-- Restore the fields saved prior to the New_Copy_Tree call
- -- and compute the girder constraint.
+ -- and compute the stored constraint.
Set_Etype (Derived_Type, Save_Etype);
Set_Next_Entity (Derived_Type, Save_Next_Entity);
@@ -4984,8 +5084,8 @@ package body Sem_Ch3 is
if Has_Discriminants (Derived_Type) then
Set_Discriminant_Constraint
(Derived_Type, Save_Discr_Constr);
- Set_Girder_Constraint
- (Derived_Type, Expand_To_Girder_Constraint (Parent_Base, Discs));
+ Set_Stored_Constraint
+ (Derived_Type, Expand_To_Stored_Constraint (Parent_Base, Discs));
Replace_Components (Derived_Type, New_Decl);
end if;
@@ -4997,9 +5097,8 @@ package body Sem_Ch3 is
-- There is no completion for record extensions declared in the
-- parameter part of a generic, so we need to complete processing for
- -- these generic record extensions here. The call to
- -- Record_Type_Definition will change the Ekind of the components
- -- from E_Void to E_Component.
+ -- these generic record extensions here. The Record_Type_Definition call
+ -- will change the Ekind of the components from E_Void to E_Component.
elsif Private_Extension and then Is_Generic_Type (Derived_Type) then
Record_Type_Definition (Empty, Derived_Type);
@@ -5077,7 +5176,44 @@ package body Sem_Ch3 is
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
Set_Convention (Derived_Type, Convention (Parent_Type));
Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type));
- Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
+
+ -- The derived type inherits the representation clauses of the parent.
+ -- However, for a private type that is completed by a derivation, there
+ -- may be operation attributes that have been specified already (stream
+ -- attributes and External_Tag) and those must be provided. Finally,
+ -- if the partial view is a private extension, the representation items
+ -- of the parent have been inherited already, and should not be chained
+ -- twice to the derived type.
+
+ if Is_Tagged_Type (Parent_Type)
+ and then Present (First_Rep_Item (Derived_Type))
+ then
+ -- The existing items are either operational items or items inherited
+ -- from a private extension declaration.
+
+ declare
+ Rep : Node_Id := First_Rep_Item (Derived_Type);
+ Found : Boolean := False;
+
+ begin
+ while Present (Rep) loop
+ if Rep = First_Rep_Item (Parent_Type) then
+ Found := True;
+ exit;
+ else
+ Rep := Next_Rep_Item (Rep);
+ end if;
+ end loop;
+
+ if not Found then
+ Set_Next_Rep_Item
+ (First_Rep_Item (Derived_Type), First_Rep_Item (Parent_Type));
+ end if;
+ end;
+
+ else
+ Set_First_Rep_Item (Derived_Type, First_Rep_Item (Parent_Type));
+ end if;
case Ekind (Parent_Type) is
when Numeric_Kind =>
@@ -5217,11 +5353,11 @@ package body Sem_Ch3 is
raise Program_Error;
end Pos_Of_Discr;
- -- Variables local to Build_Discriminant_Constraints
+ -- Declarations local to Build_Discriminant_Constraints
Discr : Entity_Id;
E : Entity_Id;
- Elist : Elist_Id := New_Elmt_List;
+ Elist : constant Elist_Id := New_Elmt_List;
Constr : Node_Id;
Expr : Node_Id;
@@ -5345,7 +5481,7 @@ package body Sem_Ch3 is
-- processing for the non-generic case so we do it in all
-- cases (for generics this statement is executed when
-- processing the generic definition, see comment at the
- -- begining of this if statement).
+ -- beginning of this if statement).
else
Set_Original_Discriminant (Id, Discr);
@@ -5406,7 +5542,7 @@ package body Sem_Ch3 is
-- Determine if there are discriminant expressions in the constraint.
for J in Discr_Expr'Range loop
- if Denotes_Discriminant (Discr_Expr (J)) then
+ if Denotes_Discriminant (Discr_Expr (J), Check_Protected => True) then
Discrim_Present := True;
end if;
end loop;
@@ -5437,10 +5573,23 @@ package body Sem_Ch3 is
-- Force the evaluation of non-discriminant expressions.
-- If we have found a discriminant in the constraint 3.4(26)
-- and 3.8(18) demand that no range checks are performed are
- -- after evaluation. In all other cases perform a range check.
+ -- after evaluation. If the constraint is for a component
+ -- definition that has a per-object constraint, expressions are
+ -- evaluated but not checked either. In all other cases perform
+ -- a range check.
else
- if not Discrim_Present then
+ if Discrim_Present then
+ null;
+
+ elsif Nkind (Parent (Def)) = N_Component_Declaration
+ and then
+ Has_Per_Object_Constraint
+ (Defining_Identifier (Parent (Def)))
+ then
+ null;
+
+ else
Apply_Range_Check (Discr_Expr (J), Etype (Discr));
end if;
@@ -5529,11 +5678,11 @@ package body Sem_Ch3 is
Make_Class_Wide_Type (Def_Id);
end if;
- Set_Girder_Constraint (Def_Id, No_Elist);
+ Set_Stored_Constraint (Def_Id, No_Elist);
if Has_Discrs then
Set_Discriminant_Constraint (Def_Id, Elist);
- Set_Girder_Constraint_From_Discriminant_Constraint (Def_Id);
+ Set_Stored_Constraint_From_Discriminant_Constraint (Def_Id);
end if;
if Is_Tagged_Type (T) then
@@ -5703,8 +5852,8 @@ package body Sem_Ch3 is
-- automatic overridings for these subprograms.
if Is_Abstract (Subp)
- and then Chars (Subp) /= Name_uInput
- and then Chars (Subp) /= Name_uOutput
+ and then not Is_TSS (Subp, TSS_Stream_Input)
+ and then not Is_TSS (Subp, TSS_Stream_Output)
and then not Is_Abstract (T)
then
if Present (Alias (Subp)) then
@@ -5814,12 +5963,16 @@ package body Sem_Ch3 is
procedure Post_Error;
-- Post error message for lack of completion for entity E
+ ----------------
+ -- Post_Error --
+ ----------------
+
procedure Post_Error is
begin
if not Comes_From_Source (E) then
- if (Ekind (E) = E_Task_Type
- or else Ekind (E) = E_Protected_Type)
+ if Ekind (E) = E_Task_Type
+ or else Ekind (E) = E_Protected_Type
then
-- It may be an anonymous protected type created for a
-- single variable. Post error on variable, if present.
@@ -5852,6 +6005,7 @@ package body Sem_Ch3 is
if not Comes_From_Source (E) then
pragma Assert
(Serious_Errors_Detected > 0
+ or else Configurable_Run_Time_Violations > 0
or else Subunits_Missing
or else not Expander_Active);
return;
@@ -5890,8 +6044,10 @@ package body Sem_Ch3 is
-- as a distinct overloading of the entity.
declare
- Candidate : Entity_Id := Current_Entity_In_Scope (E);
- Decl : Node_Id := Unit_Declaration_Node (Candidate);
+ Candidate : constant Entity_Id :=
+ Current_Entity_In_Scope (E);
+ Decl : constant Node_Id :=
+ Unit_Declaration_Node (Candidate);
begin
if Is_Overloadable (Candidate)
@@ -5981,9 +6137,16 @@ package body Sem_Ch3 is
then
Post_Error;
+ -- A single task declared in the current scope is
+ -- a constant, verify that the body of its anonymous
+ -- type is in the same scope. If the task is defined
+ -- elsewhere, this may be a renaming declaration for
+ -- which no completion is needed.
+
elsif Ekind (E) = E_Constant
and then Ekind (Etype (E)) = E_Task_Type
and then not Has_Completion (Etype (E))
+ and then Scope (Etype (E)) = Current_Scope
then
Post_Error;
@@ -6018,7 +6181,8 @@ package body Sem_Ch3 is
Wrong_Type (E, Any_Real);
elsif not Is_OK_Static_Expression (E) then
- Error_Msg_N ("non-static expression used for delta value", E);
+ Flag_Non_Static_Expr
+ ("non-static expression used for delta value!", E);
elsif not UR_Is_Positive (Expr_Value_R (E)) then
Error_Msg_N ("delta expression must be positive", E);
@@ -6046,7 +6210,8 @@ package body Sem_Ch3 is
Wrong_Type (E, Any_Integer);
elsif not Is_OK_Static_Expression (E) then
- Error_Msg_N ("non-static expression used for digits value", E);
+ Flag_Non_Static_Expr
+ ("non-static expression used for digits value!", E);
elsif Expr_Value (E) <= 0 then
Error_Msg_N ("digits value must be greater than zero", E);
@@ -6063,17 +6228,6 @@ package body Sem_Ch3 is
end Check_Digits_Expression;
- ----------------------
- -- Check_Incomplete --
- ----------------------
-
- procedure Check_Incomplete (T : Entity_Id) is
- begin
- if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type then
- Error_Msg_N ("invalid use of type before its full declaration", T);
- end if;
- end Check_Incomplete;
-
--------------------------
-- Check_Initialization --
--------------------------
@@ -6086,6 +6240,7 @@ package body Sem_Ch3 is
then
Error_Msg_N
("cannot initialize entities of limited type", Exp);
+ Explain_Limited_Type (T, Exp);
end if;
end Check_Initialization;
@@ -6098,7 +6253,11 @@ package body Sem_Ch3 is
-- were present on the incomplete declaration. In this case a full
-- conformance check is performed otherwise just process them.
- procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id) is
+ procedure Check_Or_Process_Discriminants
+ (N : Node_Id;
+ T : Entity_Id;
+ Prev : Entity_Id := Empty)
+ is
begin
if Has_Discriminants (T) then
@@ -6125,7 +6284,7 @@ package body Sem_Ch3 is
end;
elsif Present (Discriminant_Specifications (N)) then
- Process_Discriminants (N);
+ Process_Discriminants (N, Prev);
end if;
end Check_Or_Process_Discriminants;
@@ -6140,8 +6299,8 @@ package body Sem_Ch3 is
("bound in real type definition must be of real type", Bound);
elsif not Is_OK_Static_Expression (Bound) then
- Error_Msg_N
- ("non-static expression used for real type bound", Bound);
+ Flag_Non_Static_Expr
+ ("non-static expression used for real type bound!", Bound);
else
return;
@@ -6234,6 +6393,11 @@ package body Sem_Ch3 is
if not Has_Discriminants (Priv) then
Set_Is_Constrained (Full, Is_Constrained (Full_Base));
+
+ if Has_Discriminants (Full_Base) then
+ Set_Discriminant_Constraint
+ (Full, Discriminant_Constraint (Full_Base));
+ end if;
end if;
Set_First_Rep_Item (Full, First_Rep_Item (Full_Base));
@@ -6255,8 +6419,8 @@ package body Sem_Ch3 is
Set_Full_View (Priv, Full);
if Has_Discriminants (Full) then
- Set_Girder_Constraint_From_Discriminant_Constraint (Full);
- Set_Girder_Constraint (Priv, Girder_Constraint (Full));
+ Set_Stored_Constraint_From_Discriminant_Constraint (Full);
+ Set_Stored_Constraint (Priv, Stored_Constraint (Full));
if Has_Unknown_Discriminants (Full) then
Set_Discriminant_Constraint (Full, No_Elist);
end if;
@@ -6288,7 +6452,7 @@ package body Sem_Ch3 is
Set_Cloned_Subtype (Full, Full_Base);
end if;
- -- It is usafe to share to bounds of a scalar type, because the
+ -- It is unsafe to share to bounds of a scalar type, because the
-- Itype is elaborated on demand, and if a bound is non-static
-- then different orders of elaboration in different units will
-- lead to different external symbols.
@@ -6296,8 +6460,19 @@ package body Sem_Ch3 is
if Is_Scalar_Type (Full_Base) then
Set_Scalar_Range (Full,
Make_Range (Sloc (Related_Nod),
- Low_Bound => Duplicate_Subexpr (Type_Low_Bound (Full_Base)),
- High_Bound => Duplicate_Subexpr (Type_High_Bound (Full_Base))));
+ Low_Bound =>
+ Duplicate_Subexpr_No_Checks (Type_Low_Bound (Full_Base)),
+ High_Bound =>
+ Duplicate_Subexpr_No_Checks (Type_High_Bound (Full_Base))));
+
+ -- This completion inherits the bounds of the full parent, but if
+ -- the parent is an unconstrained floating point type, so is the
+ -- completion.
+
+ if Is_Floating_Point_Type (Full_Base) then
+ Set_Includes_Infinities
+ (Scalar_Range (Full), Has_Infinities (Full_Base));
+ end if;
end if;
-- ??? It seems that a lot of fields are missing that should be
@@ -6307,6 +6482,7 @@ package body Sem_Ch3 is
if Is_Tagged_Type (Full_Base) then
Set_Is_Tagged_Type (Full);
Set_Primitive_Operations (Full, Primitive_Operations (Full_Base));
+ Set_Class_Wide_Type (Full, Class_Wide_Type (Full_Base));
elsif Is_Concurrent_Type (Full_Base) then
if Has_Discriminants (Full)
@@ -6342,9 +6518,13 @@ package body Sem_Ch3 is
-- If deferred constant is an access type initialized with an
-- allocator, check whether there is an illegal recursion in the
-- definition, through a default value of some record subcomponent.
- -- This is normally detected when generating init_procs, but requires
+ -- This is normally detected when generating init procs, but requires
-- this additional mechanism when expansion is disabled.
+ ---------------------------------
+ -- Check_Recursive_Declaration --
+ ---------------------------------
+
procedure Check_Recursive_Declaration (Typ : Entity_Id) is
Comp : Entity_Id;
@@ -6532,7 +6712,8 @@ package body Sem_Ch3 is
-- by ACATS B371001).
declare
- Pack : Node_Id := Unit_Declaration_Node (Scope (Desig_Type));
+ Pack : constant Node_Id :=
+ Unit_Declaration_Node (Scope (Desig_Type));
Decls : List_Id;
Decl : Node_Id;
@@ -6688,6 +6869,8 @@ package body Sem_Ch3 is
if No (Def_Id) then
Def_Id :=
Create_Itype (E_Array_Subtype, Related_Nod, Related_Id, Suffix);
+ Set_Parent (Def_Id, Related_Nod);
+
else
Set_Ekind (Def_Id, E_Array_Subtype);
end if;
@@ -7037,16 +7220,16 @@ package body Sem_Ch3 is
-- The corresponding_Discriminant mechanism is incomplete, because
-- the correspondence between new and old discriminants is not one
-- to one: one new discriminant can constrain several old ones.
- -- In that case, scan sequentially the girder_constraint, the list
+ -- In that case, scan sequentially the stored_constraint, the list
-- of discriminants of the parents, and the constraints.
if Is_Derived_Type (Typ)
- and then Present (Girder_Constraint (Typ))
+ and then Present (Stored_Constraint (Typ))
and then Scope (Entity (Discrim)) = Etype (Typ)
then
D := First_Discriminant (Etype (Typ));
E := First_Elmt (Constraints);
- G := First_Elmt (Girder_Constraint (Typ));
+ G := First_Elmt (Stored_Constraint (Typ));
while Present (D) loop
if D = Entity (Discrim) then
@@ -7205,7 +7388,7 @@ package body Sem_Ch3 is
if Has_Discriminants (Prot_Subt) then -- False only if errors.
Set_Discriminant_Constraint (T_Sub,
Discriminant_Constraint (Prot_Subt));
- Set_Girder_Constraint_From_Discriminant_Constraint (T_Sub);
+ Set_Stored_Constraint_From_Discriminant_Constraint (T_Sub);
Create_Constrained_Components (T_Sub, Related_Nod, Corr_Rec,
Discriminant_Constraint (T_Sub));
end if;
@@ -7307,6 +7490,10 @@ package body Sem_Ch3 is
-- posted an appropriate error message. The mission is to leave the
-- entity T in as reasonable state as possible!
+ --------------------------
+ -- Fixup_Bad_Constraint --
+ --------------------------
+
procedure Fixup_Bad_Constraint is
begin
-- Set a reasonable Ekind for the entity. For an incomplete type,
@@ -7421,6 +7608,12 @@ package body Sem_Ch3 is
-- Digits constraint present
if Nkind (C) = N_Digits_Constraint then
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_N
+ ("subtype digits constraint is an " &
+ "obsolescent feature ('R'M 'J.3(8))?", C);
+ end if;
+
D := Digits_Expression (C);
Analyze_And_Resolve (D, Any_Integer);
Check_Digits_Expression (D);
@@ -7481,7 +7674,9 @@ package body Sem_Ch3 is
begin
if Nkind (S) = N_Range
- or else Nkind (S) = N_Attribute_Reference
+ or else
+ (Nkind (S) = N_Attribute_Reference
+ and then Attribute_Name (S) = Name_Range)
then
-- A Range attribute will transformed into N_Range by Resolve.
@@ -7630,6 +7825,12 @@ package body Sem_Ch3 is
-- Delta constraint present
if Nkind (C) = N_Delta_Constraint then
+ if Warn_On_Obsolescent_Feature then
+ Error_Msg_S
+ ("subtype delta constraint is an " &
+ "obsolescent feature ('R'M 'J.3(7))?");
+ end if;
+
D := Delta_Expression (C);
Analyze_And_Resolve (D, Any_Real);
Check_Delta_Expression (D);
@@ -7744,67 +7945,12 @@ package body Sem_Ch3 is
-- Copy_And_Swap --
-------------------
- procedure Copy_And_Swap (Privat, Full : Entity_Id) is
+ procedure Copy_And_Swap (Priv, Full : Entity_Id) is
+
begin
-- Initialize new full declaration entity by copying the pertinent
-- fields of the corresponding private declaration entity.
- Copy_Private_To_Full (Privat, Full);
-
- -- Swap the two entities. Now Privat is the full type entity and
- -- Full is the private one. They will be swapped back at the end
- -- of the private part. This swapping ensures that the entity that
- -- is visible in the private part is the full declaration.
-
- Exchange_Entities (Privat, Full);
- Append_Entity (Full, Scope (Full));
- end Copy_And_Swap;
-
- -------------------------------------
- -- Copy_Array_Base_Type_Attributes --
- -------------------------------------
-
- procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is
- begin
- Set_Component_Alignment (T1, Component_Alignment (T2));
- Set_Component_Type (T1, Component_Type (T2));
- Set_Component_Size (T1, Component_Size (T2));
- Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
- Set_Finalize_Storage_Only (T1, Finalize_Storage_Only (T2));
- Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2));
- Set_Has_Task (T1, Has_Task (T2));
- Set_Is_Packed (T1, Is_Packed (T2));
- Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2));
- Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2));
- Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2));
- end Copy_Array_Base_Type_Attributes;
-
- -----------------------------------
- -- Copy_Array_Subtype_Attributes --
- -----------------------------------
-
- procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is
- begin
- Set_Size_Info (T1, T2);
-
- Set_First_Index (T1, First_Index (T2));
- Set_Is_Aliased (T1, Is_Aliased (T2));
- Set_Is_Atomic (T1, Is_Atomic (T2));
- Set_Is_Volatile (T1, Is_Volatile (T2));
- Set_Is_Constrained (T1, Is_Constrained (T2));
- Set_Depends_On_Private (T1, Has_Private_Component (T2));
- Set_First_Rep_Item (T1, First_Rep_Item (T2));
- Set_Convention (T1, Convention (T2));
- Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2));
- Set_Is_Private_Composite (T1, Is_Private_Composite (T2));
- end Copy_Array_Subtype_Attributes;
-
- --------------------------
- -- Copy_Private_To_Full --
- --------------------------
-
- procedure Copy_Private_To_Full (Priv, Full : Entity_Id) is
- begin
-- We temporarily set Ekind to a value appropriate for a type to
-- avoid assert failures in Einfo from checking for setting type
-- attributes on something that is not a type. Ekind (Priv) is an
@@ -7825,9 +7971,10 @@ package body Sem_Ch3 is
if Has_Discriminants (Full) then
Set_Discriminant_Constraint (Full, Discriminant_Constraint (Priv));
- Set_Girder_Constraint (Full, Girder_Constraint (Priv));
+ Set_Stored_Constraint (Full, Stored_Constraint (Priv));
end if;
+ Set_First_Rep_Item (Full, First_Rep_Item (Priv));
Set_Homonym (Full, Homonym (Priv));
Set_Is_Immediately_Visible (Full, Is_Immediately_Visible (Priv));
Set_Is_Public (Full, Is_Public (Priv));
@@ -7845,23 +7992,73 @@ package body Sem_Ch3 is
end if;
Set_Is_Volatile (Full, Is_Volatile (Priv));
+ Set_Treat_As_Volatile (Full, Treat_As_Volatile (Priv));
Set_Scope (Full, Scope (Priv));
Set_Next_Entity (Full, Next_Entity (Priv));
Set_First_Entity (Full, First_Entity (Priv));
Set_Last_Entity (Full, Last_Entity (Priv));
-- If access types have been recorded for later handling, keep them
- -- in the full view so that they get handled when the full view freeze
- -- node is expanded.
+ -- in the full view so that they get handled when the full view
+ -- freeze node is expanded.
if Present (Freeze_Node (Priv))
and then Present (Access_Types_To_Process (Freeze_Node (Priv)))
then
Ensure_Freeze_Node (Full);
- Set_Access_Types_To_Process (Freeze_Node (Full),
- Access_Types_To_Process (Freeze_Node (Priv)));
+ Set_Access_Types_To_Process
+ (Freeze_Node (Full),
+ Access_Types_To_Process (Freeze_Node (Priv)));
end if;
- end Copy_Private_To_Full;
+
+ -- Swap the two entities. Now Privat is the full type entity and
+ -- Full is the private one. They will be swapped back at the end
+ -- of the private part. This swapping ensures that the entity that
+ -- is visible in the private part is the full declaration.
+
+ Exchange_Entities (Priv, Full);
+ Append_Entity (Full, Scope (Full));
+ end Copy_And_Swap;
+
+ -------------------------------------
+ -- Copy_Array_Base_Type_Attributes --
+ -------------------------------------
+
+ procedure Copy_Array_Base_Type_Attributes (T1, T2 : Entity_Id) is
+ begin
+ Set_Component_Alignment (T1, Component_Alignment (T2));
+ Set_Component_Type (T1, Component_Type (T2));
+ Set_Component_Size (T1, Component_Size (T2));
+ Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
+ Set_Finalize_Storage_Only (T1, Finalize_Storage_Only (T2));
+ Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2));
+ Set_Has_Task (T1, Has_Task (T2));
+ Set_Is_Packed (T1, Is_Packed (T2));
+ Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2));
+ Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2));
+ Set_Has_Volatile_Components (T1, Has_Volatile_Components (T2));
+ end Copy_Array_Base_Type_Attributes;
+
+ -----------------------------------
+ -- Copy_Array_Subtype_Attributes --
+ -----------------------------------
+
+ procedure Copy_Array_Subtype_Attributes (T1, T2 : Entity_Id) is
+ begin
+ Set_Size_Info (T1, T2);
+
+ Set_First_Index (T1, First_Index (T2));
+ Set_Is_Aliased (T1, Is_Aliased (T2));
+ Set_Is_Atomic (T1, Is_Atomic (T2));
+ Set_Is_Volatile (T1, Is_Volatile (T2));
+ Set_Treat_As_Volatile (T1, Treat_As_Volatile (T2));
+ Set_Is_Constrained (T1, Is_Constrained (T2));
+ Set_Depends_On_Private (T1, Has_Private_Component (T2));
+ Set_First_Rep_Item (T1, First_Rep_Item (T2));
+ Set_Convention (T1, Convention (T2));
+ Set_Is_Limited_Composite (T1, Is_Limited_Composite (T2));
+ Set_Is_Private_Composite (T1, Is_Private_Composite (T2));
+ end Copy_Array_Subtype_Attributes;
-----------------------------------
-- Create_Constrained_Components --
@@ -7874,14 +8071,14 @@ package body Sem_Ch3 is
Constraints : Elist_Id)
is
Loc : constant Source_Ptr := Sloc (Subt);
- Assoc_List : List_Id := New_List;
- Comp_List : Elist_Id := New_Elmt_List;
+ Comp_List : constant Elist_Id := New_Elmt_List;
+ Parent_Type : constant Entity_Id := Etype (Typ);
+ Assoc_List : constant List_Id := New_List;
Discr_Val : Elmt_Id;
Errors : Boolean;
New_C : Entity_Id;
Old_C : Entity_Id;
Is_Static : Boolean := True;
- Parent_Type : constant Entity_Id := Etype (Typ);
procedure Collect_Fixed_Components (Typ : Entity_Id);
-- Collect components of parent type that do not appear in a variant
@@ -7891,7 +8088,7 @@ package body Sem_Ch3 is
-- Iterate over Comp_List to create the components of the subtype.
function Create_Component (Old_Compon : Entity_Id) return Entity_Id;
- -- Creates a new component from Old_Compon, coppying all the fields from
+ -- Creates a new component from Old_Compon, copying all the fields from
-- it, including its Etype, inserts the new component in the Subt entity
-- chain and returns the new component.
@@ -7905,7 +8102,7 @@ package body Sem_Ch3 is
procedure Collect_Fixed_Components (Typ : Entity_Id) is
begin
- -- Build association list for discriminants, and find components of
+ -- Build association list for discriminants, and find components of
-- the variant part selected by the values of the discriminants.
Old_C := First_Discriminant (Typ);
@@ -7971,7 +8168,7 @@ package body Sem_Ch3 is
----------------------
function Create_Component (Old_Compon : Entity_Id) return Entity_Id is
- New_Compon : Entity_Id := New_Copy (Old_Compon);
+ New_Compon : constant Entity_Id := New_Copy (Old_Compon);
begin
-- Set the parent so we have a proper link for freezing etc. This
@@ -8302,6 +8499,7 @@ package body Sem_Ch3 is
Same_Subt : constant Boolean :=
Is_Scalar_Type (Parent_Type)
and then Subtypes_Statically_Compatible (Parent_Type, Derived_Type);
+ Visible_Subp : Entity_Id := Parent_Subp;
function Is_Private_Overriding return Boolean;
-- If Subp is a private overriding of a visible operation, the in-
@@ -8309,12 +8507,21 @@ package body Sem_Ch3 is
-- its body is the overriding one) and the inherited operation is
-- visible now. See sem_disp to see the details of the handling of
-- the overridden subprogram, which is removed from the list of
- -- primitive operations of the type.
+ -- primitive operations of the type. The overridden subprogram is
+ -- saved locally in Visible_Subp, and used to diagnose abstract
+ -- operations that need overriding in the derived type.
procedure Replace_Type (Id, New_Id : Entity_Id);
-- When the type is an anonymous access type, create a new access type
-- designating the derived type.
+ procedure Set_Derived_Name;
+ -- This procedure sets the appropriate Chars name for New_Subp. This
+ -- is normally just a copy of the parent name. An exception arises for
+ -- type support subprograms, where the name is changed to reflect the
+ -- name of the derived type, e.g. if type foo is derived from type bar,
+ -- then a procedure barDA is derived with a name fooDA.
+
---------------------------
-- Is_Private_Overriding --
---------------------------
@@ -8337,6 +8544,7 @@ package body Sem_Ch3 is
and then Scope (Parent_Subp) = Scope (Prev)
and then not Is_Hidden (Prev)
then
+ Visible_Subp := Prev;
return True;
end if;
@@ -8434,6 +8642,20 @@ package body Sem_Ch3 is
end if;
end Replace_Type;
+ ----------------------
+ -- Set_Derived_Name --
+ ----------------------
+
+ procedure Set_Derived_Name is
+ Nm : constant TSS_Name_Type := Get_TSS_Name (Parent_Subp);
+ begin
+ if Nm = TSS_Null then
+ Set_Chars (New_Subp, Chars (Parent_Subp));
+ else
+ Set_Chars (New_Subp, Make_TSS_Name (Base_Type (Derived_Type), Nm));
+ end if;
+ end Set_Derived_Name;
+
-- Start of processing for Derive_Subprogram
begin
@@ -8460,7 +8682,7 @@ package body Sem_Ch3 is
or else Chars (Parent_Subp) = Name_Adjust
or else Chars (Parent_Subp) = Name_Finalize
then
- Set_Chars (New_Subp, Chars (Parent_Subp));
+ Set_Derived_Name;
-- If parent is hidden, this can be a regular derivation if the
-- parent is immediately visible in a non-instantiating context,
@@ -8485,7 +8707,7 @@ package body Sem_Ch3 is
and then not In_Instance)
or else In_Instance_Not_Visible
then
- Set_Chars (New_Subp, Chars (Parent_Subp));
+ Set_Derived_Name;
-- The type is inheriting a private operation, so enter
-- it with a special name so it can't be overridden.
@@ -8517,12 +8739,26 @@ package body Sem_Ch3 is
-- If this derivation corresponds to a tagged generic actual, then
-- primitive operations rename those of the actual. Otherwise the
- -- primitive operations rename those of the parent type.
+ -- primitive operations rename those of the parent type, If the
+ -- parent renames an intrinsic operator, so does the new subprogram.
+ -- We except concatenation, which is always properly typed, and does
+ -- not get expanded as other intrinsic operations.
if No (Actual_Subp) then
- Set_Alias (New_Subp, Parent_Subp);
- Set_Is_Intrinsic_Subprogram (New_Subp,
- Is_Intrinsic_Subprogram (Parent_Subp));
+ if Is_Intrinsic_Subprogram (Parent_Subp) then
+ Set_Is_Intrinsic_Subprogram (New_Subp);
+
+ if Present (Alias (Parent_Subp))
+ and then Chars (Parent_Subp) /= Name_Op_Concat
+ then
+ Set_Alias (New_Subp, Alias (Parent_Subp));
+ else
+ Set_Alias (New_Subp, Parent_Subp);
+ end if;
+
+ else
+ Set_Alias (New_Subp, Parent_Subp);
+ end if;
else
Set_Alias (New_Subp, Actual_Subp);
@@ -8544,10 +8780,46 @@ package body Sem_Ch3 is
(New_Subp, Is_Valued_Procedure (Parent_Subp));
end if;
+ -- A derived function with a controlling result is abstract.
+ -- If the Derived_Type is a nonabstract formal generic derived
+ -- type, then inherited operations are not abstract: check is
+ -- done at instantiation time. If the derivation is for a generic
+ -- actual, the function is not abstract unless the actual is.
+
+ if Is_Generic_Type (Derived_Type)
+ and then not Is_Abstract (Derived_Type)
+ then
+ null;
+
+ elsif Is_Abstract (Alias (New_Subp))
+ or else (Is_Tagged_Type (Derived_Type)
+ and then Etype (New_Subp) = Derived_Type
+ and then No (Actual_Subp))
+ then
+ Set_Is_Abstract (New_Subp);
+
+ -- Finally, if the parent type is abstract we must verify that all
+ -- inherited operations are either non-abstract or overridden, or
+ -- that the derived type itself is abstract (this check is performed
+ -- at the end of a package declaration, in Check_Abstract_Overriding).
+ -- A private overriding in the parent type will not be visible in the
+ -- derivation if we are not in an inner package or in a child unit of
+ -- the parent type, in which case the abstractness of the inherited
+ -- operation is carried to the new subprogram.
+
+ elsif Is_Abstract (Parent_Type)
+ and then not In_Open_Scopes (Scope (Parent_Type))
+ and then Is_Private_Overriding
+ and then Is_Abstract (Visible_Subp)
+ then
+ Set_Alias (New_Subp, Visible_Subp);
+ Set_Is_Abstract (New_Subp);
+ end if;
+
New_Overloaded_Entity (New_Subp, Derived_Type);
-- Check for case of a derived subprogram for the instantiation
- -- of a formal derived tagged type, so mark the subprogram as
+ -- of a formal derived tagged type, if so mark the subprogram as
-- dispatching and inherit the dispatching attributes of the
-- parent subprogram. The derived subprogram is effectively a
-- renaming of the actual subprogram, so it needs to have the
@@ -8569,25 +8841,6 @@ package body Sem_Ch3 is
Set_Has_Completion (New_Subp);
Set_Default_Expressions_Processed (New_Subp);
- -- A derived function with a controlling result is abstract.
- -- If the Derived_Type is a nonabstract formal generic derived
- -- type, then inherited operations are not abstract: check is
- -- done at instantiation time. If the derivation is for a generic
- -- actual, the function is not abstract unless the actual is.
-
- if Is_Generic_Type (Derived_Type)
- and then not Is_Abstract (Derived_Type)
- then
- null;
-
- elsif Is_Abstract (Alias (New_Subp))
- or else (Is_Tagged_Type (Derived_Type)
- and then Etype (New_Subp) = Derived_Type
- and then No (Actual_Subp))
- then
- Set_Is_Abstract (New_Subp);
- end if;
-
if Ekind (New_Subp) = E_Function then
Set_Mechanism (New_Subp, Mechanism (Parent_Subp));
end if;
@@ -8602,7 +8855,8 @@ package body Sem_Ch3 is
Derived_Type : Entity_Id;
Generic_Actual : Entity_Id := Empty)
is
- Op_List : Elist_Id := Collect_Primitive_Operations (Parent_Type);
+ Op_List : constant Elist_Id :=
+ Collect_Primitive_Operations (Parent_Type);
Act_List : Elist_Id;
Act_Elmt : Elmt_Id;
Elmt : Elmt_Id;
@@ -8670,10 +8924,9 @@ package body Sem_Ch3 is
Lo : Node_Id;
Hi : Node_Id;
- T : Entity_Id;
begin
- T := Process_Subtype (Indic, N);
+ Discard_Node (Process_Subtype (Indic, N));
Set_Etype (Implicit_Base, Parent_Base);
Set_Size_Info (Implicit_Base, Root_Type (Parent_Type));
@@ -8682,8 +8935,11 @@ package body Sem_Ch3 is
Set_Is_Character_Type (Implicit_Base, True);
Set_Has_Delayed_Freeze (Implicit_Base);
- Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type));
- Hi := New_Copy_Tree (Type_High_Bound (Parent_Type));
+ -- The bounds of the implicit base are the bounds of the parent base.
+ -- Note that their type is the parent base.
+
+ Lo := New_Copy_Tree (Type_Low_Bound (Parent_Base));
+ Hi := New_Copy_Tree (Type_High_Bound (Parent_Base));
Set_Scalar_Range (Implicit_Base,
Make_Range (Loc,
@@ -8703,7 +8959,13 @@ package body Sem_Ch3 is
Set_Is_Character_Type (Derived_Type, True);
if Nkind (Indic) /= N_Subtype_Indication then
- Set_Scalar_Range (Derived_Type, Scalar_Range (Implicit_Base));
+
+ -- If no explicit constraint, the bounds are those
+ -- of the parent type.
+
+ Lo := New_Copy_Tree (Type_Low_Bound (Parent_Type));
+ Hi := New_Copy_Tree (Type_High_Bound (Parent_Type));
+ Set_Scalar_Range (Derived_Type, Make_Range (Loc, Lo, Hi));
end if;
Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
@@ -8715,7 +8977,6 @@ package body Sem_Ch3 is
-- rejected by Gigi (???).
Freeze_Before (N, Implicit_Base);
-
end Derived_Standard_Character;
------------------------------
@@ -8961,7 +9222,7 @@ package body Sem_Ch3 is
Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
Set_Enum_Esize (T);
- -- Set Discard_Names if configuration pragma setg, or if there is
+ -- Set Discard_Names if configuration pragma set, or if there is
-- a parameterless pragma in the current declarative region
if Global_Discard_Names
@@ -8977,186 +9238,11 @@ package body Sem_Ch3 is
end if;
end Enumeration_Type_Declaration;
- --------------------------
- -- Expand_Others_Choice --
- --------------------------
-
- procedure Expand_Others_Choice
- (Case_Table : Choice_Table_Type;
- Others_Choice : Node_Id;
- Choice_Type : Entity_Id)
- is
- Choice : Node_Id;
- Choice_List : List_Id := New_List;
- Exp_Lo : Node_Id;
- Exp_Hi : Node_Id;
- Hi : Uint;
- Lo : Uint;
- Loc : Source_Ptr := Sloc (Others_Choice);
- Previous_Hi : Uint;
-
- function Build_Choice (Value1, Value2 : Uint) return Node_Id;
- -- Builds a node representing the missing choices given by the
- -- Value1 and Value2. A N_Range node is built if there is more than
- -- one literal value missing. Otherwise a single N_Integer_Literal,
- -- N_Identifier or N_Character_Literal is built depending on what
- -- Choice_Type is.
-
- function Lit_Of (Value : Uint) return Node_Id;
- -- Returns the Node_Id for the enumeration literal corresponding to the
- -- position given by Value within the enumeration type Choice_Type.
-
- ------------------
- -- Build_Choice --
- ------------------
-
- function Build_Choice (Value1, Value2 : Uint) return Node_Id is
- Lit_Node : Node_Id;
- Lo, Hi : Node_Id;
-
- begin
- -- If there is only one choice value missing between Value1 and
- -- Value2, build an integer or enumeration literal to represent it.
-
- if (Value2 - Value1) = 0 then
- if Is_Integer_Type (Choice_Type) then
- Lit_Node := Make_Integer_Literal (Loc, Value1);
- Set_Etype (Lit_Node, Choice_Type);
- else
- Lit_Node := Lit_Of (Value1);
- end if;
-
- -- Otherwise is more that one choice value that is missing between
- -- Value1 and Value2, therefore build a N_Range node of either
- -- integer or enumeration literals.
-
- else
- if Is_Integer_Type (Choice_Type) then
- Lo := Make_Integer_Literal (Loc, Value1);
- Set_Etype (Lo, Choice_Type);
- Hi := Make_Integer_Literal (Loc, Value2);
- Set_Etype (Hi, Choice_Type);
- Lit_Node :=
- Make_Range (Loc,
- Low_Bound => Lo,
- High_Bound => Hi);
-
- else
- Lit_Node :=
- Make_Range (Loc,
- Low_Bound => Lit_Of (Value1),
- High_Bound => Lit_Of (Value2));
- end if;
- end if;
-
- return Lit_Node;
- end Build_Choice;
-
- ------------
- -- Lit_Of --
- ------------
-
- function Lit_Of (Value : Uint) return Node_Id is
- Lit : Entity_Id;
-
- begin
- -- In the case where the literal is of type Character, there needs
- -- to be some special handling since there is no explicit chain
- -- of literals to search. Instead, a N_Character_Literal node
- -- is created with the appropriate Char_Code and Chars fields.
-
- if Root_Type (Choice_Type) = Standard_Character then
- Set_Character_Literal_Name (Char_Code (UI_To_Int (Value)));
- Lit := New_Node (N_Character_Literal, Loc);
- Set_Chars (Lit, Name_Find);
- Set_Char_Literal_Value (Lit, Char_Code (UI_To_Int (Value)));
- Set_Etype (Lit, Choice_Type);
- Set_Is_Static_Expression (Lit, True);
- return Lit;
-
- -- Otherwise, iterate through the literals list of Choice_Type
- -- "Value" number of times until the desired literal is reached
- -- and then return an occurrence of it.
-
- else
- Lit := First_Literal (Choice_Type);
- for J in 1 .. UI_To_Int (Value) loop
- Next_Literal (Lit);
- end loop;
-
- return New_Occurrence_Of (Lit, Loc);
- end if;
- end Lit_Of;
-
- -- Start of processing for Expand_Others_Choice
-
- begin
- if Case_Table'Length = 0 then
-
- -- Pathological case: only an others case is present.
- -- The others case covers the full range of the type.
-
- if Is_Static_Subtype (Choice_Type) then
- Choice := New_Occurrence_Of (Choice_Type, Loc);
- else
- Choice := New_Occurrence_Of (Base_Type (Choice_Type), Loc);
- end if;
-
- Set_Others_Discrete_Choices (Others_Choice, New_List (Choice));
- return;
- end if;
-
- -- Establish the bound values for the variant depending upon whether
- -- the type of the discriminant name is static or not.
-
- if Is_OK_Static_Subtype (Choice_Type) then
- Exp_Lo := Type_Low_Bound (Choice_Type);
- Exp_Hi := Type_High_Bound (Choice_Type);
- else
- Exp_Lo := Type_Low_Bound (Base_Type (Choice_Type));
- Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
- end if;
-
- Lo := Expr_Value (Case_Table (Case_Table'First).Lo);
- Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
- Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
-
- -- Build the node for any missing choices that are smaller than any
- -- explicit choices given in the variant.
-
- if Expr_Value (Exp_Lo) < Lo then
- Append (Build_Choice (Expr_Value (Exp_Lo), Lo - 1), Choice_List);
- end if;
-
- -- Build the nodes representing any missing choices that lie between
- -- the explicit ones given in the variant.
-
- for J in Case_Table'First + 1 .. Case_Table'Last loop
- Lo := Expr_Value (Case_Table (J).Lo);
- Hi := Expr_Value (Case_Table (J).Hi);
-
- if Lo /= (Previous_Hi + 1) then
- Append_To (Choice_List, Build_Choice (Previous_Hi + 1, Lo - 1));
- end if;
-
- Previous_Hi := Hi;
- end loop;
-
- -- Build the node for any missing choices that are greater than any
- -- explicit choices given in the variant.
-
- if Expr_Value (Exp_Hi) > Hi then
- Append (Build_Choice (Hi + 1, Expr_Value (Exp_Hi)), Choice_List);
- end if;
-
- Set_Others_Discrete_Choices (Others_Choice, Choice_List);
- end Expand_Others_Choice;
-
---------------------------------
- -- Expand_To_Girder_Constraint --
+ -- Expand_To_Stored_Constraint --
---------------------------------
- function Expand_To_Girder_Constraint
+ function Expand_To_Stored_Constraint
(Typ : Entity_Id;
Constraint : Elist_Id)
return Elist_Id
@@ -9197,7 +9283,7 @@ package body Sem_Ch3 is
end Type_With_Explicit_Discrims;
- -- Start of processing for Expand_To_Girder_Constraint
+ -- Start of processing for Expand_To_Stored_Constraint
begin
if No (Constraint)
@@ -9215,7 +9301,7 @@ package body Sem_Ch3 is
Expansion := New_Elmt_List;
Discriminant :=
- First_Girder_Discriminant (Explicitly_Discriminated_Type);
+ First_Stored_Discriminant (Explicitly_Discriminated_Type);
while Present (Discriminant) loop
@@ -9224,11 +9310,11 @@ package body Sem_Ch3 is
Discriminant, Explicitly_Discriminated_Type, Constraint),
Expansion);
- Next_Girder_Discriminant (Discriminant);
+ Next_Stored_Discriminant (Discriminant);
end loop;
return Expansion;
- end Expand_To_Girder_Constraint;
+ end Expand_To_Stored_Constraint;
--------------------
-- Find_Type_Name --
@@ -9549,6 +9635,10 @@ package body Sem_Ch3 is
function Can_Derive_From (E : Entity_Id) return Boolean;
-- Find if given digits value allows derivation from specified type
+ ---------------------
+ -- Can_Derive_From --
+ ---------------------
+
function Can_Derive_From (E : Entity_Id) return Boolean is
Spec : constant Entity_Id := Real_Range_Specification (Def);
@@ -9634,14 +9724,16 @@ package body Sem_Ch3 is
Bound := Type_Low_Bound (T);
if Nkind (Bound) = N_Real_Literal then
- Set_Realval (Bound, Machine (Base_Typ, Realval (Bound), Round));
+ Set_Realval
+ (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
Set_Is_Machine_Number (Bound);
end if;
Bound := Type_High_Bound (T);
if Nkind (Bound) = N_Real_Literal then
- Set_Realval (Bound, Machine (Base_Typ, Realval (Bound), Round));
+ Set_Realval
+ (Bound, Machine (Base_Typ, Realval (Bound), Round, Bound));
Set_Is_Machine_Number (Bound);
end if;
@@ -9692,7 +9784,7 @@ package body Sem_Ch3 is
-- The subtype issue is avoided by the use of
-- Original_Record_Component, and the fact that derived subtypes
- -- also derive the constraits.
+ -- also derive the constraints.
-- This chain leads back from
@@ -9716,18 +9808,22 @@ package body Sem_Ch3 is
Constraint : Elist_Id)
return Node_Id
is
- function Recurse
+ function Search_Derivation_Levels
(Ti : Entity_Id;
Discrim_Values : Elist_Id;
- Girder_Discrim_Values : Boolean)
- return Node_Or_Entity_Id;
+ Stored_Discrim_Values : Boolean)
+ return Node_Or_Entity_Id;
-- This is the routine that performs the recursive search of levels
-- as described above.
- function Recurse
+ ------------------------------
+ -- Search_Derivation_Levels --
+ ------------------------------
+
+ function Search_Derivation_Levels
(Ti : Entity_Id;
Discrim_Values : Elist_Id;
- Girder_Discrim_Values : Boolean)
+ Stored_Discrim_Values : Boolean)
return Node_Or_Entity_Id
is
Assoc : Elmt_Id;
@@ -9743,30 +9839,33 @@ package body Sem_Ch3 is
return Error;
end if;
- -- Look deeper if possible. Use Girder_Constraints only for
+ -- Look deeper if possible. Use Stored_Constraints only for
-- untagged types. For tagged types use the given constraint.
-- This asymmetry needs explanation???
- if not Girder_Discrim_Values
- and then Present (Girder_Constraint (Ti))
+ if not Stored_Discrim_Values
+ and then Present (Stored_Constraint (Ti))
and then not Is_Tagged_Type (Ti)
then
- Result := Recurse (Ti, Girder_Constraint (Ti), True);
+ Result :=
+ Search_Derivation_Levels (Ti, Stored_Constraint (Ti), True);
else
declare
- Td : Entity_Id := Etype (Ti);
- begin
+ Td : constant Entity_Id := Etype (Ti);
+ begin
if Td = Ti then
Result := Discriminant;
else
- if Present (Girder_Constraint (Ti)) then
+ if Present (Stored_Constraint (Ti)) then
Result :=
- Recurse (Td, Girder_Constraint (Ti), True);
+ Search_Derivation_Levels
+ (Td, Stored_Constraint (Ti), True);
else
Result :=
- Recurse (Td, Discrim_Values, Girder_Discrim_Values);
+ Search_Derivation_Levels
+ (Td, Discrim_Values, Stored_Discrim_Values);
end if;
end if;
end;
@@ -9783,10 +9882,10 @@ package body Sem_Ch3 is
and then Present (Corresponding_Record_Type (Ti))
then
Result :=
- Recurse (
+ Search_Derivation_Levels (
Corresponding_Record_Type (Ti),
Discrim_Values,
- Girder_Discrim_Values);
+ Stored_Discrim_Values);
elsif Is_Private_Type (Ti)
and then not Has_Discriminants (Ti)
@@ -9794,10 +9893,10 @@ package body Sem_Ch3 is
and then Etype (Full_View (Ti)) /= Ti
then
Result :=
- Recurse (
+ Search_Derivation_Levels (
Full_View (Ti),
Discrim_Values,
- Girder_Discrim_Values);
+ Stored_Discrim_Values);
end if;
end if;
@@ -9833,8 +9932,8 @@ package body Sem_Ch3 is
Assoc := First_Elmt (Discrim_Values);
- if Girder_Discrim_Values then
- Disc := First_Girder_Discriminant (Ti);
+ if Stored_Discrim_Values then
+ Disc := First_Stored_Discriminant (Ti);
else
Disc := First_Discriminant (Ti);
end if;
@@ -9849,8 +9948,8 @@ package body Sem_Ch3 is
Next_Elmt (Assoc);
- if Girder_Discrim_Values then
- Next_Girder_Discriminant (Disc);
+ if Stored_Discrim_Values then
+ Next_Stored_Discriminant (Disc);
else
Next_Discriminant (Disc);
end if;
@@ -9859,7 +9958,7 @@ package body Sem_Ch3 is
-- Could not find it
--
return Result;
- end Recurse;
+ end Search_Derivation_Levels;
Result : Node_Or_Entity_Id;
@@ -9886,7 +9985,8 @@ package body Sem_Ch3 is
end;
end if;
- Result := Recurse (Typ_For_Constraint, Constraint, False);
+ Result := Search_Derivation_Levels
+ (Typ_For_Constraint, Constraint, False);
-- ??? hack to disappear when this routine is gone
@@ -9894,6 +9994,7 @@ package body Sem_Ch3 is
declare
D : Entity_Id := First_Discriminant (Typ_For_Constraint);
E : Elmt_Id := First_Elmt (Constraint);
+
begin
while Present (D) loop
if Corresponding_Discriminant (D) = Discriminant then
@@ -9948,15 +10049,15 @@ package body Sem_Ch3 is
Discs : Elist_Id)
return Elist_Id
is
- Assoc_List : Elist_Id := New_Elmt_List;
+ Assoc_List : constant Elist_Id := New_Elmt_List;
procedure Inherit_Component
(Old_C : Entity_Id;
Plain_Discrim : Boolean := False;
- Girder_Discrim : Boolean := False);
+ Stored_Discrim : Boolean := False);
-- Inherits component Old_C from Parent_Base to the Derived_Base.
-- If Plain_Discrim is True, Old_C is a discriminant.
- -- If Girder_Discrim is True, Old_C is a girder discriminant.
+ -- If Stored_Discrim is True, Old_C is a stored discriminant.
-- If they are both false then Old_C is a regular component.
-----------------------
@@ -9966,22 +10067,22 @@ package body Sem_Ch3 is
procedure Inherit_Component
(Old_C : Entity_Id;
Plain_Discrim : Boolean := False;
- Girder_Discrim : Boolean := False)
+ Stored_Discrim : Boolean := False)
is
- New_C : Entity_Id := New_Copy (Old_C);
+ New_C : constant Entity_Id := New_Copy (Old_C);
Discrim : Entity_Id;
Corr_Discrim : Entity_Id;
begin
- pragma Assert (not Is_Tagged or else not Girder_Discrim);
+ pragma Assert (not Is_Tagged or else not Stored_Discrim);
Set_Parent (New_C, Parent (Old_C));
-- Regular discriminants and components must be inserted
-- in the scope of the Derived_Base. Do it here.
- if not Girder_Discrim then
+ if not Stored_Discrim then
Enter_Name (New_C);
end if;
@@ -10028,16 +10129,16 @@ package body Sem_Ch3 is
Set_Corresponding_Discriminant (New_C, Old_C);
Build_Discriminal (New_C);
- -- If we are explicitly inheriting a girder discriminant it will be
+ -- If we are explicitly inheriting a stored discriminant it will be
-- completely hidden.
- elsif Girder_Discrim then
+ elsif Stored_Discrim then
Set_Corresponding_Discriminant (New_C, Empty);
Set_Discriminal (New_C, Empty);
Set_Is_Completely_Hidden (New_C);
-- Set the Original_Record_Component of each discriminant in the
- -- derived base to point to the corresponding girder that we just
+ -- derived base to point to the corresponding stored that we just
-- created.
Discrim := First_Discriminant (Derived_Base);
@@ -10069,7 +10170,7 @@ package body Sem_Ch3 is
Loc : constant Source_Ptr := Sloc (N);
Parent_Discrim : Entity_Id;
- Girder_Discrim : Entity_Id;
+ Stored_Discrim : Entity_Id;
D : Entity_Id;
Component : Entity_Id;
@@ -10092,7 +10193,7 @@ package body Sem_Ch3 is
end loop;
end if;
- -- Create explicit girder discrims for untagged types when necessary.
+ -- Create explicit stored discrims for untagged types when necessary.
if not Has_Unknown_Discriminants (Derived_Base)
and then Has_Discriminants (Parent_Base)
@@ -10100,12 +10201,12 @@ package body Sem_Ch3 is
and then
(not Inherit_Discr
or else First_Discriminant (Parent_Base) /=
- First_Girder_Discriminant (Parent_Base))
+ First_Stored_Discriminant (Parent_Base))
then
- Girder_Discrim := First_Girder_Discriminant (Parent_Base);
- while Present (Girder_Discrim) loop
- Inherit_Component (Girder_Discrim, Girder_Discrim => True);
- Next_Girder_Discriminant (Girder_Discrim);
+ Stored_Discrim := First_Stored_Discriminant (Parent_Base);
+ while Present (Stored_Discrim) loop
+ Inherit_Component (Stored_Discrim, Stored_Discrim => True);
+ Next_Stored_Discriminant (Stored_Discrim);
end loop;
end if;
@@ -10231,10 +10332,44 @@ package body Sem_Ch3 is
--------------------------
function Is_Visible_Component (C : Entity_Id) return Boolean is
- Original_Comp : constant Entity_Id := Original_Record_Component (C);
+ Original_Comp : Entity_Id := Empty;
Original_Scope : Entity_Id;
+ Type_Scope : Entity_Id;
+
+ function Is_Local_Type (Typ : Entity_Id) return Boolean;
+ -- Check whether parent type of inherited component is declared
+ -- locally, possibly within a nested package or instance. The
+ -- current scope is the derived record itself.
+
+ -------------------
+ -- Is_Local_Type --
+ -------------------
+
+ function Is_Local_Type (Typ : Entity_Id) return Boolean is
+ Scop : Entity_Id := Scope (Typ);
+
+ begin
+ while Present (Scop)
+ and then Scop /= Standard_Standard
+ loop
+ if Scop = Scope (Current_Scope) then
+ return True;
+ end if;
+
+ Scop := Scope (Scop);
+ end loop;
+ return False;
+ end Is_Local_Type;
+
+ -- Start of processing for Is_Visible_Component
begin
+ if Ekind (C) = E_Component
+ or else Ekind (C) = E_Discriminant
+ then
+ Original_Comp := Original_Record_Component (C);
+ end if;
+
if No (Original_Comp) then
-- Premature usage, or previous error
@@ -10243,14 +10378,15 @@ package body Sem_Ch3 is
else
Original_Scope := Scope (Original_Comp);
+ Type_Scope := Scope (Base_Type (Scope (C)));
end if;
- -- This test only concern tagged types
+ -- This test only concerns tagged types
if not Is_Tagged_Type (Original_Scope) then
return True;
- -- If it is _Parent or _Tag, there is no visiblity issue
+ -- If it is _Parent or _Tag, there is no visibility issue
elsif not Comes_From_Source (Original_Comp) then
return True;
@@ -10275,25 +10411,42 @@ package body Sem_Ch3 is
-- open scope and the original component's enclosing type
-- is a visible full type of a private type (which can occur
-- in cases where an attempt is being made to reference a
- -- component in a sibling package that is inherited from
- -- a visible component of a type in an ancestor package;
- -- the component in the sibling package should not be
- -- visible even though the component it inherited from
- -- is visible). This does not apply however in the case
- -- where the scope of the type is a private child unit.
- -- The latter suppression of visibility is needed for cases
- -- that are tested in B730006.
-
- elsif (Ekind (Original_Comp) /= E_Discriminant
- or else Has_Unknown_Discriminants (Original_Scope))
- and then
- (Is_Private_Type (Original_Scope)
- or else
- (not Is_Private_Descendant (Scope (Base_Type (Scope (C))))
- and then not In_Open_Scopes (Scope (Base_Type (Scope (C))))
- and then Has_Private_Declaration (Original_Scope)))
+ -- component in a sibling package that is inherited from a
+ -- visible component of a type in an ancestor package; the
+ -- component in the sibling package should not be visible
+ -- even though the component it inherited from is visible).
+ -- This does not apply however in the case where the scope
+ -- of the type is a private child unit, or when the parent
+ -- comes from a local package in which the ancestor is
+ -- currently visible. The latter suppression of visibility
+ -- is needed for cases that are tested in B730006.
+
+ elsif Is_Private_Type (Original_Scope)
+ or else
+ (not Is_Private_Descendant (Type_Scope)
+ and then not In_Open_Scopes (Type_Scope)
+ and then Has_Private_Declaration (Original_Scope))
then
- return False;
+ -- If the type derives from an entity in a formal package, there
+ -- are no additional visible components.
+
+ if Nkind (Original_Node (Unit_Declaration_Node (Type_Scope))) =
+ N_Formal_Package_Declaration
+ then
+ return False;
+
+ -- if we are not in the private part of the current package, there
+ -- are no additional visible components.
+
+ elsif Ekind (Scope (Current_Scope)) = E_Package
+ and then not In_Private_Part (Scope (Current_Scope))
+ then
+ return False;
+ else
+ return
+ Is_Child_Unit (Cunit_Entity (Current_Sem_Unit))
+ and then Is_Local_Type (Type_Scope);
+ end if;
-- There is another weird way in which a component may be invisible
-- when the private and the full view are not derived from the same
@@ -10303,7 +10456,7 @@ package body Sem_Ch3 is
-- type A2 is new A1 with record F2 : integer; end record;
-- type T is new A1 with private;
-- private
- -- type T is new A2 with private;
+ -- type T is new A2 with null record;
-- In this case, the full view of T inherits F1 and F2 but the
-- private view inherits only F1
@@ -10491,6 +10644,26 @@ package body Sem_Ch3 is
return;
end if;
+ if Nkind (Low_Bound (I)) = N_Attribute_Reference
+ and then Attribute_Name (Low_Bound (I)) = Name_First
+ and then Is_Entity_Name (Prefix (Low_Bound (I)))
+ and then Is_Type (Entity (Prefix (Low_Bound (I))))
+ and then Is_Discrete_Type (Entity (Prefix (Low_Bound (I))))
+ then
+ -- The type of the index will be the type of the prefix,
+ -- as long as the upper bound is 'Last of the same type.
+
+ Def_Id := Entity (Prefix (Low_Bound (I)));
+
+ if Nkind (High_Bound (I)) /= N_Attribute_Reference
+ or else Attribute_Name (High_Bound (I)) /= Name_Last
+ or else not Is_Entity_Name (Prefix (High_Bound (I)))
+ or else Entity (Prefix (High_Bound (I))) /= Def_Id
+ then
+ Def_Id := Empty;
+ end if;
+ end if;
+
R := I;
Process_Range_Expr_In_Decl (R, T);
@@ -10515,6 +10688,17 @@ package body Sem_Ch3 is
-- The parser guarantees that the attribute is a RANGE attribute
+ -- If the node denotes the range of a type mark, that is also the
+ -- resulting type, and we do no need to create an Itype for it.
+
+ if Is_Entity_Name (Prefix (I))
+ and then Comes_From_Source (I)
+ and then Is_Type (Entity (Prefix (I)))
+ and then Is_Discrete_Type (Entity (Prefix (I)))
+ then
+ Def_Id := Entity (Prefix (I));
+ end if;
+
Analyze_And_Resolve (I);
T := Etype (I);
R := I;
@@ -10568,11 +10752,12 @@ package body Sem_Ch3 is
Analyze (I);
T := Etype (I);
- Resolve (I, T);
+ Resolve (I);
R := I;
+ -- If expander is inactive, type is legal, nothing else to construct
+
else
- -- Type is legal, nothing else to construct.
return;
end if;
end if;
@@ -10602,10 +10787,6 @@ package body Sem_Ch3 is
-- We signal this case by setting the subtype entity in Def_Id.
- -- It would be nice to also do this optimization for the cases
- -- of X'Range and also the explicit range X'First .. X'Last,
- -- but that is not done yet (it is just an efficiency concern) ???
-
if No (Def_Id) then
Def_Id :=
@@ -10621,6 +10802,7 @@ package body Sem_Ch3 is
else
Set_Ekind (Def_Id, E_Enumeration_Subtype);
Set_Is_Character_Type (Def_Id, Is_Character_Type (T));
+ Set_First_Literal (Def_Id, First_Literal (T));
end if;
Set_Size_Info (Def_Id, (T));
@@ -10657,6 +10839,10 @@ package body Sem_Ch3 is
procedure Set_Modular_Size (Bits : Int);
-- Sets RM_Size to Bits, and Esize to normal word size above this
+ ----------------------
+ -- Set_Modular_Size --
+ ----------------------
+
procedure Set_Modular_Size (Bits : Int) is
begin
Set_RM_Size (T, UI_From_Int (Bits));
@@ -10685,8 +10871,8 @@ package body Sem_Ch3 is
Set_Is_Constrained (T);
if not Is_OK_Static_Expression (Mod_Expr) then
- Error_Msg_N
- ("non-static expression used for modular type bound", Mod_Expr);
+ Flag_Non_Static_Expr
+ ("non-static expression used for modular type bound!", Mod_Expr);
M_Val := 2 ** System_Max_Binary_Modulus_Power;
else
M_Val := Expr_Value (Mod_Expr);
@@ -10970,14 +11156,17 @@ package body Sem_Ch3 is
-- Process_Discriminants --
---------------------------
- procedure Process_Discriminants (N : Node_Id) is
+ procedure Process_Discriminants
+ (N : Node_Id;
+ Prev : Entity_Id := Empty)
+ is
+ Elist : constant Elist_Id := New_Elmt_List;
Id : Node_Id;
Discr : Node_Id;
Discr_Number : Uint;
Discr_Type : Entity_Id;
Default_Present : Boolean := False;
Default_Not_Present : Boolean := False;
- Elist : Elist_Id := New_Elmt_List;
begin
-- A composite type other than an array type can have discriminants.
@@ -10992,6 +11181,25 @@ package body Sem_Ch3 is
while Present (Discr) loop
Enter_Name (Defining_Identifier (Discr));
+ -- For navigation purposes we add a reference to the discriminant
+ -- in the entity for the type. If the current declaration is a
+ -- completion, place references on the partial view. Otherwise the
+ -- type is the current scope.
+
+ if Present (Prev) then
+
+ -- The references go on the partial view, if present. If the
+ -- partial view has discriminants, the references have been
+ -- generated already.
+
+ if not Has_Discriminants (Prev) then
+ Generate_Reference (Prev, Defining_Identifier (Discr), 'd');
+ end if;
+ else
+ Generate_Reference
+ (Current_Scope, Defining_Identifier (Discr), 'd');
+ end if;
+
if Nkind (Discriminant_Type (Discr)) = N_Access_Definition then
Discr_Type := Access_Definition (N, Discriminant_Type (Discr));
@@ -11025,11 +11233,11 @@ package body Sem_Ch3 is
-- expression of the discriminant; the default expression must be of
-- the type of the discriminant. (RM 3.7.1) Since this expression is
-- a default expression, we do the special preanalysis, since this
- -- expression does not freeze (see "Handling of Default Expressions"
- -- in spec of package Sem).
+ -- expression does not freeze (see "Handling of Default and Per-
+ -- Object Expressions" in spec of package Sem).
if Present (Expression (Discr)) then
- Analyze_Default_Expression (Expression (Discr), Discr_Type);
+ Analyze_Per_Use_Expression (Expression (Discr), Discr_Type);
if Nkind (N) = N_Formal_Type_Declaration then
Error_Msg_N
@@ -11068,7 +11276,7 @@ package body Sem_Ch3 is
-- for the type.
Set_Discriminant_Constraint (Current_Scope, Elist);
- Set_Girder_Constraint (Current_Scope, No_Elist);
+ Set_Stored_Constraint (Current_Scope, No_Elist);
-- Default expressions must be provided either for all or for none
-- of the discriminants of a discriminant part. (RM 3.7.1)
@@ -11140,6 +11348,7 @@ package body Sem_Ch3 is
then
Error_Msg_N
("completion of nonlimited type cannot be limited", Full_T);
+ Explain_Limited_Type (Full_T, Full_T);
elsif Is_Abstract (Full_T) and then not Is_Abstract (Priv_T) then
Error_Msg_N
@@ -11385,8 +11594,9 @@ package body Sem_Ch3 is
Prim := Next_Entity (Full_T);
while Present (Prim) and then Prim /= Priv_T loop
- if (Ekind (Prim) = E_Procedure
- or else Ekind (Prim) = E_Function)
+ if Ekind (Prim) = E_Procedure
+ or else
+ Ekind (Prim) = E_Function
then
D_Type := Find_Dispatching_Type (Prim);
@@ -11625,7 +11835,7 @@ package body Sem_Ch3 is
-- not be raised.
-- ??? The following code should be cleaned up as follows
- -- 1. The Is_Null_Range (Lo, Hi) test should disapper since it
+ -- 1. The Is_Null_Range (Lo, Hi) test should disappear since it
-- is done in the call to Range_Check (R, T); below
-- 2. The use of R_Check_Off should be investigated and possibly
-- removed, this would clean up things a bit.
@@ -11634,9 +11844,18 @@ package body Sem_Ch3 is
null;
else
+ -- Capture values of bounds and generate temporaries for them
+ -- if needed, before applying checks, since checks may cause
+ -- duplication of the expression without forcing evaluation.
+
+ if Expander_Active then
+ Force_Evaluation (Lo);
+ Force_Evaluation (Hi);
+ end if;
+
-- We use a flag here instead of suppressing checks on the
- -- type because the type we check against isn't necessarily the
- -- place where we put the check.
+ -- type because the type we check against isn't necessarily
+ -- the place where we put the check.
if not R_Check_Off then
R_Checks := Range_Check (R, T);
@@ -11668,9 +11887,13 @@ package body Sem_Ch3 is
-- short regression tests fail.
if Present (Type_Decl) then
+
+ -- Case of loop statement (more comments ???)
+
if Nkind (Type_Decl) = N_Loop_Statement then
declare
Indic : Node_Id := Parent (R);
+
begin
while Present (Indic) and then not
(Nkind (Indic) = N_Subtype_Indication)
@@ -11690,6 +11913,9 @@ package body Sem_Ch3 is
Do_Before => True);
end if;
end;
+
+ -- All other cases (more comments ???)
+
else
Def_Id := Defining_Identifier (Type_Decl);
@@ -11711,15 +11937,12 @@ package body Sem_Ch3 is
end if;
end if;
end if;
- end if;
-
- Get_Index_Bounds (R, Lo, Hi);
- if Expander_Active then
+ elsif Expander_Active then
+ Get_Index_Bounds (R, Lo, Hi);
Force_Evaluation (Lo);
Force_Evaluation (Hi);
end if;
-
end Process_Range_Expr_In_Decl;
--------------------------------------
@@ -11735,17 +11958,23 @@ package body Sem_Ch3 is
procedure Analyze_Bound (N : Node_Id);
-- Analyze and check one bound
+ -------------------
+ -- Analyze_Bound --
+ -------------------
+
procedure Analyze_Bound (N : Node_Id) is
begin
Analyze_And_Resolve (N, Any_Real);
if not Is_OK_Static_Expression (N) then
- Error_Msg_N
- ("bound in real type definition is not static", N);
+ Flag_Non_Static_Expr
+ ("bound in real type definition is not static!", N);
Err := True;
end if;
end Analyze_Bound;
+ -- Start of processing for Process_Real_Range_Specification
+
begin
if Present (Spec) then
Lo := Low_Bound (Spec);
@@ -11776,13 +12005,37 @@ package body Sem_Ch3 is
Def_Id : Entity_Id;
Full_View_Id : Entity_Id;
Subtype_Mark_Id : Entity_Id;
- N_Dynamic_Ityp : Node_Id := Empty;
+
+ procedure Check_Incomplete (T : Entity_Id);
+ -- Called to verify that an incomplete type is not used prematurely
+
+ ----------------------
+ -- Check_Incomplete --
+ ----------------------
+
+ procedure Check_Incomplete (T : Entity_Id) is
+ begin
+ if Ekind (Root_Type (Entity (T))) = E_Incomplete_Type then
+ Error_Msg_N ("invalid use of type before its full declaration", T);
+ end if;
+ end Check_Incomplete;
+
+ -- Start of processing for Process_Subtype
begin
+ -- Case of no constraints present
+
+ if Nkind (S) /= N_Subtype_Indication then
+
+ Find_Type (S);
+ Check_Incomplete (S);
+ return Entity (S);
+
-- Case of constraint present, so that we have an N_Subtype_Indication
-- node (this node is created only if constraints are present).
- if Nkind (S) = N_Subtype_Indication then
+ else
+
Find_Type (Subtype_Mark (S));
if Nkind (Parent (S)) /= N_Access_To_Object_Definition
@@ -11835,8 +12088,6 @@ package body Sem_Ch3 is
Def_Id :=
Create_Itype (E_Void, Related_Nod, Related_Id, Suffix);
end if;
-
- N_Dynamic_Ityp := Related_Nod;
end if;
-- If the kind of constraint is invalid for this kind of type,
@@ -11934,12 +12185,6 @@ package body Sem_Ch3 is
return Def_Id;
- -- Case of no constraints present
-
- else
- Find_Type (S);
- Check_Incomplete (S);
- return Entity (S);
end if;
end Process_Subtype;
@@ -11947,9 +12192,12 @@ package body Sem_Ch3 is
-- Record_Type_Declaration --
-----------------------------
- procedure Record_Type_Declaration (T : Entity_Id; N : Node_Id) is
+ procedure Record_Type_Declaration
+ (T : Entity_Id;
+ N : Node_Id;
+ Prev : Entity_Id)
+ is
Def : constant Node_Id := Type_Definition (N);
- Range_Checks_Suppressed_Flag : Boolean := False;
Is_Tagged : Boolean;
Tag_Comp : Entity_Id;
@@ -11987,14 +12235,14 @@ package body Sem_Ch3 is
Set_Etype (T, T);
Init_Size_Align (T);
- Set_Girder_Constraint (T, No_Elist);
+ Set_Stored_Constraint (T, No_Elist);
-- If an incomplete or private type declaration was already given for
-- the type, then this scope already exists, and the discriminants have
-- been declared within. We must verify that the full declaration
-- matches the incomplete one.
- Check_Or_Process_Discriminants (N, T);
+ Check_Or_Process_Discriminants (N, T, Prev);
Set_Is_Constrained (T, not Has_Discriminants (T));
Set_Has_Delayed_Freeze (T, True);
@@ -12025,19 +12273,15 @@ package body Sem_Ch3 is
-- We must suppress range checks when processing the components
-- of a record in the presence of discriminants, since we don't
-- want spurious checks to be generated during their analysis, but
- -- must reset the Suppress_Range_Checks flags after having procesed
+ -- must reset the Suppress_Range_Checks flags after having processed
-- the record definition.
- if Has_Discriminants (T) and then not Suppress_Range_Checks (T) then
- Set_Suppress_Range_Checks (T, True);
- Range_Checks_Suppressed_Flag := True;
- end if;
-
- Record_Type_Definition (Def, T);
-
- if Range_Checks_Suppressed_Flag then
- Set_Suppress_Range_Checks (T, False);
- Range_Checks_Suppressed_Flag := False;
+ if Has_Discriminants (T) and then not Range_Checks_Suppressed (T) then
+ Set_Kill_Range_Checks (T, True);
+ Record_Type_Definition (Def, Prev);
+ Set_Kill_Range_Checks (T, False);
+ else
+ Record_Type_Definition (Def, Prev);
end if;
-- Exit from record scope
@@ -12049,12 +12293,21 @@ package body Sem_Ch3 is
-- Record_Type_Definition --
----------------------------
- procedure Record_Type_Definition (Def : Node_Id; T : Entity_Id) is
+ procedure Record_Type_Definition (Def : Node_Id; Prev_T : Entity_Id) is
Component : Entity_Id;
Ctrl_Components : Boolean := False;
- Final_Storage_Only : Boolean := not Is_Controlled (T);
+ Final_Storage_Only : Boolean;
+ T : Entity_Id;
begin
+ if Ekind (Prev_T) = E_Incomplete_Type then
+ T := Full_View (Prev_T);
+ else
+ T := Prev_T;
+ end if;
+
+ Final_Storage_Only := not Is_Controlled (T);
+
-- If the component list of a record type is defined by the reserved
-- word null and there is no discriminant part, then the record type has
-- no components and all records of the type are null records (RM 3.7)
@@ -12115,8 +12368,11 @@ package body Sem_Ch3 is
Set_Finalize_Storage_Only (T, Final_Storage_Only);
end if;
+ -- Place reference to end record on the proper entity, which may
+ -- be a partial view.
+
if Present (Def) then
- Process_End_Label (Def, 'e', T);
+ Process_End_Label (Def, 'e', Prev_T);
end if;
end Record_Type_Definition;
@@ -12232,28 +12488,6 @@ package body Sem_Ch3 is
Set_Parent (S, E);
end Set_Fixed_Range;
- --------------------------------------------------------
- -- Set_Girder_Constraint_From_Discriminant_Constraint --
- --------------------------------------------------------
-
- procedure Set_Girder_Constraint_From_Discriminant_Constraint
- (E : Entity_Id)
- is
- begin
- -- Make sure set if encountered during
- -- Expand_To_Girder_Constraint
-
- Set_Girder_Constraint (E, No_Elist);
-
- -- Give it the right value
-
- if Is_Constrained (E) and then Has_Discriminants (E) then
- Set_Girder_Constraint (E,
- Expand_To_Girder_Constraint (E, Discriminant_Constraint (E)));
- end if;
-
- end Set_Girder_Constraint_From_Discriminant_Constraint;
-
----------------------------------
-- Set_Scalar_Range_For_Subtype --
----------------------------------
@@ -12286,6 +12520,28 @@ package body Sem_Ch3 is
end Set_Scalar_Range_For_Subtype;
+ --------------------------------------------------------
+ -- Set_Stored_Constraint_From_Discriminant_Constraint --
+ --------------------------------------------------------
+
+ procedure Set_Stored_Constraint_From_Discriminant_Constraint
+ (E : Entity_Id)
+ is
+ begin
+ -- Make sure set if encountered during
+ -- Expand_To_Stored_Constraint
+
+ Set_Stored_Constraint (E, No_Elist);
+
+ -- Give it the right value
+
+ if Is_Constrained (E) and then Has_Discriminants (E) then
+ Set_Stored_Constraint (E,
+ Expand_To_Stored_Constraint (E, Discriminant_Constraint (E)));
+ end if;
+
+ end Set_Stored_Constraint_From_Discriminant_Constraint;
+
-------------------------------------
-- Signed_Integer_Type_Declaration --
-------------------------------------
@@ -12306,6 +12562,10 @@ package body Sem_Ch3 is
-- Check bound to make sure it is integral and static. If not, post
-- appropriate error message and set Errs flag
+ ---------------------
+ -- Can_Derive_From --
+ ---------------------
+
function Can_Derive_From (E : Entity_Id) return Boolean is
Lo : constant Uint := Expr_Value (Type_Low_Bound (E));
Hi : constant Uint := Expr_Value (Type_High_Bound (E));
@@ -12319,6 +12579,10 @@ package body Sem_Ch3 is
Lo <= Hi_Val and then Hi_Val <= Hi;
end Can_Derive_From;
+ -----------------
+ -- Check_Bound --
+ -----------------
+
procedure Check_Bound (Expr : Node_Id) is
begin
-- If a range constraint is used as an integer type definition, each
@@ -12332,8 +12596,8 @@ package body Sem_Ch3 is
Errs := True;
elsif not Is_OK_Static_Expression (Expr) then
- Error_Msg_N
- ("non-static expression used for integer type bound", Expr);
+ Flag_Non_Static_Expr
+ ("non-static expression used for integer type bound!", Expr);
Errs := True;
-- The bounds are folded into literals, and we set their type to be
@@ -12344,7 +12608,7 @@ package body Sem_Ch3 is
else
if Is_Entity_Name (Expr) then
- Fold_Uint (Expr, Expr_Value (Expr));
+ Fold_Uint (Expr, Expr_Value (Expr), True);
end if;
Set_Etype (Expr, Universal_Integer);
@@ -12428,7 +12692,6 @@ package body Sem_Ch3 is
Set_Scalar_Range (T, Def);
Set_RM_Size (T, UI_From_Int (Minimum_Size (T)));
Set_Is_Constrained (T);
-
end Signed_Integer_Type_Declaration;
end Sem_Ch3;
diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads
index ebcd861dbe5..5a37de89ab4 100644
--- a/gcc/ada/sem_ch3.ads
+++ b/gcc/ada/sem_ch3.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -63,11 +63,13 @@ package Sem_Ch3 is
-- Called to analyze a list of declarations (in what context ???). Also
-- performs necessary freezing actions (more description needed ???)
- procedure Analyze_Default_Expression (N : Node_Id; T : Entity_Id);
- -- Default expressions do not freeze their components, and must be
- -- analyzed and resolved accordingly, by calling the
- -- Pre_Analyze_And_Resolve routine and setting the global
- -- In_Default_Expression flag.
+ procedure Analyze_Per_Use_Expression (N : Node_Id; T : Entity_Id);
+ -- Default and per object expressions do not freeze their components,
+ -- and must be analyzed and resolved accordingly. The analysis is
+ -- done by calling the Pre_Analyze_And_Resolve routine and setting
+ -- the global In_Default_Expression flag. See the documentation section
+ -- entitled "Handling of Default and Per-Object Expressions" in sem.ads
+ -- for details. N is the expression to be analyzed, T is the expected type.
procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id);
-- Process an array type declaration. If the array is constrained, we
@@ -121,15 +123,6 @@ package Sem_Ch3 is
-- the instance. For tagged types, the derived subprograms are aliased to
-- those of the actual, not those of the ancestor.
- function Expand_To_Girder_Constraint
- (Typ : Entity_Id;
- Constraint : Elist_Id)
- return Elist_Id;
- -- Given a Constraint (ie a list of expressions) on the discriminants of
- -- Typ, expand it into a constraint on the girder discriminants and
- -- return the new list of expressions constraining the girder
- -- discriminants.
-
function Find_Type_Name (N : Node_Id) return Entity_Id;
-- Enter the identifier in a type definition, or find the entity already
-- declared, in the case of the full declaration of an incomplete or
@@ -173,7 +166,7 @@ package Sem_Ch3 is
procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id);
-- Process some semantic actions when the full view of a private type is
-- encountered and analyzed. The first action is to create the full views
- -- of the dependent private subtypes. The second action is to recopy the
+ -- of the dependant private subtypes. The second action is to recopy the
-- primitive operations of the private view (in the tagged case).
-- N is the N_Full_Type_Declaration node.
@@ -209,9 +202,12 @@ package Sem_Ch3 is
-- will be inserted. The Related_Id and Suffix parameters are used to
-- build the associated Implicit type name.
- procedure Process_Discriminants (N : Node_Id);
+ procedure Process_Discriminants
+ (N : Node_Id;
+ Prev : Entity_Id := Empty);
-- Process the discriminants contained in an N_Full_Type_Declaration or
- -- N_Incomplete_Type_Decl node N.
+ -- N_Incomplete_Type_Decl node N. If the declaration is a completion,
+ -- Prev is entity on the partial view, on which references are posted.
procedure Set_Completion_Referenced (E : Entity_Id);
-- If E is the completion of a private or incomplete type declaration,
@@ -219,9 +215,4 @@ package Sem_Ch3 is
-- as referenced. Warnings on unused entities, if needed, go on the
-- partial view.
- procedure Set_Girder_Constraint_From_Discriminant_Constraint
- (E : Entity_Id);
- -- E is some record type. This routine computes E's Girder_Constraint
- -- from its Discriminant_Constraint.
-
end Sem_Ch3;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 23d17e9bdd9..81c4e2ab22e 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.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- --
@@ -92,10 +92,6 @@ package body Sem_Ch4 is
-- for equality, membership, and comparison operators with overloaded
-- arguments, list possible interpretations.
- procedure Insert_Explicit_Dereference (N : Node_Id);
- -- In a context that requires a composite or subprogram type and
- -- where a prefix is an access type, insert an explicit dereference.
-
procedure Analyze_One_Call
(N : Node_Id;
Nam : Entity_Id;
@@ -237,11 +233,9 @@ package body Sem_Ch4 is
------------------------
procedure Ambiguous_Operands (N : Node_Id) is
- procedure List_Interps (Opnd : Node_Id);
+ procedure List_Operand_Interps (Opnd : Node_Id);
- procedure List_Interps (Opnd : Node_Id) is
- Index : Interp_Index;
- It : Interp;
+ procedure List_Operand_Interps (Opnd : Node_Id) is
Nam : Node_Id;
Err : Node_Id := N;
@@ -270,24 +264,8 @@ package body Sem_Ch4 is
Err := Opnd;
end if;
- Get_First_Interp (Nam, Index, It);
-
- while Present (It.Nam) loop
-
- if Scope (It.Nam) = Standard_Standard
- and then Scope (It.Typ) /= Standard_Standard
- then
- Error_Msg_Sloc := Sloc (Parent (It.Typ));
- Error_Msg_NE (" & (inherited) declared#!", Err, It.Nam);
-
- else
- Error_Msg_Sloc := Sloc (It.Nam);
- Error_Msg_NE (" & declared#!", Err, It.Nam);
- end if;
-
- Get_Next_Interp (Index, It);
- end loop;
- end List_Interps;
+ List_Interps (Nam, Err);
+ end List_Operand_Interps;
begin
if Nkind (N) = N_In
@@ -305,8 +283,8 @@ package body Sem_Ch4 is
end if;
if All_Errors_Mode then
- List_Interps (Left_Opnd (N));
- List_Interps (Right_Opnd (N));
+ List_Operand_Interps (Left_Opnd (N));
+ List_Operand_Interps (Right_Opnd (N));
else
if OpenVMS then
@@ -365,6 +343,7 @@ package body Sem_Ch4 is
and then not In_Instance_Body
then
Error_Msg_N ("initialization not allowed for limited types", N);
+ Explain_Limited_Type (Type_Id, N);
end if;
Analyze_And_Resolve (Expression (E), Type_Id);
@@ -483,6 +462,7 @@ package body Sem_Ch4 is
end if;
if Has_Task (Designated_Type (Acc_Type)) then
+ Check_Restriction (Max_Tasks, N);
Check_Restriction (No_Task_Allocators, N);
end if;
@@ -496,7 +476,6 @@ package body Sem_Ch4 is
Set_Error_Posted (N);
Set_Etype (N, Any_Type);
end if;
-
end Analyze_Allocator;
---------------------------
@@ -764,7 +743,9 @@ package body Sem_Ch4 is
if Success then
Set_Etype (Nam, It.Typ);
- elsif Nkind (Name (N)) = N_Selected_Component then
+ elsif Nkind (Name (N)) = N_Selected_Component
+ or else Nkind (Name (N)) = N_Function_Call
+ then
Remove_Interp (X);
end if;
@@ -923,7 +904,9 @@ package body Sem_Ch4 is
-- If the entity is present, the node appears in an instance,
-- and denotes a predefined concatenation operation. The resulting
- -- type is obtained from the arguments when possible.
+ -- type is obtained from the arguments when possible. If the arguments
+ -- are aggregates, the array type and the concatenation type must be
+ -- visible.
if Present (Op_Id) then
if Ekind (Op_Id) = E_Operator then
@@ -941,8 +924,32 @@ package body Sem_Ch4 is
then
Add_One_Interp (N, Op_Id, RT);
- else
+ -- If one operand is a string type or a user-defined array type,
+ -- and the other is a literal, result is of the specific type.
+
+ elsif
+ (Root_Type (LT) = Standard_String
+ or else Scope (LT) /= Standard_Standard)
+ and then Etype (R) = Any_String
+ then
+ Add_One_Interp (N, Op_Id, LT);
+
+ elsif
+ (Root_Type (RT) = Standard_String
+ or else Scope (RT) /= Standard_Standard)
+ and then Etype (L) = Any_String
+ then
+ Add_One_Interp (N, Op_Id, RT);
+
+ elsif not Is_Generic_Type (Etype (Op_Id)) then
Add_One_Interp (N, Op_Id, Etype (Op_Id));
+
+ else
+ -- Type and its operations must be visible.
+
+ Set_Entity (N, Empty);
+ Analyze_Concatenation (N);
+
end if;
else
@@ -1262,12 +1269,12 @@ package body Sem_Ch4 is
------------------------------------
procedure Analyze_Indexed_Component_Form (N : Node_Id) is
- P : constant Node_Id := Prefix (N);
- Exprs : List_Id := Expressions (N);
- Exp : Node_Id;
- P_T : Entity_Id;
- E : Node_Id;
- U_N : Entity_Id;
+ P : constant Node_Id := Prefix (N);
+ Exprs : constant List_Id := Expressions (N);
+ Exp : Node_Id;
+ P_T : Entity_Id;
+ E : Node_Id;
+ U_N : Entity_Id;
procedure Process_Function_Call;
-- Prefix in indexed component form is an overloadable entity,
@@ -1333,10 +1340,7 @@ package body Sem_Ch4 is
if Is_Access_Type (Array_Type) then
Array_Type := Designated_Type (Array_Type);
-
- if Warn_On_Dereference then
- Error_Msg_N ("?implicit dereference", N);
- end if;
+ Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
end if;
if Is_Array_Type (Array_Type) then
@@ -1500,10 +1504,7 @@ package body Sem_Ch4 is
if Is_Access_Type (Typ) then
Typ := Designated_Type (Typ);
-
- if Warn_On_Dereference then
- Error_Msg_N ("?implicit dereference", N);
- end if;
+ Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
end if;
if Is_Array_Type (Typ) then
@@ -1554,6 +1555,18 @@ package body Sem_Ch4 is
-- Get name of array, function or type
Analyze (P);
+ if Nkind (N) = N_Function_Call
+ or else Nkind (N) = N_Procedure_Call_Statement
+ then
+ -- If P is an explicit dereference whose prefix is of a
+ -- remote access-to-subprogram type, then N has already
+ -- been rewritten as a subprogram call and analyzed.
+
+ return;
+ end if;
+
+ pragma Assert (Nkind (N) = N_Indexed_Component);
+
P_T := Base_Type (Etype (P));
if Is_Entity_Name (P)
@@ -1596,9 +1609,8 @@ package body Sem_Ch4 is
Process_Function_Call;
- elsif Ekind (U_N) = E_Generic_Function
- or else Ekind (U_N) = E_Generic_Procedure
- then
+ elsif Is_Generic_Subprogram (U_N) then
+
-- A common beginner's (or C++ templates fan) error.
Error_Msg_N ("generic subprogram cannot be called", N);
@@ -1613,8 +1625,7 @@ package body Sem_Ch4 is
-- an array or an access-to-subprogram.
else
-
- if (Ekind (P_T) = E_Subprogram_Type)
+ if Ekind (P_T) = E_Subprogram_Type
or else (Is_Access_Type (P_T)
and then
Ekind (Designated_Type (P_T)) = E_Subprogram_Type)
@@ -1629,6 +1640,7 @@ package body Sem_Ch4 is
else
-- Indexed component, slice, or a call to a member of a family
-- entry, which will be converted to an entry call later.
+
Process_Indexed_Component_Or_Slice;
end if;
end if;
@@ -1829,15 +1841,15 @@ package body Sem_Ch4 is
Subp_Type : constant Entity_Id := Etype (Nam);
Norm_OK : Boolean;
- procedure Set_Name;
+ procedure Indicate_Name_And_Type;
-- If candidate interpretation matches, indicate name and type of
-- result on call node.
- --------------
- -- Set_Name --
- --------------
+ ----------------------------
+ -- Indicate_Name_And_Type --
+ ----------------------------
- procedure Set_Name is
+ procedure Indicate_Name_And_Type is
begin
Add_One_Interp (N, Nam, Etype (Nam));
Success := True;
@@ -1866,7 +1878,7 @@ package body Sem_Ch4 is
Write_Int (Int (Nam));
Write_Eol;
end if;
- end Set_Name;
+ end Indicate_Name_And_Type;
-- Start of processing for Analyze_One_Call
@@ -1934,10 +1946,9 @@ package body Sem_Ch4 is
-- If Normalize succeeds, then there are default parameters for
-- all formals.
- Set_Name;
+ Indicate_Name_And_Type;
elsif Ekind (Nam) = E_Operator then
-
if Nkind (N) = N_Procedure_Call_Statement then
return;
end if;
@@ -2005,8 +2016,8 @@ package body Sem_Ch4 is
while Present (Actual) and then Present (Formal) loop
- if (Nkind (Parent (Actual)) /= N_Parameter_Association
- or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal))
+ if Nkind (Parent (Actual)) /= N_Parameter_Association
+ or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal)
then
if Has_Compatible_Type (Actual, Etype (Formal)) then
Next_Actual (Actual);
@@ -2036,7 +2047,7 @@ package body Sem_Ch4 is
if Chars (Left_Opnd (Actual)) = Chars (Formal) then
Error_Msg_N
- ("possible misspelling of `=>`!", Actual);
+ ("possible misspelling of `='>`!", Actual);
exit;
end if;
@@ -2052,9 +2063,9 @@ package body Sem_Ch4 is
and then not Comes_From_Source (Nam)
then
Error_Msg_NE
- (" ==> in call to &#(inherited)!", Actual, Nam);
+ (" =='> in call to &#(inherited)!", Actual, Nam);
else
- Error_Msg_NE (" ==> in call to &#!", Actual, Nam);
+ Error_Msg_NE (" =='> in call to &#!", Actual, Nam);
end if;
end if;
end if;
@@ -2072,7 +2083,7 @@ package body Sem_Ch4 is
-- On exit, all actuals match.
- Set_Name;
+ Indicate_Name_And_Type;
end if;
end Analyze_One_Call;
@@ -2160,9 +2171,9 @@ package body Sem_Ch4 is
-------------------------------------------
procedure Analyze_Overloaded_Selected_Component (N : Node_Id) is
+ Nam : constant Node_Id := Prefix (N);
+ Sel : constant Node_Id := Selector_Name (N);
Comp : Entity_Id;
- Nam : Node_Id := Prefix (N);
- Sel : Node_Id := Selector_Name (N);
I : Interp_Index;
It : Interp;
T : Entity_Id;
@@ -2175,10 +2186,7 @@ package body Sem_Ch4 is
while Present (It.Typ) loop
if Is_Access_Type (It.Typ) then
T := Designated_Type (It.Typ);
-
- if Warn_On_Dereference then
- Error_Msg_N ("?implicit dereference", N);
- end if;
+ Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
else
T := It.Typ;
@@ -2230,10 +2238,8 @@ package body Sem_Ch4 is
if Is_Access_Type (Etype (Nam)) then
Insert_Explicit_Dereference (Nam);
-
- if Warn_On_Dereference then
- Error_Msg_N ("?implicit dereference", N);
- end if;
+ Error_Msg_NW
+ (Warn_On_Dereference, "?implicit dereference", N);
end if;
end if;
@@ -2294,6 +2300,10 @@ package body Sem_Ch4 is
-- Test one interpretation of the low bound against all those
-- of the high bound.
+ procedure Check_Universal_Expression (N : Node_Id);
+ -- In Ada83, reject bounds of a universal range that are not
+ -- literals or entity names.
+
-----------------------
-- Check_Common_Type --
-----------------------
@@ -2307,7 +2317,7 @@ package body Sem_Ch4 is
then
Add_One_Interp (N, Base_Type (T2), Base_Type (T2));
- elsif (T1 = T2) then
+ elsif T1 = T2 then
Add_One_Interp (N, T1, T1);
else
@@ -2334,6 +2344,21 @@ package body Sem_Ch4 is
end if;
end Check_High_Bound;
+ -----------------------------
+ -- Is_Universal_Expression --
+ -----------------------------
+
+ procedure Check_Universal_Expression (N : Node_Id) is
+ begin
+ if Etype (N) = Universal_Integer
+ and then Nkind (N) /= N_Integer_Literal
+ and then not Is_Entity_Name (N)
+ and then Nkind (N) /= N_Attribute_Reference
+ then
+ Error_Msg_N ("illegal bound in discrete range", N);
+ end if;
+ end Check_Universal_Expression;
+
-- Start of processing for Analyze_Range
begin
@@ -2362,6 +2387,15 @@ package body Sem_Ch4 is
Error_Msg_N ("incompatible types in range ", N);
end if;
end if;
+
+ if Ada_83
+ and then
+ (Nkind (Parent (N)) = N_Loop_Parameter_Specification
+ or else Nkind (Parent (N)) = N_Constrained_Array_Definition)
+ then
+ Check_Universal_Expression (L);
+ Check_Universal_Expression (H);
+ end if;
end Analyze_Range;
-----------------------
@@ -2421,7 +2455,7 @@ package body Sem_Ch4 is
-- (Breaks 2129-008) ???.
if Nkind (Name) = N_Function_Call then
- Resolve (Name, Etype (Name));
+ Resolve (Name);
end if;
Prefix_Type := Etype (Name);
@@ -2444,9 +2478,7 @@ package body Sem_Ch4 is
-- Normal case of selected component applied to access type
else
- if Warn_On_Dereference then
- Error_Msg_N ("?implicit dereference", N);
- end if;
+ Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
end if;
Prefix_Type := Designated_Type (Prefix_Type);
@@ -2489,10 +2521,7 @@ package body Sem_Ch4 is
if Is_Access_Type (Etype (Name)) then
Insert_Explicit_Dereference (Name);
-
- if Warn_On_Dereference then
- Error_Msg_N ("?implicit dereference", N);
- end if;
+ Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
end if;
elsif Is_Record_Type (Prefix_Type) then
@@ -2529,7 +2558,7 @@ package body Sem_Ch4 is
-- to duplicate this prefix and duplication is only allowed
-- on fully resolved expressions.
- Resolve (Name, Etype (Name));
+ Resolve (Name);
-- We never need an actual subtype for the case of a selection
-- for a indexed component of a non-packed array, since in
@@ -2567,7 +2596,7 @@ package body Sem_Ch4 is
-- In all other cases, we currently build an actual subtype. It
-- seems likely that many of these cases can be avoided, but
-- right now, the front end makes direct references to the
- -- bounds (e.g. in egnerating a length check), and if we do
+ -- bounds (e.g. in generating a length check), and if we do
-- not make an actual subtype, we end up getting a direct
-- reference to a discriminant which will not do.
@@ -2584,7 +2613,8 @@ package body Sem_Ch4 is
-- main attributes of the subtype.
declare
- Subt : Entity_Id := Defining_Identifier (Act_Decl);
+ Subt : constant Entity_Id :=
+ Defining_Identifier (Act_Decl);
begin
Set_Etype (Subt, Base_Type (Etype (Comp)));
@@ -2683,10 +2713,8 @@ package body Sem_Ch4 is
if Is_Access_Type (Etype (Name)) then
Insert_Explicit_Dereference (Name);
-
- if Warn_On_Dereference then
- Error_Msg_N ("?implicit dereference", N);
- end if;
+ Error_Msg_NW
+ (Warn_On_Dereference, "?implicit dereference", N);
end if;
end if;
@@ -2735,6 +2763,35 @@ package body Sem_Ch4 is
Analyze_Selected_Component (N);
return;
+ elsif Ekind (Prefix_Type) = E_Record_Subtype_With_Private
+ and then Is_Generic_Actual_Type (Prefix_Type)
+ and then Present (Full_View (Prefix_Type))
+ then
+ -- Similarly, if this the actual for a formal derived type,
+ -- the component inherited from the generic parent may not
+ -- be visible in the actual, but the selected component is
+ -- legal.
+
+ declare
+ Comp : Entity_Id;
+ begin
+ Comp :=
+ First_Component (Generic_Parent_Type (Parent (Prefix_Type)));
+
+ while Present (Comp) loop
+ if Chars (Comp) = Chars (Sel) then
+ Set_Entity_With_Style_Check (Sel, Comp);
+ Set_Etype (Sel, Etype (Comp));
+ Set_Etype (N, Etype (Comp));
+ exit;
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ pragma Assert (Etype (N) /= Any_Type);
+ end;
+
else
if Ekind (Prefix_Type) = E_Record_Subtype then
@@ -2864,10 +2921,7 @@ package body Sem_Ch4 is
if Is_Access_Type (Typ) then
Typ := Designated_Type (Typ);
-
- if Warn_On_Dereference then
- Error_Msg_N ("?implicit dereference", N);
- end if;
+ Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
end if;
if Is_Array_Type (Typ)
@@ -2905,10 +2959,7 @@ package body Sem_Ch4 is
if Is_Access_Type (Array_Type) then
Array_Type := Designated_Type (Array_Type);
-
- if Warn_On_Dereference then
- Error_Msg_N ("?implicit dereference", N);
- end if;
+ Error_Msg_NW (Warn_On_Dereference, "?implicit dereference", N);
end if;
if not Is_Array_Type (Array_Type) then
@@ -3194,7 +3245,8 @@ package body Sem_Ch4 is
-- from source and Fixed_As_Integer cannot apply.
if Nkind (N) not in N_Op
- or else not Treat_Fixed_As_Integer (N) then
+ or else not Treat_Fixed_As_Integer (N)
+ then
Add_One_Interp (N, Op_Id, Universal_Fixed);
end if;
@@ -3371,10 +3423,13 @@ package body Sem_Ch4 is
-------------------
procedure Diagnose_Call (N : Node_Id; Nam : Node_Id) is
- Actual : Node_Id;
- X : Interp_Index;
- It : Interp;
- Success : Boolean;
+ Actual : Node_Id;
+ X : Interp_Index;
+ It : Interp;
+ Success : Boolean;
+ Err_Mode : Boolean;
+ New_Nam : Node_Id;
+ Void_Interp_Seen : Boolean := False;
begin
if Extensions_Allowed then
@@ -3395,33 +3450,38 @@ package body Sem_Ch4 is
end loop;
end if;
- if All_Errors_Mode then
-
- -- Analyze each candidate call again, with full error reporting
- -- for each.
-
- Error_Msg_N ("\no candidate interpretations "
- & "match the actuals:!", Nam);
-
+ -- Analyze each candidate call again, with full error reporting
+ -- for each.
+
+ Error_Msg_N
+ ("no candidate interpretations match the actuals:!", Nam);
+ Err_Mode := All_Errors_Mode;
+ All_Errors_Mode := True;
+
+ -- If this is a call to an operation of a concurrent type,
+ -- the failed interpretations have been removed from the
+ -- name. Recover them to provide full diagnostics.
+
+ if Nkind (Parent (Nam)) = N_Selected_Component then
+ Set_Entity (Nam, Empty);
+ New_Nam := New_Copy_Tree (Parent (Nam));
+ Set_Is_Overloaded (New_Nam, False);
+ Set_Is_Overloaded (Selector_Name (New_Nam), False);
+ Set_Parent (New_Nam, Parent (Parent (Nam)));
+ Analyze_Selected_Component (New_Nam);
+ Get_First_Interp (Selector_Name (New_Nam), X, It);
+ else
Get_First_Interp (Nam, X, It);
+ end if;
- while Present (It.Nam) loop
- Analyze_One_Call (N, It.Nam, True, Success);
- Get_Next_Interp (X, It);
- end loop;
-
- else
- if OpenVMS then
- Error_Msg_N
- ("invalid parameter list in call " &
- "('/'R'E'P'O'R'T'_'E'R'R'O'R'S'='F'U'L'L for details)!",
- Nam);
- else
- Error_Msg_N
- ("invalid parameter list in call (use -gnatf for details)!",
- Nam);
+ while Present (It.Nam) loop
+ if Etype (It.Nam) = Standard_Void_Type then
+ Void_Interp_Seen := True;
end if;
- end if;
+
+ Analyze_One_Call (N, It.Nam, True, Success);
+ Get_Next_Interp (X, It);
+ end loop;
if Nkind (N) = N_Function_Call then
Get_First_Interp (Nam, X, It);
@@ -3449,7 +3509,15 @@ package body Sem_Ch4 is
Error_Msg_N (
"\period should probably be semicolon", Parent (N));
end if;
+
+ elsif Nkind (N) = N_Procedure_Call_Statement
+ and then not Void_Interp_Seen
+ then
+ Error_Msg_N (
+ "\function name found in procedure call", Nam);
end if;
+
+ All_Errors_Mode := Err_Mode;
end Diagnose_Call;
---------------------------
@@ -3637,6 +3705,15 @@ package body Sem_Ch4 is
-- Start processing for Find_Comparison_Types
begin
+ -- If left operand is aggregate, the right operand has to
+ -- provide a usable type for it.
+
+ if Nkind (L) = N_Aggregate
+ and then Nkind (R) /= N_Aggregate
+ then
+ Find_Comparison_Types (R, L, Op_Id, N);
+ return;
+ end if;
if Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Expanded_Name
@@ -3820,6 +3897,15 @@ package body Sem_Ch4 is
-- Start of processing for Find_Equality_Types
begin
+ -- If left operand is aggregate, the right operand has to
+ -- provide a usable type for it.
+
+ if Nkind (L) = N_Aggregate
+ and then Nkind (R) /= N_Aggregate
+ then
+ Find_Equality_Types (R, L, Op_Id, N);
+ return;
+ end if;
if Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Expanded_Name
@@ -3916,46 +4002,6 @@ package body Sem_Ch4 is
end if;
end Find_Unary_Types;
- ---------------------------------
- -- Insert_Explicit_Dereference --
- ---------------------------------
-
- procedure Insert_Explicit_Dereference (N : Node_Id) is
- New_Prefix : Node_Id := Relocate_Node (N);
- I : Interp_Index;
- It : Interp;
- T : Entity_Id;
-
- begin
- Save_Interps (N, New_Prefix);
- Rewrite (N,
- Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix));
-
- Set_Etype (N, Designated_Type (Etype (New_Prefix)));
-
- if Is_Overloaded (New_Prefix) then
-
- -- The deference is also overloaded, and its interpretations are the
- -- designated types of the interpretations of the original node.
-
- Set_Is_Overloaded (N);
- Get_First_Interp (New_Prefix, I, It);
-
- while Present (It.Nam) loop
- T := It.Typ;
-
- if Is_Access_Type (T) then
- Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
- end if;
-
- Get_Next_Interp (I, It);
- end loop;
-
- End_Interp_List;
- end if;
-
- end Insert_Explicit_Dereference;
-
------------------
-- Junk_Operand --
------------------
@@ -4213,13 +4259,22 @@ package body Sem_Ch4 is
return;
else
- Error_Msg_N ("invalid operand types for operator&", N);
+ if Nkind (N) in N_Binary_Op then
+ if not Is_Overloaded (L)
+ and then not Is_Overloaded (R)
+ and then Base_Type (Etype (L)) = Base_Type (Etype (R))
+ then
+ Error_Msg_Node_2 := Etype (R);
+ Error_Msg_N ("there is no applicable operator& for}", N);
- if Nkind (N) in N_Binary_Op
- and then Nkind (N) /= N_Op_Concat
- then
- Error_Msg_NE ("\left operand has}!", N, Etype (L));
- Error_Msg_NE ("\right operand has}!", N, Etype (R));
+ else
+ Error_Msg_N ("invalid operand types for operator&", N);
+
+ if Nkind (N) /= N_Op_Concat then
+ Error_Msg_NE ("\left operand has}!", N, Etype (L));
+ Error_Msg_NE ("\right operand has}!", N, Etype (R));
+ end if;
+ end if;
end if;
end if;
end;
@@ -4236,11 +4291,13 @@ package body Sem_Ch4 is
Typ : Entity_Id)
return Boolean
is
- Actuals : List_Id := Parameter_Associations (N);
- Actual : Node_Id := First (Actuals);
- Formal : Entity_Id := First_Formal (Designated_Type (Typ));
+ Actuals : constant List_Id := Parameter_Associations (N);
+ Actual : Node_Id;
+ Formal : Entity_Id;
begin
+ Actual := First (Actuals);
+ Formal := First_Formal (Designated_Type (Typ));
while Present (Actual)
and then Present (Formal)
loop
@@ -4280,11 +4337,13 @@ package body Sem_Ch4 is
Typ : Entity_Id)
return Boolean
is
- Actuals : List_Id := Parameter_Associations (N);
- Actual : Node_Id := First (Actuals);
- Index : Entity_Id := First_Index (Typ);
+ Actuals : constant List_Id := Parameter_Associations (N);
+ Actual : Node_Id;
+ Index : Entity_Id;
begin
+ Actual := First (Actuals);
+ Index := First_Index (Typ);
while Present (Actual)
and then Present (Index)
loop
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 10cdec474b2..227bb140446 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.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- --
@@ -46,6 +46,7 @@ with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Stand; use Stand;
with Sinfo; use Sinfo;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
@@ -66,15 +67,26 @@ package body Sem_Ch5 is
procedure Analyze_Iteration_Scheme (N : Node_Id);
+ procedure Check_Possible_Current_Value_Condition (Cnode : Node_Id);
+ -- Cnode is N_If_Statement, N_Elsif_Part, or N_Iteration_Scheme
+ -- (the latter when a WHILE condition is present). This call checks
+ -- if Condition (Cnode) is of the form ([NOT] var op val), where var
+ -- is a simple object, val is known at compile time, and op is one
+ -- of the six relational operators. If this is the case, and the
+ -- Current_Value field of "var" is not set, then it is set to Cnode.
+ -- See Exp_Util.Set_Current_Value_Condition for further details.
+
------------------------
-- Analyze_Assignment --
------------------------
procedure Analyze_Assignment (N : Node_Id) is
- Lhs : constant Node_Id := Name (N);
- Rhs : constant Node_Id := Expression (N);
- T1, T2 : Entity_Id;
- Decl : Node_Id;
+ Lhs : constant Node_Id := Name (N);
+ Rhs : constant Node_Id := Expression (N);
+ T1 : Entity_Id;
+ T2 : Entity_Id;
+ Decl : Node_Id;
+ Ent : Entity_Id;
procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
-- N is the node for the left hand side of an assignment, and it
@@ -141,7 +153,6 @@ package body Sem_Ch5 is
-- If we fall through, we have no special message to issue!
Error_Msg_N ("left hand side of assignment must be a variable", N);
-
end Diagnose_Non_Variable_Lhs;
-------------------------
@@ -153,23 +164,36 @@ package body Sem_Ch5 is
Opnd_Type : in out Entity_Id)
is
begin
+ Require_Entity (Opnd);
+
-- If the assignment operand is an in-out or out parameter, then we
-- get the actual subtype (needed for the unconstrained case).
+ -- If the operand is the actual in an entry declaration, then within
+ -- the accept statement it is replaced with a local renaming, which
+ -- may also have an actual subtype.
if Is_Entity_Name (Opnd)
and then (Ekind (Entity (Opnd)) = E_Out_Parameter
or else Ekind (Entity (Opnd)) =
E_In_Out_Parameter
or else Ekind (Entity (Opnd)) =
- E_Generic_In_Out_Parameter)
+ E_Generic_In_Out_Parameter
+ or else
+ (Ekind (Entity (Opnd)) = E_Variable
+ and then Nkind (Parent (Entity (Opnd))) =
+ N_Object_Renaming_Declaration
+ and then Nkind (Parent (Parent (Entity (Opnd)))) =
+ N_Accept_Statement))
then
Opnd_Type := Get_Actual_Subtype (Opnd);
-- If assignment operand is a component reference, then we get the
-- actual subtype of the component for the unconstrained case.
- elsif Nkind (Opnd) = N_Selected_Component
- or else Nkind (Opnd) = N_Explicit_Dereference
+ elsif
+ (Nkind (Opnd) = N_Selected_Component
+ or else Nkind (Opnd) = N_Explicit_Dereference)
+ and then not Is_Unchecked_Union (Opnd_Type)
then
Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
@@ -213,7 +237,6 @@ package body Sem_Ch5 is
while Present (It.Typ) loop
if Has_Compatible_Type (Rhs, It.Typ) then
-
if T1 /= Any_Type then
-- An explicit dereference is overloaded if the prefix
@@ -232,8 +255,9 @@ package body Sem_Ch5 is
Get_First_Interp (Prefix (Lhs), PI, PIt);
while Present (PIt.Typ) loop
- if Has_Compatible_Type (Rhs,
- Designated_Type (PIt.Typ))
+ if Is_Access_Type (PIt.Typ)
+ and then Has_Compatible_Type
+ (Rhs, Designated_Type (PIt.Typ))
then
if Found then
PIt :=
@@ -241,7 +265,10 @@ package body Sem_Ch5 is
PI1, PI, Any_Type);
if PIt = No_Interp then
- return;
+ Error_Msg_N
+ ("ambiguous left-hand side"
+ & " in assignment", Lhs);
+ exit;
else
Resolve (Prefix (Lhs), PIt.Typ);
end if;
@@ -290,6 +317,7 @@ package body Sem_Ch5 is
then
Error_Msg_N
("left hand of assignment must not be limited type", Lhs);
+ Explain_Limited_Type (T1, Lhs);
return;
end if;
@@ -302,7 +330,7 @@ package body Sem_Ch5 is
Resolve (Rhs, T1);
- -- Remaining steps are skipped if Rhs was synatactically in error
+ -- Remaining steps are skipped if Rhs was syntactically in error
if Rhs = Error then
return;
@@ -310,7 +338,6 @@ package body Sem_Ch5 is
T2 := Etype (Rhs);
Check_Unset_Reference (Rhs);
- Note_Possible_Modification (Lhs);
if Covers (T1, T2) then
null;
@@ -321,6 +348,16 @@ package body Sem_Ch5 is
Set_Assignment_Type (Rhs, T2);
+ if Total_Errors_Detected /= 0 then
+ if No (T1) then
+ T1 := Any_Type;
+ end if;
+
+ if No (T2) then
+ T2 := Any_Type;
+ end if;
+ end if;
+
if T1 = Any_Type or else T2 = Any_Type then
return;
end if;
@@ -353,10 +390,19 @@ package body Sem_Ch5 is
if Is_Scalar_Type (T1) then
Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
- elsif Is_Array_Type (T1) then
+ elsif Is_Array_Type (T1)
+ and then
+ (Nkind (Rhs) /= N_Type_Conversion
+ or else Is_Constrained (Etype (Rhs)))
+ then
-- Assignment verifies that the length of the Lsh and Rhs are equal,
- -- but of course the indices do not have to match.
+ -- but of course the indices do not have to match. If the right-hand
+ -- side is a type conversion to an unconstrained type, a length check
+ -- is performed on the expression itself during expansion. In rare
+ -- cases, the redundant length check is computed on an index type
+ -- with a different representation, triggering incorrect code in
+ -- the back end.
Apply_Length_Check (Rhs, Etype (Lhs));
@@ -378,8 +424,8 @@ package body Sem_Ch5 is
-- Where the entity is the same on both sides
and then Is_Entity_Name (Lhs)
- and then Is_Entity_Name (Rhs)
- and then Entity (Lhs) = Entity (Rhs)
+ and then Is_Entity_Name (Original_Node (Rhs))
+ and then Entity (Lhs) = Entity (Original_Node (Rhs))
-- But exclude the case where the right side was an operation
-- that got rewritten (e.g. JUNK + K, where K was known to be
@@ -392,6 +438,46 @@ package body Sem_Ch5 is
Error_Msg_NE
("?useless assignment of & to itself", N, Entity (Lhs));
end if;
+
+ Note_Possible_Modification (Lhs);
+
+ -- Check for non-allowed composite assignment
+
+ if not Support_Composite_Assign_On_Target
+ and then (Is_Array_Type (T1) or else Is_Record_Type (T1))
+ and then (not Has_Size_Clause (T1) or else Esize (T1) > 64)
+ then
+ Error_Msg_CRT ("composite assignment", N);
+ end if;
+
+ -- One more step. Let's see if we have a simple assignment of a
+ -- known at compile time value to a simple variable. If so, we
+ -- can record the value as the current value providing that:
+
+ -- We still have a simple assignment statement (no expansion
+ -- activity has modified it in some peculiar manner)
+
+ -- The type is a discrete type
+
+ -- The assignment is to a named entity
+
+ -- The value is known at compile time
+
+ if Nkind (N) /= N_Assignment_Statement
+ or else not Is_Discrete_Type (T1)
+ or else not Is_Entity_Name (Lhs)
+ or else not Compile_Time_Known_Value (Rhs)
+ then
+ return;
+ end if;
+
+ Ent := Entity (Lhs);
+
+ -- Capture value if save to do so
+
+ if Safe_To_Capture_Value (N, Ent) then
+ Set_Current_Value (Ent, Rhs);
+ end if;
end Analyze_Assignment;
-----------------------------
@@ -401,7 +487,7 @@ package body Sem_Ch5 is
procedure Analyze_Block_Statement (N : Node_Id) is
Decls : constant List_Id := Declarations (N);
Id : constant Node_Id := Identifier (N);
- Ent : Entity_Id;
+ Ent : Entity_Id := Empty;
begin
-- If a label is present analyze it and mark it as referenced
@@ -409,19 +495,35 @@ package body Sem_Ch5 is
if Present (Id) then
Analyze (Id);
Ent := Entity (Id);
- Set_Ekind (Ent, E_Block);
- Generate_Reference (Ent, N, ' ');
- Generate_Definition (Ent);
- if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
- Set_Label_Construct (Parent (Ent), N);
+ -- An error defense. If we have an identifier, but no entity, then
+ -- something is wrong. If we have previous errors, then just remove
+ -- the identifier and continue, otherwise raise an exception.
+
+ if No (Ent) then
+ if Total_Errors_Detected /= 0 then
+ Set_Identifier (N, Empty);
+ else
+ raise Program_Error;
+ end if;
+
+ else
+ Set_Ekind (Ent, E_Block);
+ Generate_Reference (Ent, N, ' ');
+ Generate_Definition (Ent);
+
+ if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
+ Set_Label_Construct (Parent (Ent), N);
+ end if;
end if;
+ end if;
- -- Otherwise create a label entity
+ -- If no entity set, create a label entity
- else
+ if No (Ent) then
Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N)));
+ Set_Parent (Ent, N);
end if;
Set_Etype (Ent, Standard_Void_Type);
@@ -453,9 +555,7 @@ package body Sem_Ch5 is
Set_Has_Nested_Block_With_Handler (S);
exit when Is_Overloadable (S)
or else Ekind (S) = E_Package
- or else Ekind (S) = E_Generic_Function
- or else Ekind (S) = E_Generic_Package
- or else Ekind (S) = E_Generic_Procedure;
+ or else Is_Generic_Unit (S);
S := Scope (S);
end loop;
end;
@@ -482,7 +582,7 @@ package body Sem_Ch5 is
procedure Non_Static_Choice_Error (Choice : Node_Id);
-- Error routine invoked by the generic instantiation below when
- -- the case statement has a non static choice.
+ -- the case statment has a non static choice.
procedure Process_Statements (Alternative : Node_Id);
-- Analyzes all the statements associated to a case alternative.
@@ -504,7 +604,8 @@ package body Sem_Ch5 is
procedure Non_Static_Choice_Error (Choice : Node_Id) is
begin
- Error_Msg_N ("choice given in case statement is not static", Choice);
+ Flag_Non_Static_Expr
+ ("choice given in case statement is not static!", Choice);
end Non_Static_Choice_Error;
------------------------
@@ -599,6 +700,27 @@ package body Sem_Ch5 is
else
Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
end if;
+
+ if not Expander_Active
+ and then Compile_Time_Known_Value (Expression (N))
+ and then Serious_Errors_Detected = 0
+ then
+ declare
+ Chosen : Node_Id := Find_Static_Alternative (N);
+ Alt : Node_Id;
+
+ begin
+ Alt := First (Alternatives (N));
+
+ while Present (Alt) loop
+ if Alt /= Chosen then
+ Remove_Warning_Messages (Statements (Alt));
+ end if;
+
+ Next (Alt);
+ end loop;
+ end;
+ end if;
end Analyze_Case_Statement;
----------------------------
@@ -708,7 +830,6 @@ package body Sem_Ch5 is
end loop;
raise Program_Error;
-
end Analyze_Goto_Statement;
--------------------------
@@ -716,13 +837,16 @@ package body Sem_Ch5 is
--------------------------
-- A special complication arises in the analysis of if statements.
- -- The expander has circuitry to completely deleted code that it
+
+ -- The expander has circuitry to completely delete code that it
-- can tell will not be executed (as a result of compile time known
-- conditions). In the analyzer, we ensure that code that will be
-- deleted in this manner is analyzed but not expanded. This is
-- obviously more efficient, but more significantly, difficulties
-- arise if code is expanded and then eliminated (e.g. exception
- -- table entries disappear).
+ -- table entries disappear). Similarly, itypes generated in deleted
+ -- code must be frozen from start, because the nodes on which they
+ -- depend will not be available at the freeze point.
procedure Analyze_If_Statement (N : Node_Id) is
E : Node_Id;
@@ -730,6 +854,8 @@ package body Sem_Ch5 is
Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
-- Recursively save value of this global, will be restored on exit
+ Save_In_Deleted_Code : Boolean;
+
Del : Boolean := False;
-- This flag gets set True if a True condition has been found,
-- which means that remaining ELSE/ELSIF parts are deleted.
@@ -739,6 +865,10 @@ package body Sem_Ch5 is
-- to an N_Elsif_Part node. It deals with analyzing the condition
-- and the THEN statements associated with it.
+ -----------------------
+ -- Analyze_Cond_Then --
+ -----------------------
+
procedure Analyze_Cond_Then (Cnode : Node_Id) is
Cond : constant Node_Id := Condition (Cnode);
Tstm : constant List_Id := Then_Statements (Cnode);
@@ -747,6 +877,7 @@ package body Sem_Ch5 is
Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
Analyze_And_Resolve (Cond, Any_Boolean);
Check_Unset_Reference (Cond);
+ Check_Possible_Current_Value_Condition (Cnode);
-- If already deleting, then just analyze then statements
@@ -756,6 +887,7 @@ package body Sem_Ch5 is
-- Compile time known value, not deleting yet
elsif Compile_Time_Known_Value (Cond) then
+ Save_In_Deleted_Code := In_Deleted_Code;
-- If condition is True, then analyze the THEN statements
-- and set no expansion for ELSE and ELSIF parts.
@@ -764,13 +896,16 @@ package body Sem_Ch5 is
Analyze_Statements (Tstm);
Del := True;
Expander_Mode_Save_And_Set (False);
+ In_Deleted_Code := True;
-- If condition is False, analyze THEN with expansion off
else -- Is_False (Expr_Value (Cond))
Expander_Mode_Save_And_Set (False);
+ In_Deleted_Code := True;
Analyze_Statements (Tstm);
Expander_Mode_Restore;
+ In_Deleted_Code := Save_In_Deleted_Code;
end if;
-- Not known at compile time, not deleting, normal analysis
@@ -817,8 +952,29 @@ package body Sem_Ch5 is
if Del then
Expander_Mode_Restore;
+ In_Deleted_Code := Save_In_Deleted_Code;
end if;
+ if not Expander_Active
+ and then Compile_Time_Known_Value (Condition (N))
+ and then Serious_Errors_Detected = 0
+ then
+ if Is_True (Expr_Value (Condition (N))) then
+ Remove_Warning_Messages (Else_Statements (N));
+
+ if Present (Elsif_Parts (N)) then
+ E := First (Elsif_Parts (N));
+
+ while Present (E) loop
+ Remove_Warning_Messages (Then_Statements (E));
+ Next (E);
+ end loop;
+ end if;
+
+ else
+ Remove_Warning_Messages (Then_Statements (N));
+ end if;
+ end if;
end Analyze_If_Statement;
----------------------------------------
@@ -833,10 +989,10 @@ package body Sem_Ch5 is
-- Analyze_Label_Entity.
procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is
- Id : Node_Id := Defining_Identifier (N);
+ Id : constant Node_Id := Defining_Identifier (N);
begin
- Enter_Name (Id);
+ Enter_Name (Id);
Set_Ekind (Id, E_Label);
Set_Etype (Id, Standard_Void_Type);
Set_Enclosing_Scope (Id, Current_Scope);
@@ -872,7 +1028,6 @@ package body Sem_Ch5 is
LP : constant Node_Id := Loop_Parameter_Specification (N);
Id : constant Entity_Id := Defining_Identifier (LP);
DS : constant Node_Id := Discrete_Subtype_Definition (LP);
- F : List_Id;
begin
Enter_Name (Id);
@@ -932,12 +1087,15 @@ package body Sem_Ch5 is
Set_Is_Known_Valid (Id, True);
-- The loop is not a declarative part, so the only entity
- -- declared "within" must be frozen explicitly. Since the
- -- type of this entity has already been frozen, this cannot
- -- generate any freezing actions.
+ -- declared "within" must be frozen explicitly.
- F := Freeze_Entity (Id, Sloc (LP));
- pragma Assert (F = No_List);
+ declare
+ Flist : constant List_Id := Freeze_Entity (Id, Sloc (N));
+ begin
+ if Is_Non_Empty_List (Flist) then
+ Insert_Actions (N, Flist);
+ end if;
+ end;
-- Check for null or possibly null range and issue warning.
-- We suppress such messages in generic templates and
@@ -946,8 +1104,6 @@ package body Sem_Ch5 is
if Nkind (DS) = N_Range
and then Comes_From_Source (N)
- and then not Inside_A_Generic
- and then not In_Instance
then
declare
L : constant Node_Id := Low_Bound (DS);
@@ -967,14 +1123,42 @@ package body Sem_Ch5 is
-- If range of loop is null, issue warning
if (LOK and HOK) and then Llo > Hhi then
- Error_Msg_N
- ("?loop range is null, loop will not execute",
- DS);
+
+ -- Suppress the warning if inside a generic
+ -- template or instance, since in practice
+ -- they tend to be dubious in these cases since
+ -- they can result from intended parametrization.
+
+ if not Inside_A_Generic
+ and then not In_Instance
+ then
+ Error_Msg_N
+ ("?loop range is null, loop will not execute",
+ DS);
+ end if;
+
+ -- Since we know the range of the loop is null,
+ -- set the appropriate flag to suppress any
+ -- warnings that would otherwise be issued in
+ -- the body of the loop that will not execute.
+ -- We do this even in the generic case, since
+ -- if it is dubious to warn on the null loop
+ -- itself, it is certainly dubious to warn for
+ -- conditions that occur inside it!
+
+ Set_Is_Null_Loop (Parent (N));
-- The other case for a warning is a reverse loop
-- where the upper bound is the integer literal
-- zero or one, and the lower bound can be positive.
+ -- For example, we have
+
+ -- for J in reverse N .. 1 loop
+
+ -- In practice, this is very likely to be a case
+ -- of reversing the bounds incorrectly in the range.
+
elsif Reverse_Present (LP)
and then Nkind (H) = N_Integer_Literal
and then (Intval (H) = Uint_0
@@ -982,9 +1166,7 @@ package body Sem_Ch5 is
Intval (H) = Uint_1)
and then Lhi > Hhi
then
- Warn_On_Instance := True;
Error_Msg_N ("?loop range may be null", DS);
- Warn_On_Instance := False;
end if;
end;
end if;
@@ -998,41 +1180,18 @@ package body Sem_Ch5 is
-- Analyze_Label --
-------------------
- -- Important note: normally this routine is called from Analyze_Statements
- -- which does a prescan, to make sure that the Reachable flags are set on
- -- all labels before encountering a possible goto to one of these labels.
- -- If expanded code analyzes labels via the normal Sem path, then it must
- -- ensure that Reachable is set early enough to avoid problems in the case
- -- of a forward goto.
+ -- Note: the semantic work required for analyzing labels (setting them as
+ -- reachable) was done in a prepass through the statements in the block,
+ -- so that forward gotos would be properly handled. See Analyze_Statements
+ -- for further details. The only processing required here is to deal with
+ -- optimizations that depend on an assumption of sequential control flow,
+ -- since of course the occurrence of a label breaks this assumption.
procedure Analyze_Label (N : Node_Id) is
- Lab : Entity_Id;
+ pragma Warnings (Off, N);
begin
- Analyze (Identifier (N));
- Lab := Entity (Identifier (N));
-
- -- If we found a label mark it as reachable.
-
- if Ekind (Lab) = E_Label then
- Generate_Definition (Lab);
- Set_Reachable (Lab);
-
- if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then
- Set_Label_Construct (Parent (Lab), N);
- end if;
-
- -- If we failed to find a label, it means the implicit declaration
- -- of the label was hidden. A for-loop parameter can do this to a
- -- label with the same name inside the loop, since the implicit label
- -- declaration is in the innermost enclosing body or block statement.
-
- else
- Error_Msg_Sloc := Sloc (Lab);
- Error_Msg_N
- ("implicit label declaration for & is hidden#",
- Identifier (N));
- end if;
+ Kill_Current_Values;
end Analyze_Label;
--------------------------
@@ -1088,11 +1247,18 @@ package body Sem_Ch5 is
Set_Parent (Ent, N);
end if;
+ -- Kill current values on entry to loop, since statements in body
+ -- of loop may have been executed before the loop is entered.
+ -- Similarly we kill values after the loop, since we do not know
+ -- that the body of the loop was executed.
+
+ Kill_Current_Values;
New_Scope (Ent);
Analyze_Iteration_Scheme (Iteration_Scheme (N));
Analyze_Statements (Statements (N));
Process_End_Label (N, 'e', Ent);
End_Scope;
+ Kill_Current_Values;
end Analyze_Loop_Statement;
----------------------------
@@ -1114,7 +1280,8 @@ package body Sem_Ch5 is
------------------------
procedure Analyze_Statements (L : List_Id) is
- S : Node_Id;
+ S : Node_Id;
+ Lab : Entity_Id;
begin
-- The labels declared in the statement list are reachable from
@@ -1123,10 +1290,33 @@ package body Sem_Ch5 is
-- reachable. This is not required, but is nice behavior!
S := First (L);
-
while Present (S) loop
if Nkind (S) = N_Label then
- Analyze_Label (S);
+ Analyze (Identifier (S));
+ Lab := Entity (Identifier (S));
+
+ -- If we found a label mark it as reachable.
+
+ if Ekind (Lab) = E_Label then
+ Generate_Definition (Lab);
+ Set_Reachable (Lab);
+
+ if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then
+ Set_Label_Construct (Parent (Lab), S);
+ end if;
+
+ -- If we failed to find a label, it means the implicit declaration
+ -- of the label was hidden. A for-loop parameter can do this to
+ -- a label with the same name inside the loop, since the implicit
+ -- label declaration is in the innermost enclosing body or block
+ -- statement.
+
+ else
+ Error_Msg_Sloc := Sloc (Lab);
+ Error_Msg_N
+ ("implicit label declaration for & is hidden#",
+ Identifier (S));
+ end if;
end if;
Next (S);
@@ -1134,24 +1324,22 @@ package body Sem_Ch5 is
-- Perform semantic analysis on all statements
- S := First (L);
+ Conditional_Statements_Begin;
+ S := First (L);
while Present (S) loop
-
- if Nkind (S) /= N_Label then
- Analyze (S);
- end if;
-
+ Analyze (S);
Next (S);
end loop;
+ Conditional_Statements_End;
+
-- Make labels unreachable. Visibility is not sufficient, because
-- labels in one if-branch for example are not reachable from the
-- other branch, even though their declarations are in the enclosing
-- declarative part.
S := First (L);
-
while Present (S) loop
if Nkind (S) = N_Label then
Set_Reachable (Entity (Identifier (S)), False);
@@ -1161,6 +1349,72 @@ package body Sem_Ch5 is
end loop;
end Analyze_Statements;
+ --------------------------------------------
+ -- Check_Possible_Current_Value_Condition --
+ --------------------------------------------
+
+ procedure Check_Possible_Current_Value_Condition (Cnode : Node_Id) is
+ Cond : Node_Id;
+
+ begin
+ -- Loop to deal with (ignore for now) any NOT operators present
+
+ Cond := Condition (Cnode);
+ while Nkind (Cond) = N_Op_Not loop
+ Cond := Right_Opnd (Cond);
+ end loop;
+
+ -- Check possible relational operator
+
+ if Nkind (Cond) = N_Op_Eq
+ or else
+ Nkind (Cond) = N_Op_Ne
+ or else
+ Nkind (Cond) = N_Op_Ge
+ or else
+ Nkind (Cond) = N_Op_Le
+ or else
+ Nkind (Cond) = N_Op_Gt
+ or else
+ Nkind (Cond) = N_Op_Lt
+ then
+ if Compile_Time_Known_Value (Right_Opnd (Cond))
+ and then Nkind (Left_Opnd (Cond)) = N_Identifier
+ then
+ declare
+ Ent : constant Entity_Id := Entity (Left_Opnd (Cond));
+
+ begin
+ if Ekind (Ent) = E_Variable
+ or else
+ Ekind (Ent) = E_Constant
+ or else
+ Is_Formal (Ent)
+ or else
+ Ekind (Ent) = E_Loop_Parameter
+ then
+ -- Here we have a case where the Current_Value field
+ -- may need to be set. We set it if it is not already
+ -- set to a compile time expression value.
+
+ -- Note that this represents a decision that one
+ -- condition blots out another previous one. That's
+ -- certainly right if they occur at the same level.
+ -- If the second one is nested, then the decision is
+ -- neither right nor wrong (it would be equally OK
+ -- to leave the outer one in place, or take the new
+ -- inner one. Really we should record both, but our
+ -- data structures are not that elaborate.
+
+ if Nkind (Current_Value (Ent)) not in N_Subexpr then
+ Set_Current_Value (Ent, Cnode);
+ end if;
+ end if;
+ end;
+ end if;
+ end if;
+ end Check_Possible_Current_Value_Condition;
+
----------------------------
-- Check_Unreachable_Code --
----------------------------
@@ -1213,7 +1467,15 @@ package body Sem_Ch5 is
if Operating_Mode = Generate_Code then
loop
Nxt := Next (N);
- exit when No (Nxt) or else not Is_Statement (Nxt);
+
+ -- Quit deleting when we have nothing more to delete
+ -- or if we hit a label (since someone could transfer
+ -- control to a label, so we should not delete it).
+
+ exit when No (Nxt) or else Nkind (Nxt) = N_Label;
+
+ -- Statement/declaration is to be deleted
+
Analyze (Nxt);
Remove (Nxt);
Kill_Dead_Code (Nxt);
diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads
index 9963b31b371..2fd057f7f01 100644
--- a/gcc/ada/sem_ch5.ads
+++ b/gcc/ada/sem_ch5.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 89687887b11..6c9b3990328 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,6 +32,7 @@ with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Ch7; use Exp_Ch7;
+with Fname; use Fname;
with Freeze; use Freeze;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
@@ -78,7 +79,8 @@ package body Sem_Ch6 is
-----------------------
procedure Analyze_Generic_Subprogram_Body (N : Node_Id; Gen_Id : Entity_Id);
- -- Analyze a generic subprogram body
+ -- Analyze a generic subprogram body. N is the body to be analyzed,
+ -- and Gen_Id is the defining entity Id for the corresponding spec.
function Build_Body_To_Inline
(N : Node_Id;
@@ -116,6 +118,14 @@ package body Sem_Ch6 is
-- against a formal access-to-subprogram type so Get_Instance_Of must
-- be called.
+ procedure Check_Overriding_Operation
+ (N : Node_Id;
+ Subp : Entity_Id);
+ -- Check that a subprogram with a pragma Overriding or Optional_Overriding
+ -- is legal. This check is performed here rather than in Sem_Prag because
+ -- the pragma must follow immediately the declaration, and can be treated
+ -- as part of the declaration itself, as described in AI-218.
+
procedure Check_Subprogram_Order (N : Node_Id);
-- N is the N_Subprogram_Body node for a subprogram. This routine applies
-- the alpha ordering rule for N if this ordering requirement applicable.
@@ -173,6 +183,12 @@ package body Sem_Ch6 is
-- Flag functions that can be called without parameters, i.e. those that
-- have no parameters, or those for which defaults exist for all parameters
+ procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id);
+ -- If there is a separate spec for a subprogram or generic subprogram,
+ -- the formals of the body are treated as references to the corresponding
+ -- formals of the spec. This reference does not count as an actual use of
+ -- the formal, in order to diagnose formals that are unused in the body.
+
procedure Set_Formal_Validity (Formal_Id : Entity_Id);
-- Formal_Id is an formal parameter entity. This procedure deals with
-- setting the proper validity status for this entity, which depends
@@ -183,7 +199,8 @@ package body Sem_Ch6 is
---------------------------------------------
procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id) is
- Designator : constant Entity_Id := Analyze_Spec (Specification (N));
+ Designator : constant Entity_Id :=
+ Analyze_Subprogram_Specification (Specification (N));
Scop : constant Entity_Id := Current_Scope;
begin
@@ -192,16 +209,14 @@ package body Sem_Ch6 is
New_Overloaded_Entity (Designator);
Check_Delayed_Subprogram (Designator);
- Set_Is_Pure (Designator,
- Is_Pure (Scop) and then Is_Library_Level_Entity (Designator));
- Set_Is_Remote_Call_Interface (
- Designator, Is_Remote_Call_Interface (Scop));
- Set_Is_Remote_Types (Designator, Is_Remote_Types (Scop));
+ Set_Categorization_From_Scope (Designator, Scop);
if Ekind (Scope (Designator)) = E_Protected_Type then
Error_Msg_N
("abstract subprogram not allowed in protected type", N);
end if;
+
+ Generate_Reference_To_Formals (Designator);
end Analyze_Abstract_Subprogram_Declaration;
----------------------------
@@ -236,7 +251,6 @@ package body Sem_Ch6 is
end if;
Analyze_Call (N);
-
end Analyze_Function_Call;
-------------------------------------
@@ -247,11 +261,11 @@ package body Sem_Ch6 is
(N : Node_Id;
Gen_Id : Entity_Id)
is
- Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Id);
- Spec : Node_Id;
+ Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Id);
Kind : constant Entity_Kind := Ekind (Gen_Id);
- Nam : Entity_Id;
+ Body_Id : Entity_Id;
New_N : Node_Id;
+ Spec : Node_Id;
begin
-- Copy body and disable expansion while analyzing the generic
@@ -269,22 +283,22 @@ package body Sem_Ch6 is
-- Within the body of the generic, the subprogram is callable, and
-- behaves like the corresponding non-generic unit.
- Nam := Defining_Entity (Spec);
+ Body_Id := Defining_Entity (Spec);
if Kind = E_Generic_Procedure
and then Nkind (Spec) /= N_Procedure_Specification
then
- Error_Msg_N ("invalid body for generic procedure ", Nam);
+ Error_Msg_N ("invalid body for generic procedure ", Body_Id);
return;
elsif Kind = E_Generic_Function
and then Nkind (Spec) /= N_Function_Specification
then
- Error_Msg_N ("invalid body for generic function ", Nam);
+ Error_Msg_N ("invalid body for generic function ", Body_Id);
return;
end if;
- Set_Corresponding_Body (Gen_Decl, Nam);
+ Set_Corresponding_Body (Gen_Decl, Body_Id);
if Has_Completion (Gen_Id)
and then Nkind (Parent (N)) /= N_Subunit
@@ -329,26 +343,16 @@ package body Sem_Ch6 is
-- Now generic formals are visible, and the specification can be
-- analyzed, for subsequent conformance check.
- Nam := Analyze_Spec (Spec);
+ Body_Id := Analyze_Subprogram_Specification (Spec);
- if Nkind (N) = N_Subprogram_Body_Stub then
-
- -- Nothing to do if no body to process
-
- Set_Ekind (Nam, Kind);
- End_Scope;
- return;
- end if;
+ -- Make formal parameters visible
if Present (E) then
- -- E is the first formal parameter, which must be the first
- -- entity in the subprogram body.
+ -- E is the first formal parameter, we loop through the formals
+ -- installing them so that they will be visible.
Set_First_Entity (Gen_Id, E);
-
- -- Now make formal parameters visible
-
while Present (E) loop
Install_Entity (E);
Next_Formal (E);
@@ -357,10 +361,26 @@ package body Sem_Ch6 is
-- Visible generic entity is callable within its own body.
- Set_Ekind (Gen_Id, Ekind (Nam));
- Set_Convention (Nam, Convention (Gen_Id));
- Set_Scope (Nam, Scope (Gen_Id));
- Check_Fully_Conformant (Nam, Gen_Id, Nam);
+ Set_Ekind (Gen_Id, Ekind (Body_Id));
+ Set_Ekind (Body_Id, E_Subprogram_Body);
+ Set_Convention (Body_Id, Convention (Gen_Id));
+ Set_Scope (Body_Id, Scope (Gen_Id));
+ Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id);
+
+ if Nkind (N) = N_Subprogram_Body_Stub then
+
+ -- No body to analyze, so restore state of generic unit.
+
+ Set_Ekind (Gen_Id, Kind);
+ Set_Ekind (Body_Id, Kind);
+
+ if Present (First_Ent) then
+ Set_First_Entity (Gen_Id, First_Ent);
+ end if;
+
+ End_Scope;
+ return;
+ end if;
-- If this is a compilation unit, it must be made visible
-- explicitly, because the compilation of the declaration,
@@ -368,6 +388,7 @@ package body Sem_Ch6 is
-- is not a unit, the following is redundant but harmless.
Set_Is_Immediately_Visible (Gen_Id);
+ Reference_Body_Formals (Gen_Id, Body_Id);
Set_Actual_Subtypes (N, Current_Scope);
Analyze_Declarations (Declarations (N));
@@ -383,6 +404,7 @@ package body Sem_Ch6 is
Set_First_Entity (Gen_Id, First_Ent);
end if;
+ Check_References (Gen_Id);
end;
End_Scope;
@@ -391,11 +413,9 @@ package body Sem_Ch6 is
-- Outside of its body, unit is generic again.
Set_Ekind (Gen_Id, Kind);
- Set_Ekind (Nam, E_Subprogram_Body);
- Generate_Reference (Gen_Id, Nam, 'b');
- Style.Check_Identifier (Nam, Gen_Id);
+ Generate_Reference (Gen_Id, Body_Id, 'b', Set_Ref => False);
+ Style.Check_Identifier (Body_Id, Gen_Id);
End_Generic;
-
end Analyze_Generic_Subprogram_Body;
-----------------------------
@@ -453,6 +473,10 @@ package body Sem_Ch6 is
procedure Analyze_Call_And_Resolve;
-- Do Analyze and Resolve calls for procedure call
+ ------------------------------
+ -- Analyze_Call_And_Resolve --
+ ------------------------------
+
procedure Analyze_Call_And_Resolve is
begin
if Nkind (N) = N_Procedure_Call_Statement then
@@ -734,7 +758,7 @@ package body Sem_Ch6 is
if (Ekind (Scope_Id) = E_Procedure
or else Ekind (Scope_Id) = E_Generic_Procedure)
- and then No_Return (Scope_Id)
+ and then No_Return (Scope_Id)
then
Error_Msg_N
("RETURN statement not allowed (No_Return)", N);
@@ -744,70 +768,6 @@ package body Sem_Ch6 is
Check_Unreachable_Code (N);
end Analyze_Return_Statement;
- ------------------
- -- Analyze_Spec --
- ------------------
-
- function Analyze_Spec (N : Node_Id) return Entity_Id is
- Designator : constant Entity_Id := Defining_Entity (N);
- Formals : constant List_Id := Parameter_Specifications (N);
- Typ : Entity_Id;
-
- begin
- Generate_Definition (Designator);
-
- if Nkind (N) = N_Function_Specification then
- Set_Ekind (Designator, E_Function);
- Set_Mechanism (Designator, Default_Mechanism);
-
- if Subtype_Mark (N) /= Error then
- Find_Type (Subtype_Mark (N));
- Typ := Entity (Subtype_Mark (N));
- Set_Etype (Designator, Typ);
-
- if (Ekind (Typ) = E_Incomplete_Type
- or else (Is_Class_Wide_Type (Typ)
- and then
- Ekind (Root_Type (Typ)) = E_Incomplete_Type))
- then
- Error_Msg_N
- ("invalid use of incomplete type", Subtype_Mark (N));
- end if;
-
- else
- Set_Etype (Designator, Any_Type);
- end if;
-
- else
- Set_Ekind (Designator, E_Procedure);
- Set_Etype (Designator, Standard_Void_Type);
- end if;
-
- if Present (Formals) then
- Set_Scope (Designator, Current_Scope);
- New_Scope (Designator);
- Process_Formals (Formals, N);
- End_Scope;
- end if;
-
- if Nkind (N) = N_Function_Specification then
- if Nkind (Designator) = N_Defining_Operator_Symbol then
- Valid_Operator_Definition (Designator);
- end if;
-
- May_Need_Actuals (Designator);
-
- if Is_Abstract (Etype (Designator))
- and then Nkind (Parent (N)) /= N_Abstract_Subprogram_Declaration
- then
- Error_Msg_N
- ("function that returns abstract type must be abstract", N);
- end if;
- end if;
-
- return Designator;
- end Analyze_Spec;
-
-----------------------------
-- Analyze_Subprogram_Body --
-----------------------------
@@ -818,10 +778,11 @@ package body Sem_Ch6 is
-- the subprogram, or to perform conformance checks.
procedure Analyze_Subprogram_Body (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Body_Spec : constant Node_Id := Specification (N);
- Body_Id : Entity_Id := Defining_Entity (Body_Spec);
- Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
+ Loc : constant Source_Ptr := Sloc (N);
+ Body_Spec : constant Node_Id := Specification (N);
+ Body_Id : Entity_Id := Defining_Entity (Body_Spec);
+ Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
+ Body_Deleted : constant Boolean := False;
HSS : Node_Id;
Spec_Id : Entity_Id;
@@ -829,7 +790,6 @@ package body Sem_Ch6 is
Last_Formal : Entity_Id := Empty;
Conformant : Boolean;
Missing_Ret : Boolean;
- Body_Deleted : Boolean := False;
P_Ent : Entity_Id;
begin
@@ -856,9 +816,7 @@ package body Sem_Ch6 is
and then (Nkind (Parent (Prev_Id)) /= N_Package_Renaming_Declaration
or else Comes_From_Source (Prev_Id))
then
- if Ekind (Prev_Id) = E_Generic_Procedure
- or else Ekind (Prev_Id) = E_Generic_Function
- then
+ if Is_Generic_Subprogram (Prev_Id) then
Spec_Id := Prev_Id;
Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
@@ -886,7 +844,7 @@ package body Sem_Ch6 is
return;
else
- Body_Id := Analyze_Spec (Body_Spec);
+ Body_Id := Analyze_Subprogram_Specification (Body_Spec);
if Nkind (N) = N_Subprogram_Body_Stub
or else No (Corresponding_Spec (N))
@@ -935,16 +893,15 @@ package body Sem_Ch6 is
P_Ent := Scope (P_Ent);
exit when No (P_Ent) or else P_Ent = Standard_Standard;
- if Is_Subprogram (P_Ent) and then Is_Inlined (P_Ent) then
+ if Is_Subprogram (P_Ent) then
Set_Is_Inlined (P_Ent, False);
if Comes_From_Source (P_Ent)
- and then Ineffective_Inline_Warnings
and then Has_Pragma_Inline (P_Ent)
then
- Error_Msg_NE
- ("?pragma Inline for & ignored (has nested subprogram)",
- Get_Rep_Pragma (P_Ent, Name_Inline), P_Ent);
+ Cannot_Inline
+ ("cannot inline& (nested subprogram)?",
+ N, P_Ent);
end if;
end if;
end loop;
@@ -1033,7 +990,9 @@ package body Sem_Ch6 is
if Present (Spec_Id) then
Generate_Reference (Spec_Id, Body_Id, 'b', Set_Ref => False);
- Style.Check_Identifier (Body_Id, Spec_Id);
+ if Style_Check then
+ Style.Check_Identifier (Body_Id, Spec_Id);
+ end if;
Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
@@ -1089,28 +1048,8 @@ package body Sem_Ch6 is
end if;
end if;
- -- Generate references from body formals to spec formals
- -- and also set the Spec_Entity fields for all formals. We
- -- do not set this reference count as a reference for the
- -- purposes of identifying unreferenced formals however.
-
if Spec_Id /= Body_Id then
- declare
- Fs : Entity_Id;
- Fb : Entity_Id;
-
- begin
- Fs := First_Formal (Spec_Id);
- Fb := First_Formal (Body_Id);
- while Present (Fs) loop
- Generate_Reference (Fs, Fb, 'b');
- Style.Check_Identifier (Fb, Fs);
- Set_Spec_Entity (Fb, Fs);
- Set_Referenced (Fs, False);
- Next_Formal (Fs);
- Next_Formal (Fb);
- end loop;
- end;
+ Reference_Body_Formals (Spec_Id, Body_Id);
end if;
if Nkind (N) /= N_Subprogram_Body_Stub then
@@ -1146,6 +1085,9 @@ package body Sem_Ch6 is
if Nkind (N) /= N_Subprogram_Body_Stub then
Set_Acts_As_Spec (N);
Generate_Definition (Body_Id);
+ Generate_Reference
+ (Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
+ Generate_Reference_To_Formals (Body_Id);
Install_Formals (Body_Id);
New_Scope (Body_Id);
end if;
@@ -1161,10 +1103,11 @@ package body Sem_Ch6 is
and then not Error_Posted (Body_Id)
then
declare
+ Old_Id : constant Entity_Id :=
+ Defining_Entity
+ (Specification (Corresponding_Stub (Parent (N))));
+
Conformant : Boolean := False;
- Old_Id : Entity_Id :=
- Defining_Entity
- (Specification (Corresponding_Stub (Parent (N))));
begin
if No (Spec_Id) then
@@ -1196,7 +1139,8 @@ package body Sem_Ch6 is
and then (Is_Always_Inlined (Spec_Id)
or else (Has_Pragma_Inline (Spec_Id)
and then
- (Front_End_Inlining or else No_Run_Time)))
+ (Front_End_Inlining
+ or else Configurable_Run_Time_Mode)))
then
if Build_Body_To_Inline (N, Spec_Id, Copy_Separate_Tree (N)) then
null;
@@ -1284,22 +1228,77 @@ package body Sem_Ch6 is
Check_Returns (HSS, 'P', Missing_Ret);
end if;
- -- Don't worry about checking for variables that are never modified
- -- if the first statement of the body is a raise statement, since
- -- we assume this is some kind of stub. We ignore a label generated
- -- by the exception stuff for the purpose of this test.
+ -- Now we are going to check for variables that are never modified
+ -- in the body of the procedure. We omit these checks if the first
+ -- statement of the procedure raises an exception. In particular
+ -- this deals with the common idiom of a stubbed function, which
+ -- might appear as something like
+
+ -- function F (A : Integer) return Some_Type;
+ -- X : Some_Type;
+ -- begin
+ -- raise Program_Error;
+ -- return X;
+ -- end F;
+
+ -- Here the purpose of X is simply to satisfy the (annoying)
+ -- requirement in Ada that there be at least one return, and
+ -- we certainly do not want to go posting warnings on X that
+ -- it is not initialized!
declare
Stm : Node_Id := First (Statements (HSS));
begin
+ -- Skip an initial label (for one thing this occurs when we
+ -- are in front end ZCX mode, but in any case it is irrelevant).
+
if Nkind (Stm) = N_Label then
Next (Stm);
end if;
- if Nkind (Original_Node (Stm)) = N_Raise_Statement then
- return;
- end if;
+ -- Do the test on the original statement before expansion
+
+ declare
+ Ostm : constant Node_Id := Original_Node (Stm);
+
+ begin
+ -- If explicit raise statement, return with no checks
+
+ if Nkind (Ostm) = N_Raise_Statement then
+ return;
+
+ -- Check for explicit call cases which likely raise an exception
+
+ elsif Nkind (Ostm) = N_Procedure_Call_Statement then
+ if Is_Entity_Name (Name (Ostm)) then
+ declare
+ Ent : constant Entity_Id := Entity (Name (Ostm));
+
+ begin
+ -- If the procedure is marked No_Return, then likely it
+ -- raises an exception, but in any case it is not coming
+ -- back here, so no need to check beyond the call.
+
+ if Ekind (Ent) = E_Procedure
+ and then No_Return (Ent)
+ then
+ return;
+
+ -- If the procedure name is Raise_Exception, then also
+ -- assume that it raises an exception. The main target
+ -- here is Ada.Exceptions.Raise_Exception, but this name
+ -- is pretty evocative in any context! Note that the
+ -- procedure in Ada.Exceptions is not marked No_Return
+ -- because of the annoying case of the null exception Id.
+
+ elsif Chars (Ent) = Name_Raise_Exception then
+ return;
+ end if;
+ end;
+ end if;
+ end if;
+ end;
end;
-- Check for variables that are never modified
@@ -1308,7 +1307,7 @@ package body Sem_Ch6 is
E1, E2 : Entity_Id;
begin
- -- If there is a separate spec, then transfer Not_Source_Assigned
+ -- If there is a separate spec, then transfer Never_Set_In_Source
-- flags from out parameters to the corresponding entities in the
-- body. The reason we do that is we want to post error flags on
-- the body entities, not the spec entities.
@@ -1319,21 +1318,14 @@ package body Sem_Ch6 is
while Present (E1) loop
if Ekind (E1) = E_Out_Parameter then
E2 := First_Entity (Body_Id);
-
- loop
- -- If no matching body entity, then we already had
- -- a detected error of some kind, so just forget
- -- about worrying about these warnings.
-
- if No (E2) then
- return;
- end if;
-
+ while Present (E2) loop
exit when Chars (E1) = Chars (E2);
Next_Entity (E2);
end loop;
- Set_Not_Source_Assigned (E2, Not_Source_Assigned (E1));
+ if Present (E2) then
+ Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
+ end if;
end if;
Next_Entity (E1);
@@ -1355,8 +1347,9 @@ package body Sem_Ch6 is
------------------------------------
procedure Analyze_Subprogram_Declaration (N : Node_Id) is
- Designator : constant Entity_Id := Analyze_Spec (Specification (N));
- Scop : constant Entity_Id := Current_Scope;
+ Designator : constant Entity_Id :=
+ Analyze_Subprogram_Specification (Specification (N));
+ Scop : constant Entity_Id := Current_Scope;
-- Start of processing for Analyze_Subprogram_Declaration
@@ -1384,18 +1377,22 @@ package body Sem_Ch6 is
New_Overloaded_Entity (Designator);
Check_Delayed_Subprogram (Designator);
- Set_Suppress_Elaboration_Checks
- (Designator, Elaboration_Checks_Suppressed (Designator));
+
+ -- What is the following code for, it used to be
+
+ -- ??? Set_Suppress_Elaboration_Checks
+ -- ??? (Designator, Elaboration_Checks_Suppressed (Designator));
+
+ -- The following seems equivalent, but a bit dubious
+
+ if Elaboration_Checks_Suppressed (Designator) then
+ Set_Kill_Elaboration_Checks (Designator);
+ end if;
if Scop /= Standard_Standard
and then not Is_Child_Unit (Designator)
then
- Set_Is_Pure (Designator,
- Is_Pure (Scop) and then Is_Library_Level_Entity (Designator));
- Set_Is_Remote_Call_Interface (
- Designator, Is_Remote_Call_Interface (Scop));
- Set_Is_Remote_Types (Designator, Is_Remote_Types (Scop));
-
+ Set_Categorization_From_Scope (Designator, Scop);
else
-- For a compilation unit, check for library-unit pragmas.
@@ -1412,9 +1409,85 @@ package body Sem_Ch6 is
Set_Body_Required (Parent (N), True);
end if;
+ Generate_Reference_To_Formals (Designator);
Check_Eliminated (Designator);
+
+ if Comes_From_Source (N)
+ and then Is_List_Member (N)
+ then
+ Check_Overriding_Operation (N, Designator);
+ end if;
+
end Analyze_Subprogram_Declaration;
+ --------------------------------------
+ -- Analyze_Subprogram_Specification --
+ --------------------------------------
+
+ -- Reminder: N here really is a subprogram specification (not a subprogram
+ -- declaration). This procedure is called to analyze the specification in
+ -- both subprogram bodies and subprogram declarations (specs).
+
+ function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
+ Designator : constant Entity_Id := Defining_Entity (N);
+ Formals : constant List_Id := Parameter_Specifications (N);
+ Typ : Entity_Id;
+
+ begin
+ Generate_Definition (Designator);
+
+ if Nkind (N) = N_Function_Specification then
+ Set_Ekind (Designator, E_Function);
+ Set_Mechanism (Designator, Default_Mechanism);
+
+ if Subtype_Mark (N) /= Error then
+ Find_Type (Subtype_Mark (N));
+ Typ := Entity (Subtype_Mark (N));
+ Set_Etype (Designator, Typ);
+
+ if Ekind (Typ) = E_Incomplete_Type
+ or else (Is_Class_Wide_Type (Typ)
+ and then
+ Ekind (Root_Type (Typ)) = E_Incomplete_Type)
+ then
+ Error_Msg_N
+ ("invalid use of incomplete type", Subtype_Mark (N));
+ end if;
+
+ else
+ Set_Etype (Designator, Any_Type);
+ end if;
+
+ else
+ Set_Ekind (Designator, E_Procedure);
+ Set_Etype (Designator, Standard_Void_Type);
+ end if;
+
+ if Present (Formals) then
+ Set_Scope (Designator, Current_Scope);
+ New_Scope (Designator);
+ Process_Formals (Formals, N);
+ End_Scope;
+ end if;
+
+ if Nkind (N) = N_Function_Specification then
+ if Nkind (Designator) = N_Defining_Operator_Symbol then
+ Valid_Operator_Definition (Designator);
+ end if;
+
+ May_Need_Actuals (Designator);
+
+ if Is_Abstract (Etype (Designator))
+ and then Nkind (Parent (N)) /= N_Abstract_Subprogram_Declaration
+ then
+ Error_Msg_N
+ ("function that returns abstract type must be abstract", N);
+ end if;
+ end if;
+
+ return Designator;
+ end Analyze_Subprogram_Specification;
+
--------------------------
-- Build_Body_To_Inline --
--------------------------
@@ -1422,7 +1495,8 @@ package body Sem_Ch6 is
function Build_Body_To_Inline
(N : Node_Id;
Subp : Entity_Id;
- Orig_Body : Node_Id) return Boolean
+ Orig_Body : Node_Id)
+ return Boolean
is
Decl : constant Node_Id := Unit_Declaration_Node (Subp);
Original_Body : Node_Id;
@@ -1445,23 +1519,11 @@ package body Sem_Ch6 is
-- conflict with subsequent inlinings, so that it is unsafe to try to
-- inline in such a case.
- -------------------
- -- Cannot_Inline --
- -------------------
-
- procedure Cannot_Inline (Msg : String; N : Node_Id);
- -- If subprogram has pragma Inline_Always, it is an error if
- -- it cannot be inlined. Otherwise, emit a warning.
-
- procedure Cannot_Inline (Msg : String; N : Node_Id) is
- begin
- if Is_Always_Inlined (Subp) then
- Error_Msg_NE (Msg (1 .. Msg'Length - 1), N, Subp);
-
- elsif Ineffective_Inline_Warnings then
- Error_Msg_NE (Msg, N, Subp);
- end if;
- end Cannot_Inline;
+ procedure Remove_Pragmas;
+ -- A pragma Unreferenced that mentions a formal parameter has no
+ -- meaning when the body is inlined and the formals are rewritten.
+ -- Remove it from body to inline. The analysis of the non-inlined
+ -- body will handle the pragma properly.
------------------------------
-- Has_Excluded_Declaration --
@@ -1470,11 +1532,46 @@ package body Sem_Ch6 is
function Has_Excluded_Declaration (Decls : List_Id) return Boolean is
D : Node_Id;
+ function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
+ -- Nested subprograms make a given body ineligible for inlining,
+ -- but we make an exception for instantiations of unchecked
+ -- conversion. The body has not been analyzed yet, so we check
+ -- the name, and verify that the visible entity with that name is
+ -- the predefined unit.
+
+ function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
+ Id : constant Node_Id := Name (D);
+ Conv : Entity_Id;
+
+ begin
+ if Nkind (Id) = N_Identifier
+ and then Chars (Id) = Name_Unchecked_Conversion
+ then
+ Conv := Current_Entity (Id);
+
+ elsif Nkind (Id) = N_Selected_Component
+ and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
+ then
+ Conv := Current_Entity (Selector_Name (Id));
+
+ else
+ return False;
+ end if;
+
+ return
+ Present (Conv)
+ and then Scope (Conv) = Standard_Standard
+ and then Is_Intrinsic_Subprogram (Conv);
+ end Is_Unchecked_Conversion;
+
+ -- Start of processing for Has_Excluded_Declaration
+
begin
D := First (Decls);
while Present (D) loop
- if Nkind (D) = N_Function_Instantiation
+ if (Nkind (D) = N_Function_Instantiation
+ and then not Is_Unchecked_Conversion (D))
or else Nkind (D) = N_Protected_Type_Declaration
or else Nkind (D) = N_Package_Declaration
or else Nkind (D) = N_Package_Instantiation
@@ -1483,7 +1580,7 @@ package body Sem_Ch6 is
or else Nkind (D) = N_Task_Type_Declaration
then
Cannot_Inline
- ("\declaration prevents front-end inlining of&?", D);
+ ("cannot inline & (non-allowed declaration)?", D, Subp);
return True;
end if;
@@ -1491,7 +1588,6 @@ package body Sem_Ch6 is
end loop;
return False;
-
end Has_Excluded_Declaration;
----------------------------
@@ -1517,7 +1613,7 @@ package body Sem_Ch6 is
or else Nkind (S) = N_Timed_Entry_Call
then
Cannot_Inline
- ("\statement prevents front-end inlining of&?", S);
+ ("cannot inline & (non-allowed statement)?", S, Subp);
return True;
elsif Nkind (S) = N_Block_Statement then
@@ -1607,6 +1703,29 @@ package body Sem_Ch6 is
return False;
end Has_Pending_Instantiation;
+ --------------------
+ -- Remove_Pragmas --
+ --------------------
+
+ procedure Remove_Pragmas is
+ Decl : Node_Id;
+ Nxt : Node_Id;
+
+ begin
+ Decl := First (Declarations (Body_To_Analyze));
+ while Present (Decl) loop
+ Nxt := Next (Decl);
+
+ if Nkind (Decl) = N_Pragma
+ and then Chars (Decl) = Name_Unreferenced
+ then
+ Remove (Decl);
+ end if;
+
+ Decl := Nxt;
+ end loop;
+ end Remove_Pragmas;
+
-- Start of processing for Build_Body_To_Inline
begin
@@ -1624,7 +1743,7 @@ package body Sem_Ch6 is
and then not Is_Constrained (Etype (Subp))
then
Cannot_Inline
- ("unconstrained return type prevents front-end inlining of&?", N);
+ ("cannot inline & (unconstrained return type)?", N, Subp);
return False;
end if;
@@ -1660,6 +1779,9 @@ package body Sem_Ch6 is
(Generic_Parent (Specification (N)), Empty,
Instantiating => True);
end if;
+
+ -- Case of not in an instance
+
else
Body_To_Analyze :=
Copy_Generic_Node (Original_Body, Empty,
@@ -1683,11 +1805,11 @@ package body Sem_Ch6 is
end if;
if Present (Handled_Statement_Sequence (N)) then
- if
- (Present (Exception_Handlers (Handled_Statement_Sequence (N))))
- then
- Cannot_Inline ("handler prevents front-end inlining of&?",
- First (Exception_Handlers (Handled_Statement_Sequence (N))));
+ if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
+ Cannot_Inline
+ ("cannot inline& (exception handler)?",
+ First (Exception_Handlers (Handled_Statement_Sequence (N))),
+ Subp);
return False;
elsif
Has_Excluded_Statement
@@ -1704,14 +1826,14 @@ package body Sem_Ch6 is
if Stat_Count > Max_Size
and then not Is_Always_Inlined (Subp)
then
- Cannot_Inline ("body is too large for front-end inlining of&?", N);
+ Cannot_Inline ("cannot inline& (body too large)?", N, Subp);
return False;
end if;
if Has_Pending_Instantiation then
Cannot_Inline
- ("cannot inline& because of forward instance within enclosing body",
- N);
+ ("cannot inline& (forward instance within enclosing body)?",
+ N, Subp);
return False;
end if;
@@ -1732,6 +1854,7 @@ package body Sem_Ch6 is
end if;
Expander_Mode_Save_And_Set (False);
+ Remove_Pragmas;
Analyze (Body_To_Analyze);
New_Scope (Defining_Entity (Body_To_Analyze));
@@ -1741,11 +1864,35 @@ package body Sem_Ch6 is
Expander_Mode_Restore;
Set_Body_To_Inline (Decl, Original_Body);
+ Set_Ekind (Defining_Entity (Original_Body), Ekind (Subp));
Set_Is_Inlined (Subp);
return True;
-
end Build_Body_To_Inline;
+ -------------------
+ -- Cannot_Inline --
+ -------------------
+
+ procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id) is
+ begin
+ -- Do not emit warning if this is a predefined unit which is not
+ -- the main unit. With validity checks enabled, some predefined
+ -- subprograms may contain nested subprograms and become ineligible
+ -- for inlining.
+
+ if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
+ and then not In_Extended_Main_Source_Unit (Subp)
+ then
+ null;
+
+ elsif Is_Always_Inlined (Subp) then
+ Error_Msg_NE (Msg (1 .. Msg'Length - 1), N, Subp);
+
+ elsif Ineffective_Inline_Warnings then
+ Error_Msg_NE (Msg, N, Subp);
+ end if;
+ end Cannot_Inline;
+
-----------------------
-- Check_Conformance --
-----------------------
@@ -1856,7 +2003,6 @@ package body Sem_Ch6 is
-- entity is inherited.
if Ctype >= Subtype_Conformant then
-
if Convention (Old_Id) /= Convention (New_Id) then
if not Is_Frozen (New_Id) then
@@ -1897,6 +2043,21 @@ package body Sem_Ch6 is
New_Formal := First_Formal (New_Id);
while Present (Old_Formal) and then Present (New_Formal) loop
+ if Ctype = Fully_Conformant then
+
+ -- Names must match. Error message is more accurate if we do
+ -- this before checking that the types of the formals match.
+
+ if Chars (Old_Formal) /= Chars (New_Formal) then
+ Conformance_Error ("name & does not match!", New_Formal);
+
+ -- Set error posted flag on new formal as well to stop
+ -- junk cascaded messages in some cases.
+
+ Set_Error_Posted (New_Formal);
+ return;
+ end if;
+ end if;
-- Types must always match. In the visible part of an instance,
-- usual overloading rules for dispatching operations apply, and
@@ -1933,15 +2094,10 @@ package body Sem_Ch6 is
if Ctype = Fully_Conformant then
- -- Names must match
-
- if Chars (Old_Formal) /= Chars (New_Formal) then
- Conformance_Error ("name & does not match!", New_Formal);
- return;
+ -- We have checked already that names match.
+ -- Check default expressions for in parameters
- -- And default expressions for in parameters
-
- elsif Parameter_Mode (Old_Formal) = E_In_Parameter then
+ if Parameter_Mode (Old_Formal) = E_In_Parameter then
declare
NewD : constant Boolean :=
Present (Default_Value (New_Formal));
@@ -1950,15 +2106,16 @@ package body Sem_Ch6 is
begin
if NewD or OldD then
- -- The old default value has been analyzed and expanded,
- -- because the current full declaration will have frozen
+ -- The old default value has been analyzed because
+ -- the current full declaration will have frozen
-- everything before. The new default values have not
- -- been expanded, so expand now to check conformance.
+ -- been analyzed, so analyze them now before we check
+ -- for conformance.
if NewD then
New_Scope (New_Id);
- Analyze_Default_Expression
- (Default_Value (New_Formal), Etype (New_Formal));
+ Analyze_Per_Use_Expression
+ (Default_Value (New_Formal), Etype (New_Formal));
End_Scope;
end if;
@@ -2170,6 +2327,14 @@ package body Sem_Ch6 is
then
Conformance_Error ("type of & does not match!", New_Discr_Id);
return;
+ else
+ -- Treat the new discriminant as an occurrence of the old
+ -- one, for navigation purposes, and fill in some semantic
+ -- information, for completeness.
+
+ Generate_Reference (Old_Discr, New_Discr_Id, 'r');
+ Set_Etype (New_Discr_Id, Etype (Old_Discr));
+ Set_Scope (New_Discr_Id, Scope (Old_Discr));
end if;
-- Names must match
@@ -2196,7 +2361,7 @@ package body Sem_Ch6 is
-- been expanded, so expand now to check conformance.
if NewD then
- Analyze_Default_Expression
+ Analyze_Per_Use_Expression
(Expression (New_Discr), New_Discr_Type);
end if;
@@ -2288,6 +2453,102 @@ package body Sem_Ch6 is
(New_Id, Old_Id, Mode_Conformant, True, Result, Err_Loc, Get_Inst);
end Check_Mode_Conformant;
+ --------------------------------
+ -- Check_Overriding_Operation --
+ --------------------------------
+
+ procedure Check_Overriding_Operation
+ (N : Node_Id;
+ Subp : Entity_Id)
+ is
+ Arg1 : Node_Id;
+ Decl : Node_Id;
+ Has_Pragma : Boolean := False;
+
+ begin
+ -- See whether there is an overriding pragma immediately following
+ -- the declaration. Intervening pragmas, such as Inline, are allowed.
+
+ Decl := Next (N);
+ while Present (Decl)
+ and then Nkind (Decl) = N_Pragma
+ loop
+ if Chars (Decl) = Name_Overriding
+ or else Chars (Decl) = Name_Optional_Overriding
+ then
+ -- For now disable the use of these pragmas, until the ARG
+ -- finalizes the design of this feature.
+
+ Error_Msg_N ("?unrecognized pragma", Decl);
+
+ if not Is_Overriding_Operation (Subp) then
+
+ -- Before emitting an error message, check whether this
+ -- may override an operation that is not yet visible, as
+ -- in the case of a derivation of a private operation in
+ -- a child unit. Such an operation is introduced with a
+ -- different name, but its alias is the parent operation.
+
+ declare
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Current_Scope);
+
+ while Present (E) loop
+ if Ekind (E) = Ekind (Subp)
+ and then not Comes_From_Source (E)
+ and then Present (Alias (E))
+ and then Chars (Alias (E)) = Chars (Subp)
+ and then In_Open_Scopes (Scope (Alias (E)))
+ then
+ exit;
+ else
+ Next_Entity (E);
+ end if;
+ end loop;
+
+ if No (E) then
+ Error_Msg_NE
+ ("& must override an inherited operation",
+ Decl, Subp);
+ end if;
+ end;
+ end if;
+
+ -- Verify syntax of pragma
+
+ Arg1 := First (Pragma_Argument_Associations (Decl));
+
+ if Present (Arg1) then
+ if not Is_Entity_Name (Expression (Arg1)) then
+ Error_Msg_N ("pragma applies to local subprogram", Decl);
+
+ elsif Chars (Expression (Arg1)) /= Chars (Subp) then
+ Error_Msg_N
+ ("pragma must apply to preceding subprogram", Decl);
+
+ elsif Present (Next (Arg1)) then
+ Error_Msg_N ("illegal pragma format", Decl);
+ end if;
+ end if;
+
+ Set_Analyzed (Decl);
+ Has_Pragma := True;
+ exit;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ if not Has_Pragma
+ and then Explicit_Overriding
+ and then Is_Overriding_Operation (Subp)
+ then
+ Error_Msg_NE ("Missing overriding pragma for&", Subp, Subp);
+ end if;
+ end Check_Overriding_Operation;
+
-------------------
-- Check_Returns --
-------------------
@@ -2639,7 +2900,8 @@ package body Sem_Ch6 is
begin
-- Check body in alpha order if this is option
- if Style_Check_Subprogram_Order
+ if Style_Check
+ and then Style_Check_Subprogram_Order
and then Nkind (N) = N_Subprogram_Body
and then Comes_From_Source (N)
and then In_Extended_Main_Source_Unit (N)
@@ -2779,6 +3041,14 @@ package body Sem_Ch6 is
then
return Ctype <= Mode_Conformant
or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
+
+ elsif Is_Private_Type (Type_2)
+ and then In_Instance
+ and then Present (Full_View (Type_2))
+ and then Base_Types_Match (Type_1, Full_View (Type_2))
+ then
+ return Ctype <= Mode_Conformant
+ or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
end if;
-- Test anonymous access type case. For this case, static subtype
@@ -2827,11 +3097,13 @@ package body Sem_Ch6 is
-- This can only happen in the context of an access parameter,
-- other uses of an incomplete Class_Wide_Type are illegal.
- if Ekind (Desig_1) = E_Class_Wide_Type
- and then Ekind (Desig_2) = E_Class_Wide_Type
+ if Is_Class_Wide_Type (Desig_1)
+ and then Is_Class_Wide_Type (Desig_2)
then
return
- Conforming_Types (Etype (Desig_1), Etype (Desig_2), Ctype);
+ Conforming_Types
+ (Etype (Base_Type (Desig_1)),
+ Etype (Base_Type (Desig_2)), Ctype);
else
return Base_Type (Desig_1) = Base_Type (Desig_2)
and then (Ctype = Type_Conformant
@@ -2854,7 +3126,6 @@ package body Sem_Ch6 is
procedure Create_Extra_Formals (E : Entity_Id) is
Formal : Entity_Id;
- Last_Formal : Entity_Id;
Last_Extra : Entity_Id;
Formal_Type : Entity_Id;
P_Formal : Entity_Id := Empty;
@@ -2864,6 +3135,10 @@ package body Sem_Ch6 is
-- extra formal is added to the list of extra formals, and also
-- returned as the result. These formals are always of mode IN.
+ ----------------------
+ -- Add_Extra_Formal --
+ ----------------------
+
function Add_Extra_Formal (Typ : Entity_Id) return Entity_Id is
EF : constant Entity_Id :=
Make_Defining_Identifier (Sloc (Formal),
@@ -2962,17 +3237,18 @@ package body Sem_Ch6 is
-- Create extra formal for supporting accessibility checking
-- This is suppressed if we specifically suppress accessibility
- -- checks for either the subprogram, or the package in which it
- -- resides. However, we do not suppress it simply if the scope
- -- has accessibility checks suppressed, since this could cause
- -- trouble when clients are compiled with a different suppression
- -- setting. The explicit checks are safe from this point of view.
+ -- checks at the pacage level for either the subprogram, or the
+ -- package in which it resides. However, we do not suppress it
+ -- simply if the scope has accessibility checks suppressed, since
+ -- this could cause trouble when clients are compiled with a
+ -- different suppression setting. The explicit checks at the
+ -- package level are safe from this point of view.
if Ekind (Etype (Formal)) = E_Anonymous_Access_Type
and then not
- (Suppress_Accessibility_Checks (E)
+ (Explicit_Suppress (E, Accessibility_Check)
or else
- Suppress_Accessibility_Checks (Scope (E)))
+ Explicit_Suppress (Scope (E), Accessibility_Check))
and then
(not Present (P_Formal)
or else Present (Extra_Accessibility (P_Formal)))
@@ -2994,7 +3270,6 @@ package body Sem_Ch6 is
Next_Formal (P_Formal);
end if;
- Last_Formal := Formal;
Next_Formal (Formal);
end loop;
end Create_Extra_Formals;
@@ -3095,10 +3370,9 @@ package body Sem_Ch6 is
-- another regardless of whether they are type conformant or not).
if Scope (E) = Current_Scope then
- if (Current_Scope = Standard_Standard
- or else (Ekind (E) = Ekind (Designator)
- and then
- Type_Conformant (E, Designator)))
+ if Current_Scope = Standard_Standard
+ or else (Ekind (E) = Ekind (Designator)
+ and then Type_Conformant (E, Designator))
then
-- Within an instantiation, we know that spec and body are
-- subtype conformant, because they were subtype conformant
@@ -3488,7 +3762,6 @@ package body Sem_Ch6 is
when N_Parameter_Association =>
return
-
Chars (Selector_Name (E1)) = Chars (Selector_Name (E2))
and then FCE (Explicit_Actual_Parameter (E1),
Explicit_Actual_Parameter (E2));
@@ -3570,6 +3843,70 @@ package body Sem_Ch6 is
end if;
end Fully_Conformant_Expressions;
+ ----------------------------------------
+ -- Fully_Conformant_Discrete_Subtypes --
+ ----------------------------------------
+
+ function Fully_Conformant_Discrete_Subtypes
+ (Given_S1 : Node_Id;
+ Given_S2 : Node_Id)
+ return Boolean
+ is
+ S1 : constant Node_Id := Original_Node (Given_S1);
+ S2 : constant Node_Id := Original_Node (Given_S2);
+
+ function Conforming_Bounds (B1, B2 : Node_Id) return Boolean;
+ -- Special-case for a bound given by a discriminant, which in the
+ -- body is replaced with the discriminal of the enclosing type.
+
+ function Conforming_Ranges (R1, R2 : Node_Id) return Boolean;
+ -- Check both bounds.
+
+ function Conforming_Bounds (B1, B2 : Node_Id) return Boolean is
+ begin
+ if Is_Entity_Name (B1)
+ and then Is_Entity_Name (B2)
+ and then Ekind (Entity (B1)) = E_Discriminant
+ then
+ return Chars (B1) = Chars (B2);
+
+ else
+ return Fully_Conformant_Expressions (B1, B2);
+ end if;
+ end Conforming_Bounds;
+
+ function Conforming_Ranges (R1, R2 : Node_Id) return Boolean is
+ begin
+ return
+ Conforming_Bounds (Low_Bound (R1), Low_Bound (R2))
+ and then
+ Conforming_Bounds (High_Bound (R1), High_Bound (R2));
+ end Conforming_Ranges;
+
+ -- Start of processing for Fully_Conformant_Discrete_Subtypes
+
+ begin
+ if Nkind (S1) /= Nkind (S2) then
+ return False;
+
+ elsif Is_Entity_Name (S1) then
+ return Entity (S1) = Entity (S2);
+
+ elsif Nkind (S1) = N_Range then
+ return Conforming_Ranges (S1, S2);
+
+ elsif Nkind (S1) = N_Subtype_Indication then
+ return
+ Entity (Subtype_Mark (S1)) = Entity (Subtype_Mark (S2))
+ and then
+ Conforming_Ranges
+ (Range_Expression (Constraint (S1)),
+ Range_Expression (Constraint (S2)));
+ else
+ return True;
+ end if;
+ end Fully_Conformant_Discrete_Subtypes;
+
--------------------
-- Install_Entity --
--------------------
@@ -3765,6 +4102,7 @@ package body Sem_Ch6 is
begin
while Present (Prim_Elt) loop
P_Prim := Node (Prim_Elt);
+
if Chars (P_Prim) = Chars (New_E)
and then Ekind (P_Prim) = Ekind (New_E)
then
@@ -3927,13 +4265,16 @@ package body Sem_Ch6 is
(S : Entity_Id;
Derived_Type : Entity_Id := Empty)
is
- E : Entity_Id := Current_Entity_In_Scope (S);
+ E : Entity_Id;
+ -- Entity that S overrides
+
Prev_Vis : Entity_Id := Empty;
+ -- Needs comment ???
function Is_Private_Declaration (E : Entity_Id) return Boolean;
-- Check that E is declared in the private part of the current package,
-- or in the package body, where it may hide a previous declaration.
- -- We can' use In_Private_Part by itself because this flag is also
+ -- We can't use In_Private_Part by itself because this flag is also
-- set when freezing entities, so we must examine the place of the
-- declaration in the tree, and recognize wrapper packages as well.
@@ -4115,11 +4456,22 @@ package body Sem_Ch6 is
-- Start of processing for New_Overloaded_Entity
begin
+ -- We need to look for an entity that S may override. This must be a
+ -- homonym in the current scope, so we look for the first homonym of
+ -- S in the current scope as the starting point for the search.
+
+ E := Current_Entity_In_Scope (S);
+
+ -- If there is no homonym then this is definitely not overriding
+
if No (E) then
Enter_Overloaded_Entity (S);
Check_Dispatching_Operation (S, Empty);
Maybe_Primitive_Operation;
+ -- If there is a homonym that is not overloadable, then we have an
+ -- error, except for the special cases checked explicitly below.
+
elsif not Is_Overloadable (E) then
-- Check for spurious conflict produced by a subprogram that has the
@@ -4161,7 +4513,7 @@ package body Sem_Ch6 is
Error_Msg_Sloc := Sloc (E);
Error_Msg_N ("& conflicts with declaration#", S);
- -- Useful additional warning.
+ -- Useful additional warning
if Is_Generic_Unit (E) then
Error_Msg_N ("\previous generic unit cannot be overloaded", S);
@@ -4170,15 +4522,21 @@ package body Sem_Ch6 is
return;
end if;
+ -- E exists and is overloadable
+
else
- -- E exists and is overloadable. Determine whether S is the body
- -- of E, a new overloaded entity with a different signature, or
- -- an error altogether.
+ -- Loop through E and its homonyms to determine if any of them
+ -- is the candidate for overriding by S.
while Present (E) loop
+
+ -- Definitely not interesting if not in the current scope
+
if Scope (E) /= Current_Scope then
null;
+ -- Check if we have type conformance
+
elsif Type_Conformant (E, S) then
-- If the old and new entities have the same profile and
@@ -4338,9 +4696,9 @@ package body Sem_Ch6 is
null;
end if;
- else
- -- Find predecessor of E in Homonym chain.
+ else
+ -- Find predecessor of E in Homonym chain
if E = Current_Entity (E) then
Prev_Vis := Empty;
@@ -4371,8 +4729,10 @@ package body Sem_Ch6 is
end if;
Enter_Overloaded_Entity (S);
+ Set_Is_Overriding_Operation (S);
if Is_Dispatching_Operation (E) then
+
-- An overriding dispatching subprogram inherits
-- the convention of the overridden subprogram
-- (by AI-117).
@@ -4452,7 +4812,7 @@ package body Sem_Ch6 is
-- If this is a user-defined equality operator that is not
-- a derived subprogram, create the corresponding inequality.
-- If the operation is dispatching, the expansion is done
- -- elsewhere, and we do not create an explicit inequality
+ -- elsewhere, and we do not create an explicit inequality
-- operation.
<<Check_Inequality>>
@@ -4463,7 +4823,6 @@ package body Sem_Ch6 is
then
Make_Inequality_Operator (S);
end if;
-
end New_Overloaded_Entity;
---------------------
@@ -4528,7 +4887,16 @@ package body Sem_Ch6 is
and then Ekind (Root_Type (Formal_Type)) =
E_Incomplete_Type)
then
- if Nkind (Parent (T)) /= N_Access_Function_Definition
+
+ -- Incomplete tagged types that are made visible through
+ -- a limited with_clause are valid formal types.
+
+ if From_With_Type (Formal_Type)
+ and then Is_Tagged_Type (Formal_Type)
+ then
+ null;
+
+ elsif Nkind (Parent (T)) /= N_Access_Function_Definition
and then Nkind (Parent (T)) /= N_Access_Procedure_Definition
then
Error_Msg_N ("invalid use of incomplete type", Param_Spec);
@@ -4548,7 +4916,7 @@ package body Sem_Ch6 is
Set_Etype (Formal, Formal_Type);
- Default := Expression (Param_Spec);
+ Default := Expression (Param_Spec);
if Present (Default) then
if Out_Present (Param_Spec) then
@@ -4560,7 +4928,7 @@ package body Sem_Ch6 is
-- Do the special preanalysis of the expression (see section on
-- "Handling of Default Expressions" in the spec of package Sem).
- Analyze_Default_Expression (Default, Formal_Type);
+ Analyze_Per_Use_Expression (Default, Formal_Type);
-- Check that the designated type of an access parameter's
-- default is not a class-wide type unless the parameter's
@@ -4615,6 +4983,36 @@ package body Sem_Ch6 is
end Process_Formals;
+ ----------------------------
+ -- Reference_Body_Formals --
+ ----------------------------
+
+ procedure Reference_Body_Formals (Spec : Entity_Id; Bod : Entity_Id) is
+ Fs : Entity_Id;
+ Fb : Entity_Id;
+
+ begin
+ if Error_Posted (Spec) then
+ return;
+ end if;
+
+ Fs := First_Formal (Spec);
+ Fb := First_Formal (Bod);
+
+ while Present (Fs) loop
+ Generate_Reference (Fs, Fb, 'b');
+
+ if Style_Check then
+ Style.Check_Identifier (Fb, Fs);
+ end if;
+
+ Set_Spec_Entity (Fb, Fs);
+ Set_Referenced (Fs, False);
+ Next_Formal (Fs);
+ Next_Formal (Fb);
+ end loop;
+ end Reference_Body_Formals;
+
-------------------------
-- Set_Actual_Subtypes --
-------------------------
@@ -4628,6 +5026,15 @@ package body Sem_Ch6 is
AS_Needed : Boolean;
begin
+ -- If this is an emtpy initialization procedure, no need to create
+ -- actual subtypes (small optimization).
+
+ if Ekind (Subp) = E_Procedure
+ and then Is_Null_Init_Proc (Subp)
+ then
+ return;
+ end if;
+
Formal := First_Formal (Subp);
while Present (Formal) loop
T := Etype (Formal);
@@ -4681,9 +5088,20 @@ package body Sem_Ch6 is
-- unconstrained discriminated records.
if AS_Needed then
- Decl := Build_Actual_Subtype (T, Formal);
if Nkind (N) = N_Accept_Statement then
+
+ -- If expansion is active, The formal is replaced by a local
+ -- variable that renames the corresponding entry of the
+ -- parameter block, and it is this local variable that may
+ -- require an actual subtype.
+
+ if Expander_Active then
+ Decl := Build_Actual_Subtype (T, Renamed_Object (Formal));
+ else
+ Decl := Build_Actual_Subtype (T, Formal);
+ end if;
+
if Present (Handled_Statement_Sequence (N)) then
First_Stmt :=
First (Statements (Handled_Statement_Sequence (N)));
@@ -4698,6 +5116,7 @@ package body Sem_Ch6 is
end if;
else
+ Decl := Build_Actual_Subtype (T, Formal);
Prepend (Decl, Declarations (N));
Mark_Rewrite_Insertion (Decl);
end if;
@@ -4712,7 +5131,14 @@ package body Sem_Ch6 is
Freeze_Entity (Defining_Identifier (Decl), Loc));
end if;
- Set_Actual_Subtype (Formal, Defining_Identifier (Decl));
+ if Nkind (N) = N_Accept_Statement
+ and then Expander_Active
+ then
+ Set_Actual_Subtype (Renamed_Object (Formal),
+ Defining_Identifier (Decl));
+ else
+ Set_Actual_Subtype (Formal, Defining_Identifier (Decl));
+ end if;
end if;
Next_Formal (Formal);
@@ -4732,7 +5158,6 @@ package body Sem_Ch6 is
-- point of the call.
if Out_Present (Spec) then
-
if Ekind (Scope (Formal_Id)) = E_Function
or else Ekind (Scope (Formal_Id)) = E_Generic_Function
then
@@ -4743,14 +5168,25 @@ package body Sem_Ch6 is
Set_Ekind (Formal_Id, E_In_Out_Parameter);
else
- Set_Ekind (Formal_Id, E_Out_Parameter);
- Set_Not_Source_Assigned (Formal_Id);
+ Set_Ekind (Formal_Id, E_Out_Parameter);
+ Set_Never_Set_In_Source (Formal_Id, True);
+ Set_Is_True_Constant (Formal_Id, False);
+ Set_Current_Value (Formal_Id, Empty);
end if;
else
Set_Ekind (Formal_Id, E_In_Parameter);
end if;
+ -- Set Is_Known_Non_Null for access parameters since the language
+ -- guarantees that access parameters are always non-null. We also
+ -- set Can_Never_Be_Null, since there is no way to change the value.
+
+ if Nkind (Parameter_Type (Spec)) = N_Access_Definition then
+ Set_Is_Known_Non_Null (Formal_Id);
+ Set_Can_Never_Be_Null (Formal_Id);
+ end if;
+
Set_Mechanism (Formal_Id, Default_Mechanism);
Set_Formal_Validity (Formal_Id);
end Set_Formal_Mode;
@@ -4761,17 +5197,29 @@ package body Sem_Ch6 is
procedure Set_Formal_Validity (Formal_Id : Entity_Id) is
begin
- -- If in full validity checking mode, then we can assume that
- -- an IN or IN OUT parameter is valid (see Exp_Ch5.Expand_Call)
+ -- If no validity checking, then we cannot assume anything about
+ -- the validity of parameters, since we do not know there is any
+ -- checking of the validity on the call side.
if not Validity_Checks_On then
return;
+ -- If validity checking for parameters is enabled, this means we are
+ -- not supposed to make any assumptions about argument values.
+
+ elsif Validity_Check_Parameters then
+ return;
+
+ -- If we are checking in parameters, we will assume that the caller is
+ -- also checking parameters, so we can assume the parameter is valid.
+
elsif Ekind (Formal_Id) = E_In_Parameter
and then Validity_Check_In_Params
then
Set_Is_Known_Valid (Formal_Id, True);
+ -- Similar treatment for IN OUT parameters
+
elsif Ekind (Formal_Id) = E_In_Out_Parameter
and then Validity_Check_In_Out_Params
then
diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads
index 1db25e0a4fb..9b92a422bdd 100644
--- a/gcc/ada/sem_ch6.ads
+++ b/gcc/ada/sem_ch6.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -27,18 +27,26 @@
with Types; use Types;
package Sem_Ch6 is
- procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id);
- procedure Analyze_Function_Call (N : Node_Id);
- procedure Analyze_Operator_Symbol (N : Node_Id);
- procedure Analyze_Parameter_Association (N : Node_Id);
- procedure Analyze_Procedure_Call (N : Node_Id);
- procedure Analyze_Return_Statement (N : Node_Id);
- procedure Analyze_Subprogram_Declaration (N : Node_Id);
- procedure Analyze_Subprogram_Body (N : Node_Id);
+ procedure Analyze_Abstract_Subprogram_Declaration (N : Node_Id);
+ procedure Analyze_Function_Call (N : Node_Id);
+ procedure Analyze_Operator_Symbol (N : Node_Id);
+ procedure Analyze_Parameter_Association (N : Node_Id);
+ procedure Analyze_Procedure_Call (N : Node_Id);
+ procedure Analyze_Return_Statement (N : Node_Id);
+ procedure Analyze_Subprogram_Declaration (N : Node_Id);
+ procedure Analyze_Subprogram_Body (N : Node_Id);
- function Analyze_Spec (N : Node_Id) return Entity_Id;
+ function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id;
-- Analyze subprogram specification in both subprogram declarations
- -- and body declarations.
+ -- and body declarations. Returns the defining entity for the spec.
+
+ procedure Cannot_Inline (Msg : String; N : Node_Id; Subp : Entity_Id);
+ -- This procedure is called if the node N, an instance of a call to
+ -- subprogram Subp, cannot be inlined. Msg is the message to be issued,
+ -- and has a ? as the last character. If Subp has a pragma Always_Inlined,
+ -- then an error message is issued (by removing the last character of Msg).
+ -- If Subp is not Always_Inlined, then a warning is issued if the flag
+ -- Ineffective_Inline_Warnings is set, and if not, the call has no effect.
procedure Check_Delayed_Subprogram (Designator : Entity_Id);
-- Designator can be a E_Subrpgram_Type, E_Procedure or E_Function. If a
@@ -117,10 +125,17 @@ package Sem_Ch6 is
function Fully_Conformant_Expressions
(Given_E1 : Node_Id;
Given_E2 : Node_Id)
- return Boolean;
+ return Boolean;
-- Determines if two (non-empty) expressions are fully conformant
-- as defined by (RM 6.3.1(18-21))
+ function Fully_Conformant_Discrete_Subtypes
+ (Given_S1 : Node_Id;
+ Given_S2 : Node_Id)
+ return Boolean;
+ -- Determines if two subtype definitions are fully conformant. Used
+ -- for entry family conformance checks (RM 6.3.1 (24)).
+
function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
-- Determine whether two callable entities (subprograms, entries,
-- literals) are mode conformant (RM 6.3.1(15))
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index 2aa339ee826..caaf9263b45 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.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- --
@@ -85,11 +85,10 @@ package body Sem_Ch7 is
-- Local Subprograms --
-----------------------
- procedure Install_Composite_Operations (P : Entity_Id);
- -- Composite types declared in the current scope may depend on
- -- types that were private at the point of declaration, and whose
- -- full view is now in scope. Indicate that the corresponding
- -- operations on the composite type are available.
+ procedure Install_Package_Entity (Id : Entity_Id);
+ -- Basic procedure for the previous two. Places one entity on its
+ -- visibility chain, and recurses on the visible part if the entity
+ -- is an inner package.
function Is_Private_Base_Type (E : Entity_Id) return Boolean;
-- True for a private type that is not a subtype.
@@ -100,10 +99,6 @@ package body Sem_Ch7 is
-- only if we are in the immediate scope of the private dependent.
-- Should this predicate be tightened further???
- procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
- -- Copy to the private declaration the attributes of the full view
- -- that need to be available for the partial view also.
-
procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id);
-- Called upon entering the private part of a public child package
-- and the body of a nested package, to potentially declare certain
@@ -111,7 +106,7 @@ package body Sem_Ch7 is
-- part, but whose declaration was deferred because the parent
-- operation was private and not visible at that point. These
-- subprograms are located by traversing the visible part declarations
- -- looking for nonprivate type extensions and then examining each of
+ -- looking for non-private type extensions and then examining each of
-- the primitive operations of such types to find those that were
-- inherited but declared with a special internal name. Each such
-- operation is now declared as an operation with a normal name (using
@@ -133,6 +128,39 @@ package body Sem_Ch7 is
New_N : Node_Id;
Pack_Decl : Node_Id;
+ procedure Install_Composite_Operations (P : Entity_Id);
+ -- Composite types declared in the current scope may depend on
+ -- types that were private at the point of declaration, and whose
+ -- full view is now in scope. Indicate that the corresponding
+ -- operations on the composite type are available.
+
+ ----------------------------------
+ -- Install_Composite_Operations --
+ ----------------------------------
+
+ procedure Install_Composite_Operations (P : Entity_Id) is
+ Id : Entity_Id;
+
+ begin
+ Id := First_Entity (P);
+
+ while Present (Id) loop
+
+ if Is_Type (Id)
+ and then (Is_Limited_Composite (Id)
+ or else Is_Private_Composite (Id))
+ and then No (Private_Component (Id))
+ then
+ Set_Is_Limited_Composite (Id, False);
+ Set_Is_Private_Composite (Id, False);
+ end if;
+
+ Next_Entity (Id);
+ end loop;
+ end Install_Composite_Operations;
+
+ -- Start of processing for Analyze_Package_Body
+
begin
-- Find corresponding package specification, and establish the
-- current scope. The visible defining entity for the package is the
@@ -149,7 +177,7 @@ package body Sem_Ch7 is
Write_Eol;
end if;
- -- Set Body_Id. Note that this will be reset to point to the
+ -- Set Body_Id. Note that this Will be reset to point to the
-- generic copy later on in the generic case.
Body_Id := Defining_Entity (N);
@@ -204,7 +232,6 @@ package body Sem_Ch7 is
Style.Check_Identifier (Body_Id, Spec_Id);
if Is_Child_Unit (Spec_Id) then
-
if Nkind (Parent (N)) /= N_Compilation_Unit then
Error_Msg_NE
("body of child unit& cannot be an inner package", N, Spec_Id);
@@ -375,6 +402,13 @@ package body Sem_Ch7 is
Check_References (Body_Id);
+ -- For a generic unit, check that the formal parameters are referenced,
+ -- and that local variables are used, as for regular packages.
+
+ if Ekind (Spec_Id) = E_Generic_Package then
+ Check_References (Spec_Id);
+ end if;
+
-- The processing so far has made all entities of the package body
-- public (i.e. externally visible to the linker). This is in general
-- necessary, since inlined or generic bodies, for which code is
@@ -396,7 +430,6 @@ package body Sem_Ch7 is
and then Present (Declarations (N))
then
Make_Non_Public_Where_Possible : declare
- Discard : Boolean;
function Has_Referencer
(L : List_Id;
@@ -552,7 +585,13 @@ package body Sem_Ch7 is
-- Start of processing for Make_Non_Public_Where_Possible
begin
- Discard := Has_Referencer (Declarations (N), Outer => True);
+ declare
+ Discard : Boolean;
+ pragma Warnings (Off, Discard);
+
+ begin
+ Discard := Has_Referencer (Declarations (N), Outer => True);
+ end;
end Make_Non_Public_Where_Possible;
end if;
@@ -586,6 +625,7 @@ package body Sem_Ch7 is
Enter_Name (Id);
Set_Ekind (Id, E_Package);
Set_Etype (Id, Standard_Void_Type);
+
New_Scope (Id);
PF := Is_Pure (Enclosing_Lib_Unit_Entity);
@@ -617,34 +657,15 @@ package body Sem_Ch7 is
Validate_RT_RAT_Component (N);
end if;
-
- -- Clear Not_Source_Assigned on all variables in the package spec,
- -- because at this stage some client, or the body, or a child package,
- -- may modify variables in the declaration. Note that we wait till now
- -- to reset these flags, because during analysis of the declaration,
- -- the flags correctly indicated the status up to that point. We
- -- similarly clear any Is_True_Constant indications.
-
- declare
- E : Entity_Id;
-
- begin
- E := First_Entity (Id);
- while Present (E) loop
- if Ekind (E) = E_Variable then
- Set_Not_Source_Assigned (E, False);
- Set_Is_True_Constant (E, False);
- end if;
-
- Next_Entity (E);
- end loop;
- end;
end Analyze_Package_Declaration;
-----------------------------------
-- Analyze_Package_Specification --
-----------------------------------
+ -- Note that this code is shared for the analysis of generic package
+ -- specs (see Sem_Ch12.Analyze_Generic_Package_Declaration for details).
+
procedure Analyze_Package_Specification (N : Node_Id) is
Id : constant Entity_Id := Defining_Entity (N);
Orig_Decl : constant Node_Id := Original_Node (Parent (N));
@@ -652,12 +673,110 @@ package body Sem_Ch7 is
Priv_Decls : constant List_Id := Private_Declarations (N);
E : Entity_Id;
L : Entity_Id;
- Public_Child : Boolean := False;
+ Public_Child : Boolean;
+
+ procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id);
+ -- Clears constant indications (Never_Set_In_Source, Constant_Value,
+ -- and Is_True_Constant) on all variables that are entities of Id,
+ -- and on the chain whose first element is FE. A recursive call is
+ -- made for all packages and generic packages.
+
+ procedure Generate_Parent_References;
+ -- For a child unit, generate references to parent units, for
+ -- GPS navigation purposes.
function Is_Public_Child (Child, Unit : Entity_Id) return Boolean;
-- Child and Unit are entities of compilation units. True if Child
-- is a public child of Parent as defined in 10.1.1
+ ---------------------
+ -- Clear_Constants --
+ ---------------------
+
+ procedure Clear_Constants (Id : Entity_Id; FE : Entity_Id) is
+ E : Entity_Id;
+
+ begin
+ -- Ignore package renamings, not interesting and they can
+ -- cause self referential loops in the code below.
+
+ if Nkind (Parent (Id)) = N_Package_Renaming_Declaration then
+ return;
+ end if;
+
+ -- Note: in the loop below, the check for Next_Entity pointing
+ -- back to the package entity seems very odd, but it is needed,
+ -- because this kind of unexpected circularity does occur ???
+
+ E := FE;
+ while Present (E) and then E /= Id loop
+ if Ekind (E) = E_Variable then
+ Set_Never_Set_In_Source (E, False);
+ Set_Is_True_Constant (E, False);
+ Set_Current_Value (E, Empty);
+ Set_Is_Known_Non_Null (E, False);
+
+ elsif Ekind (E) = E_Package
+ or else
+ Ekind (E) = E_Generic_Package
+ then
+ Clear_Constants (E, First_Entity (E));
+ Clear_Constants (E, First_Private_Entity (E));
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end Clear_Constants;
+
+ --------------------------------
+ -- Generate_Parent_References --
+ --------------------------------
+
+ procedure Generate_Parent_References is
+ Decl : Node_Id := Parent (N);
+
+ begin
+ if Id = Cunit_Entity (Main_Unit)
+ or else Parent (Decl) = Library_Unit (Cunit (Main_Unit))
+ then
+ Generate_Reference (Id, Scope (Id), 'k', False);
+
+ elsif Nkind (Unit (Cunit (Main_Unit))) /= N_Subprogram_Body
+ and then Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit
+ then
+ -- If current unit is an ancestor of main unit, generate
+ -- a reference to its own parent.
+
+ declare
+ U : Node_Id;
+ Main_Spec : Node_Id := Unit (Cunit (Main_Unit));
+
+ begin
+ if Nkind (Main_Spec) = N_Package_Body then
+ Main_Spec := Unit (Library_Unit (Cunit (Main_Unit)));
+ end if;
+
+ U := Parent_Spec (Main_Spec);
+ while Present (U) loop
+ if U = Parent (Decl) then
+ Generate_Reference (Id, Scope (Id), 'k', False);
+ exit;
+
+ elsif Nkind (Unit (U)) = N_Package_Body then
+ exit;
+
+ else
+ U := Parent_Spec (Unit (U));
+ end if;
+ end loop;
+ end;
+ end if;
+ end Generate_Parent_References;
+
+ ---------------------
+ -- Is_Public_Child --
+ ---------------------
+
function Is_Public_Child (Child, Unit : Entity_Id) return Boolean is
begin
if not Is_Private_Descendant (Child) then
@@ -682,7 +801,6 @@ package body Sem_Ch7 is
-- Verify that incomplete types have received full declarations.
E := First_Entity (Id);
-
while Present (E) loop
if Ekind (E) = E_Incomplete_Type
and then No (Full_View (E))
@@ -722,7 +840,11 @@ package body Sem_Ch7 is
-- If package is a public child unit, then make the private
-- declarations of the parent visible.
+ Public_Child := False;
+
if Present (Parent_Spec (Parent (N))) then
+ Generate_Parent_References;
+
declare
Par : Entity_Id := Id;
Pack_Decl : Node_Id;
@@ -746,7 +868,6 @@ package body Sem_Ch7 is
L := Last_Entity (Id);
if Present (Priv_Decls) then
- L := Last_Entity (Id);
Set_In_Private_Part (Id);
-- Upon entering a public child's private part, it may be
@@ -815,6 +936,26 @@ package body Sem_Ch7 is
end if;
Process_End_Label (N, 'e', Id);
+
+ -- For the case of a library level package, we must go through all
+ -- the entities clearing the indications that the value may be
+ -- constant and not modified. Why? Because any client of this
+ -- package may modify these values freely from anywhere. This
+ -- also applies to any nested packages or generic packages.
+
+ -- For now we unconditionally clear constants for packages that
+ -- are instances of generic packages. The reason is that we do not
+ -- have the body yet, and we otherwise think things are unreferenced
+ -- when they are not. This should be fixed sometime (the effect is
+ -- not terrible, we just lose some warnings, and also some cases
+ -- of value propagation) ???
+
+ if Is_Library_Level_Entity (Id)
+ or else Is_Generic_Instance (Id)
+ then
+ Clear_Constants (Id, First_Entity (Id));
+ Clear_Constants (Id, First_Private_Entity (Id));
+ end if;
end Analyze_Package_Specification;
--------------------------------------
@@ -822,8 +963,8 @@ package body Sem_Ch7 is
--------------------------------------
procedure Analyze_Private_Type_Declaration (N : Node_Id) is
- PF : constant Boolean := Is_Pure (Enclosing_Lib_Unit_Entity);
- Id : Entity_Id := Defining_Identifier (N);
+ PF : constant Boolean := Is_Pure (Enclosing_Lib_Unit_Entity);
+ Id : constant Entity_Id := Defining_Identifier (N);
begin
Generate_Definition (Id);
@@ -839,8 +980,6 @@ package body Sem_Ch7 is
New_Private_Type (N, Id, N);
Set_Depends_On_Private (Id);
- Set_Has_Delayed_Freeze (Id);
-
end Analyze_Private_Type_Declaration;
-------------------------------------------
@@ -848,20 +987,58 @@ package body Sem_Ch7 is
-------------------------------------------
procedure Declare_Inherited_Private_Subprograms (Id : Entity_Id) is
- E : Entity_Id;
+ E : Entity_Id;
Op_List : Elist_Id;
Op_Elmt : Elmt_Id;
Op_Elmt_2 : Elmt_Id;
Prim_Op : Entity_Id;
- New_Op : Entity_Id;
+ New_Op : Entity_Id := Empty;
Parent_Subp : Entity_Id;
Found_Explicit : Boolean;
Decl_Privates : Boolean;
+ function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean;
+ -- Check whether a pragma Overriding has been provided for a primitive
+ -- operation that is found to be overriding in the private part.
+
function Is_Primitive_Of (T : Entity_Id; S : Entity_Id) return Boolean;
-- Check whether an inherited subprogram is an operation of an
-- untagged derived type.
+ ---------------------------
+ -- Has_Overriding_Pragma --
+ ---------------------------
+
+ function Has_Overriding_Pragma (Subp : Entity_Id) return Boolean is
+ Decl : constant Node_Id := Unit_Declaration_Node (Subp);
+ Prag : Node_Id;
+
+ begin
+ if No (Decl)
+ or else Nkind (Decl) /= N_Subprogram_Declaration
+ or else No (Next (Decl))
+ then
+ return False;
+
+ else
+ Prag := Next (Decl);
+
+ while Present (Prag)
+ and then Nkind (Prag) = N_Pragma
+ loop
+ if Chars (Prag) = Name_Overriding
+ or else Chars (Prag) = Name_Optional_Overriding
+ then
+ return True;
+ else
+ Next (Prag);
+ end if;
+ end loop;
+ end if;
+
+ return False;
+ end Has_Overriding_Pragma;
+
---------------------
-- Is_Primitive_Of --
---------------------
@@ -892,7 +1069,6 @@ package body Sem_Ch7 is
begin
E := First_Entity (Id);
-
while Present (E) loop
-- If the entity is a nonprivate type extension whose parent
@@ -902,17 +1078,17 @@ package body Sem_Ch7 is
if ((Is_Derived_Type (E) and then not Is_Private_Type (E))
or else
- (Nkind (Parent (E)) = N_Private_Extension_Declaration
- and then Is_Generic_Type (E)))
+ (Nkind (Parent (E)) = N_Private_Extension_Declaration
+ and then Is_Generic_Type (E)))
and then In_Open_Scopes (Scope (Etype (E)))
and then E = Base_Type (E)
then
if Is_Tagged_Type (E) then
Op_List := Primitive_Operations (E);
- Op_Elmt := First_Elmt (Op_List);
New_Op := Empty;
Decl_Privates := False;
+ Op_Elmt := First_Elmt (Op_List);
while Present (Op_Elmt) loop
Prim_Op := Node (Op_Elmt);
@@ -946,6 +1122,19 @@ package body Sem_Ch7 is
Remove_Elmt (Op_List, Op_Elmt_2);
Found_Explicit := True;
Decl_Privates := True;
+
+ -- If explicit_overriding is in effect, check that
+ -- the overriding operation is properly labelled.
+
+ if Explicit_Overriding
+ and then Comes_From_Source (New_Op)
+ and then not Has_Overriding_Pragma (New_Op)
+ then
+ Error_Msg_NE
+ ("Missing overriding pragma for&",
+ New_Op, New_Op);
+ end if;
+
exit;
end if;
@@ -1067,31 +1256,6 @@ package body Sem_Ch7 is
Set_Homonym (Full_Id, H2);
end Exchange_Declarations;
- ----------------------------------
- -- Install_Composite_Operations --
- ----------------------------------
-
- procedure Install_Composite_Operations (P : Entity_Id) is
- Id : Entity_Id;
-
- begin
- Id := First_Entity (P);
-
- while Present (Id) loop
-
- if Is_Type (Id)
- and then (Is_Limited_Composite (Id)
- or else Is_Private_Composite (Id))
- and then No (Private_Component (Id))
- then
- Set_Is_Limited_Composite (Id, False);
- Set_Is_Private_Composite (Id, False);
- end if;
-
- Next_Entity (Id);
- end loop;
- end Install_Composite_Operations;
-
----------------------------
-- Install_Package_Entity --
----------------------------
@@ -1132,7 +1296,6 @@ package body Sem_Ch7 is
-- one so we also skip the exchange.
Id := First_Entity (P);
-
while Present (Id) and then Id /= First_Private_Entity (P) loop
if Is_Private_Base_Type (Id)
@@ -1141,8 +1304,6 @@ package body Sem_Ch7 is
and then Scope (Full_View (Id)) = Scope (Id)
and then Ekind (Full_View (Id)) /= E_Incomplete_Type
then
- Priv_Elmt := First_Elmt (Private_Dependents (Id));
-
-- If there is a use-type clause on the private type, set the
-- full view accordingly.
@@ -1172,6 +1333,8 @@ package body Sem_Ch7 is
end if;
end if;
+ Priv_Elmt := First_Elmt (Private_Dependents (Id));
+
Exchange_Declarations (Id);
Set_Is_Immediately_Visible (Id);
@@ -1200,8 +1363,6 @@ package body Sem_Ch7 is
Next_Elmt (Priv_Elmt);
end loop;
-
- null;
end if;
Next_Entity (Id);
@@ -1238,29 +1399,6 @@ package body Sem_Ch7 is
end loop;
end Install_Visible_Declarations;
- ----------------------
- -- Is_Fully_Visible --
- ----------------------
-
- -- The full declaration of a private type is visible in the private
- -- part of the package declaration, and in the package body, at which
- -- point the full declaration must have been given.
-
- function Is_Fully_Visible (Type_Id : Entity_Id) return Boolean is
- S : constant Entity_Id := Scope (Type_Id);
-
- begin
- if Is_Generic_Type (Type_Id) then
- return False;
-
- elsif In_Private_Part (S) then
- return Present (Full_View (Type_Id));
-
- else
- return In_Package_Body (S);
- end if;
- end Is_Fully_Visible;
-
--------------------------
-- Is_Private_Base_Type --
--------------------------
@@ -1294,7 +1432,13 @@ package body Sem_Ch7 is
elsif not (Is_Derived_Type (Dep))
and then Is_Derived_Type (Full_View (Dep))
then
- return In_Open_Scopes (S);
+ -- When instantiating a package body, the scope stack is empty,
+ -- so check instead whether the dependent type is defined in
+ -- the same scope as the instance itself.
+
+ return In_Open_Scopes (S)
+ or else (Is_Generic_Instance (Current_Scope)
+ and then Scope (Dep) = Scope (Current_Scope));
else
return True;
end if;
@@ -1365,7 +1509,7 @@ package body Sem_Ch7 is
Set_Is_Tagged_Type (Id, Tagged_Present (Def));
Set_Discriminant_Constraint (Id, No_Elist);
- Set_Girder_Constraint (Id, No_Elist);
+ Set_Stored_Constraint (Id, No_Elist);
if Present (Discriminant_Specifications (N)) then
New_Scope (Id);
@@ -1391,57 +1535,71 @@ package body Sem_Ch7 is
end if;
end New_Private_Type;
- ------------------------------
- -- Preserve_Full_Attributes --
- ------------------------------
+ ----------------------------
+ -- Uninstall_Declarations --
+ ----------------------------
+
+ procedure Uninstall_Declarations (P : Entity_Id) is
+ Decl : constant Node_Id := Unit_Declaration_Node (P);
+ Id : Entity_Id;
+ Full : Entity_Id;
+ Priv_Elmt : Elmt_Id;
+ Priv_Sub : Entity_Id;
- procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
- Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv);
+ procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
+ -- Copy to the private declaration the attributes of the full view
+ -- that need to be available for the partial view also.
- begin
- Set_Size_Info (Priv, (Full));
- Set_RM_Size (Priv, RM_Size (Full));
- Set_Size_Known_At_Compile_Time (Priv, Size_Known_At_Compile_Time
- (Full));
+ function Type_In_Use (T : Entity_Id) return Boolean;
+ -- Check whether type or base type appear in an active use_type clause.
- if Priv_Is_Base_Type then
- Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full)));
- Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only
- (Base_Type (Full)));
- Set_Has_Task (Priv, Has_Task (Base_Type (Full)));
- Set_Has_Controlled_Component (Priv, Has_Controlled_Component
- (Base_Type (Full)));
- end if;
+ ------------------------------
+ -- Preserve_Full_Attributes --
+ ------------------------------
- Set_Freeze_Node (Priv, Freeze_Node (Full));
+ procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
+ Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv);
+
+ begin
+ Set_Size_Info (Priv, (Full));
+ Set_RM_Size (Priv, RM_Size (Full));
+ Set_Size_Known_At_Compile_Time (Priv, Size_Known_At_Compile_Time
+ (Full));
+ Set_Is_Volatile (Priv, Is_Volatile (Full));
+ Set_Treat_As_Volatile (Priv, Treat_As_Volatile (Full));
+
+ if Referenced (Full) then
+ Set_Referenced (Priv);
+ end if;
- if Is_Tagged_Type (Priv)
- and then Is_Tagged_Type (Full)
- and then not Error_Posted (Full)
- then
if Priv_Is_Base_Type then
- Set_Access_Disp_Table (Priv, Access_Disp_Table
+ Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full)));
+ Set_Finalize_Storage_Only (Priv, Finalize_Storage_Only
+ (Base_Type (Full)));
+ Set_Has_Task (Priv, Has_Task (Base_Type (Full)));
+ Set_Has_Controlled_Component (Priv, Has_Controlled_Component
(Base_Type (Full)));
end if;
- Set_First_Entity (Priv, First_Entity (Full));
- Set_Last_Entity (Priv, Last_Entity (Full));
- end if;
- end Preserve_Full_Attributes;
+ Set_Freeze_Node (Priv, Freeze_Node (Full));
- ----------------------------
- -- Uninstall_Declarations --
- ----------------------------
+ if Is_Tagged_Type (Priv)
+ and then Is_Tagged_Type (Full)
+ and then not Error_Posted (Full)
+ then
+ if Priv_Is_Base_Type then
+ Set_Access_Disp_Table (Priv, Access_Disp_Table
+ (Base_Type (Full)));
+ end if;
- procedure Uninstall_Declarations (P : Entity_Id) is
- Id : Entity_Id;
- Decl : Node_Id := Unit_Declaration_Node (P);
- Full : Entity_Id;
- Priv_Elmt : Elmt_Id;
- Priv_Sub : Entity_Id;
+ Set_First_Entity (Priv, First_Entity (Full));
+ Set_Last_Entity (Priv, Last_Entity (Full));
+ end if;
+ end Preserve_Full_Attributes;
- function Type_In_Use (T : Entity_Id) return Boolean;
- -- Check whether type or base type appear in an active use_type clause.
+ -----------------
+ -- Type_In_Use --
+ -----------------
function Type_In_Use (T : Entity_Id) return Boolean is
begin
@@ -1475,6 +1633,7 @@ package body Sem_Ch7 is
if Ekind (Id) = E_Function
and then Is_Operator_Symbol_Name (Chars (Id))
and then not Is_Hidden (Id)
+ and then not Error_Posted (Id)
then
Set_Is_Potentially_Use_Visible (Id,
In_Use (P)
@@ -1523,7 +1682,32 @@ package body Sem_Ch7 is
and then (Nkind (Parent (Id)) /= N_Object_Declaration
or else not No_Initialization (Parent (Id)))
then
- Error_Msg_N ("missing full declaration for deferred constant", Id);
+ if not Has_Private_Declaration (Etype (Id)) then
+
+ -- We assume that the user did not not intend a deferred
+ -- constant declaration, and the expression is just missing.
+
+ Error_Msg_N
+ ("constant declaration requires initialization expression",
+ Parent (Id));
+
+ if Is_Limited_Type (Etype (Id)) then
+ Error_Msg_N
+ ("\else remove keyword CONSTANT from declaration",
+ Parent (Id));
+ end if;
+
+ else
+ Error_Msg_N
+ ("missing full declaration for deferred constant ('R'M 7.4)",
+ Id);
+
+ if Is_Limited_Type (Etype (Id)) then
+ Error_Msg_N
+ ("\else remove keyword CONSTANT from declaration",
+ Parent (Id));
+ end if;
+ end if;
end if;
Next_Entity (Id);
@@ -1562,7 +1746,7 @@ package body Sem_Ch7 is
-- If the partial view is not declared in the visible part
-- of the package (as is the case when it is a type derived
- -- from some other private type in the private part if the
+ -- from some other private type in the private part of the
-- current package), no exchange takes place.
if No (Parent (Id))
@@ -1641,7 +1825,6 @@ package body Sem_Ch7 is
<<Next_Id>>
Next_Entity (Id);
end loop;
-
end Uninstall_Declarations;
------------------------
@@ -1666,12 +1849,7 @@ package body Sem_Ch7 is
-- Body required if subprogram
- elsif (Is_Subprogram (P)
- or else
- Ekind (P) = E_Generic_Function
- or else
- Ekind (P) = E_Generic_Procedure)
- then
+ elsif Is_Subprogram (P) or else Is_Generic_Subprogram (P) then
return True;
-- Treat a block as requiring a body
@@ -1684,7 +1862,7 @@ package body Sem_Ch7 is
and then Present (Generic_Parent (Parent (P)))
then
declare
- G_P : Entity_Id := Generic_Parent (Parent (P));
+ G_P : constant Entity_Id := Generic_Parent (Parent (P));
begin
if Has_Pragma_Elaborate_Body (G_P) then
@@ -1733,11 +1911,7 @@ package body Sem_Ch7 is
and then Unit_Requires_Body (E))
or else
- (Ekind (E) = E_Generic_Function
- and then not Has_Completion (E))
-
- or else
- (Ekind (E) = E_Generic_Procedure
+ (Is_Generic_Subprogram (E)
and then not Has_Completion (E))
then
diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads
index 040d3a38361..d863e4e9458 100644
--- a/gcc/ada/sem_ch7.ads
+++ b/gcc/ada/sem_ch7.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992,1993,1994 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- --
@@ -49,14 +49,9 @@ package Sem_Ch7 is
-- When compiling the body of a package, both routines are called in
-- succession. When compiling the body of a child package, the call
-- to Install_Private_Declaration is immediate for private children,
- -- but is deffered until the compilation of the private part of the
+ -- but is deferred until the compilation of the private part of the
-- child for public child packages.
- procedure Install_Package_Entity (Id : Entity_Id);
- -- Basic procedure for the previous two. Places one entity on its
- -- visibility chain, and recurses on the visible part if the entity
- -- is an inner package.
-
function Unit_Requires_Body (P : Entity_Id) return Boolean;
-- Check if a unit requires a body. A specification requires a body
-- if it contains declarations that require completion in a body.
@@ -66,9 +61,6 @@ package Sem_Ch7 is
-- body, create an implicit body at the end of the current declarative
-- part to activate those tasks.
- function Is_Fully_Visible (Type_Id : Entity_Id) return Boolean;
- -- Indicates whether the Full Declaration of a private type is visible.
-
procedure New_Private_Type (N : Node_Id; Id : Entity_Id; Def : Node_Id);
-- Common processing for private type declarations and for formal
-- private type declarations. For private types, N and Def are the type
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 243bcd8150e..da29d208cef 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -43,6 +43,7 @@ with Output; use Output;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch4; use Sem_Ch4;
with Sem_Ch6; use Sem_Ch6;
@@ -165,7 +166,7 @@ package body Sem_Ch8 is
-- Each identifier points to an entry in the names table. The resolution
-- of a simple name consists in traversing the homonym chain, starting
-- from the names table. If an entry is immediately visible, it is the one
- -- designated by the identifier. If only potemtially use-visible entities
+ -- designated by the identifier. If only potentially use-visible entities
-- are on the chain, we must verify that they do not hide each other. If
-- the entity we find is overloadable, we collect all other overloadable
-- entities on the chain as long as they are not hidden.
@@ -186,7 +187,7 @@ package body Sem_Ch8 is
-- The discriminants of a type and the operations of a protected type or
-- task are unchained on exit from the first view of the type, (such as
-- a private or incomplete type declaration, or a protected type speci-
- -- fication) and rechained when compiling the second view.
+ -- fication) and re-chained when compiling the second view.
-- In the case of operators, we do not make operators on derived types
-- explicit. As a result, the notation P."+" may denote either a user-
@@ -384,6 +385,11 @@ package body Sem_Ch8 is
-- Used when the renamed entity is an indexed component. The prefix must
-- denote an entry family.
+ function Applicable_Use (Pack_Name : Node_Id) return Boolean;
+ -- Common code to Use_One_Package and Set_Use, to determine whether
+ -- use clause must be processed. Pack_Name is an entity name that
+ -- references the package in question.
+
procedure Attribute_Renaming (N : Node_Id);
-- Analyze renaming of attribute as function. The renaming declaration N
-- is rewritten as a function body that returns the attribute reference
@@ -396,6 +402,15 @@ package body Sem_Ch8 is
-- body at the point of freezing will not work. Subp is the subprogram
-- for which N provides the Renaming_As_Body.
+ procedure Check_In_Previous_With_Clause
+ (N : Node_Id;
+ Nam : Node_Id);
+ -- N is a use_package clause and Nam the package name, or N is a use_type
+ -- clause and Nam is the prefix of the type name. In either case, verify
+ -- that the package is visible at that point in the context: either it
+ -- appears in a previous with_clause, or because it is a fully qualified
+ -- name and the root ancestor appears in a previous with_clause.
+
procedure Check_Library_Unit_Renaming (N : Node_Id; Old_E : Entity_Id);
-- Verify that the entity in a renaming declaration that is a library unit
-- is itself a library unit and not a nested unit or subunit. Also check
@@ -412,6 +427,10 @@ package body Sem_Ch8 is
-- Find a type derived from Character or Wide_Character in the prefix of N.
-- Used to resolved qualified names whose selector is a character literal.
+ procedure Find_Expanded_Name (N : Node_Id);
+ -- Selected component is known to be expanded name. Verify legality
+ -- of selector given the scope denoted by prefix.
+
function Find_Renamed_Entity
(N : Node_Id;
Nam : Node_Id;
@@ -423,15 +442,42 @@ package body Sem_Ch8 is
-- indicates that the renaming is the one generated for an actual subpro-
-- gram in an instance, for which special visibility checks apply.
+ function Has_Implicit_Operator (N : Node_Id) return Boolean;
+ -- N is an expanded name whose selector is an operator name (eg P."+").
+ -- A declarative part contains an implicit declaration of an operator
+ -- if it has a declaration of a type to which one of the predefined
+ -- operators apply. The existence of this routine is an artifact of
+ -- our implementation: a more straightforward but more space-consuming
+ -- choice would be to make all inherited operators explicit in the
+ -- symbol table.
+
procedure Inherit_Renamed_Profile (New_S : Entity_Id; Old_S : Entity_Id);
-- A subprogram defined by a renaming declaration inherits the parameter
-- profile of the renamed entity. The subtypes given in the subprogram
-- specification are discarded and replaced with those of the renamed
-- subprogram, which are then used to recheck the default values.
+ function Is_Appropriate_For_Record (T : Entity_Id) return Boolean;
+ -- Prefix is appropriate for record if it is of a record type, or
+ -- an access to such.
+
+ function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean;
+ -- True if it is of a task type, a protected type, or else an access
+ -- to one of these types.
+
procedure Premature_Usage (N : Node_Id);
-- Diagnose usage of an entity before it is visible.
+ procedure Use_One_Package (P : Entity_Id; N : Node_Id);
+ -- Make visible entities declared in package P potentially use-visible
+ -- in the current context. Also used in the analysis of subunits, when
+ -- re-installing use clauses of parent units. N is the use_clause that
+ -- names P (and possibly other packages).
+
+ procedure Use_One_Type (Id : Node_Id);
+ -- Id is the subtype mark from a use type clause. This procedure makes
+ -- the primitive operators of the type potentially use-visible.
+
procedure Write_Info;
-- Write debugging information on entities declared in current scope
@@ -538,7 +584,7 @@ package body Sem_Ch8 is
(N : Node_Id;
K : Entity_Kind)
is
- New_P : Entity_Id := Defining_Entity (N);
+ New_P : constant Entity_Id := Defining_Entity (N);
Old_P : Entity_Id;
Inst : Boolean := False; -- prevent junk warning
@@ -658,7 +704,6 @@ package body Sem_Ch8 is
-- It may have been rewritten in several ways.
elsif Is_Object_Reference (Nam) then
-
if Comes_From_Source (N)
and then Is_Dependent_Component_Of_Mutable_Object (Nam)
then
@@ -705,7 +750,7 @@ package body Sem_Ch8 is
if not Is_Variable (Nam) then
Set_Ekind (Id, E_Constant);
- Set_Not_Source_Assigned (Id, True);
+ Set_Never_Set_In_Source (Id, True);
Set_Is_True_Constant (Id, True);
end if;
@@ -878,24 +923,23 @@ package body Sem_Ch8 is
Nam : constant Node_Id := Name (N);
P : constant Node_Id := Prefix (Nam);
Typ : Entity_Id;
- I : Interp_Index;
+ Ind : Interp_Index;
It : Interp;
begin
if not Is_Overloaded (P) then
-
if Ekind (Etype (Nam)) /= E_Subprogram_Type
or else not Type_Conformant (Etype (Nam), New_S) then
Error_Msg_N ("designated type does not match specification", P);
else
- Resolve (P, Etype (P));
+ Resolve (P);
end if;
return;
else
Typ := Any_Type;
- Get_First_Interp (Nam, I, It);
+ Get_First_Interp (Nam, Ind, It);
while Present (It.Nam) loop
@@ -910,7 +954,7 @@ package body Sem_Ch8 is
end if;
end if;
- Get_Next_Interp (I, It);
+ Get_Next_Interp (Ind, It);
end loop;
if Typ = Any_Type then
@@ -934,8 +978,8 @@ package body Sem_Ch8 is
New_S : Entity_Id;
Is_Body : Boolean)
is
- Nam : Node_Id := Name (N);
- Sel : Node_Id := Selector_Name (Nam);
+ Nam : constant Node_Id := Name (N);
+ Sel : constant Node_Id := Selector_Name (Nam);
Old_S : Entity_Id;
begin
@@ -981,8 +1025,8 @@ package body Sem_Ch8 is
New_S : Entity_Id;
Is_Body : Boolean)
is
- Nam : Node_Id := Name (N);
- P : Node_Id := Prefix (Nam);
+ Nam : constant Node_Id := Name (N);
+ P : constant Node_Id := Prefix (Nam);
Old_S : Entity_Id;
begin
@@ -1021,14 +1065,14 @@ package body Sem_Ch8 is
---------------------------------
procedure Analyze_Subprogram_Renaming (N : Node_Id) is
- Nam : Node_Id := Name (N);
Spec : constant Node_Id := Specification (N);
+ Save_83 : constant Boolean := Ada_83;
+ Nam : constant Node_Id := Name (N);
New_S : Entity_Id;
- Old_S : Entity_Id := Empty;
+ Old_S : Entity_Id := Empty;
Rename_Spec : Entity_Id;
- Is_Actual : Boolean := False;
- Inst_Node : Node_Id := Empty;
- Save_83 : Boolean := Ada_83;
+ Is_Actual : Boolean := False;
+ Inst_Node : Node_Id := Empty;
function Original_Subprogram (Subp : Entity_Id) return Entity_Id;
-- Find renamed entity when the declaration is a renaming_as_body
@@ -1082,7 +1126,7 @@ package body Sem_Ch8 is
end if;
end Original_Subprogram;
- -- Start of procesing for Analyze_Subprogram_Renaming
+ -- Start of processing for Analyze_Subprogram_Renaming
begin
-- We must test for the attribute renaming case before the Analyze
@@ -1109,7 +1153,7 @@ package body Sem_Ch8 is
if Present (Corresponding_Spec (N)) then
Is_Actual := True;
- Inst_Node := Corresponding_Spec (N);
+ Inst_Node := Unit_Declaration_Node (Corresponding_Spec (N));
if Is_Entity_Name (Nam)
and then Present (Entity (Nam))
@@ -1117,17 +1161,17 @@ package body Sem_Ch8 is
and then not Is_Overloaded (Nam)
then
Old_S := Entity (Nam);
- New_S := Analyze_Spec (Spec);
+ New_S := Analyze_Subprogram_Specification (Spec);
if Ekind (Entity (Nam)) = E_Operator
- and then Box_Present (Corresponding_Spec (N))
+ and then Box_Present (Inst_Node)
then
Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
end if;
else
Analyze (Nam);
- New_S := Analyze_Spec (Spec);
+ New_S := Analyze_Subprogram_Specification (Spec);
end if;
Set_Corresponding_Spec (N, Empty);
@@ -1141,7 +1185,7 @@ package body Sem_Ch8 is
-- The renaming defines a new overloaded entity, which is analyzed
-- like a subprogram declaration.
- New_S := Analyze_Spec (Spec);
+ New_S := Analyze_Subprogram_Specification (Spec);
end if;
if Current_Scope /= Standard_Standard then
@@ -1195,7 +1239,7 @@ package body Sem_Ch8 is
-- may be called before the next freezing point where the body will
-- appear.
- Set_Suppress_Elaboration_Checks (New_S, True);
+ Set_Kill_Elaboration_Checks (New_S, True);
if Etype (Nam) = Any_Type then
Set_Has_Completion (New_S);
@@ -1328,8 +1372,19 @@ package body Sem_Ch8 is
-- for this call, and it is in this body that the required
-- intrinsic processing will take place).
+ -- Also, if this is a renaming of inequality, the renamed
+ -- operator is intrinsic, but what matters is the corresponding
+ -- equality operator, which may be user-defined.
+
Set_Is_Intrinsic_Subprogram
- (New_S, Is_Intrinsic_Subprogram (Old_S));
+ (New_S,
+ Is_Intrinsic_Subprogram (Old_S)
+ and then
+ (Chars (Old_S) /= Name_Op_Ne
+ or else Ekind (Old_S) = E_Operator
+ or else
+ Is_Intrinsic_Subprogram
+ (Corresponding_Equality (Old_S))));
if Ekind (Alias (New_S)) = E_Operator then
Set_Has_Delayed_Freeze (New_S, False);
@@ -1388,9 +1443,10 @@ package body Sem_Ch8 is
begin
Error_Msg_Node_2 := Prefix (Nam);
- Error_Msg_NE ("\operator for type& is not declared in&",
- Prefix (Nam), T);
+ Error_Msg_NE
+ ("operator for type& is not declared in&", Prefix (Nam), T);
end;
+
else
Error_Msg_NE
("no visible subprogram matches the specification for&",
@@ -1443,36 +1499,6 @@ package body Sem_Ch8 is
Pack_Name : Node_Id;
Pack : Entity_Id;
- function In_Previous_With_Clause return Boolean;
- -- For use clauses in a context clause, the indicated package may
- -- be visible and yet illegal, if it did not appear in a previous
- -- with clause.
-
- -----------------------------
- -- In_Previous_With_Clause --
- -----------------------------
-
- function In_Previous_With_Clause return Boolean is
- Item : Node_Id;
-
- begin
- Item := First (Context_Items (Parent (N)));
-
- while Present (Item)
- and then Item /= N
- loop
- if Nkind (Item) = N_With_Clause
- and then Entity (Name (Item)) = Pack
- then
- return True;
- end if;
-
- Next (Item);
- end loop;
-
- return False;
- end In_Previous_With_Clause;
-
-- Start of processing for Analyze_Use_Package
begin
@@ -1547,14 +1573,14 @@ package body Sem_Ch8 is
Error_Msg_N ("& is not a usable package", Pack_Name);
end if;
- elsif Nkind (Parent (N)) = N_Compilation_Unit
- and then Nkind (Pack_Name) /= N_Expanded_Name
- and then not In_Previous_With_Clause
- then
- Error_Msg_N ("package is not directly visible", Pack_Name);
+ else
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ Check_In_Previous_With_Clause (N, Pack_Name);
+ end if;
- elsif Applicable_Use (Pack_Name) then
- Use_One_Package (Pack, N);
+ if Applicable_Use (Pack_Name) then
+ Use_One_Package (Pack, N);
+ end if;
end if;
end if;
@@ -1586,6 +1612,17 @@ package body Sem_Ch8 is
if Entity (Id) /= Any_Type then
Use_One_Type (Id);
+
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ if Nkind (Id) = N_Identifier then
+ Error_Msg_N ("Type is not directly visible", Id);
+
+ elsif Is_Child_Unit (Scope (Entity (Id)))
+ and then Scope (Entity (Id)) /= System_Aux_Id
+ then
+ Check_In_Previous_With_Clause (N, Prefix (Id));
+ end if;
+ end if;
end if;
Next (Id);
@@ -1678,6 +1715,10 @@ package body Sem_Ch8 is
Make_Identifier (Loc,
Chars => Chars (Defining_Identifier (Param_Spec))));
+ -- The expressions in the attribute reference are not freeze
+ -- points. Neither is the attribute as a whole, see below.
+
+ Set_Must_Not_Freeze (Last (Expr_List));
Next (Param_Spec);
end loop;
end if;
@@ -1700,7 +1741,7 @@ package body Sem_Ch8 is
then
if Nkind (N) = N_Subprogram_Renaming_Declaration
and then Present (Corresponding_Spec (N))
- and then Nkind (Corresponding_Spec (N)) =
+ and then Nkind (Unit_Declaration_Node (Corresponding_Spec (N))) =
N_Formal_Subprogram_Declaration
then
Error_Msg_N
@@ -1843,13 +1884,10 @@ package body Sem_Ch8 is
if Is_Entity_Name (Name (N)) then
Old_S := Entity (Name (N));
- if not Is_Frozen (Old_S) then
- Ensure_Freeze_Node (Old_S);
- if No (Actions (Freeze_Node (Old_S))) then
- Set_Actions (Freeze_Node (Old_S), New_List (B_Node));
- else
- Append (B_Node, Actions (Freeze_Node (Old_S)));
- end if;
+ if not Is_Frozen (Old_S)
+ and then Operating_Mode /= Check_Semantics
+ then
+ Append_Freeze_Action (Old_S, B_Node);
else
Insert_After (N, B_Node);
Analyze (B_Node);
@@ -1870,6 +1908,57 @@ package body Sem_Ch8 is
end if;
end Check_Frozen_Renaming;
+ -----------------------------------
+ -- Check_In_Previous_With_Clause --
+ -----------------------------------
+
+ procedure Check_In_Previous_With_Clause
+ (N : Node_Id;
+ Nam : Entity_Id)
+ is
+ Pack : constant Entity_Id := Entity (Original_Node (Nam));
+ Item : Node_Id;
+ Par : Node_Id;
+
+ begin
+ Item := First (Context_Items (Parent (N)));
+
+ while Present (Item)
+ and then Item /= N
+ loop
+ if Nkind (Item) = N_With_Clause
+ and then Entity (Name (Item)) = Pack
+ then
+ Par := Nam;
+
+ -- Find root library unit in with_clause.
+
+ while Nkind (Par) = N_Expanded_Name loop
+ Par := Prefix (Par);
+ end loop;
+
+ if Is_Child_Unit (Entity (Original_Node (Par))) then
+ Error_Msg_NE
+ ("& is not directly visible", Par, Entity (Par));
+ else
+ return;
+ end if;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ -- On exit, package is not mentioned in a previous with_clause.
+ -- Check if its prefix is.
+
+ if Nkind (Nam) = N_Expanded_Name then
+ Check_In_Previous_With_Clause (N, Prefix (Nam));
+
+ elsif Pack /= Any_Id then
+ Error_Msg_NE ("& is not visible", Nam, Pack);
+ end if;
+ end Check_In_Previous_With_Clause;
+
---------------------------------
-- Check_Library_Unit_Renaming --
---------------------------------
@@ -2021,14 +2110,25 @@ package body Sem_Ch8 is
---------------------
procedure End_Use_Clauses (Clause : Node_Id) is
- U : Node_Id := Clause;
+ U : Node_Id;
begin
+ -- Remove Use_Type clauses first, because they affect the
+ -- visibility of operators in subsequent used packages.
+
+ U := Clause;
+ while Present (U) loop
+ if Nkind (U) = N_Use_Type_Clause then
+ End_Use_Type (U);
+ end if;
+
+ Next_Use_Clause (U);
+ end loop;
+
+ U := Clause;
while Present (U) loop
if Nkind (U) = N_Use_Package_Clause then
End_Use_Package (U);
- elsif Nkind (U) = N_Use_Type_Clause then
- End_Use_Type (U);
end if;
Next_Use_Clause (U);
@@ -2045,6 +2145,30 @@ package body Sem_Ch8 is
Id : Entity_Id;
Elmt : Elmt_Id;
+ function Is_Primitive_Operator
+ (Op : Entity_Id;
+ F : Entity_Id)
+ return Boolean;
+ -- Check whether Op is a primitive operator of a use-visible type
+
+ ---------------------------
+ -- Is_Primitive_Operator --
+ ---------------------------
+
+ function Is_Primitive_Operator
+ (Op : Entity_Id;
+ F : Entity_Id)
+ return Boolean
+ is
+ T : constant Entity_Id := Etype (F);
+
+ begin
+ return In_Use (T)
+ and then Scope (T) = Scope (Op);
+ end Is_Primitive_Operator;
+
+ -- Start of processing for End_Use_Package
+
begin
Pack_Name := First (Names (N));
@@ -2062,17 +2186,18 @@ package body Sem_Ch8 is
while Present (Id) loop
- -- Preserve use-visibility of operators whose formals have
- -- a type that is use_visible thanks to a previous use_type
- -- clause.
+ -- Preserve use-visibility of operators that are primitive
+ -- operators of a type that is use_visible through an active
+ -- use_type clause.
if Nkind (Id) = N_Defining_Operator_Symbol
and then
- (In_Use (Etype (First_Formal (Id)))
+ (Is_Primitive_Operator (Id, First_Formal (Id))
or else
- (Present (Next_Formal (First_Formal (Id)))
- and then In_Use (Etype (Next_Formal
- (First_Formal (Id))))))
+ (Present (Next_Formal (First_Formal (Id)))
+ and then
+ Is_Primitive_Operator
+ (Id, Next_Formal (First_Formal (Id)))))
then
null;
@@ -2149,6 +2274,17 @@ package body Sem_Ch8 is
Id := First (Subtype_Marks (N));
while Present (Id) loop
+
+ -- A call to rtsfind may occur while analyzing a use_type clause,
+ -- in which case the type marks are not resolved yet, and there is
+ -- nothing to remove.
+
+ if not Is_Entity_Name (Id)
+ or else No (Entity (Id))
+ then
+ goto Continue;
+ end if;
+
T := Entity (Id);
if T = Any_Type then
@@ -2177,6 +2313,7 @@ package body Sem_Ch8 is
end loop;
end if;
+ <<Continue>>
Next (Id);
end loop;
end End_Use_Type;
@@ -2416,6 +2553,14 @@ package body Sem_Ch8 is
Error_Msg_N ("non-visible (private) declaration#!", N);
else
Error_Msg_N ("non-visible declaration#!", N);
+
+ if Is_Compilation_Unit (Ent)
+ and then
+ Nkind (Parent (Parent (N))) = N_Use_Package_Clause
+ then
+ Error_Msg_NE
+ ("\possibly missing with_clause for&", N, Ent);
+ end if;
end if;
-- Set entity and its containing package as referenced. We
@@ -2443,6 +2588,20 @@ package body Sem_Ch8 is
Emsg : Error_Msg_Id;
begin
+ -- We should never find an undefined internal name. If we do, then
+ -- see if we have previous errors. If so, ignore on the grounds that
+ -- it is probably a cascaded message (e.g. a block label from a badly
+ -- formed block). If no previous errors, then we have a real internal
+ -- error of some kind so raise an exception.
+
+ if Is_Internal_Name (Chars (N)) then
+ if Total_Errors_Detected /= 0 then
+ return;
+ else
+ raise Program_Error;
+ end if;
+ end if;
+
-- A very specialized error check, if the undefined variable is
-- a case tag, and the case type is an enumeration type, check
-- for a possible misspelling, and if so, modify the identifier
@@ -2680,16 +2839,16 @@ package body Sem_Ch8 is
if not Nvis_Entity then
Undefined (Nvis => False);
- return;
-- Otherwise there is at least one entry on the homonym chain that
-- is reasonably considered as being known and non-visible.
else
Nvis_Messages;
- return;
end if;
+ return;
+
-- Processing for a potentially use visible entry found. We must search
-- the rest of the homonym chain for two reasons. First, if there is a
-- directly visible entry, then none of the potentially use-visible
@@ -2744,14 +2903,33 @@ package body Sem_Ch8 is
-- Note that E points to the first such entity on the homonym list.
-- Special case: if one of the entities is declared in an actual
-- package, it was visible in the generic, and takes precedence over
- -- other entities that are potentially use-visible.
+ -- other entities that are potentially use-visible. Same if it is
+ -- declared in a local instantiation of the current instance.
else
if In_Instance then
+ Inst := Current_Scope;
+
+ -- Find current instance.
+
+ while Present (Inst)
+ and then Inst /= Standard_Standard
+ loop
+ if Is_Generic_Instance (Inst) then
+ exit;
+ end if;
+
+ Inst := Scope (Inst);
+ end loop;
+
E2 := E;
while Present (E2) loop
- if Is_Generic_Instance (Scope (E2)) then
+ if From_Actual_Package (E2)
+ or else
+ (Is_Generic_Instance (Scope (E2))
+ and then Scope_Depth (Scope (E2)) > Scope_Depth (Inst))
+ then
E := E2;
goto Found;
end if;
@@ -2882,13 +3060,6 @@ package body Sem_Ch8 is
-- corresponding discriminal, which is the formal corresponding to
-- to the discriminant in the initialization procedure.
- -- This replacement must not be done if we are currently processing
- -- a generic spec or body.
-
- -- The replacement is not done either for a task discriminant that
- -- appears in a default expression of an entry parameter. See
- -- Expand_Discriminant in exp_ch2 for details on their handling.
-
else
-- Entity is unambiguous, indicate that it is referenced here
-- One slightly odd case is that we do not want to set the
@@ -2905,16 +3076,33 @@ package body Sem_Ch8 is
Set_Referenced (E, R);
end;
+ -- Normal case, not a label. Generate reference.
+
else
Generate_Reference (E, N);
end if;
+ -- Set Entity, with style check if need be. If this is a
+ -- discriminant reference, it must be replaced by the
+ -- corresponding discriminal, that is to say the parameter
+ -- of the initialization procedure that corresponds to the
+ -- discriminant. If this replacement is being performed, there
+ -- is no style check to perform.
+
+ -- This replacement must not be done if we are currently
+ -- processing a generic spec or body, because the discriminal
+ -- has not been not generated in this case.
+
if not In_Default_Expression
or else Ekind (E) /= E_Discriminant
or else Inside_A_Generic
then
Set_Entity_With_Style_Check (N, E);
+ -- The replacement is not done either for a task discriminant that
+ -- appears in a default expression of an entry parameter. See
+ -- Expand_Discriminant in exp_ch2 for details on their handling.
+
elsif Is_Concurrent_Type (Scope (E)) then
declare
P : Node_Id := Parent (N);
@@ -2936,6 +3124,10 @@ package body Sem_Ch8 is
end if;
end;
+ -- Otherwise, this is a discriminant in a context in which
+ -- it is a reference to the corresponding parameter of the
+ -- init proc for the enclosing type.
+
else
Set_Entity (N, Discriminal (E));
end if;
@@ -2991,13 +3183,12 @@ package body Sem_Ch8 is
Candidate := Id;
if Is_Child_Unit (Id) then
- exit when
- (Is_Visible_Child_Unit (Id)
- or else Is_Immediately_Visible (Id));
+ exit when Is_Visible_Child_Unit (Id)
+ or else Is_Immediately_Visible (Id);
else
- exit when
- (not Is_Hidden (Id) or else Is_Immediately_Visible (Id));
+ exit when not Is_Hidden (Id)
+ or else Is_Immediately_Visible (Id);
end if;
end if;
@@ -3034,15 +3225,15 @@ package body Sem_Ch8 is
if Chars (P_Name) = Name_System
and then Scope (P_Name) = Standard_Standard
- and then Present (System_Extend_Pragma_Arg)
+ and then Present (System_Extend_Unit)
and then Present_System_Aux (N)
then
Set_Entity (Prefix (N), System_Aux_Id);
Find_Expanded_Name (N);
return;
- elsif (Nkind (Selector) = N_Operator_Symbol
- and then Has_Implicit_Operator (N))
+ elsif Nkind (Selector) = N_Operator_Symbol
+ and then Has_Implicit_Operator (N)
then
-- There is an implicit instance of the predefined operator in
-- the given scope. The operator entity is defined in Standard.
@@ -3127,12 +3318,11 @@ package body Sem_Ch8 is
end;
end if;
- if (Chars (P_Name) = Name_Ada
- and then Scope (P_Name) = Standard_Standard)
+ if Chars (P_Name) = Name_Ada
+ and then Scope (P_Name) = Standard_Standard
then
Error_Msg_Node_2 := Selector;
- Error_Msg_NE
- ("\missing with for `&.&`", N, P_Name);
+ Error_Msg_NE ("missing with for `&.&`", N, P_Name);
-- If this is a selection from a dummy package, then
-- suppress the error message, of course the entity
@@ -3267,6 +3457,25 @@ package body Sem_Ch8 is
H := Homonym (H);
end loop;
+
+ -- If an extension of System is present, collect possible
+ -- explicit overloadings declared in the extension.
+
+ if Chars (P_Name) = Name_System
+ and then Scope (P_Name) = Standard_Standard
+ and then Present (System_Extend_Unit)
+ and then Present_System_Aux (N)
+ then
+ H := Current_Entity (Id);
+
+ while Present (H) loop
+ if Scope (H) = System_Aux_Id then
+ Add_One_Interp (N, H, Etype (H));
+ end if;
+
+ H := Homonym (H);
+ end loop;
+ end if;
end;
end if;
@@ -3295,7 +3504,7 @@ package body Sem_Ch8 is
New_S : Entity_Id;
Is_Actual : Boolean := False) return Entity_Id
is
- I : Interp_Index;
+ Ind : Interp_Index;
I1 : Interp_Index := 0; -- Suppress junk warnings
It : Interp;
It1 : Interp;
@@ -3432,6 +3641,26 @@ package body Sem_Ch8 is
return False;
end Within;
+ function Report_Overload return Entity_Id;
+ -- List possible interpretations, and specialize message in the
+ -- case of a generic actual.
+
+ function Report_Overload return Entity_Id is
+ begin
+ if Is_Actual then
+ Error_Msg_NE
+ ("ambiguous actual subprogram&, " &
+ "possible interpretations: ", N, Nam);
+ else
+ Error_Msg_N
+ ("ambiguous subprogram, " &
+ "possible interpretations: ", N);
+ end if;
+
+ List_Interps (Nam, N);
+ return Old_S;
+ end Report_Overload;
+
-- Start of processing for Find_Renamed_Entry
begin
@@ -3454,7 +3683,7 @@ package body Sem_Ch8 is
end if;
else
- Get_First_Interp (Nam, I, It);
+ Get_First_Interp (Nam, Ind, It);
while Present (It.Nam) loop
@@ -3467,7 +3696,7 @@ package body Sem_Ch8 is
-- previous interpretation was found, in which case I1
-- has received a value.
- It1 := Disambiguate (Nam, I1, I, Etype (Old_S));
+ It1 := Disambiguate (Nam, I1, Ind, Etype (Old_S));
if It1 = No_Interp then
@@ -3482,13 +3711,11 @@ package body Sem_Ch8 is
return (Old_S);
else
- Error_Msg_N ("ambiguous renaming", N);
- return Old_S;
+ return Report_Overload;
end if;
else
- Error_Msg_N ("ambiguous renaming", N);
- return Old_S;
+ return Report_Overload;
end if;
else
@@ -3497,7 +3724,7 @@ package body Sem_Ch8 is
end if;
else
- I1 := I;
+ I1 := Ind;
Old_S := It.Nam;
end if;
@@ -3510,7 +3737,7 @@ package body Sem_Ch8 is
Candidate_Renaming := It.Nam;
end if;
- Get_Next_Interp (I, It);
+ Get_Next_Interp (Ind, It);
end loop;
Set_Entity (Nam, Old_S);
@@ -3525,7 +3752,7 @@ package body Sem_Ch8 is
-----------------------------
procedure Find_Selected_Component (N : Node_Id) is
- P : Node_Id := Prefix (N);
+ P : constant Node_Id := Prefix (N);
P_Name : Entity_Id;
-- Entity denoted by prefix
@@ -3552,19 +3779,19 @@ package body Sem_Ch8 is
or else Etype (N) = Any_Type
then
declare
- Sel_Name : Node_Id := Selector_Name (N);
- Selector : Entity_Id := Entity (Sel_Name);
+ Sel_Name : constant Node_Id := Selector_Name (N);
+ Selector : constant Entity_Id := Entity (Sel_Name);
C_Etype : Node_Id;
begin
Set_Etype (Sel_Name, Etype (Selector));
if not Is_Entity_Name (P) then
- Resolve (P, Etype (P));
+ Resolve (P);
end if;
-- Build an actual subtype except for the first parameter
- -- of an init_proc, where this actual subtype is by
+ -- of an init proc, where this actual subtype is by
-- definition incorrect, since the object is uninitialized
-- (and does not even have defined discriminants etc.)
@@ -3612,9 +3839,9 @@ package body Sem_Ch8 is
and then Is_Concurrent_Type (Designated_Type (Etype (P)))
then
declare
- New_P : Node_Id :=
- Make_Explicit_Dereference (Sloc (P),
- Prefix => Relocate_Node (P));
+ New_P : constant Node_Id :=
+ Make_Explicit_Dereference (Sloc (P),
+ Prefix => Relocate_Node (P));
begin
Rewrite (P, New_P);
Set_Etype (P, Designated_Type (Etype (Prefix (P))));
@@ -3624,7 +3851,7 @@ package body Sem_Ch8 is
-- If the selected component appears within a default expression
-- and it has an actual subtype, the pre-analysis has not yet
-- completed its analysis, because Insert_Actions is disabled in
- -- that context. Within the init_proc of the enclosing type we
+ -- that context. Within the init proc of the enclosing type we
-- must complete this analysis, if an actual subtype was created.
elsif Inside_Init_Proc then
@@ -3720,11 +3947,11 @@ package body Sem_Ch8 is
declare
Found : Boolean := False;
- I : Interp_Index;
+ Ind : Interp_Index;
It : Interp;
begin
- Get_First_Interp (P, I, It);
+ Get_First_Interp (P, Ind, It);
while Present (It.Nam) loop
@@ -3742,7 +3969,7 @@ package body Sem_Ch8 is
end if;
end if;
- Get_Next_Interp (I, It);
+ Get_Next_Interp (Ind, It);
end loop;
end;
end if;
@@ -3814,13 +4041,10 @@ package body Sem_Ch8 is
else
-- Format node as expanded name, to avoid cascaded errors
- Change_Node (N, N_Expanded_Name);
- Set_Prefix (N, P);
+ Change_Selected_Component_To_Expanded_Name (N);
Set_Entity (N, Any_Id);
Set_Etype (N, Any_Type);
- -- Set_Selector_Name (N, Empty); ????
-
-- Issue error message, but avoid this if error issued already.
-- Use identifier of prefix if one is available.
@@ -3936,15 +4160,6 @@ package body Sem_Ch8 is
Set_Entity_With_Style_Check (N, C);
Generate_Reference (C, N);
Set_Etype (N, C);
-
- if From_With_Type (C)
- and then Nkind (Parent (N)) /= N_Access_Definition
- and then not Analyzed (T)
- then
- Error_Msg_N
- ("imported class-wide type can only be used" &
- " for access parameters", N);
- end if;
end if;
-- Base attribute, allowed in Ada 95 mode only
@@ -3958,7 +4173,14 @@ package body Sem_Ch8 is
Find_Type (Prefix (N));
Typ := Entity (Prefix (N));
- if Sloc (Typ) = Standard_Location
+ if Ada_95
+ and then not Is_Scalar_Type (Typ)
+ and then not Is_Generic_Type (Typ)
+ then
+ Error_Msg_N
+ ("prefix of Base attribute must be scalar type", Typ);
+
+ elsif Sloc (Typ) = Standard_Location
and then Base_Type (Typ) = Typ
and then Warn_On_Redundant_Constructs
then
@@ -3967,14 +4189,25 @@ package body Sem_Ch8 is
end if;
T := Base_Type (Typ);
- Set_Entity (N, T);
- Set_Etype (N, T);
-- Rewrite attribute reference with type itself (see similar
- -- processing in Analyze_Attribute, case Base)
+ -- processing in Analyze_Attribute, case Base). Preserve
+ -- prefix if present, for other legality checks.
+
+ if Nkind (Prefix (N)) = N_Expanded_Name then
+ Rewrite (N,
+ Make_Expanded_Name (Sloc (N),
+ Chars => Chars (Entity (N)),
+ Prefix => New_Copy (Prefix (Prefix (N))),
+ Selector_Name =>
+ New_Reference_To (Entity (N), Sloc (N))));
- Rewrite (N,
- New_Reference_To (Entity (N), Sloc (N)));
+ else
+ Rewrite (N,
+ New_Reference_To (Entity (N), Sloc (N)));
+ end if;
+
+ Set_Entity (N, T);
Set_Etype (N, T);
end if;
@@ -4046,8 +4279,8 @@ package body Sem_Ch8 is
function Get_Full_View (T_Name : Entity_Id) return Entity_Id is
begin
- if (Ekind (T_Name) = E_Incomplete_Type
- and then Present (Full_View (T_Name)))
+ if Ekind (T_Name) = E_Incomplete_Type
+ and then Present (Full_View (T_Name))
then
return Full_View (T_Name);
@@ -4132,15 +4365,22 @@ package body Sem_Ch8 is
Id : Entity_Id;
Priv_Id : Entity_Id := Empty;
- procedure Add_Implicit_Operator (T : Entity_Id);
+ procedure Add_Implicit_Operator
+ (T : Entity_Id;
+ Op_Type : Entity_Id := Empty);
-- Add implicit interpretation to node N, using the type for which
- -- a predefined operator exists.
+ -- a predefined operator exists. If the operator yields a boolean
+ -- type, the Operand_Type is implicitly referenced by the operator,
+ -- and a reference to it must be generated.
---------------------------
-- Add_Implicit_Operator --
---------------------------
- procedure Add_Implicit_Operator (T : Entity_Id) is
+ procedure Add_Implicit_Operator
+ (T : Entity_Id;
+ Op_Type : Entity_Id := Empty)
+ is
Predef_Op : Entity_Id;
begin
@@ -4163,6 +4403,15 @@ package body Sem_Ch8 is
if Present (Homonym (Predef_Op)) then
Add_One_Interp (N, Homonym (Predef_Op), T);
end if;
+
+ -- The node is a reference to a predefined operator, and
+ -- an implicit reference to the type of its operands.
+
+ if Present (Op_Type) then
+ Generate_Operator_Reference (N, Op_Type);
+ else
+ Generate_Operator_Reference (N, T);
+ end if;
end Add_Implicit_Operator;
-- Start of processing for Has_Implicit_Operator
@@ -4207,7 +4456,7 @@ package body Sem_Ch8 is
and then not Is_Limited_Type (Id)
and then Id = Base_Type (Id)
then
- Add_Implicit_Operator (Standard_Boolean);
+ Add_Implicit_Operator (Standard_Boolean, Id);
return True;
end if;
@@ -4224,7 +4473,7 @@ package body Sem_Ch8 is
and then Is_Scalar_Type (Component_Type (Id))))
and then Id = Base_Type (Id)
then
- Add_Implicit_Operator (Standard_Boolean);
+ Add_Implicit_Operator (Standard_Boolean, Id);
return True;
end if;
@@ -4417,8 +4666,12 @@ package body Sem_Ch8 is
P := First (Subtype_Marks (U));
while Present (P) loop
+ if not Is_Entity_Name (P)
+ or else No (Entity (P))
+ then
+ null;
- if Entity (P) /= Any_Type then
+ elsif Entity (P) /= Any_Type then
Use_One_Type (P);
end if;
@@ -4510,29 +4763,29 @@ package body Sem_Ch8 is
Scope_Stack.Increment_Last;
- Scope_Stack.Table (Scope_Stack.Last).Entity := S;
-
- Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress :=
- Scope_Suppress;
-
- Scope_Stack.Table (Scope_Stack.Last).Save_Entity_Suppress :=
- Entity_Suppress.Last;
+ declare
+ SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
- if Scope_Stack.Last > Scope_Stack.First then
- Scope_Stack.Table (Scope_Stack.Last).Component_Alignment_Default :=
- Scope_Stack.Table (Scope_Stack.Last - 1).Component_Alignment_Default;
- end if;
+ begin
+ SST.Entity := S;
+ SST.Save_Scope_Suppress := Scope_Suppress;
+ SST.Save_Local_Entity_Suppress := Local_Entity_Suppress.Last;
+
+ if Scope_Stack.Last > Scope_Stack.First then
+ SST.Component_Alignment_Default := Scope_Stack.Table
+ (Scope_Stack.Last - 1).
+ Component_Alignment_Default;
+ end if;
- Scope_Stack.Table (Scope_Stack.Last).Last_Subprogram_Name := null;
- Scope_Stack.Table (Scope_Stack.Last).Is_Transient := False;
- Scope_Stack.Table (Scope_Stack.Last).Node_To_Be_Wrapped := Empty;
- Scope_Stack.Table (Scope_Stack.Last).Pending_Freeze_Actions := No_List;
- Scope_Stack.Table
- (Scope_Stack.Last).Actions_To_Be_Wrapped_Before := No_List;
- Scope_Stack.Table
- (Scope_Stack.Last).Actions_To_Be_Wrapped_After := No_List;
- Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause := Empty;
- Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := False;
+ SST.Last_Subprogram_Name := null;
+ SST.Is_Transient := False;
+ SST.Node_To_Be_Wrapped := Empty;
+ SST.Pending_Freeze_Actions := No_List;
+ SST.Actions_To_Be_Wrapped_Before := No_List;
+ SST.Actions_To_Be_Wrapped_After := No_List;
+ SST.First_Use_Clause := Empty;
+ SST.Is_Active_Stack_Base := False;
+ end;
if Debug_Flag_W then
Write_Str ("--> new scope: ");
@@ -4562,11 +4815,9 @@ package body Sem_Ch8 is
-- inner level subprograms do not inherit the categorization.
if Is_Library_Level_Entity (S) then
- Set_Is_Pure (S, Is_Pure (E));
Set_Is_Preelaborated (S, Is_Preelaborated (E));
- Set_Is_Remote_Call_Interface (S, Is_Remote_Call_Interface (E));
- Set_Is_Remote_Types (S, Is_Remote_Types (E));
Set_Is_Shared_Passive (S, Is_Shared_Passive (E));
+ Set_Categorization_From_Scope (E => S, Scop => E);
end if;
end if;
end New_Scope;
@@ -4576,65 +4827,15 @@ package body Sem_Ch8 is
---------------
procedure Pop_Scope is
- E : Entity_Id;
+ SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
begin
if Debug_Flag_E then
Write_Info;
end if;
- Scope_Suppress :=
- Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress;
-
- while Entity_Suppress.Last >
- Scope_Stack.Table (Scope_Stack.Last).Save_Entity_Suppress
- loop
- E := Entity_Suppress.Table (Entity_Suppress.Last).Entity;
-
- case Entity_Suppress.Table (Entity_Suppress.Last).Check is
-
- when Access_Check =>
- Set_Suppress_Access_Checks (E, False);
-
- when Accessibility_Check =>
- Set_Suppress_Accessibility_Checks (E, False);
-
- when Discriminant_Check =>
- Set_Suppress_Discriminant_Checks (E, False);
-
- when Division_Check =>
- Set_Suppress_Division_Checks (E, False);
-
- when Elaboration_Check =>
- Set_Suppress_Elaboration_Checks (E, False);
-
- when Index_Check =>
- Set_Suppress_Index_Checks (E, False);
-
- when Length_Check =>
- Set_Suppress_Length_Checks (E, False);
-
- when Overflow_Check =>
- Set_Suppress_Overflow_Checks (E, False);
-
- when Range_Check =>
- Set_Suppress_Range_Checks (E, False);
-
- when Storage_Check =>
- Set_Suppress_Storage_Checks (E, False);
-
- when Tag_Check =>
- Set_Suppress_Tag_Checks (E, False);
-
- -- All_Checks should not appear here (since it is entered as a
- -- series of its separate checks). Bomb if it is encountered
-
- when All_Checks =>
- raise Program_Error;
- end case;
-
- Entity_Suppress.Decrement_Last;
- end loop;
+ Scope_Suppress := SST.Save_Scope_Suppress;
+ Local_Entity_Suppress.Set_Last (SST.Save_Local_Entity_Suppress);
if Debug_Flag_W then
Write_Str ("--> exiting scope: ");
@@ -4644,21 +4845,23 @@ package body Sem_Ch8 is
Write_Eol;
end if;
- End_Use_Clauses (Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause);
+ End_Use_Clauses (SST.First_Use_Clause);
-- If the actions to be wrapped are still there they will get lost
-- causing incomplete code to be generated. It is better to abort in
- -- this case.
+ -- this case (and we do the abort even with assertions off since the
+ -- penalty is incorrect code generation)
- pragma Assert (Scope_Stack.Table
- (Scope_Stack.Last).Actions_To_Be_Wrapped_Before = No_List);
-
- pragma Assert (Scope_Stack.Table
- (Scope_Stack.Last).Actions_To_Be_Wrapped_After = No_List);
+ if SST.Actions_To_Be_Wrapped_Before /= No_List
+ or else
+ SST.Actions_To_Be_Wrapped_After /= No_List
+ then
+ return;
+ end if;
-- Free last subprogram name if allocated, and pop scope
- Free (Scope_Stack.Table (Scope_Stack.Last).Last_Subprogram_Name);
+ Free (SST.Last_Subprogram_Name);
Scope_Stack.Decrement_Last;
end Pop_Scope;
@@ -4667,7 +4870,7 @@ package body Sem_Ch8 is
---------------------
procedure Premature_Usage (N : Node_Id) is
- Kind : Node_Kind := Nkind (Parent (Entity (N)));
+ Kind : constant Node_Kind := Nkind (Parent (Entity (N)));
E : Entity_Id := Entity (N);
begin
@@ -4767,7 +4970,7 @@ package body Sem_Ch8 is
-- If no previous pragma for System.Aux, nothing to load
- elsif No (System_Extend_Pragma_Arg) then
+ elsif No (System_Extend_Unit) then
return False;
-- Use the unit name given in the pragma to retrieve the unit.
@@ -4810,7 +5013,7 @@ package body Sem_Ch8 is
end if;
Loc := Sloc (With_Sys);
- Get_Name_String (Chars (Expression (System_Extend_Pragma_Arg)));
+ Get_Name_String (Chars (Expression (System_Extend_Unit)));
Name_Buffer (8 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
Name_Buffer (1 .. 7) := "system.";
Name_Buffer (Name_Len + 8) := '%';
@@ -4856,10 +5059,10 @@ package body Sem_Ch8 is
else
Error_Msg_Name_1 := Name_System;
- Error_Msg_Name_2 := Chars (Expression (System_Extend_Pragma_Arg));
+ Error_Msg_Name_2 := Chars (Expression (System_Extend_Unit));
Error_Msg_N
("extension package `%.%` does not exist",
- Opt.System_Extend_Pragma_Arg);
+ Opt.System_Extend_Unit);
return False;
end if;
end if;
@@ -4875,6 +5078,7 @@ package body Sem_Ch8 is
Comp_Unit : Node_Id;
In_Child : Boolean := False;
Full_Vis : Boolean := True;
+ SS_Last : constant Int := Scope_Stack.Last;
begin
-- Restore visibility of previous scope stack, if any.
@@ -4967,6 +5171,12 @@ package body Sem_Ch8 is
Full_Vis := True;
end if;
end loop;
+
+ if SS_Last >= Scope_Stack.First
+ and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
+ then
+ Install_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
+ end if;
end Restore_Scope_Stack;
----------------------
@@ -4983,6 +5193,8 @@ package body Sem_Ch8 is
and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard
then
+ End_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause);
+
-- If the call is from within a compilation unit, as when
-- called from Rtsfind, make current entries in scope stack
-- invisible while we analyze the new unit.
@@ -5227,14 +5439,19 @@ package body Sem_Ch8 is
T := Base_Type (Entity (Id));
- -- Save current visibility status of type, before setting.
-
Set_Redundant_Use
- (Id, In_Use (T) or else Is_Potentially_Use_Visible (T));
+ (Id,
+ In_Use (T)
+ or else Is_Potentially_Use_Visible (T)
+ or else In_Use (Scope (T)));
if In_Open_Scopes (Scope (T)) then
null;
+ -- If the subtype mark designates a subtype in a different package,
+ -- we have to check that the parent type is visible, otherwise the
+ -- use type clause is a noop. Not clear how to do that???
+
elsif not Redundant_Use (Id) then
Set_In_Use (T);
Op_List := Collect_Primitive_Operations (T);
diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads
index e94a229479f..87db07a074d 100644
--- a/gcc/ada/sem_ch8.ads
+++ b/gcc/ada/sem_ch8.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -56,11 +56,6 @@ package Sem_Ch8 is
procedure Analyze_Use_Package (N : Node_Id);
procedure Analyze_Use_Type (N : Node_Id);
- function Applicable_Use (Pack_Name : Node_Id) return Boolean;
- -- Common code to Use_One_Package and Set_Use, to determine whether
- -- use clause must be processed. Pack_Name is an entity name that
- -- references the package in question.
-
procedure End_Scope;
-- Called at end of scope. On exit from blocks and bodies (subprogram,
-- package, task, and protected bodies), the name of the current scope
@@ -91,10 +86,6 @@ package Sem_Ch8 is
-- an appropriate list of entries has been made in the overload
-- interpretation table (to be disambiguated in the resolve phase).
- procedure Find_Expanded_Name (N : Node_Id);
- -- Selected component is known to be expanded name. Verify legality
- -- of selector given the scope denoted by prefix.
-
procedure Find_Selected_Component (N : Node_Id);
-- Resolve various cases of selected components, recognize expanded names
@@ -102,25 +93,17 @@ package Sem_Ch8 is
-- Perform name resolution, and verify that the name found is that of a
-- type. On return the Entity and Etype fields of the node N are set
-- appropriately. If it is an incomplete type whose full declaration has
- -- been seen, return the entity in the full declaration. Similarly, if
- -- the type is private, it has receivd a full declaration, and we are
- -- in the private part or body of the package, return the full
- -- declaration as well. Special processing for Class types as well.
+ -- been seen, they are set to the entity in the full declaration.
+ -- Similarly, if the type is private, it has received a full declaration,
+ -- and we are in the private part or body of the package, then the two
+ -- fields are set to the entity of the full declaration as well. This
+ -- procedure also provides special processing for Class types as well.
function Get_Full_View (T_Name : Entity_Id) return Entity_Id;
-- If T_Name is an incomplete type and the full declaration has been
-- seen, or is the name of a class_wide type whose root is incomplete.
-- return the corresponding full declaration.
- function Has_Implicit_Operator (N : Node_Id) return Boolean;
- -- N is an expanded name whose selector is an operator name (eg P."+").
- -- A declarative part contains an implicit declaration of an operator
- -- if it has a declaration of a type to which one of the predefined
- -- operators apply. The existence of this routine is an artifact of
- -- our implementation: a more straightforward but more space-consuming
- -- choice would be to make all inherited operators explicit in the
- -- symbol table.
-
procedure Initialize;
-- Initializes data structures used for visibility analysis. Must be
-- called before analyzing each new main source program.
@@ -135,14 +118,6 @@ package Sem_Ch8 is
-- S is the entity of a scope. This function determines if this scope
-- is currently open (i.e. it appears somewhere in the scope stack).
- function Is_Appropriate_For_Record (T : Entity_Id) return Boolean;
- -- Prefix is appropriate for record if it is of a record type, or
- -- an access to such.
-
- function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean;
- -- True if it is of a task type, a protected type, or else an access
- -- to one of these types.
-
procedure New_Scope (S : Entity_Id);
-- Make new scope stack entry, pushing S, the entity for a scope
-- onto the top of the scope table. The current setting of the scope
@@ -169,16 +144,6 @@ package Sem_Ch8 is
-- stack containing U2 and local scopes must be made unreachable. On
-- return, the contents of the scope stack must be made accessible again.
- procedure Use_One_Package (P : Entity_Id; N : Node_Id);
- -- Make visible entities declarated in package P potentially use-visible
- -- in the current context. Also used in the analysis of subunits, when
- -- re-installing use clauses of parent units. N is the use_clause that
- -- names P (and possibly other packages).
-
- procedure Use_One_Type (Id : Node_Id);
- -- Id is the subtype mark from a use type clause. This procedure makes
- -- the primitive operators of the type potentially use-visible.
-
procedure Set_Use (L : List_Id);
-- Find use clauses that are declarative items in a package declaration
-- and set the potentially use-visible flags of imported entities before
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index 5c428aadda3..653774fdee1 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.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- --
@@ -91,7 +91,7 @@ package body Sem_Ch9 is
Error_Msg_N ("expect task name for ABORT", T_Name);
return;
else
- Resolve (T_Name, Etype (T_Name));
+ Resolve (T_Name);
end if;
Next (T_Name);
@@ -113,12 +113,12 @@ package body Sem_Ch9 is
Analyze_List (Pragmas_Before (N));
end if;
- Analyze (Accept_Statement (N));
-
if Present (Condition (N)) then
Analyze_And_Resolve (Condition (N), Any_Boolean);
end if;
+ Analyze (Accept_Statement (N));
+
if Is_Non_Empty_List (Statements (N)) then
Analyze_Statements (Statements (N));
end if;
@@ -149,17 +149,21 @@ package body Sem_Ch9 is
-- local variable that renames it in the task body.
function Actual_Index_Type (E : Entity_Id) return Entity_Id is
- Typ : Entity_Id := Entry_Index_Type (E);
- Lo : Node_Id := Type_Low_Bound (Typ);
- Hi : Node_Id := Type_High_Bound (Typ);
+ Typ : constant Entity_Id := Entry_Index_Type (E);
+ Lo : constant Node_Id := Type_Low_Bound (Typ);
+ Hi : constant Node_Id := Type_High_Bound (Typ);
New_T : Entity_Id;
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-- If bound is discriminant reference, replace with corresponding
-- local variable of the same name.
+ -----------------------------
+ -- Actual_Discriminant_Ref --
+ -----------------------------
+
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
- Typ : Entity_Id := Etype (Bound);
+ Typ : constant Entity_Id := Etype (Bound);
Ref : Node_Id;
begin
@@ -343,17 +347,6 @@ package body Sem_Ch9 is
Error_Msg_N ("invalid entry index in accept for simple entry", N);
end if;
- -- If statements are present, they must be analyzed in the context
- -- of the entry, so that references to formals are correctly resolved.
- -- We also have to add the declarations that are required by the
- -- expansion of the accept statement in this case if expansion active.
-
- -- In the case of a select alternative of a selective accept,
- -- the expander references the address declaration even if there
- -- is no statement list.
-
- Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
-
-- If label declarations present, analyze them. They are declared
-- in the enclosing task, but their enclosing scope is the entry itself,
-- so that goto's to the label are recognized as local to the accept.
@@ -380,12 +373,31 @@ package body Sem_Ch9 is
end;
end if;
- -- Set Not_Source_Assigned flag on all entry formals
+ -- If statements are present, they must be analyzed in the context
+ -- of the entry, so that references to formals are correctly resolved.
+ -- We also have to add the declarations that are required by the
+ -- expansion of the accept statement in this case if expansion active.
- E := First_Entity (Entry_Nam);
+ -- In the case of a select alternative of a selective accept,
+ -- the expander references the address declaration even if there
+ -- is no statement list.
+ -- We also need to create the renaming declarations for the local
+ -- variables that will replace references to the formals within
+ -- the accept.
+
+ Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
+ -- Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
+ -- fields on all entry formals (this loop ignores all other entities).
+
+ E := First_Entity (Entry_Nam);
while Present (E) loop
- Set_Not_Source_Assigned (E, True);
+ if Is_Formal (E) then
+ Set_Never_Set_In_Source (E, True);
+ Set_Is_True_Constant (E, False);
+ Set_Current_Value (E, Empty);
+ end if;
+
Next_Entity (E);
end loop;
@@ -396,6 +408,7 @@ package body Sem_Ch9 is
Install_Declarations (Entry_Nam);
Set_Actual_Subtypes (N, Current_Scope);
+
Analyze (Stats);
Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam);
End_Scope;
@@ -418,9 +431,12 @@ package body Sem_Ch9 is
Check_Restriction (Max_Asynchronous_Select_Nesting, N);
Check_Restriction (No_Select_Statements, N);
- Analyze (Triggering_Alternative (N));
+ -- Analyze the statements. We analyze statements in the abortable part
+ -- first, because this is the section that is executed first, and that
+ -- way our remembering of saved values and checks is accurate.
Analyze_Statements (Statements (Abortable_Part (N)));
+ Analyze (Triggering_Alternative (N));
end Analyze_Asynchronous_Select;
------------------------------------
@@ -557,7 +573,65 @@ package body Sem_Ch9 is
then
Entry_Name := E;
Set_Convention (Id, Convention (E));
+ Set_Corresponding_Body (Parent (Entry_Name), Id);
Check_Fully_Conformant (Id, E, N);
+
+ if Ekind (Id) = E_Entry_Family then
+ if not Fully_Conformant_Discrete_Subtypes (
+ Discrete_Subtype_Definition (Parent (E)),
+ Discrete_Subtype_Definition
+ (Entry_Index_Specification (Formals)))
+ then
+ Error_Msg_N
+ ("index not fully conformant with previous declaration",
+ Discrete_Subtype_Definition
+ (Entry_Index_Specification (Formals)));
+
+ else
+ -- The elaboration of the entry body does not recompute
+ -- the bounds of the index, which may have side effects.
+ -- Inherit the bounds from the entry declaration. This
+ -- is critical if the entry has a per-object constraint.
+ -- If a bound is given by a discriminant, it must be
+ -- reanalyzed in order to capture the discriminal of the
+ -- current entry, rather than that of the protected type.
+
+ declare
+ Index_Spec : constant Node_Id :=
+ Entry_Index_Specification (Formals);
+
+ Def : constant Node_Id :=
+ New_Copy_Tree
+ (Discrete_Subtype_Definition (Parent (E)));
+
+ begin
+ if Nkind
+ (Original_Node
+ (Discrete_Subtype_Definition (Index_Spec))) = N_Range
+ then
+ Set_Etype (Def, Empty);
+ Set_Analyzed (Def, False);
+ Set_Discrete_Subtype_Definition (Index_Spec, Def);
+ Set_Analyzed (Low_Bound (Def), False);
+ Set_Analyzed (High_Bound (Def), False);
+
+ if Denotes_Discriminant (Low_Bound (Def)) then
+ Set_Entity (Low_Bound (Def), Empty);
+ end if;
+
+ if Denotes_Discriminant (High_Bound (Def)) then
+ Set_Entity (High_Bound (Def), Empty);
+ end if;
+
+ Analyze (Def);
+ Make_Index (Def, Index_Spec);
+ Set_Etype
+ (Defining_Identifier (Index_Spec), Etype (Def));
+ end if;
+ end;
+ end if;
+ end if;
+
exit;
end if;
@@ -603,7 +677,60 @@ package body Sem_Ch9 is
Analyze (Stats);
end if;
+ -- Check for unreferenced variables etc. Before the Check_References
+ -- call, we transfer Never_Set_In_Source and Referenced flags from
+ -- parameters in the spec to the corresponding entities in the body,
+ -- since we want the warnings on the body entities. Note that we do
+ -- not have to transfer Referenced_As_LHS, since that flag can only
+ -- be set for simple variables.
+
+ -- At the same time, we set the flags on the spec entities to suppress
+ -- any warnings on the spec formals, since we also scan the spec.
+
+ declare
+ E1 : Entity_Id;
+ E2 : Entity_Id;
+
+ begin
+ E1 := First_Entity (Entry_Name);
+ while Present (E1) loop
+ E2 := First_Entity (Id);
+ while Present (E2) loop
+ exit when Chars (E1) = Chars (E2);
+ Next_Entity (E2);
+ end loop;
+
+ -- If no matching body entity, then we already had
+ -- a detected error of some kind, so just forget
+ -- about worrying about these warnings.
+
+ if No (E2) then
+ goto Continue;
+ end if;
+
+ if Ekind (E1) = E_Out_Parameter then
+ Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
+ Set_Never_Set_In_Source (E1, False);
+ end if;
+
+ Set_Referenced (E2, Referenced (E1));
+ Set_Referenced (E1);
+
+ <<Continue>>
+ Next_Entity (E1);
+ end loop;
+
+ Check_References (Id);
+ end;
+
+ -- We still need to check references for the spec, since objects
+ -- declared in the body are chained (in the First_Entity sense) to
+ -- the spec rather than the body in the case of entries.
+
Check_References (Entry_Name);
+
+ -- Process the end label, and terminate the scope
+
Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name);
End_Scope;
@@ -640,7 +767,6 @@ package body Sem_Ch9 is
Process_Formals (Formals, Parent (N));
End_Scope;
end if;
-
end Analyze_Entry_Body_Formal_Part;
------------------------------------
@@ -648,6 +774,8 @@ package body Sem_Ch9 is
------------------------------------
procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
+ Call : constant Node_Id := Entry_Call_Statement (N);
+
begin
Tasking_Used := True;
@@ -655,7 +783,17 @@ package body Sem_Ch9 is
Analyze_List (Pragmas_Before (N));
end if;
- Analyze (Entry_Call_Statement (N));
+ if Nkind (Call) = N_Attribute_Reference then
+
+ -- Possibly a stream attribute, but definitely illegal. Other
+ -- illegalitles, such as procedure calls, are diagnosed after
+ -- resolution.
+
+ Error_Msg_N ("entry call alternative requires an entry call", Call);
+ return;
+ end if;
+
+ Analyze (Call);
if Is_Non_Empty_List (Statements (N)) then
Analyze_Statements (Statements (N));
@@ -667,9 +805,9 @@ package body Sem_Ch9 is
-------------------------------
procedure Analyze_Entry_Declaration (N : Node_Id) is
- Id : Entity_Id := Defining_Identifier (N);
- D_Sdef : Node_Id := Discrete_Subtype_Definition (N);
- Formals : List_Id := Parameter_Specifications (N);
+ Formals : constant List_Id := Parameter_Specifications (N);
+ Id : constant Entity_Id := Defining_Identifier (N);
+ D_Sdef : constant Node_Id := Discrete_Subtype_Definition (N);
begin
Generate_Definition (Id);
@@ -699,7 +837,6 @@ package body Sem_Ch9 is
if Ekind (Id) = E_Entry then
New_Overloaded_Entity (Id);
end if;
-
end Analyze_Entry_Declaration;
---------------------------------------
@@ -717,16 +854,25 @@ package body Sem_Ch9 is
-- be knwown to routines that process entry families.
procedure Analyze_Entry_Index_Specification (N : Node_Id) is
- Iden : constant Node_Id := Defining_Identifier (N);
- Def : constant Node_Id := Discrete_Subtype_Definition (N);
- Loop_Id : Entity_Id :=
+ Iden : constant Node_Id := Defining_Identifier (N);
+ Def : constant Node_Id := Discrete_Subtype_Definition (N);
+ Loop_Id : constant Entity_Id :=
Make_Defining_Identifier (Sloc (N),
Chars => New_Internal_Name ('L'));
begin
Tasking_Used := True;
Analyze (Def);
- Make_Index (Def, N);
+
+ -- There is no elaboration of the entry index specification. Therefore,
+ -- if the index is a range, it is not resolved and expanded, but the
+ -- bounds are inherited from the entry declaration, and reanalyzed.
+ -- See Analyze_Entry_Body.
+
+ if Nkind (Def) /= N_Range then
+ Make_Index (Def, N);
+ end if;
+
Set_Ekind (Loop_Id, E_Loop);
Set_Scope (Loop_Id, Current_Scope);
New_Scope (Loop_Id);
@@ -875,6 +1021,11 @@ package body Sem_Ch9 is
Def_Id : constant Entity_Id := Defining_Identifier (N);
begin
+ if No_Run_Time_Mode then
+ Error_Msg_CRT ("protected type", N);
+ return;
+ end if;
+
Tasking_Used := True;
Check_Restriction (No_Protected_Types, N);
@@ -890,7 +1041,7 @@ package body Sem_Ch9 is
Set_Etype (T, T);
Set_Is_First_Subtype (T, True);
Set_Has_Delayed_Freeze (T, True);
- Set_Girder_Constraint (T, No_Elist);
+ Set_Stored_Constraint (T, No_Elist);
New_Scope (T);
if Present (Discriminant_Specifications (N)) then
@@ -946,7 +1097,6 @@ package body Sem_Ch9 is
Exp_Ch9.Expand_N_Protected_Type_Declaration (N);
Process_Full_View (N, T, Def_Id);
end if;
-
end Analyze_Protected_Type;
---------------------
@@ -997,9 +1147,9 @@ package body Sem_Ch9 is
-- the restrictions of 9.5.4(6).
if Present (Target_Obj) then
- -- Locate containing concurrent unit and determine
- -- enclosing entry body or outermost enclosing accept
- -- statement within the unit.
+
+ -- Locate containing concurrent unit and determine enclosing entry
+ -- body or outermost enclosing accept statement within the unit.
Outer_Ent := Empty;
for S in reverse 0 .. Scope_Stack.Last loop
@@ -1039,7 +1189,6 @@ package body Sem_Ch9 is
Entry_Id := Empty;
while Present (It.Nam) loop
-
if No (First_Formal (It.Nam))
or else Subtype_Conformant (Enclosing, It.Nam)
then
@@ -1107,34 +1256,51 @@ package body Sem_Ch9 is
if not Is_Entry (Entry_Id) then
Error_Msg_N ("expect entry name in requeue statement", Name (N));
elsif Ekind (Entry_Id) = E_Entry_Family
-
and then Nkind (Entry_Name) /= N_Indexed_Component
then
Error_Msg_N ("missing index for entry family component", Name (N));
else
Resolve_Entry (Name (N));
+ Generate_Reference (Entry_Id, Entry_Name);
if Present (First_Formal (Entry_Id)) then
Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
- -- Mark any output parameters as assigned
+ -- Processing for parameters accessed by the requeue
declare
Ent : Entity_Id := First_Formal (Enclosing);
begin
while Present (Ent) loop
- if Ekind (Ent) = E_Out_Parameter then
- Set_Not_Source_Assigned (Ent, False);
+
+ -- For OUT or IN OUT parameter, the effect of the requeue
+ -- is to assign the parameter a value on exit from the
+ -- requeued body, so we can set it as source assigned.
+ -- We also clear the Is_True_Constant indication. We do
+ -- not need to clear Current_Value, since the effect of
+ -- the requeue is to perform an unconditional goto so
+ -- that any further references will not occur anyway.
+
+ if Ekind (Ent) = E_Out_Parameter
+ or else
+ Ekind (Ent) = E_In_Out_Parameter
+ then
+ Set_Never_Set_In_Source (Ent, False);
+ Set_Is_True_Constant (Ent, False);
end if;
+ -- For all parameters, the requeue acts as a reference,
+ -- since the value of the parameter is passed to the
+ -- new entry, so we want to suppress unreferenced warnings.
+
+ Set_Referenced (Ent);
Next_Formal (Ent);
end loop;
end;
end if;
end if;
-
end Analyze_Requeue;
------------------------------
@@ -1153,6 +1319,7 @@ package body Sem_Ch9 is
begin
Check_Restriction (No_Select_Statements, N);
+ Check_Restriction (Max_Select_Alternatives, N);
Tasking_Used := True;
Alt := First (Alts);
@@ -1163,8 +1330,8 @@ package body Sem_Ch9 is
if Nkind (Alt) = N_Delay_Alternative then
if Delay_Present then
- if (Relative_Present /=
- (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement))
+ if Relative_Present /=
+ (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
then
Error_Msg_N
("delay_until and delay_relative alternatives ", Alt);
@@ -1410,6 +1577,17 @@ package body Sem_Ch9 is
return;
end if;
+ if Has_Completion (Spec_Id)
+ and then Present (Corresponding_Body (Parent (Spec_Id)))
+ then
+ if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
+ Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
+
+ else
+ Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
+ end if;
+ end if;
+
Ref_Id := Spec_Id;
Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
Style.Check_Identifier (Body_Id, Spec_Id);
@@ -1444,6 +1622,7 @@ package body Sem_Ch9 is
Analyze (Handled_Statement_Sequence (N));
Check_Completion (Body_Id);
Check_References (Body_Id);
+ Check_References (Spec_Id);
-- Check for entries with no corresponding accept
@@ -1510,7 +1689,6 @@ package body Sem_Ch9 is
begin
Tasking_Used := True;
- Check_Restriction (Max_Tasks, N);
Check_Restriction (No_Tasking, N);
T := Find_Type_Name (N);
Generate_Definition (T);
@@ -1526,7 +1704,7 @@ package body Sem_Ch9 is
Init_Size_Align (T);
Set_Etype (T, T);
Set_Has_Delayed_Freeze (T, True);
- Set_Girder_Constraint (T, No_Elist);
+ Set_Stored_Constraint (T, No_Elist);
New_Scope (T);
if Present (Discriminant_Specifications (N)) then
@@ -1599,7 +1777,8 @@ package body Sem_Ch9 is
------------------------------------
procedure Analyze_Triggering_Alternative (N : Node_Id) is
- Trigger : Node_Id := Triggering_Statement (N);
+ Trigger : constant Node_Id := Triggering_Statement (N);
+
begin
Tasking_Used := True;
@@ -1632,6 +1811,10 @@ package body Sem_Ch9 is
procedure Count (L : List_Id);
-- Count entries in given declaration list
+ -----------
+ -- Count --
+ -----------
+
procedure Count (L : List_Id) is
D : Node_Id;
@@ -1648,9 +1831,13 @@ package body Sem_Ch9 is
Discrete_Subtype_Definition (D);
begin
+ -- If not an entry family, then just one entry
+
if No (DSD) then
Ecount := Ecount + 1;
+ -- If entry family with static bounds, count entries
+
elsif Is_OK_Static_Subtype (Etype (DSD)) then
declare
Lo : constant Uint :=
@@ -1666,7 +1853,9 @@ package body Sem_Ch9 is
end if;
end;
- else
+ -- If entry family with non-static bounds, give error msg
+
+ elsif Restriction_Parameters (R) /= No_Uint then
Error_Msg_N
("static subtype required by Restriction pragma", DSD);
end if;
@@ -1680,10 +1869,11 @@ package body Sem_Ch9 is
-- Start of processing for Check_Max_Entries
begin
- if Restriction_Parameters (R) >= 0 then
- Ecount := Uint_0;
- Count (Visible_Declarations (Def));
- Count (Private_Declarations (Def));
+ Ecount := Uint_0;
+ Count (Visible_Declarations (Def));
+ Count (Private_Declarations (Def));
+
+ if Ecount > 0 then
Check_Restriction (R, Ecount, Def);
end if;
end Check_Max_Entries;
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 29b8e409e21..4c538b0ff40 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.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- --
@@ -54,7 +54,7 @@ package body Sem_Disp is
(Tagged_Type : Entity_Id;
Prev_Op : Entity_Id;
New_Op : Entity_Id);
- -- Replace an implicit dispatching operation with an explicit one.
+ -- Replace an implicit dispatching operation with an explicit one.
-- Prev_Op is an inherited primitive operation which is overridden
-- by the explicit declaration of New_Op.
@@ -145,7 +145,7 @@ package body Sem_Disp is
("operation can be dispatching in only one type", Subp);
end if;
- -- Verify that the restriction in E.2.2 (1) is obeyed.
+ -- Verify that the restriction in E.2.2 (14) is obeyed
elsif Remote
and then Ekind (Etype (Formal)) = E_Anonymous_Access_Type
@@ -274,8 +274,8 @@ package body Sem_Disp is
and then not Is_Abstract (Alias (Func))
and then No (DTC_Entity (Func))
then
- -- private overriding of inherited abstract operation,
- -- call is legal
+ -- Private overriding of inherited abstract operation,
+ -- call is legal.
Set_Entity (Name (N), Alias (Func));
return;
@@ -341,7 +341,7 @@ package body Sem_Disp is
if not Is_Controlling_Actual (Actual) then
null; -- can be anything
- elsif (Is_Dynamically_Tagged (Actual)) then
+ elsif Is_Dynamically_Tagged (Actual) then
null; -- valid parameter
elsif Is_Tag_Indeterminate (Actual) then
@@ -437,8 +437,9 @@ package body Sem_Disp is
-- inherited private subprograms are treated as dispatching, even
-- if the associated tagged type is already frozen.
- Has_Dispatching_Parent := Present (Alias (Subp))
- and then Is_Dispatching_Operation (Alias (Subp));
+ Has_Dispatching_Parent :=
+ Present (Alias (Subp))
+ and then Is_Dispatching_Operation (Alias (Subp));
if No (Tagged_Type) then
return;
@@ -487,7 +488,7 @@ package body Sem_Disp is
then
declare
Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
- Decl_Item : Node_Id := Next (Parent (Tagged_Type));
+ Decl_Item : Node_Id := Next (Parent (Tagged_Type));
begin
-- ??? The checks here for whether the type has been
@@ -537,7 +538,7 @@ package body Sem_Disp is
elsif Is_Frozen (Subp) then
- -- the subprogram body declares a primitive operation.
+ -- The subprogram body declares a primitive operation.
-- if the subprogram is already frozen, we must update
-- its dispatching information explicitly here. The
-- information is taken from the overridden subprogram.
@@ -595,7 +596,7 @@ package body Sem_Disp is
if Present (Old_Subp) then
Check_Subtype_Conformant (Subp, Old_Subp);
Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
-
+ Set_Is_Overriding_Operation (Subp);
else
Add_Dispatching_Operation (Tagged_Type, Subp);
end if;
@@ -612,7 +613,7 @@ package body Sem_Disp is
or else Chars (Subp) = Name_Finalize)
then
declare
- F_Node : Node_Id := Freeze_Node (Tagged_Type);
+ F_Node : constant Node_Id := Freeze_Node (Tagged_Type);
Decl : Node_Id;
Old_P : Entity_Id;
Old_Bod : Node_Id;
@@ -623,19 +624,19 @@ package body Sem_Disp is
Name_Adjust,
Name_Finalize);
- D_Names : constant array (1 .. 3) of Name_Id :=
- (Name_uDeep_Initialize,
- Name_uDeep_Adjust,
- Name_uDeep_Finalize);
+ D_Names : constant array (1 .. 3) of TSS_Name_Type :=
+ (TSS_Deep_Initialize,
+ TSS_Deep_Adjust,
+ TSS_Deep_Finalize);
begin
-- Remove previous controlled function, which was constructed
-- and analyzed when the type was frozen. This requires
- -- removing the body of the redefined primitive, as well as its
- -- specification if needed (there is no spec created for
+ -- removing the body of the redefined primitive, as well as
+ -- its specification if needed (there is no spec created for
-- Deep_Initialize, see exp_ch3.adb). We must also dismantle
- -- the exception information that may have been generated for it
- -- when zero-cost is enabled.
+ -- the exception information that may have been generated for
+ -- it when front end zero-cost tables are enabled.
for J in D_Names'Range loop
Old_P := TSS (Tagged_Type, D_Names (J));
@@ -654,7 +655,7 @@ package body Sem_Disp is
Old_Spec := Corresponding_Spec (Old_Bod);
Set_Has_Completion (Old_Spec, False);
- if Exception_Mechanism = Front_End_ZCX then
+ if Exception_Mechanism = Front_End_ZCX_Exceptions then
Set_Has_Subprogram_Descriptor (Old_Spec, False);
Set_Handler_Records (Old_Spec, No_List);
Set_Is_Eliminated (Old_Spec);
@@ -772,10 +773,9 @@ package body Sem_Disp is
Next_Elmt (Op2);
end loop;
- -- Operation is a new primitive.
+ -- Operation is a new primitive
Append_Elmt (Subp, New_Prim);
-
end Check_Operation_From_Incomplete_Type;
---------------------------------------
@@ -800,6 +800,35 @@ package body Sem_Disp is
-- dispatching attributes here.
if not Is_Dispatching_Operation (Old_Subp) then
+
+ -- If the untagged type has no discriminants, and the full
+ -- view is constrained, there will be a spurious mismatch
+ -- of subtypes on the controlling arguments, because the tagged
+ -- type is the internal base type introduced in the derivation.
+ -- Use the original type to verify conformance, rather than the
+ -- base type.
+
+ if not Comes_From_Source (Tagged_Type)
+ and then Has_Discriminants (Tagged_Type)
+ then
+ declare
+ Formal : Entity_Id;
+ begin
+ Formal := First_Formal (Old_Subp);
+ while Present (Formal) loop
+ if Tagged_Type = Base_Type (Etype (Formal)) then
+ Tagged_Type := Etype (Formal);
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end;
+
+ if Tagged_Type = Base_Type (Etype (Old_Subp)) then
+ Tagged_Type := Etype (Old_Subp);
+ end if;
+ end if;
+
Check_Controlling_Formals (Tagged_Type, Old_Subp);
Set_Is_Dispatching_Operation (Old_Subp, True);
Set_DT_Position (Old_Subp, No_Uint);
@@ -816,6 +845,7 @@ package body Sem_Disp is
Set_Alias (Old_Subp, Alias (Subp));
-- The derived subprogram should inherit the abstractness
+
-- of the parent subprogram (except in the case of a function
-- returning the type). This sets the abstractness properly
-- for cases where a private extension may have inherited
@@ -853,7 +883,11 @@ package body Sem_Disp is
-- Normal case
- elsif Is_Controlling_Actual (N) then
+ elsif Is_Controlling_Actual (N)
+ or else
+ (Nkind (Parent (N)) = N_Qualified_Expression
+ and then Is_Controlling_Actual (Parent (N)))
+ then
Typ := Etype (N);
if Is_Access_Type (Typ) then
@@ -880,7 +914,12 @@ package body Sem_Disp is
end if;
end if;
- if Is_Class_Wide_Type (Typ) then
+ if Is_Class_Wide_Type (Typ)
+ or else
+ (Nkind (Parent (N)) = N_Qualified_Expression
+ and then Is_Access_Type (Etype (N))
+ and then Is_Class_Wide_Type (Designated_Type (Etype (N))))
+ then
return N;
end if;
end if;
@@ -953,6 +992,12 @@ package body Sem_Disp is
if not Has_Controlling_Result (Nam) then
return False;
+ -- An explicit dereference means that the call has already been
+ -- expanded and there is no tag to propagate.
+
+ elsif Nkind (N) = N_Explicit_Dereference then
+ return False;
+
-- If there are no actuals, the call is tag-indeterminate
elsif No (Parameter_Associations (Orig_Node)) then
@@ -992,7 +1037,7 @@ package body Sem_Disp is
Prev_Op : Entity_Id;
New_Op : Entity_Id)
is
- Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
+ Op_Elmt : Elmt_Id := First_Elmt (Primitive_Operations (Tagged_Type));
begin
-- Patch the primitive operation list
diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads
index 6245df244f1..129047b7f8a 100644
--- a/gcc/ada/sem_disp.ads
+++ b/gcc/ada/sem_disp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -45,7 +45,7 @@ package Sem_Disp is
procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id);
-- Add "Subp" to the list of primitive operations of the corresponding type
-- if it has a parameter of this type and is defined at a proper place for
- -- primitive operations. (new primitives are only defined in package spec,
+ -- primitive operations (new primitives are only defined in package spec,
-- overridden operation can be defined in any scope). If Old_Subp is not
-- Empty we are in the overriding case.
diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb
index a94e59c731d..70f96942d1c 100644
--- a/gcc/ada/sem_dist.adb
+++ b/gcc/ada/sem_dist.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -248,7 +248,6 @@ package body Sem_Dist is
procedure Process_Partition_Id (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ety : Entity_Id;
- Nd : Node_Id;
Get_Pt_Id : Node_Id;
Get_Pt_Id_Call : Node_Id;
Prefix_String : String_Id;
@@ -267,8 +266,6 @@ package body Sem_Dist is
Ety := Scope (Ety);
end loop;
- Nd := Enclosing_Lib_Unit_Node (N);
-
-- Retrieve the proper function to call.
if Is_Remote_Call_Interface (Ety) then
@@ -319,7 +316,6 @@ package body Sem_Dist is
Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
Analyze_And_Resolve (N, Typ);
-
end Process_Partition_Id;
----------------------------------
@@ -334,12 +330,9 @@ package body Sem_Dist is
Remote_Subp : Entity_Id;
Tick_Access_Conv_Call : Node_Id;
Remote_Subp_Decl : Node_Id;
- RAS_Decl : Node_Id;
RS_Pkg_Specif : Node_Id;
RS_Pkg_E : Entity_Id;
- RAS_Pkg_E : Entity_Id;
RAS_Type : Entity_Id;
- RAS_Name : Name_Id;
Async_E : Entity_Id;
Subp_Id : Int;
Attribute_Subp : Entity_Id;
@@ -360,7 +353,7 @@ package body Sem_Dist is
-- If the remote type has not been constructed yet, create
-- it and its attributes now.
- Attribute_Subp := TSS (New_Type, Name_uRAS_Access);
+ Attribute_Subp := TSS (New_Type, TSS_RAS_Access);
if No (Attribute_Subp) then
Add_RAST_Features (Parent (New_Type));
@@ -369,11 +362,7 @@ package body Sem_Dist is
RAS_Type := Equivalent_Type (New_Type);
end if;
- RAS_Name := Chars (RAS_Type);
- RAS_Decl := Parent (RAS_Type);
- Attribute_Subp := TSS (RAS_Type, Name_uRAS_Access);
-
- RAS_Pkg_E := Defining_Entity (Parent (RAS_Decl));
+ Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access);
Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
@@ -394,11 +383,6 @@ package body Sem_Dist is
Async_E := Standard_False;
end if;
- -- Right now, we do not call the Name_uAddress_Resolver subprogram,
- -- which means that we end up with a Null_Address value in the ras
- -- field: each dereference of an RAS will go through the PCS, which
- -- is authorized but potentially not very efficient ???
-
Parameter := New_Occurrence_Of (RTE (RE_Null_Address), Loc);
Tick_Access_Conv_Call :=
@@ -413,7 +397,6 @@ package body Sem_Dist is
Rewrite (N, Tick_Access_Conv_Call);
Analyze_And_Resolve (N, RAS_Type);
-
end Process_Remote_AST_Attribute;
------------------------------------
@@ -490,14 +473,13 @@ package body Sem_Dist is
-- The reason we suppress the initialization procedure is that we know
-- that no initialization is required (even if Initialize_Scalars mode
-- is active), and there are order of elaboration problems if we do try
- -- to generate an Init_Proc for this created record type.
+ -- to generate an init proc for this created record type.
Set_Suppress_Init_Proc (Fat_Type);
if Expander_Active then
Add_RAST_Features (Parent (User_Type));
end if;
-
end Process_Remote_AST_Declaration;
-----------------------
@@ -542,14 +524,14 @@ package body Sem_Dist is
return;
end if;
- Deref_Proc := TSS (New_Type, Name_uRAS_Dereference);
+ Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
if not Expander_Active then
return;
elsif No (Deref_Proc) then
Add_RAST_Features (RAS_Decl);
- Deref_Proc := TSS (New_Type, Name_uRAS_Dereference);
+ Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
end if;
if Ekind (Deref_Proc) = E_Function then
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index f440f7d3cc9..9aa4d352025 100644
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-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- --
@@ -30,6 +30,7 @@ with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Expander; use Expander;
with Fname; use Fname;
@@ -316,15 +317,12 @@ package body Sem_Elab is
Unit_Caller : Unit_Number_Type;
Unit_Callee : Unit_Number_Type;
- Cunit_SW : Boolean := False;
- -- Set to suppress warnings for case of external reference where
- -- one of the enclosing scopes has the Suppress_Elaboration_Warnings
- -- flag set. For the internal case, we ignore this flag.
-
Cunit_SC : Boolean := False;
-- Set to suppress dynamic elaboration checks where one of the
- -- enclosing scopes has Suppress_Elaboration_Checks set. For
- -- the internal case, we ignore this flag.
+ -- enclosing scopes has Elaboration_Checks_Suppressed set, or else
+ -- if a pragma Elaborate (_All) applies to that scope, in which case
+ -- warnings on the scope are also suppressed. For the internal case,
+ -- we ignore this flag.
begin
-- Go to parent for derived subprogram, or to original subprogram
@@ -332,7 +330,10 @@ package body Sem_Elab is
Ent := E;
loop
- if Suppress_Elaboration_Warnings (Ent) then
+ if (Suppress_Elaboration_Warnings (Ent)
+ or else Elaboration_Checks_Suppressed (Ent))
+ and then (Inst_Case or else No (Alias (Ent)))
+ then
return;
end if;
@@ -368,11 +369,9 @@ package body Sem_Elab is
E_Scope := Ent;
loop
- if Suppress_Elaboration_Warnings (E_Scope) then
- Cunit_SW := True;
- end if;
-
- if Suppress_Elaboration_Checks (E_Scope) then
+ if Elaboration_Checks_Suppressed (E_Scope)
+ or else Suppress_Elaboration_Warnings (E_Scope)
+ then
Cunit_SC := True;
end if;
@@ -435,9 +434,9 @@ package body Sem_Elab is
return;
end if;
- -- Nothing to do if some scope said to ignore warnings
+ -- Nothing to do if some scope said that no checks were required
- if Cunit_SW then
+ if Cunit_SC then
return;
end if;
@@ -449,10 +448,36 @@ package body Sem_Elab is
return;
end if;
- -- Nothing to do if subprogram with no separate spec
+ -- Nothing to do if subprogram with no separate spec. However,
+ -- a call to Deep_Initialize may result in a call to a user-defined
+ -- Initialize procedure, which imposes a body dependency. This
+ -- happens only if the type is controlled and the Initialize
+ -- procedure is not inherited.
if Body_Acts_As_Spec then
- return;
+ if Is_TSS (Ent, TSS_Deep_Initialize) then
+ declare
+ Typ : Entity_Id;
+ Init : Entity_Id;
+ begin
+ Typ := Etype (Next_Formal (First_Formal (Ent)));
+
+ if not Is_Controlled (Typ) then
+ return;
+ else
+ Init := Find_Prim_Op (Typ, Name_Initialize);
+
+ if Comes_From_Source (Init) then
+ Ent := Init;
+ else
+ return;
+ end if;
+ end if;
+ end;
+
+ else
+ return;
+ end if;
end if;
-- Check cases of internal units
@@ -495,7 +520,9 @@ package body Sem_Elab is
return;
end if;
- Ent := E;
+ if Is_TSS (E, TSS_Deep_Initialize) then
+ Ent := E;
+ end if;
-- If the call is in an instance, and the called entity is not
-- defined in the same instance, then the elaboration issue
@@ -573,6 +600,12 @@ package body Sem_Elab is
exit when E_Scope /= C_Scope;
Ent := Alias (Ent);
E_Scope := Ent;
+
+ -- If no alias, there is a previous error.
+
+ if No (Ent) then
+ return;
+ end if;
end loop;
end if;
@@ -581,18 +614,28 @@ package body Sem_Elab is
end if;
if not Suppress_Elaboration_Warnings (Ent)
+ and then not Elaboration_Checks_Suppressed (Ent)
and then not Suppress_Elaboration_Warnings (E_Scope)
+ and then not Elaboration_Checks_Suppressed (E_Scope)
and then Elab_Warnings
and then Generate_Warnings
then
- Warn_On_Instance := True;
-
if Inst_Case then
Error_Msg_NE
("instantiation of& may raise Program_Error?", N, Ent);
else
- Error_Msg_NE
- ("call to & may raise Program_Error?", N, Ent);
+ if Is_Init_Proc (Entity (Name (N)))
+ and then Comes_From_Source (Ent)
+ then
+ Error_Msg_NE
+ ("implicit call to & in initialization" &
+ " may raise Program_Error?", N, Ent);
+ E_Scope := Scope (Entity (Name (N)));
+
+ else
+ Error_Msg_NE
+ ("call to & may raise Program_Error?", N, Ent);
+ end if;
if Unit_Callee = No_Unit
and then E_Scope = Current_Scope
@@ -614,13 +657,12 @@ package body Sem_Elab is
("\missing pragma Elaborate_All for&?", N, E_Scope);
Error_Msg_Qual_Level := 0;
Output_Calls (N);
- Warn_On_Instance := False;
-- Set flag to prevent further warnings for same unit
-- unless in All_Errors_Mode.
if not All_Errors_Mode and not Dynamic_Elaboration_Checks then
- Set_Suppress_Elaboration_Warnings (E_Scope);
+ Set_Suppress_Elaboration_Warnings (E_Scope, True);
end if;
end if;
@@ -628,10 +670,10 @@ package body Sem_Elab is
if Dynamic_Elaboration_Checks then
if not Elaboration_Checks_Suppressed (Ent)
- and then not Suppress_Elaboration_Checks (E_Scope)
+ and then not Elaboration_Checks_Suppressed (E_Scope)
and then not Cunit_SC
then
- -- Runtime elaboration check required. generate check of the
+ -- Runtime elaboration check required. Generate check of the
-- elaboration Boolean for the unit containing the entity.
Insert_Elab_Check (N,
@@ -647,7 +689,9 @@ package body Sem_Elab is
else
if not Suppress_Elaboration_Warnings (E)
+ and then not Elaboration_Checks_Suppressed (E)
and then not Suppress_Elaboration_Warnings (E_Scope)
+ and then not Elaboration_Checks_Suppressed (E_Scope)
and then Elab_Warnings
and then Generate_Warnings
and then not Inst_Case
@@ -658,7 +702,7 @@ package body Sem_Elab is
end if;
Set_Elaborate_All_Desirable (E_Scope);
- Set_Suppress_Elaboration_Warnings (E_Scope);
+ Set_Suppress_Elaboration_Warnings (E_Scope, True);
end if;
-- Case of entity is in same unit as call or instantiation
@@ -666,7 +710,6 @@ package body Sem_Elab is
elsif not Inter_Unit_Only then
Check_Internal_Call (N, Ent, Outer_Scope, E);
end if;
-
end Check_A_Call;
-----------------------------
@@ -674,7 +717,6 @@ package body Sem_Elab is
-----------------------------
procedure Check_Bad_Instantiation (N : Node_Id) is
- Nam : Node_Id;
Ent : Entity_Id;
begin
@@ -713,7 +755,6 @@ package body Sem_Elab is
return;
end if;
- Nam := Name (N);
Ent := Get_Generic_Entity (N);
-- The case we are interested in is when the generic spec is in the
@@ -873,7 +914,6 @@ package body Sem_Elab is
-- First case, we are in elaboration code
From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
-
if From_Elab_Code then
-- Complain if call that comes from source in preelaborated
@@ -1070,9 +1110,60 @@ package body Sem_Elab is
Inter_Unit_Only => True,
Generate_Warnings => False);
+ -- Otherwise nothing to do
+
else
return;
end if;
+
+ -- A call to an Init_Proc in elaboration code may bring additional
+ -- dependencies, if some of the record components thereof have
+ -- initializations that are function calls that come from source.
+ -- We treat the current node as a call to each of these functions,
+ -- to check their elaboration impact.
+
+ if Is_Init_Proc (Ent)
+ and then From_Elab_Code
+ then
+ Process_Init_Proc : declare
+ Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent);
+
+ function Process (Nod : Node_Id) return Traverse_Result;
+ -- Find subprogram calls within body of init_proc for
+ -- Traverse instantiation below.
+
+ function Process (Nod : Node_Id) return Traverse_Result is
+ Func : Entity_Id;
+
+ begin
+ if (Nkind (Nod) = N_Function_Call
+ or else Nkind (Nod) = N_Procedure_Call_Statement)
+ and then Is_Entity_Name (Name (Nod))
+ then
+ Func := Entity (Name (Nod));
+
+ if Comes_From_Source (Func) then
+ Check_A_Call
+ (N, Func, Standard_Standard, Inter_Unit_Only => True);
+ end if;
+
+ return OK;
+
+ else
+ return OK;
+ end if;
+ end Process;
+
+ procedure Traverse_Body is new Traverse_Proc (Process);
+
+ -- Start of processing for Process_Init_Proc
+
+ begin
+ if Nkind (Unit_Decl) = N_Subprogram_Body then
+ Traverse_Body (Handled_Statement_Sequence (Unit_Decl));
+ end if;
+ end Process_Init_Proc;
+ end if;
end Check_Elab_Call;
----------------------
@@ -1124,8 +1215,7 @@ package body Sem_Elab is
(N : Node_Id;
Outer_Scope : Entity_Id := Empty)
is
- Nam : Node_Id;
- Ent : Entity_Id;
+ Ent : Entity_Id;
begin
-- Check for and deal with bad instantiation case. There is some
@@ -1150,7 +1240,6 @@ package body Sem_Elab is
return;
end if;
- Nam := Name (N);
Ent := Get_Generic_Entity (N);
From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
@@ -1304,6 +1393,10 @@ package body Sem_Elab is
-- Checks for call that needs checking, and if so checks
-- it. Always returns OK, so entire tree is traversed.
+ -------------
+ -- Process --
+ -------------
+
function Process (N : Node_Id) return Traverse_Result is
begin
-- If user has specified that there are no entry calls in elaboration
@@ -1445,13 +1538,10 @@ package body Sem_Elab is
-- Here is the case of calling a subprogram where the body has
-- not yet been encountered, a warning message is needed.
- Warn_On_Instance := True;
-
-- If we have nothing in the call stack, then this is at the
-- outer level, and the ABE is bound to occur.
if Elab_Call.Last = 0 then
-
if Inst_Case then
Error_Msg_NE
("?cannot instantiate& before body seen", N, Orig_Ent);
@@ -1501,6 +1591,14 @@ package body Sem_Elab is
Set_Elaboration_Flag (Sbody, E);
+ -- Kill current value indication. This is necessary
+ -- because the tests of this flag are inserted out of
+ -- sequence and must not pick up bogus indications of
+ -- the wrong constant value. Also, this is never a true
+ -- constant, since one way or another, it gets reset.
+
+ Set_Current_Value (Ent, Empty);
+ Set_Is_True_Constant (Ent, False);
Pop_Scope;
end;
end if;
@@ -1513,7 +1611,9 @@ package body Sem_Elab is
-- Generate the warning
- if not Suppress_Elaboration_Warnings (E) then
+ if not Suppress_Elaboration_Warnings (E)
+ and then not Elaboration_Checks_Suppressed (E)
+ then
if Inst_Case then
Error_Msg_NE
("instantiation of& may occur before body is seen?",
@@ -1530,8 +1630,6 @@ package body Sem_Elab is
end if;
end if;
- Warn_On_Instance := False;
-
-- Set flag to suppress further warnings on same subprogram
-- unless in all errors mode
@@ -1540,20 +1638,20 @@ package body Sem_Elab is
end if;
end Check_Internal_Call_Continue;
- ----------------------------
- -- Check_Task_Activation --
- ----------------------------
+ ---------------------------
+ -- Check_Task_Activation --
+ ---------------------------
procedure Check_Task_Activation (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Inter_Procs : constant Elist_Id := New_Elmt_List;
+ Intra_Procs : constant Elist_Id := New_Elmt_List;
Ent : Entity_Id;
P : Entity_Id;
Task_Scope : Entity_Id;
Cunit_SC : Boolean := False;
Decl : Node_Id;
Elmt : Elmt_Id;
- Inter_Procs : Elist_Id := New_Elmt_List;
- Intra_Procs : Elist_Id := New_Elmt_List;
Enclosing : Entity_Id;
procedure Add_Task_Proc (Typ : Entity_Id);
@@ -1609,7 +1707,7 @@ package body Sem_Elab is
-- Skip this test if errors have occurred, since in this case
-- we can get false indications.
- if Total_Errors_Detected /= 0 then
+ if Serious_Errors_Detected /= 0 then
return;
end if;
@@ -1683,7 +1781,7 @@ package body Sem_Elab is
begin
while Present (Outer) loop
- if Suppress_Elaboration_Checks (Outer) then
+ if Elaboration_Checks_Suppressed (Outer) then
Cunit_SC := True;
end if;
@@ -1739,7 +1837,9 @@ package body Sem_Elab is
if not Is_Compilation_Unit (Task_Scope) then
null;
- elsif Suppress_Elaboration_Warnings (Task_Scope) then
+ elsif Suppress_Elaboration_Warnings (Task_Scope)
+ or else Elaboration_Checks_Suppressed (Task_Scope)
+ then
null;
elsif Dynamic_Elaboration_Checks then
@@ -1759,11 +1859,13 @@ package body Sem_Elab is
end if;
else
- -- Force the binder to elaborate other unit first.
+ -- Force the binder to elaborate other unit first
if not Suppress_Elaboration_Warnings (Ent)
+ and then not Elaboration_Checks_Suppressed (Ent)
and then Elab_Warnings
and then not Suppress_Elaboration_Warnings (Task_Scope)
+ and then not Elaboration_Checks_Suppressed (Task_Scope)
then
Error_Msg_Node_2 := Task_Scope;
Error_Msg_NE ("activation of an instance of task type&" &
@@ -2081,12 +2183,18 @@ package body Sem_Elab is
-- Unfortunately this does not work if the call has a dynamic size,
-- because gigi regards it as a dynamic-sized temporary. If such a call
-- appears in a short-circuit expression, the elaboration check will be
- -- missed (rare enough ???).
+ -- missed (rare enough ???). Otherwise, the code below inserts the check
+ -- at the appropriate place before the call. Same applies in the even
+ -- rarer case the return type has a known size but is unconstrained.
else
if Nkind (N) = N_Function_Call
and then Analyzed (Parent (N))
and then Size_Known_At_Compile_Time (Etype (N))
+ and then
+ (not Has_Discriminants (Etype (N))
+ or else Is_Constrained (Etype (N)))
+
then
declare
Typ : constant Entity_Id := Etype (N);
@@ -2175,7 +2283,7 @@ package body Sem_Elab is
if Is_Generic_Unit (Ent) then
Error_Msg_NE ("\?& instantiated #", N, Ent);
- elsif Chars (Ent) = Name_uInit_Proc then
+ elsif Is_Init_Proc (Ent) then
Error_Msg_N ("\?initialization procedure called #", N);
elsif Is_Printable_Error_Name (Chars (Ent)) then
@@ -2340,9 +2448,17 @@ package body Sem_Elab is
if Nkind (Item) = N_Pragma
and then Get_Pragma_Id (Chars (Item)) = Pragma_Elaborate_All
then
+ if Error_Posted (Item) then
+
+ -- Some previous error on the pragma itself
+
+ return False;
+ end if;
+
Elab_Id :=
Entity (
Expression (First (Pragma_Argument_Associations (Item))));
+
Par := Parent (Unit_Declaration_Node (Elab_Id));
Item2 := First (Context_Items (Par));
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 92bf0a14199..cc6d6f3d79f 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -1,4 +1,4 @@
----------------------
+------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
@@ -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- --
@@ -209,23 +209,42 @@ package body Sem_Eval is
------------------------------
procedure Check_Non_Static_Context (N : Node_Id) is
- T : Entity_Id := Etype (N);
- Checks_On : constant Boolean :=
+ T : constant Entity_Id := Etype (N);
+ Checks_On : constant Boolean :=
not Index_Checks_Suppressed (T)
and not Range_Checks_Suppressed (T);
begin
- -- We need the check only for static expressions not raising CE
- -- We can also ignore cases in which the type is Any_Type
+ -- Ignore cases of non-scalar types or error types
- if not Is_OK_Static_Expression (N)
- or else Etype (N) = Any_Type
- then
+ if T = Any_Type or else not Is_Scalar_Type (T) then
return;
+ end if;
- -- Skip this check for non-scalar expressions
+ -- At this stage we have a scalar type. If we have an expression
+ -- that raises CE, then we already issued a warning or error msg
+ -- so there is nothing more to be done in this routine.
+
+ if Raises_Constraint_Error (N) then
+ return;
+ end if;
+
+ -- Now we have a scalar type which is not marked as raising a
+ -- constraint error exception. The main purpose of this routine
+ -- is to deal with static expressions appearing in a non-static
+ -- context. That means that if we do not have a static expression
+ -- then there is not much to do. The one case that we deal with
+ -- here is that if we have a floating-point value that is out of
+ -- range, then we post a warning that an infinity will result.
+
+ if not Is_Static_Expression (N) then
+ if Is_Floating_Point_Type (T)
+ and then Is_Out_Of_Range (N, Base_Type (T))
+ then
+ Error_Msg_N
+ ("?float value out of range, infinity will be generated", N);
+ end if;
- elsif not Is_Scalar_Type (T) then
return;
end if;
@@ -265,21 +284,16 @@ package body Sem_Eval is
(N, Corresponding_Integer_Value (N) * Small_Value (T));
elsif not UR_Is_Zero (Realval (N)) then
- declare
- RT : constant Entity_Id := Base_Type (T);
- X : constant Ureal := Machine (RT, Realval (N), Round);
- begin
- -- Warn if result of static rounding actually differs from
- -- runtime evaluation, which uses round to even.
+ -- Note: even though RM 4.9(38) specifies biased rounding,
+ -- this has been modified by AI-100 in order to prevent
+ -- confusing differences in rounding between static and
+ -- non-static expressions. AI-100 specifies that the effect
+ -- of such rounding is implementation dependent, and in GNAT
+ -- we round to nearest even to match the run-time behavior.
- if Warn_On_Biased_Rounding and Rounding_Was_Biased then
- Error_Msg_N ("static expression does not round to even"
- & " ('R'M 4.9(38))?", N);
- end if;
-
- Set_Realval (N, X);
- end;
+ Set_Realval
+ (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
end if;
Set_Is_Machine_Number (N);
@@ -361,7 +375,11 @@ package body Sem_Eval is
-- Compile_Time_Compare --
--------------------------
- function Compile_Time_Compare (L, R : Node_Id) return Compare_Result is
+ function Compile_Time_Compare
+ (L, R : Node_Id;
+ Rec : Boolean := False)
+ return Compare_Result
+ is
Ltyp : constant Entity_Id := Etype (L);
Rtyp : constant Entity_Id := Etype (R);
@@ -518,12 +536,47 @@ package body Sem_Eval is
Lf : constant Node_Id := Compare_Fixup (L);
Rf : constant Node_Id := Compare_Fixup (R);
+ function Is_Same_Subscript (L, R : List_Id) return Boolean;
+ -- L, R are the Expressions values from two attribute nodes
+ -- for First or Last attributes. Either may be set to No_List
+ -- if no expressions are present (indicating subscript 1).
+ -- The result is True if both expressions represent the same
+ -- subscript (note that one case is where one subscript is
+ -- missing and the other is explicitly set to 1).
+
+ -----------------------
+ -- Is_Same_Subscript --
+ -----------------------
+
+ function Is_Same_Subscript (L, R : List_Id) return Boolean is
+ begin
+ if L = No_List then
+ if R = No_List then
+ return True;
+ else
+ return Expr_Value (First (R)) = Uint_1;
+ end if;
+
+ else
+ if R = No_List then
+ return Expr_Value (First (L)) = Uint_1;
+ else
+ return Expr_Value (First (L)) = Expr_Value (First (R));
+ end if;
+ end if;
+ end Is_Same_Subscript;
+
+ -- Start of processing for Is_Same_Value
+
begin
-- Values are the same if they are the same identifier and the
- -- identifier refers to a constant object (E_Constant)
+ -- identifier refers to a constant object (E_Constant). This
+ -- does not however apply to Float types, since we may have two
+ -- NaN values and they should never compare equal.
if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier
and then Entity (Lf) = Entity (Rf)
+ and then not Is_Floating_Point_Type (Etype (L))
and then (Ekind (Entity (Lf)) = E_Constant or else
Ekind (Entity (Lf)) = E_In_Parameter or else
Ekind (Entity (Lf)) = E_Loop_Parameter)
@@ -552,6 +605,7 @@ package body Sem_Eval is
and then Is_Entity_Name (Prefix (Lf))
and then Is_Entity_Name (Prefix (Rf))
and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
+ and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
then
return True;
@@ -588,7 +642,9 @@ package body Sem_Eval is
elsif No (Ltyp) or else No (Rtyp) then
return Unknown;
- -- We only attempt compile time analysis for scalar values
+ -- We only attempt compile time analysis for scalar values, and
+ -- not for packed arrays represented as modular types, where the
+ -- semantics of comparison is quite different.
elsif not Is_Scalar_Type (Ltyp)
or else Is_Packed_Array_Type (Ltyp)
@@ -655,22 +711,46 @@ package body Sem_Eval is
-- attempt this optimization with generic types, since the type
-- bounds may not be meaningful in this case.
- if Is_Discrete_Type (Ltyp)
+ -- We are in danger of an infinite recursion here. It does not seem
+ -- useful to go more than one level deep, so the parameter Rec is
+ -- used to protect ourselves against this infinite recursion.
+
+ if not Rec
+ and then Is_Discrete_Type (Ltyp)
+ and then Is_Discrete_Type (Rtyp)
and then not Is_Generic_Type (Ltyp)
and then not Is_Generic_Type (Rtyp)
then
- if Is_Same_Value (R, Type_High_Bound (Ltyp)) then
- return LE;
+ -- See if we can get a decisive check against one operand and
+ -- a bound of the other operand (four possible tests here).
+
+ case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), True) is
+ when LT => return LT;
+ when LE => return LE;
+ when EQ => return LE;
+ when others => null;
+ end case;
- elsif Is_Same_Value (R, Type_Low_Bound (Ltyp)) then
- return GE;
+ case Compile_Time_Compare (L, Type_High_Bound (Rtyp), True) is
+ when GT => return GT;
+ when GE => return GE;
+ when EQ => return GE;
+ when others => null;
+ end case;
- elsif Is_Same_Value (L, Type_High_Bound (Rtyp)) then
- return GE;
+ case Compile_Time_Compare (Type_Low_Bound (Ltyp), R, True) is
+ when GT => return GT;
+ when GE => return GE;
+ when EQ => return GE;
+ when others => null;
+ end case;
- elsif Is_Same_Value (L, Type_Low_Bound (Ltyp)) then
- return LE;
- end if;
+ case Compile_Time_Compare (Type_High_Bound (Ltyp), R, True) is
+ when LT => return LT;
+ when LE => return LE;
+ when EQ => return LE;
+ when others => null;
+ end case;
end if;
-- Next attempt is to decompose the expressions to extract
@@ -735,6 +815,17 @@ package body Sem_Eval is
return False;
end if;
+ -- If this is not a static expression and we are in configurable run
+ -- time mode, then we consider it not known at compile time. This
+ -- avoids anomalies where whether something is permitted with a given
+ -- configurable run-time library depends on how good the compiler is
+ -- at optimizing and knowing that things are constant when they
+ -- are non-static.
+
+ if Configurable_Run_Time_Mode and then not Is_Static_Expression (Op) then
+ return False;
+ end if;
+
-- If we have an entity name, then see if it is the name of a constant
-- and if so, test the corresponding constant value, or the name of
-- an enumeration literal, which is always a constant.
@@ -976,8 +1067,11 @@ package body Sem_Eval is
if Right_Int = 0 then
Apply_Compile_Time_Constraint_Error
- (N, "division by zero", CE_Divide_By_Zero);
+ (N, "division by zero",
+ CE_Divide_By_Zero,
+ Warn => not Stat);
return;
+
else
Result := Left_Int / Right_Int;
end if;
@@ -989,7 +1083,9 @@ package body Sem_Eval is
if Right_Int = 0 then
Apply_Compile_Time_Constraint_Error
- (N, "mod with zero divisor", CE_Divide_By_Zero);
+ (N, "mod with zero divisor",
+ CE_Divide_By_Zero,
+ Warn => not Stat);
return;
else
Result := Left_Int mod Right_Int;
@@ -1002,8 +1098,11 @@ package body Sem_Eval is
if Right_Int = 0 then
Apply_Compile_Time_Constraint_Error
- (N, "rem with zero divisor", CE_Divide_By_Zero);
+ (N, "rem with zero divisor",
+ CE_Divide_By_Zero,
+ Warn => not Stat);
return;
+
else
Result := Left_Int rem Right_Int;
end if;
@@ -1018,7 +1117,7 @@ package body Sem_Eval is
Result := Result mod Modulus (Ltype);
end if;
- Fold_Uint (N, Result);
+ Fold_Uint (N, Result, Stat);
end;
-- Cases where at least one operand is a real. We handle the cases
@@ -1063,11 +1162,9 @@ package body Sem_Eval is
Result := Left_Real / Right_Real;
end if;
- Fold_Ureal (N, Result);
+ Fold_Ureal (N, Result, Stat);
end;
end if;
-
- Set_Is_Static_Expression (N, Stat);
end Eval_Arithmetic_Op;
----------------------------
@@ -1185,7 +1282,7 @@ package body Sem_Eval is
Set_Etype (N, Etype (Right));
end if;
- Fold_Str (N, End_String);
+ Fold_Str (N, End_String, True);
end if;
end;
end Eval_Concatenation;
@@ -1279,13 +1376,35 @@ package body Sem_Eval is
Expr : Node_Id;
begin
+ -- Check for non-static context on index values
+
Expr := First (Expressions (N));
while Present (Expr) loop
Check_Non_Static_Context (Expr);
Next (Expr);
end loop;
- -- See if this is a constant array reference
+ -- If the indexed component appears in an object renaming declaration
+ -- then we do not want to try to evaluate it, since in this case we
+ -- need the identity of the array element.
+
+ if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
+ return;
+
+ -- Similarly if the indexed component appears as the prefix of an
+ -- attribute we don't want to evaluate it, because at least for
+ -- some cases of attributes we need the identify (e.g. Access, Size)
+
+ elsif Nkind (Parent (N)) = N_Attribute_Reference then
+ return;
+ end if;
+
+ -- Note: there are other cases, such as the left side of an assignment,
+ -- or an OUT parameter for a call, where the replacement results in the
+ -- illegal use of a constant, But these cases are illegal in the first
+ -- place, so the replacement, though silly, is harmless.
+
+ -- Now see if this is a constant array reference
if List_Length (Expressions (N)) = 1
and then Is_Entity_Name (Prefix (N))
@@ -1446,7 +1565,7 @@ package body Sem_Eval is
end loop;
end if;
- Fold_Uint (N, From_Bits (Left_Bits, Etype (N)));
+ Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
end;
else
@@ -1454,20 +1573,18 @@ package body Sem_Eval is
if Nkind (N) = N_Op_And then
Fold_Uint (N,
- Test (Is_True (Left_Int) and then Is_True (Right_Int)));
+ Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
elsif Nkind (N) = N_Op_Or then
Fold_Uint (N,
- Test (Is_True (Left_Int) or else Is_True (Right_Int)));
+ Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
else
pragma Assert (Nkind (N) = N_Op_Xor);
Fold_Uint (N,
- Test (Is_True (Left_Int) xor Is_True (Right_Int)));
+ Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
end if;
end if;
-
- Set_Is_Static_Expression (N, Stat);
end;
end Eval_Logical_Op;
@@ -1601,9 +1718,8 @@ package body Sem_Eval is
Result := not Result;
end if;
- Fold_Uint (N, Test (Result));
+ Fold_Uint (N, Test (Result), True);
Warn_On_Known_Condition (N);
-
end Eval_Membership_Op;
------------------------
@@ -1613,7 +1729,7 @@ package body Sem_Eval is
procedure Eval_Named_Integer (N : Node_Id) is
begin
Fold_Uint (N,
- Expr_Value (Expression (Declaration_Node (Entity (N)))));
+ Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
end Eval_Named_Integer;
---------------------
@@ -1623,7 +1739,7 @@ package body Sem_Eval is
procedure Eval_Named_Real (N : Node_Id) is
begin
Fold_Ureal (N,
- Expr_Value_R (Expression (Declaration_Node (Entity (N)))));
+ Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
end Eval_Named_Real;
-------------------
@@ -1667,7 +1783,9 @@ package body Sem_Eval is
if Right_Int < 0 then
Apply_Compile_Time_Constraint_Error
- (N, "integer exponent negative", CE_Range_Check_Failed);
+ (N, "integer exponent negative",
+ CE_Range_Check_Failed,
+ Warn => not Stat);
return;
else
@@ -1681,7 +1799,7 @@ package body Sem_Eval is
Result := Result mod Modulus (Etype (N));
end if;
- Fold_Uint (N, Result);
+ Fold_Uint (N, Result, Stat);
end if;
end;
@@ -1698,19 +1816,19 @@ package body Sem_Eval is
if Right_Int < 0 then
Apply_Compile_Time_Constraint_Error
- (N, "zero ** negative integer", CE_Range_Check_Failed);
+ (N, "zero ** negative integer",
+ CE_Range_Check_Failed,
+ Warn => not Stat);
return;
else
- Fold_Ureal (N, Ureal_0);
+ Fold_Ureal (N, Ureal_0, Stat);
end if;
else
- Fold_Ureal (N, Left_Real ** Right_Int);
+ Fold_Ureal (N, Left_Real ** Right_Int, Stat);
end if;
end;
end if;
-
- Set_Is_Static_Expression (N, Stat);
end;
end Eval_Op_Expon;
@@ -1748,11 +1866,11 @@ package body Sem_Eval is
-- is an arbitrary but consistent definition.
if Is_Modular_Integer_Type (Typ) then
- Fold_Uint (N, Modulus (Typ) - 1 - Rint);
+ Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
else
pragma Assert (Is_Boolean_Type (Typ));
- Fold_Uint (N, Test (not Is_True (Rint)));
+ Fold_Uint (N, Test (not Is_True (Rint)), Stat);
end if;
Set_Is_Static_Expression (N, Stat);
@@ -1811,8 +1929,7 @@ package body Sem_Eval is
-- Fold the result of qualification
if Is_Discrete_Type (Target_Type) then
- Fold_Uint (N, Expr_Value (Operand));
- Set_Is_Static_Expression (N, Stat);
+ Fold_Uint (N, Expr_Value (Operand), Stat);
-- Preserve Print_In_Hex indication
@@ -1821,11 +1938,10 @@ package body Sem_Eval is
end if;
elsif Is_Real_Type (Target_Type) then
- Fold_Ureal (N, Expr_Value_R (Operand));
- Set_Is_Static_Expression (N, Stat);
+ Fold_Ureal (N, Expr_Value_R (Operand), Stat);
else
- Fold_Str (N, Strval (Get_String_Val (Operand)));
+ Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
if not Stat then
Set_Is_Static_Expression (N, False);
@@ -1836,10 +1952,13 @@ package body Sem_Eval is
return;
end if;
+ -- The expression may be foldable but not static
+
+ Set_Is_Static_Expression (N, Stat);
+
if Is_Out_Of_Range (N, Etype (N)) then
Out_Of_Range (N);
end if;
-
end Eval_Qualified_Expression;
-----------------------
@@ -1903,6 +2022,10 @@ package body Sem_Eval is
-- known at compile time length, then Len is set to this
-- (non-negative length). Otherwise Len is set to minus 1.
+ -----------------------
+ -- Get_Static_Length --
+ -----------------------
+
procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
T : Entity_Id;
@@ -1942,8 +2065,7 @@ package body Sem_Eval is
and then Len_R /= Uint_Minus_1
and then Len_L /= Len_R
then
- Fold_Uint (N, Test (Nkind (N) = N_Op_Ne));
- Set_Is_Static_Expression (N, False);
+ Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
Warn_On_Known_Condition (N);
return;
end if;
@@ -1986,7 +2108,7 @@ package body Sem_Eval is
raise Program_Error;
end case;
- Fold_Uint (N, Test (Result));
+ Fold_Uint (N, Test (Result), Stat);
end;
-- Real type case
@@ -2011,11 +2133,10 @@ package body Sem_Eval is
raise Program_Error;
end case;
- Fold_Uint (N, Test (Result));
+ Fold_Uint (N, Test (Result), Stat);
end;
end if;
- Set_Is_Static_Expression (N, Stat);
Warn_On_Known_Condition (N);
end Eval_Relational_Op;
@@ -2114,7 +2235,7 @@ package body Sem_Eval is
if (Kind = N_And_Then and then Is_False (Left_Int))
or else (Kind = N_Or_Else and Is_True (Left_Int))
then
- Fold_Uint (N, Left_Int);
+ Fold_Uint (N, Left_Int, Rstat);
return;
end if;
@@ -2132,9 +2253,8 @@ package body Sem_Eval is
-- Otherwise the result depends on the right operand
- Fold_Uint (N, Expr_Value (Right));
+ Fold_Uint (N, Expr_Value (Right), Rstat);
return;
-
end Eval_Short_Circuit;
----------------
@@ -2244,6 +2364,10 @@ package body Sem_Eval is
-- fixed-point type that is not to be treated as an integer (i.e. the
-- flag Conversion_OK is not set on the conversion node).
+ ------------------------------
+ -- To_Be_Treated_As_Integer --
+ ------------------------------
+
function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
begin
return
@@ -2251,6 +2375,10 @@ package body Sem_Eval is
or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
end To_Be_Treated_As_Integer;
+ ---------------------------
+ -- To_Be_Treated_As_Real --
+ ---------------------------
+
function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
begin
return
@@ -2292,8 +2420,7 @@ package body Sem_Eval is
-- Fold conversion, case of string type. The result is not static.
if Is_String_Type (Target_Type) then
- Fold_Str (N, Strval (Get_String_Val (Operand)));
- Set_Is_Static_Expression (N, False);
+ Fold_Str (N, Strval (Get_String_Val (Operand)), False);
return;
@@ -2322,12 +2449,12 @@ package body Sem_Eval is
if Is_Fixed_Point_Type (Target_Type) then
Fold_Ureal
- (N, UR_From_Uint (Result) * Small_Value (Target_Type));
+ (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
-- Otherwise result is integer literal
else
- Fold_Uint (N, Result);
+ Fold_Uint (N, Result, Stat);
end if;
end;
@@ -2344,17 +2471,15 @@ package body Sem_Eval is
Result := UR_From_Uint (Expr_Value (Operand));
end if;
- Fold_Ureal (N, Result);
+ Fold_Ureal (N, Result, Stat);
end;
-- Enumeration types
else
- Fold_Uint (N, Expr_Value (Operand));
+ Fold_Uint (N, Expr_Value (Operand), Stat);
end if;
- Set_Is_Static_Expression (N, Stat);
-
if Is_Out_Of_Range (N, Etype (N)) then
Out_Of_Range (N);
end if;
@@ -2412,7 +2537,7 @@ package body Sem_Eval is
Result := abs Rint;
end if;
- Fold_Uint (N, Result);
+ Fold_Uint (N, Result, Stat);
end;
-- Fold for real case
@@ -2434,12 +2559,9 @@ package body Sem_Eval is
Result := abs Rreal;
end if;
- Fold_Ureal (N, Result);
+ Fold_Ureal (N, Result, Stat);
end;
end if;
-
- Set_Is_Static_Expression (N, Stat);
-
end Eval_Unary_Op;
-------------------------------
@@ -2691,40 +2813,79 @@ package body Sem_Eval is
end if;
end Expr_Value_S;
+ --------------------------
+ -- Flag_Non_Static_Expr --
+ --------------------------
+
+ procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
+ begin
+ if Error_Posted (Expr) and then not All_Errors_Mode then
+ return;
+ else
+ Error_Msg_F (Msg, Expr);
+ Why_Not_Static (Expr);
+ end if;
+ end Flag_Non_Static_Expr;
+
--------------
-- Fold_Str --
--------------
- procedure Fold_Str (N : Node_Id; Val : String_Id) is
+ procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
begin
Rewrite (N, Make_String_Literal (Loc, Strval => Val));
- Analyze_And_Resolve (N, Typ);
+
+ -- We now have the literal with the right value, both the actual type
+ -- and the expected type of this literal are taken from the expression
+ -- that was evaluated.
+
+ Analyze (N);
+ Set_Is_Static_Expression (N, Static);
+ Set_Etype (N, Typ);
+ Resolve (N);
end Fold_Str;
---------------
-- Fold_Uint --
---------------
- procedure Fold_Uint (N : Node_Id; Val : Uint) is
+ procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
+ Typ : Entity_Id := Etype (N);
+ Ent : Entity_Id;
begin
+ -- If we are folding a named number, retain the entity in the
+ -- literal, for ASIS use.
+
+ if Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_Named_Integer
+ then
+ Ent := Entity (N);
+ else
+ Ent := Empty;
+ end if;
+
+ if Is_Private_Type (Typ) then
+ Typ := Full_View (Typ);
+ end if;
+
-- For a result of type integer, subsitute an N_Integer_Literal node
-- for the result of the compile time evaluation of the expression.
- if Is_Integer_Type (Etype (N)) then
+ if Is_Integer_Type (Typ) then
Rewrite (N, Make_Integer_Literal (Loc, Val));
+ Set_Original_Entity (N, Ent);
-- Otherwise we have an enumeration type, and we substitute either
-- an N_Identifier or N_Character_Literal to represent the enumeration
-- literal corresponding to the given value, which must always be in
-- range, because appropriate tests have already been made for this.
- else pragma Assert (Is_Enumeration_Type (Etype (N)));
+ else pragma Assert (Is_Enumeration_Type (Typ));
Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
end if;
@@ -2733,26 +2894,41 @@ package body Sem_Eval is
-- that was evaluated.
Analyze (N);
+ Set_Is_Static_Expression (N, Static);
Set_Etype (N, Typ);
- Resolve (N, Typ);
+ Resolve (N);
end Fold_Uint;
----------------
-- Fold_Ureal --
----------------
- procedure Fold_Ureal (N : Node_Id; Val : Ureal) is
+ procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
+ Ent : Entity_Id;
begin
+ -- If we are folding a named number, retain the entity in the
+ -- literal, for ASIS use.
+
+ if Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_Named_Real
+ then
+ Ent := Entity (N);
+ else
+ Ent := Empty;
+ end if;
+
Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
- Analyze (N);
+ Set_Original_Entity (N, Ent);
-- Both the actual and expected type comes from the original expression
+ Analyze (N);
+ Set_Is_Static_Expression (N, Static);
Set_Etype (N, Typ);
- Resolve (N, Typ);
+ Resolve (N);
end Fold_Ureal;
---------------
@@ -2794,6 +2970,15 @@ package body Sem_Eval is
end if;
end Get_String_Val;
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ CV_Cache := (others => (Node_High_Bound, Uint_0));
+ end Initialize;
+
--------------------
-- In_Subrange_Of --
--------------------
@@ -3112,7 +3297,7 @@ package body Sem_Eval is
elsif Is_Generic_Type (Typ) then
return False;
- -- Never out of range unless we have a compile time known value.
+ -- Never out of range unless we have a compile time known value
elsif not Compile_Time_Known_Value (N) then
return False;
@@ -3291,9 +3476,9 @@ package body Sem_Eval is
if Is_Static_Expression (N)
and then not In_Instance
+ and then not In_Inlined_Body
and then Ada_95
then
-
if Nkind (Parent (N)) = N_Defining_Identifier
and then Is_Array_Type (Parent (N))
and then Present (Packed_Array_Type (Parent (N)))
@@ -3313,10 +3498,8 @@ package body Sem_Eval is
-- in an instance, or when we have a non-static expression case.
else
- Warn_On_Instance := True;
Apply_Compile_Time_Constraint_Error
(N, "value not in range of}?", CE_Range_Check_Failed);
- Warn_On_Instance := False;
end if;
end Out_Of_Range;
@@ -3409,7 +3592,7 @@ package body Sem_Eval is
-- we???) but we do at least check that both types are
-- real, or both types are not real.
- elsif (Is_Real_Type (T1) /= Is_Real_Type (T2)) then
+ elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
return False;
-- Here we check the bounds
@@ -3832,4 +4015,256 @@ package body Sem_Eval is
end loop;
end To_Bits;
+ --------------------
+ -- Why_Not_Static --
+ --------------------
+
+ procedure Why_Not_Static (Expr : Node_Id) is
+ N : constant Node_Id := Original_Node (Expr);
+ Typ : Entity_Id;
+ E : Entity_Id;
+
+ procedure Why_Not_Static_List (L : List_Id);
+ -- A version that can be called on a list of expressions. Finds
+ -- all non-static violations in any element of the list.
+
+ -------------------------
+ -- Why_Not_Static_List --
+ -------------------------
+
+ procedure Why_Not_Static_List (L : List_Id) is
+ N : Node_Id;
+
+ begin
+ if Is_Non_Empty_List (L) then
+ N := First (L);
+ while Present (N) loop
+ Why_Not_Static (N);
+ Next (N);
+ end loop;
+ end if;
+ end Why_Not_Static_List;
+
+ -- Start of processing for Why_Not_Static
+
+ begin
+ -- If in ACATS mode (debug flag 2), then suppress all these
+ -- messages, this avoids massive updates to the ACATS base line.
+
+ if Debug_Flag_2 then
+ return;
+ end if;
+
+ -- Ignore call on error or empty node
+
+ if No (Expr) or else Nkind (Expr) = N_Error then
+ return;
+ end if;
+
+ -- Preprocessing for sub expressions
+
+ if Nkind (Expr) in N_Subexpr then
+
+ -- Nothing to do if expression is static
+
+ if Is_OK_Static_Expression (Expr) then
+ return;
+ end if;
+
+ -- Test for constraint error raised
+
+ if Raises_Constraint_Error (Expr) then
+ Error_Msg_N
+ ("expression raises exception, cannot be static " &
+ "('R'M 4.9(34))!", N);
+ return;
+ end if;
+
+ -- If no type, then something is pretty wrong, so ignore
+
+ Typ := Etype (Expr);
+
+ if No (Typ) then
+ return;
+ end if;
+
+ -- Type must be scalar or string type
+
+ if not Is_Scalar_Type (Typ)
+ and then not Is_String_Type (Typ)
+ then
+ Error_Msg_N
+ ("static expression must have scalar or string type " &
+ "('R'M 4.9(2))!", N);
+ return;
+ end if;
+ end if;
+
+ -- If we got through those checks, test particular node kind
+
+ case Nkind (N) is
+ when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
+ E := Entity (N);
+
+ if Is_Named_Number (E) then
+ null;
+
+ elsif Ekind (E) = E_Constant then
+ if not Is_Static_Expression (Constant_Value (E)) then
+ Error_Msg_NE
+ ("& is not a static constant ('R'M 4.9(5))!", N, E);
+ end if;
+
+ else
+ Error_Msg_NE
+ ("& is not static constant or named number " &
+ "('R'M 4.9(5))!", N, E);
+ end if;
+
+ when N_Binary_Op | N_And_Then | N_Or_Else | N_In | N_Not_In =>
+ if Nkind (N) in N_Op_Shift then
+ Error_Msg_N
+ ("shift functions are never static ('R'M 4.9(6,18))!", N);
+
+ else
+ Why_Not_Static (Left_Opnd (N));
+ Why_Not_Static (Right_Opnd (N));
+ end if;
+
+ when N_Unary_Op =>
+ Why_Not_Static (Right_Opnd (N));
+
+ when N_Attribute_Reference =>
+ Why_Not_Static_List (Expressions (N));
+
+ E := Etype (Prefix (N));
+
+ if E = Standard_Void_Type then
+ return;
+ end if;
+
+ -- Special case non-scalar'Size since this is a common error
+
+ if Attribute_Name (N) = Name_Size then
+ Error_Msg_N
+ ("size attribute is only static for scalar type " &
+ "('R'M 4.9(7,8))", N);
+
+ -- Flag array cases
+
+ elsif Is_Array_Type (E) then
+ if Attribute_Name (N) /= Name_First
+ and then
+ Attribute_Name (N) /= Name_Last
+ and then
+ Attribute_Name (N) /= Name_Length
+ then
+ Error_Msg_N
+ ("static array attribute must be Length, First, or Last " &
+ "('R'M 4.9(8))!", N);
+
+ -- Since we know the expression is not-static (we already
+ -- tested for this, must mean array is not static).
+
+ else
+ Error_Msg_N
+ ("prefix is non-static array ('R'M 4.9(8))!", Prefix (N));
+ end if;
+
+ return;
+
+ -- Special case generic types, since again this is a common
+ -- source of confusion.
+
+ elsif Is_Generic_Actual_Type (E)
+ or else
+ Is_Generic_Type (E)
+ then
+ Error_Msg_N
+ ("attribute of generic type is never static " &
+ "('R'M 4.9(7,8))!", N);
+
+ elsif Is_Static_Subtype (E) then
+ null;
+
+ elsif Is_Scalar_Type (E) then
+ Error_Msg_N
+ ("prefix type for attribute is not static scalar subtype " &
+ "('R'M 4.9(7))!", N);
+
+ else
+ Error_Msg_N
+ ("static attribute must apply to array/scalar type " &
+ "('R'M 4.9(7,8))!", N);
+ end if;
+
+ when N_String_Literal =>
+ Error_Msg_N
+ ("subtype of string literal is non-static ('R'M 4.9(4))!", N);
+
+ when N_Explicit_Dereference =>
+ Error_Msg_N
+ ("explicit dereference is never static ('R'M 4.9)!", N);
+
+ when N_Function_Call =>
+ Why_Not_Static_List (Parameter_Associations (N));
+ Error_Msg_N ("non-static function call ('R'M 4.9(6,18))!", N);
+
+ when N_Parameter_Association =>
+ Why_Not_Static (Explicit_Actual_Parameter (N));
+
+ when N_Indexed_Component =>
+ Error_Msg_N
+ ("indexed component is never static ('R'M 4.9)!", N);
+
+ when N_Procedure_Call_Statement =>
+ Error_Msg_N
+ ("procedure call is never static ('R'M 4.9)!", N);
+
+ when N_Qualified_Expression =>
+ Why_Not_Static (Expression (N));
+
+ when N_Aggregate | N_Extension_Aggregate =>
+ Error_Msg_N
+ ("an aggregate is never static ('R'M 4.9)!", N);
+
+ when N_Range =>
+ Why_Not_Static (Low_Bound (N));
+ Why_Not_Static (High_Bound (N));
+
+ when N_Range_Constraint =>
+ Why_Not_Static (Range_Expression (N));
+
+ when N_Subtype_Indication =>
+ Why_Not_Static (Constraint (N));
+
+ when N_Selected_Component =>
+ Error_Msg_N
+ ("selected component is never static ('R'M 4.9)!", N);
+
+ when N_Slice =>
+ Error_Msg_N
+ ("slice is never static ('R'M 4.9)!", N);
+
+ when N_Type_Conversion =>
+ Why_Not_Static (Expression (N));
+
+ if not Is_Scalar_Type (Etype (Prefix (N)))
+ or else not Is_Static_Subtype (Etype (Prefix (N)))
+ then
+ Error_Msg_N
+ ("static conversion requires static scalar subtype result " &
+ "('R'M 4.9(9))!", N);
+ end if;
+
+ when N_Unchecked_Type_Conversion =>
+ Error_Msg_N
+ ("unchecked type conversion is never static ('R'M 4.9)!", N);
+
+ when others =>
+ null;
+
+ end case;
+ end Why_Not_Static;
+
end Sem_Eval;
diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads
index 36553167b5e..02718850179 100644
--- a/gcc/ada/sem_eval.ads
+++ b/gcc/ada/sem_eval.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -135,13 +135,29 @@ package Sem_Eval is
type Compare_Result is (LT, LE, EQ, GT, GE, NE, Unknown);
subtype Compare_GE is Compare_Result range EQ .. GE;
subtype Compare_LE is Compare_Result range LT .. EQ;
- function Compile_Time_Compare (L, R : Node_Id) return Compare_Result;
+ function Compile_Time_Compare
+ (L, R : Node_Id;
+ Rec : Boolean := False)
+ return Compare_Result;
-- Given two expression nodes, finds out whether it can be determined
-- at compile time how the runtime values will compare. An Unknown
-- result means that the result of a comparison cannot be determined at
-- compile time, otherwise the returned result indicates the known result
-- of the comparison, given as tightly as possible (i.e. EQ or LT is a
- -- preferred returned value to LE).
+ -- preferred returned value to LE). Rec is a parameter that is set True
+ -- for a recursive call from within Compile_Time_Compare to avoid some
+ -- infinite recursion cases. It should never be set by a client.
+
+ procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id);
+ -- This procedure is called after it has been determined that Expr is
+ -- not static when it is required to be. Msg is the text of a message
+ -- that explains the error. This procedure checks if an error is already
+ -- posted on Expr, if so, it does nothing unless All_Errors_Mode is set
+ -- in which case this flag is ignored. Otherwise the given message is
+ -- posted using Error_Msg_F, and then Why_Not_Static is called on
+ -- Expr to generate additional messages. The string given as Msg
+ -- should end with ! to make it an unconditional message, to ensure
+ -- that if it is posted, the entire set of messages is all posted.
function Is_OK_Static_Expression (N : Node_Id) return Boolean;
-- An OK static expression is one that is static in the RM definition
@@ -275,24 +291,39 @@ package Sem_Eval is
procedure Eval_Unary_Op (N : Node_Id);
procedure Eval_Unchecked_Conversion (N : Node_Id);
- procedure Fold_Str (N : Node_Id; Val : String_Id);
+ procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean);
-- Rewrite N with a new N_String_Literal node as the result of the
-- compile time evaluation of the node N. Val is the resulting string
-- value from the folding operation. The Is_Static_Expression flag is
-- set in the result node. The result is fully analyzed and resolved.
+ -- Static indicates whether the result should be considered static or
+ -- not (True = consider static). The point here is that normally all
+ -- string literals are static, but if this was the result of some
+ -- sequence of evaluation where values were known at compile time
+ -- but not static, then the result is not static.
- procedure Fold_Uint (N : Node_Id; Val : Uint);
+ procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean);
-- Rewrite N with a (N_Integer_Literal, N_Identifier, N_Character_Literal)
-- node as the result of the compile time evaluation of the node N. Val
-- is the result in the integer case and is the position of the literal
-- in the literals list for the enumeration case. Is_Static_Expression
-- is set True in the result node. The result is fully analyzed/resolved.
+ -- Static indicates whether the result should be considered static or
+ -- not (True = consider static). The point here is that normally all
+ -- string literals are static, but if this was the result of some
+ -- sequence of evaluation where values were known at compile time
+ -- but not static, then the result is not static.
- procedure Fold_Ureal (N : Node_Id; Val : Ureal);
+ procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean);
-- Rewrite N with a new N_Real_Literal node as the result of the compile
-- time evaluation of the node N. Val is the resulting real value from
-- the folding operation. The Is_Static_Expression flag is set in the
- -- result node. The result is fully analyzed and result.
+ -- result node. The result is fully analyzed and result. Static
+ -- indicates whether the result should be considered static or not
+ -- (True = consider static). The point here is that normally all
+ -- string literals are static, but if this was the result of some
+ -- sequence of evaluation where values were known at compile time
+ -- but not static, then the result is not static.
function Is_In_Range
(N : Node_Id;
@@ -330,7 +361,7 @@ package Sem_Eval is
-- determined to be outside a compile_time known bound of Typ. A result
-- of False does not mean that the expression is in range, merely that
-- it cannot be determined at compile time that it is out of range. Flags
- -- Int_Real and Fixed_Int are used like in routine Is_In_Range above.
+ -- Int_Real and Fixed_Int are used as in routine Is_In_Range above.
function In_Subrange_Of
(T1 : Entity_Id;
@@ -341,7 +372,7 @@ package Sem_Eval is
-- of values for scalar type T1 are always in the range of scalar type
-- T2. A result of False does not mean that T1 is not in T2's subrange,
-- only that it cannot be determined at compile time. Flag Fixed_Int is
- -- used is like in routine Is_In_Range_Above.
+ -- used as in routine Is_In_Range above.
function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
-- Returns True if it can guarantee that Lo .. Hi is a null range.
@@ -353,6 +384,24 @@ package Sem_Eval is
-- If it cannot (because the value of Lo or Hi is not known at compile
-- time) then it returns False.
+ procedure Why_Not_Static (Expr : Node_Id);
+ -- This procedure may be called after generating an error message that
+ -- complains that something is non-static. If it finds good reasons,
+ -- it generates one or more error messages pointing the appropriate
+ -- offending component of the expression. If no good reasons can be
+ -- figured out, then no messages are generated. The expectation here
+ -- is that the caller has already issued a message complaining that
+ -- the expression is non-static. Note that this message should be
+ -- placed using Error_Msg_F or Error_Msg_FE, so that it will sort
+ -- before any messages placed by this call. Note that it is fine to
+ -- call Why_Not_Static with something that is not an expression, and
+ -- usually this has no effect, but in some cases (N_Parameter_Association
+ -- or N_Range), it makes sense for the internal recursive calls.
+
+ procedure Initialize;
+ -- Initializes the internal data structures. Must be called before
+ -- each separate main program unit (e.g. in a GNSA/ASIS context).
+
private
-- The Eval routines are all marked inline, since they are called once
diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb
index b0a5579ba87..6bac42513c8 100644
--- a/gcc/ada/sem_intr.adb
+++ b/gcc/ada/sem_intr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -117,8 +117,9 @@ package body Sem_Intr is
null;
elsif not Is_Static_Expression (Arg1) then
- Error_Msg_NE
- ("call to & requires static string argument", N, Nam);
+ Error_Msg_FE
+ ("call to & requires static string argument!", N, Nam);
+ Why_Not_Static (Arg1);
elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
Error_Msg_NE
@@ -264,7 +265,6 @@ package body Sem_Intr is
if not Is_Numeric_Type (T1) then
Errint ("intrinsic operator can only apply to numeric types", E, N);
end if;
-
end Check_Intrinsic_Operator;
--------------------------------
@@ -290,6 +290,7 @@ package body Sem_Intr is
if Name_Buffer (1) /= 'O'
and then Nam /= Name_Asm
+ and then Nam /= Name_To_Address
and then Nam not in First_Intrinsic_Name .. Last_Intrinsic_Name
then
Errint ("unrecognized intrinsic subprogram", E, N);
diff --git a/gcc/ada/sem_maps.adb b/gcc/ada/sem_maps.adb
index c0e1e125e87..9656b00960c 100644
--- a/gcc/ada/sem_maps.adb
+++ b/gcc/ada/sem_maps.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-1998 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -284,7 +284,7 @@ package body Sem_Maps is
-------------
function New_Map (Num_Assoc : Int) return Map is
- Header_Size : Header_Index := Find_Header_Size (Num_Assoc);
+ Header_Size : constant Header_Index := Find_Header_Size (Num_Assoc);
Res : Map_Info;
begin
diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb
index fb58aebc232..cf362241fb6 100644
--- a/gcc/ada/sem_mech.adb
+++ b/gcc/ada/sem_mech.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1996-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- --
@@ -170,7 +170,6 @@ package body Sem_Mech is
Bad_Class;
return;
end if;
-
end Set_Mechanism_Value;
-------------------------------
@@ -416,17 +415,19 @@ package body Sem_Mech is
Next_Formal (Formal);
end loop;
- -- Now deal with return type, we always leave the default mechanism
- -- set except for the case of returning a By_Reference type for an
- -- Ada convention, where we force return by reference
+ -- Note: there is nothing we need to do for the return type here.
+ -- We deal with returning by reference in the Ada sense, by use of
+ -- the flag By_Ref, rather than by messing with mechanisms.
- if Ekind (E) = E_Function
- and then Mechanism (E) = Default_Mechanism
- and then not Has_Foreign_Convention (E)
- and then Is_By_Reference_Type (Etype (E))
- then
- Set_Mechanism (E, By_Reference);
- end if;
+ -- A mechanism of Reference for the return means that an extra
+ -- parameter must be provided for the return value (that is the
+ -- DEC meaning of the pragma), and is unrelated to the Ada notion
+ -- of return by reference.
+
+ -- Note: there was originally code here to set the mechanism to
+ -- By_Reference for types that are "by reference" in the Ada sense,
+ -- but, in accordance with the discussion above, this is wrong, and
+ -- the code was removed.
end Set_Mechanisms;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index d8debec4990..57712b06d9c 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,6 +42,8 @@ with Exp_Dist; use Exp_Dist;
with Fname; use Fname;
with Hostparm; use Hostparm;
with Lib; use Lib;
+with Lib.Writ; use Lib.Writ;
+with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -50,6 +52,7 @@ with Output; use Output;
with Restrict; use Restrict;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
@@ -146,9 +149,6 @@ package body Sem_Prag is
-- it is set to Uppercase or Lowercase, then a new string literal with
-- appropriate casing is constructed.
- function Is_Generic_Subprogram (Id : Entity_Id) return Boolean;
- -- Return True if Id is a generic procedure or a function
-
function Get_Base_Subprogram (Def_Id : Entity_Id) return Entity_Id;
-- If Def_Id refers to a renamed subprogram, then the base subprogram
-- (the original one, following the renaming chain) is returned.
@@ -159,15 +159,6 @@ package body Sem_Prag is
-- Elaborate_All pragma. Entity name for unit and its parents is
-- taken from item in previous with_clause that mentions the unit.
- Locking_Policy_Sloc : Source_Ptr := No_Location;
- Queuing_Policy_Sloc : Source_Ptr := No_Location;
- Task_Dispatching_Policy_Sloc : Source_Ptr := No_Location;
- -- These global variables remember the location of a previous locking,
- -- queuing or task dispatching policy pragma, so that appropriate error
- -- messages can be generated for inconsistent pragmas. Note that it is
- -- fine that these are global locations, because the check for consistency
- -- is over the entire program.
-
-------------------------------
-- Adjust_External_Name_Case --
-------------------------------
@@ -542,7 +533,8 @@ package body Sem_Prag is
procedure Set_Exported (E : Entity_Id; Arg : Node_Id);
-- This procedure sets the Is_Exported flag for the given entity,
-- checking that the entity was not previously imported. Arg is
- -- the argument that specified the entity.
+ -- the argument that specified the entity. A check is also made
+ -- for exporting inappropriate entities.
procedure Set_Extended_Import_Export_External_Name
(Internal_Ent : Entity_Id;
@@ -773,10 +765,11 @@ package body Sem_Prag is
-- Finally, we have a real error
else
- Error_Pragma_Arg
- ("argument for pragma% must be a static expression", Argx);
+ Error_Msg_Name_1 := Chars (N);
+ Flag_Non_Static_Expr
+ ("argument for pragma% must be a static expression!", Argx);
+ raise Pragma_Exit;
end if;
-
end Check_Arg_Is_Static_Expression;
---------------------------------
@@ -869,7 +862,7 @@ package body Sem_Prag is
-- Otherwise warn if obviously not main program
elsif Present (Parameter_Specifications (Specification (P)))
- or else not Is_Library_Level_Entity (Defining_Entity (P))
+ or else not Is_Compilation_Unit (Defining_Entity (P))
then
Error_Msg_Name_1 := Chars (N);
Error_Msg_N
@@ -896,13 +889,13 @@ package body Sem_Prag is
end if;
declare
- Prot_Proc : Entity_Id := Empty;
- Prot_Type : Entity_Id;
- Found : Boolean := False;
+ Handler_Proc : Entity_Id := Empty;
+ Proc_Scope : Entity_Id;
+ Found : Boolean := False;
begin
if not Is_Overloaded (Arg1_X) then
- Prot_Proc := Entity (Arg1_X);
+ Handler_Proc := Entity (Arg1_X);
else
declare
@@ -912,14 +905,14 @@ package body Sem_Prag is
begin
Get_First_Interp (Arg1_X, Index, It);
while Present (It.Nam) loop
- Prot_Proc := It.Nam;
+ Handler_Proc := It.Nam;
- if Ekind (Prot_Proc) = E_Procedure
- and then No (First_Formal (Prot_Proc))
+ if Ekind (Handler_Proc) = E_Procedure
+ and then No (First_Formal (Handler_Proc))
then
if not Found then
Found := True;
- Set_Entity (Arg1_X, Prot_Proc);
+ Set_Entity (Arg1_X, Handler_Proc);
Set_Is_Overloaded (Arg1_X, False);
else
Error_Pragma_Arg
@@ -935,38 +928,54 @@ package body Sem_Prag is
("argument of pragma% must be parameterless procedure",
Arg1);
else
- Prot_Proc := Entity (Arg1_X);
+ Handler_Proc := Entity (Arg1_X);
end if;
end;
end if;
- Prot_Type := Scope (Prot_Proc);
+ Proc_Scope := Scope (Handler_Proc);
+
+ -- On AAMP only, a pragma Interrupt_Handler is supported for
+ -- nonprotected parameterless procedures.
+
+ if AAMP_On_Target
+ and then Prag_Id = Pragma_Interrupt_Handler
+ then
+ if Ekind (Handler_Proc) /= E_Procedure then
+ Error_Pragma_Arg
+ ("argument of pragma% must be a procedure", Arg1);
+ end if;
- if Ekind (Prot_Proc) /= E_Procedure
- or else Ekind (Prot_Type) /= E_Protected_Type
+ elsif Ekind (Handler_Proc) /= E_Procedure
+ or else Ekind (Proc_Scope) /= E_Protected_Type
then
Error_Pragma_Arg
- ("argument of pragma% must be protected procedure",
- Arg1);
+ ("argument of pragma% must be protected procedure", Arg1);
+ end if;
+
+ if (not AAMP_On_Target or else Prag_Id = Pragma_Attach_Handler)
+ and then Ekind (Proc_Scope) = E_Protected_Type
+ then
+ if Parent (N) /=
+ Protected_Definition (Parent (Proc_Scope))
+ then
+ Error_Pragma ("pragma% must be in protected definition");
+ end if;
end if;
- if not Is_Library_Level_Entity (Prot_Type) then
+ if not Is_Library_Level_Entity (Proc_Scope)
+ or else (AAMP_On_Target
+ and then not Is_Library_Level_Entity (Handler_Proc))
+ then
Error_Pragma_Arg
- ("pragma% requires library level entity", Arg1);
+ ("pragma% requires library-level entity", Arg1);
end if;
- if Present (First_Formal (Prot_Proc)) then
+ if Present (First_Formal (Handler_Proc)) then
Error_Pragma_Arg
("argument of pragma% must be parameterless procedure",
Arg1);
end if;
-
- if Parent (N) /=
- Protected_Definition (Parent (Prot_Type))
- then
- Error_Pragma ("pragma% must be in protected definition");
- end if;
-
end;
end Check_Interrupt_Or_Attach_Handler;
@@ -1010,7 +1019,6 @@ package body Sem_Prag is
end loop;
Error_Pragma ("pragma% is not in declarative part or package spec");
-
end Check_Is_In_Decl_Part_Or_Package_Spec;
-------------------------
@@ -1073,6 +1081,7 @@ package body Sem_Prag is
-- Note: for convenience in writing this procedure, in addition to
-- the officially (i.e. by spec) allowed argument which is always
-- a constraint, it also allows ranges and discriminant associations.
+ -- Above is not clear ???
procedure Check_Static_Constraint (Constr : Node_Id) is
@@ -1086,8 +1095,8 @@ package body Sem_Prag is
procedure Require_Static (E : Node_Id) is
begin
if not Is_OK_Static_Expression (E) then
- Error_Msg_N
- ("non-static constraint not allowed in Unchecked_Union", E);
+ Flag_Non_Static_Expr
+ ("non-static constraint not allowed in Unchecked_Union!", E);
raise Pragma_Exit;
end if;
end Require_Static;
@@ -1149,7 +1158,6 @@ package body Sem_Prag is
Plist : List_Id;
Parent_Node : Node_Id;
Unit_Name : Entity_Id;
- Valid : Boolean := True;
Unit_Kind : Node_Kind;
Unit_Node : Node_Id;
Sindex : Source_File_Index;
@@ -1157,7 +1165,6 @@ package body Sem_Prag is
begin
if not Is_List_Member (N) then
Pragma_Misplaced;
- Valid := False;
else
Plist := List_Containing (N);
@@ -1285,7 +1292,6 @@ package body Sem_Prag is
end if;
end if;
end if;
-
end Check_Valid_Library_Unit_Pragma;
------------------
@@ -1341,7 +1347,6 @@ package body Sem_Prag is
and then Defining_Entity (Parent (N)) /= Current_Scope
then
return Defining_Entity (Parent (N));
-
else
return Current_Scope;
end if;
@@ -1519,7 +1524,6 @@ package body Sem_Prag is
Next (Item);
end loop;
-
end Is_Before_First_Decl;
-----------------------------
@@ -1564,7 +1568,6 @@ package body Sem_Prag is
else
return False;
end if;
-
end Is_Configuration_Pragma;
----------------------
@@ -1617,9 +1620,16 @@ package body Sem_Prag is
Set_Is_Atomic (Underlying_Type (E));
end if;
- Set_Is_Volatile (E);
+ -- Attribute belongs on the base type. If the
+ -- view of the type is currently private, it also
+ -- belongs on the underlying type.
+
+ Set_Is_Volatile (Base_Type (E));
Set_Is_Volatile (Underlying_Type (E));
+ Set_Treat_As_Volatile (E);
+ Set_Treat_As_Volatile (Underlying_Type (E));
+
elsif K = N_Object_Declaration
or else (K = N_Component_Declaration
and then Original_Record_Component (E) = E)
@@ -1631,6 +1641,17 @@ package body Sem_Prag is
if Prag_Id /= Pragma_Volatile then
Set_Is_Atomic (E);
+ -- If the object declaration has an explicit
+ -- initialization, a temporary may have to be
+ -- created to hold the expression, to insure
+ -- that access to the object remain atomic.
+
+ if Nkind (Parent (E)) = N_Object_Declaration
+ and then Present (Expression (Parent (E)))
+ then
+ Set_Has_Delayed_Freeze (E);
+ end if;
+
-- An interesting improvement here. If an object of type X
-- is declared atomic, and the type X is not atomic, that's
-- a pity, since it may not have appropraite alignment etc.
@@ -1652,6 +1673,7 @@ package body Sem_Prag is
end if;
Set_Is_Volatile (E);
+ Set_Treat_As_Volatile (E);
else
Error_Pragma_Arg
@@ -1762,7 +1784,7 @@ package body Sem_Prag is
-- with a warning in the non-VMS case.
else
- if not OpenVMS_On_Target then
+ if Warn_On_Export_Import and not OpenVMS_On_Target then
Error_Msg_N
("?unrecognized convention name, C assumed",
Expression (Arg1));
@@ -1893,6 +1915,12 @@ package body Sem_Prag is
Comp_Unit := Get_Source_Unit (E);
Set_Convention_From_Pragma (E);
+ -- Treat a pragma Import as an implicit body, for GPS use.
+
+ if Prag_Id = Pragma_Import then
+ Generate_Reference (E, Id, 'b');
+ end if;
+
E1 := E;
loop
E1 := Homonym (E1);
@@ -1904,10 +1932,13 @@ package body Sem_Prag is
if Comp_Unit = Get_Source_Unit (E1) then
Set_Convention_From_Pragma (E1);
+
+ if Prag_Id = Pragma_Import then
+ Generate_Reference (E, Id, 'b');
+ end if;
end if;
end loop;
end if;
-
end Process_Convention;
-----------------------------------------------------
@@ -1925,6 +1956,12 @@ package body Sem_Prag is
begin
GNAT_Pragma;
+
+ if not OpenVMS_On_Target then
+ Error_Pragma
+ ("?pragma% ignored (applies only to Open'V'M'S)");
+ end if;
+
Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
Def_Id := Entity (Arg_Internal);
@@ -1967,7 +2004,6 @@ package body Sem_Prag is
Set_Exception_Code (Def_Id, Code_Val);
end if;
end if;
-
end Process_Extended_Import_Export_Exception_Pragma;
-------------------------------------------------
@@ -2000,7 +2036,6 @@ package body Sem_Prag is
end if;
Check_Arg_Is_Local_Name (Arg_Internal);
-
end Process_Extended_Import_Export_Internal_Arg;
--------------------------------------------------
@@ -2012,7 +2047,7 @@ package body Sem_Prag is
Arg_External : Node_Id;
Arg_Size : Node_Id)
is
- Def_Id : Entity_Id;
+ Def_Id : Entity_Id;
begin
Process_Extended_Import_Export_Internal_Arg (Arg_Internal);
@@ -2049,7 +2084,6 @@ package body Sem_Prag is
-- Export_Object case
if Prag_Id = Pragma_Export_Object then
-
if not Is_Library_Level_Entity (Def_Id) then
Error_Pragma_Arg
("argument for pragma% must be library level entity",
@@ -2066,7 +2100,7 @@ package body Sem_Prag is
Arg_Internal);
end if;
- if Is_Exported (Def_Id) then
+ if Warn_On_Export_Import and then Is_Exported (Def_Id) then
Error_Msg_N
("?duplicate Export_Object pragma", N);
else
@@ -2087,24 +2121,45 @@ package body Sem_Prag is
("cannot import a constant", Arg_Internal);
end if;
- if Has_Discriminants (Etype (Def_Id)) then
+ if Warn_On_Export_Import
+ and then Has_Discriminants (Etype (Def_Id))
+ then
Error_Msg_N
("imported value must be initialized?", Arg_Internal);
end if;
- if Is_Access_Type (Etype (Def_Id)) then
+ if Warn_On_Export_Import
+ and then Is_Access_Type (Etype (Def_Id))
+ then
Error_Pragma_Arg
("cannot import object of an access type?", Arg_Internal);
end if;
- if Is_Imported (Def_Id) then
+ if Warn_On_Export_Import
+ and then Is_Imported (Def_Id)
+ then
Error_Msg_N
("?duplicate Import_Object pragma", N);
+
+ -- Check for explicit initialization present. Note that an
+ -- initialization that generated by the code generator, e.g.
+ -- for an access type, does not count here.
+
+ elsif Present (Expression (Parent (Def_Id)))
+ and then
+ Comes_From_Source
+ (Original_Node (Expression (Parent (Def_Id))))
+ then
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Pragma_Arg
+ ("no initialization allowed for declaration of& #",
+ "\imported entities cannot be initialized ('R'M' 'B.1(24))",
+ Arg1);
else
Set_Imported (Def_Id);
+ Note_Possible_Modification (Arg_Internal);
end if;
end if;
-
end Process_Extended_Import_Export_Object_Pragma;
------------------------------------------------------
@@ -2128,21 +2183,62 @@ package body Sem_Prag is
Match : Boolean;
Dval : Node_Id;
- function Same_Base_Type (Ptype, Formal : Entity_Id) return Boolean;
+ function Same_Base_Type
+ (Ptype : Node_Id;
+ Formal : Entity_Id)
+ return Boolean;
-- Determines if Ptype references the type of Formal. Note that
- -- only the base types need to match according to the spec.
+ -- only the base types need to match according to the spec. Ptype
+ -- here is the argument from the pragma, which is either a type
+ -- name, or an access attribute.
+
+ --------------------
+ -- Same_Base_Type --
+ --------------------
function Same_Base_Type (Ptype, Formal : Entity_Id) return Boolean is
+ Ftyp : constant Entity_Id := Base_Type (Etype (Formal));
+ Pref : Node_Id;
+
begin
- Find_Type (Ptype);
+ -- Case where pragma argument is typ'Access
- if not Is_Entity_Name (Ptype)
- or else Entity (Ptype) = Any_Type
+ if Nkind (Ptype) = N_Attribute_Reference
+ and then Attribute_Name (Ptype) = Name_Access
then
- raise Pragma_Exit;
- end if;
+ Pref := Prefix (Ptype);
+ Find_Type (Pref);
+
+ if not Is_Entity_Name (Pref)
+ or else Entity (Pref) = Any_Type
+ then
+ raise Pragma_Exit;
+ end if;
+
+ -- We have a match if the corresponding argument is of an
+ -- anonymous access type, and its designicated type matches
+ -- the type of the prefix of the access attribute
- return Base_Type (Entity (Ptype)) = Base_Type (Etype (Formal));
+ return Ekind (Ftyp) = E_Anonymous_Access_Type
+ and then Base_Type (Entity (Pref)) =
+ Base_Type (Etype (Designated_Type (Ftyp)));
+
+ -- Case where pragma argument is a type name
+
+ else
+ Find_Type (Ptype);
+
+ if not Is_Entity_Name (Ptype)
+ or else Entity (Ptype) = Any_Type
+ then
+ raise Pragma_Exit;
+ end if;
+
+ -- We have a match if the corresponding argument is of
+ -- the type given in the pragma (comparing base types)
+
+ return Base_Type (Entity (Ptype)) = Ftyp;
+ end if;
end Same_Base_Type;
-- Start of processing for
@@ -2189,6 +2285,13 @@ package body Sem_Prag is
then
Match := False;
+ elsif Etype (Def_Id) /= Standard_Void_Type
+ and then
+ (Chars (N) = Name_Export_Procedure
+ or else Chars (N) = Name_Import_Procedure)
+ then
+ Match := False;
+
-- Test parameter types if given. Note that this parameter
-- has not been analyzed (and must not be, since it is
-- semantic nonsense), so we get it as the parser left it.
@@ -2301,20 +2404,29 @@ package body Sem_Prag is
-- Import pragmas must be be for imported entities
- if (Prag_Id = Pragma_Import_Function
- or else
- Prag_Id = Pragma_Import_Procedure
- or else
- Prag_Id = Pragma_Import_Valued_Procedure)
+ if Prag_Id = Pragma_Import_Function
+ or else
+ Prag_Id = Pragma_Import_Procedure
+ or else
+ Prag_Id = Pragma_Import_Valued_Procedure
then
if not Is_Imported (Ent) then
Error_Pragma
("pragma Import or Interface must precede pragma%");
end if;
- -- For the Export cases, the pragma Export is sufficient to set
- -- the entity as exported, if it is not exported already. We
- -- leave the default Ada convention in this case.
+ -- Here we have the Export case which can set the entity as exported
+
+ -- But does not do so if the specified external name is null,
+ -- since that is taken as a signal in DEC Ada 83 (with which
+ -- we want to be compatible) to request no external name.
+
+ elsif Nkind (Arg_External) = N_String_Literal
+ and then String_Length (Strval (Arg_External)) = 0
+ then
+ null;
+
+ -- In all other cases, set entit as exported
else
Set_Exported (Ent, Arg_Internal);
@@ -2355,7 +2467,6 @@ package body Sem_Prag is
-- nonsense, so we get it in exactly as the parser left it.
if Present (Arg_Mechanism) then
-
declare
Formal : Entity_Id;
Massoc : Node_Id;
@@ -2498,7 +2609,7 @@ package body Sem_Prag is
null;
else
- Error_Msg_NE
+ Error_Msg_FE
("default value for optional formal& is non-static!",
Arg_First_Optional_Parameter, Formal);
end if;
@@ -2563,7 +2674,9 @@ package body Sem_Prag is
then
-- User initialization is not allowed for imported object, but
-- the object declaration may contain a default initialization,
- -- that will be discarded.
+ -- that will be discarded. Note that an explicit initialization
+ -- only counts if it comes from source, otherwise it is simply
+ -- the code generator making an implicit initialization explicit.
if Present (Expression (Parent (Def_Id)))
and then Comes_From_Source (Expression (Parent (Def_Id)))
@@ -2578,6 +2691,18 @@ package body Sem_Prag is
Set_Imported (Def_Id);
Set_Is_Public (Def_Id);
Process_Interface_Name (Def_Id, Arg3, Arg4);
+
+ -- It is not possible to import a constant of an unconstrained
+ -- array type (e.g. string) because there is no simple way to
+ -- write a meaningful subtype for it.
+
+ if Is_Array_Type (Etype (Def_Id))
+ and then not Is_Constrained (Etype (Def_Id))
+ then
+ Error_Msg_NE
+ ("imported constant& must have a constrained subtype",
+ N, Def_Id);
+ end if;
end if;
elsif Is_Subprogram (Def_Id)
@@ -2599,6 +2724,14 @@ package body Sem_Prag is
then
null;
+ -- If it is not a subprogram, it must be in an outer
+ -- scope and pragma does not apply.
+
+ elsif not Is_Subprogram (Def_Id)
+ and then not Is_Generic_Subprogram (Def_Id)
+ then
+ null;
+
-- Verify that the homonym is in the same declarative
-- part (not just the same scope).
@@ -2624,6 +2757,30 @@ package body Sem_Prag is
-- always referenced from another object file.
Set_Is_Public (Def_Id);
+
+ -- Verify that the subprogram does not have a completion
+ -- through a renaming declaration. For other completions
+ -- the pragma appears as a too late representation.
+
+ declare
+ Decl : constant Node_Id := Unit_Declaration_Node (Def_Id);
+ begin
+ if Present (Decl)
+ and then Nkind (Decl) = N_Subprogram_Declaration
+ and then Present (Corresponding_Body (Decl))
+ and then
+ Nkind
+ (Unit_Declaration_Node
+ (Corresponding_Body (Decl))) =
+ N_Subprogram_Renaming_Declaration
+ then
+ Error_Msg_Sloc := Sloc (Def_Id);
+ Error_Msg_NE ("cannot import&#," &
+ " already completed by a renaming",
+ N, Def_Id);
+ end if;
+ end;
+
Set_Has_Completion (Def_Id);
Process_Interface_Name (Def_Id, Arg3, Arg4);
end if;
@@ -2671,7 +2828,6 @@ package body Sem_Prag is
Set_Body_Required (Cunit, False);
end;
end if;
-
end Process_Import_Or_Interface;
--------------------
@@ -2693,18 +2849,54 @@ package body Sem_Prag is
procedure Set_Inline_Flags (Subp : Entity_Id);
-- Sets Is_Inlined and Has_Pragma_Inline flags for Subp
+ function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean;
+ -- Do not set the inline flag if body is available and contains
+ -- exception handlers, to prevent undefined symbols at link time.
+
+ ----------------------------
+ -- Back_End_Cannot_Inline --
+ ----------------------------
+
+ function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is
+ Decl : Node_Id := Unit_Declaration_Node (Subp);
+
+ begin
+ if Nkind (Decl) = N_Subprogram_Body then
+ return
+ Present
+ (Exception_Handlers (Handled_Statement_Sequence (Decl)));
+
+ elsif Nkind (Decl) = N_Subprogram_Declaration
+ and then Present (Corresponding_Body (Decl))
+ then
+ return
+ Present (Exception_Handlers
+ (Handled_Statement_Sequence
+ (Unit_Declaration_Node (Corresponding_Body (Decl)))));
+ else
+ -- If body is not available, assume the best, the check is
+ -- performed again when compiling enclosing package bodies.
+
+ return False;
+ end if;
+ end Back_End_Cannot_Inline;
+
-----------------
-- Make_Inline --
-----------------
procedure Make_Inline (Subp : Entity_Id) is
- Kind : Entity_Kind := Ekind (Subp);
+ Kind : constant Entity_Kind := Ekind (Subp);
Inner_Subp : Entity_Id := Subp;
begin
if Etype (Subp) = Any_Type then
return;
+ elsif Back_End_Cannot_Inline (Subp) then
+ Applies := True; -- Do not treat as an error.
+ return;
+
-- Here we have a candidate for inlining, but we must exclude
-- derived operations. Otherwise we will end up trying to
-- inline a phantom declaration, and the result would be to
@@ -2741,10 +2933,7 @@ package body Sem_Prag is
-- If subprogram is aliased (as for an instance) indicate
-- that the renamed entity is inlined.
- if Kind = E_Procedure
- or else Kind = E_Function
- or else Kind = E_Operator
- then
+ if Is_Subprogram (Subp) then
while Present (Alias (Inner_Subp)) loop
Inner_Subp := Alias (Inner_Subp);
end loop;
@@ -2765,13 +2954,11 @@ package body Sem_Prag is
-- the point of instantiation, to determine whether the
-- body should be generated.
- elsif Kind = E_Generic_Procedure
- or else Kind = E_Generic_Function
- then
+ elsif Is_Generic_Subprogram (Subp) then
Set_Inline_Flags (Subp);
Applies := True;
- -- Literals are by definition inlined.
+ -- Literals are by definition inlined
elsif Kind = E_Enumeration_Literal then
null;
@@ -2842,7 +3029,6 @@ package body Sem_Prag is
Next (Assoc);
end loop;
-
end Process_Inline;
----------------------------
@@ -2877,9 +3063,10 @@ package body Sem_Prag is
for J in 1 .. SL loop
C := Get_String_Char (S, J);
- if not In_Character_Range (C)
- or else Get_Character (C) = ' '
- or else Get_Character (C) = ','
+ if Warn_On_Export_Import
+ and then (not In_Character_Range (C)
+ or else Get_Character (C) = ' '
+ or else Get_Character (C) = ',')
then
Error_Msg_N
("?interface name contains illegal character", SN);
@@ -2999,108 +3186,66 @@ package body Sem_Prag is
-----------------------------------------
procedure Process_Interrupt_Or_Attach_Handler is
- Arg1_X : constant Node_Id := Expression (Arg1);
- Prot_Proc : constant Entity_Id := Entity (Arg1_X);
- Prot_Type : constant Entity_Id := Scope (Prot_Proc);
+ Arg1_X : constant Node_Id := Expression (Arg1);
+ Handler_Proc : constant Entity_Id := Entity (Arg1_X);
+ Proc_Scope : constant Entity_Id := Scope (Handler_Proc);
begin
- Set_Is_Interrupt_Handler (Prot_Proc);
+ Set_Is_Interrupt_Handler (Handler_Proc);
- if Prag_Id = Pragma_Interrupt_Handler
- or Prag_Id = Pragma_Attach_Handler
- then
- Record_Rep_Item (Prot_Type, N);
- end if;
+ -- If the pragma is not associated with a handler procedure
+ -- within a protected type, then it must be for a nonprotected
+ -- procedure for the AAMP target, in which case we don't
+ -- associate a representation item with the procedure's scope.
+ if Ekind (Proc_Scope) = E_Protected_Type then
+ if Prag_Id = Pragma_Interrupt_Handler
+ or Prag_Id = Pragma_Attach_Handler
+ then
+ Record_Rep_Item (Proc_Scope, N);
+ end if;
+ end if;
end Process_Interrupt_Or_Attach_Handler;
---------------------------------
-- Process_Suppress_Unsuppress --
---------------------------------
+ -- Note: this procedure makes entries in the check suppress data
+ -- structures managed by Sem. See spec of package Sem for full
+ -- details on how we handle recording of check suppression.
+
procedure Process_Suppress_Unsuppress (Suppress_Case : Boolean) is
- C : Check_Id;
- E_Id : Node_Id;
- E : Entity_Id;
- Effective : Boolean;
+ C : Check_Id;
+ E_Id : Node_Id;
+ E : Entity_Id;
+
+ In_Package_Spec : constant Boolean :=
+ (Ekind (Current_Scope) = E_Package
+ or else
+ Ekind (Current_Scope) = E_Generic_Package)
+ and then not In_Package_Body (Current_Scope);
procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id);
-- Used to suppress a single check on the given entity
+ --------------------------------
+ -- Suppress_Unsuppress_Echeck --
+ --------------------------------
+
procedure Suppress_Unsuppress_Echeck (E : Entity_Id; C : Check_Id) is
- begin
- -- First set appropriate suppress flags in the entity
-
- case C is
- when Access_Check =>
- Effective := Suppress_Access_Checks (E);
- Set_Suppress_Access_Checks (E, Suppress_Case);
-
- when Accessibility_Check =>
- Effective := Suppress_Accessibility_Checks (E);
- Set_Suppress_Accessibility_Checks (E, Suppress_Case);
-
- when Discriminant_Check =>
- Effective := Suppress_Discriminant_Checks (E);
- Set_Suppress_Discriminant_Checks (E, Suppress_Case);
-
- when Division_Check =>
- Effective := Suppress_Division_Checks (E);
- Set_Suppress_Division_Checks (E, Suppress_Case);
-
- when Elaboration_Check =>
- Effective := Suppress_Elaboration_Checks (E);
- Set_Suppress_Elaboration_Checks (E, Suppress_Case);
-
- when Index_Check =>
- Effective := Suppress_Index_Checks (E);
- Set_Suppress_Index_Checks (E, Suppress_Case);
-
- when Length_Check =>
- Effective := Suppress_Length_Checks (E);
- Set_Suppress_Length_Checks (E, Suppress_Case);
-
- when Overflow_Check =>
- Effective := Suppress_Overflow_Checks (E);
- Set_Suppress_Overflow_Checks (E, Suppress_Case);
-
- when Range_Check =>
- Effective := Suppress_Range_Checks (E);
- Set_Suppress_Range_Checks (E, Suppress_Case);
-
- when Storage_Check =>
- Effective := Suppress_Storage_Checks (E);
- Set_Suppress_Storage_Checks (E, Suppress_Case);
-
- when Tag_Check =>
- Effective := Suppress_Tag_Checks (E);
- Set_Suppress_Tag_Checks (E, Suppress_Case);
-
- when All_Checks =>
- Suppress_Unsuppress_Echeck (E, Access_Check);
- Suppress_Unsuppress_Echeck (E, Accessibility_Check);
- Suppress_Unsuppress_Echeck (E, Discriminant_Check);
- Suppress_Unsuppress_Echeck (E, Division_Check);
- Suppress_Unsuppress_Echeck (E, Elaboration_Check);
- Suppress_Unsuppress_Echeck (E, Index_Check);
- Suppress_Unsuppress_Echeck (E, Length_Check);
- Suppress_Unsuppress_Echeck (E, Overflow_Check);
- Suppress_Unsuppress_Echeck (E, Range_Check);
- Suppress_Unsuppress_Echeck (E, Storage_Check);
- Suppress_Unsuppress_Echeck (E, Tag_Check);
- end case;
+ ESR : constant Entity_Check_Suppress_Record :=
+ (Entity => E,
+ Check => C,
+ Suppress => Suppress_Case);
- -- If the entity is not declared in the current scope, then we
- -- make an entry in the Entity_Suppress table so that the flag
- -- will be removed on exit. This entry is only made if the
- -- suppress did something (i.e. the flag was not already set).
+ begin
+ Set_Checks_May_Be_Suppressed (E);
- if Effective and then Scope (E) /= Current_Scope then
- Entity_Suppress.Increment_Last;
- Entity_Suppress.Table
- (Entity_Suppress.Last).Entity := E;
- Entity_Suppress.Table
- (Entity_Suppress.Last).Check := C;
+ if In_Package_Spec then
+ Global_Entity_Suppress.Append (ESR);
+ else
+ Local_Entity_Suppress.Append (ESR);
end if;
-- If this is a first subtype, and the base type is distinct,
@@ -3137,44 +3282,24 @@ package body Sem_Prag is
end if;
if Arg_Count = 1 then
- case C is
- when Access_Check =>
- Scope_Suppress.Access_Checks := Suppress_Case;
-
- when Accessibility_Check =>
- Scope_Suppress.Accessibility_Checks := Suppress_Case;
-
- when Discriminant_Check =>
- Scope_Suppress.Discriminant_Checks := Suppress_Case;
-
- when Division_Check =>
- Scope_Suppress.Division_Checks := Suppress_Case;
-
- when Elaboration_Check =>
- Scope_Suppress.Elaboration_Checks := Suppress_Case;
-
- when Index_Check =>
- Scope_Suppress.Index_Checks := Suppress_Case;
-
- when Length_Check =>
- Scope_Suppress.Length_Checks := Suppress_Case;
-
- when Overflow_Check =>
- Scope_Suppress.Overflow_Checks := Suppress_Case;
-
- when Range_Check =>
- Scope_Suppress.Range_Checks := Suppress_Case;
- when Storage_Check =>
- Scope_Suppress.Storage_Checks := Suppress_Case;
+ -- Make an entry in the local scope suppress table. This is the
+ -- table that directly shows the current value of the scope
+ -- suppress check for any check id value.
- when Tag_Check =>
- Scope_Suppress.Tag_Checks := Suppress_Case;
+ if C = All_Checks then
+ Scope_Suppress := (others => Suppress_Case);
+ else
+ Scope_Suppress (C) := Suppress_Case;
+ end if;
- when All_Checks =>
- Scope_Suppress := (others => Suppress_Case);
+ -- Also make an entry in the Local_Entity_Suppress table. See
+ -- extended description in the package spec of Sem for details.
- end case;
+ Local_Entity_Suppress.Append
+ ((Entity => Empty,
+ Check => C,
+ Suppress => Suppress_Case));
-- Case of two arguments present, where the check is
-- suppressed for a specified entity (given as the second
@@ -3194,34 +3319,48 @@ package body Sem_Prag is
if E = Any_Id then
return;
- else
- loop
- Suppress_Unsuppress_Echeck (E, C);
+ end if;
- if Is_Generic_Instance (E)
- and then Is_Subprogram (E)
- and then Present (Alias (E))
- then
- Suppress_Unsuppress_Echeck (Alias (E), C);
- end if;
+ -- Enforce RM 11.5(7) which requires that for a pragma that
+ -- appears within a package spec, the named entity must be
+ -- within the package spec. We allow the package name itself
+ -- to be mentioned since that makes sense, although it is not
+ -- strictly allowed by 11.5(7).
- if C = Elaboration_Check and then Suppress_Case then
- Set_Suppress_Elaboration_Warnings (E);
- end if;
+ if In_Package_Spec
+ and then E /= Current_Scope
+ and then Scope (E) /= Current_Scope
+ then
+ Error_Pragma_Arg
+ ("entity in pragma% is not in package spec ('R'M 11.5(7))",
+ Arg2);
+ end if;
- -- If we are within a package specification, the
- -- pragma only applies to homonyms in the same scope.
+ -- Loop through homonyms. As noted below, in the case of a package
+ -- spec, only homonyms within the package spec are considered.
- exit when No (Homonym (E))
- or else (Scope (Homonym (E)) /= Current_Scope
- and then Ekind (Current_Scope) = E_Package
- and then not In_Package_Body (Current_Scope));
+ loop
+ Suppress_Unsuppress_Echeck (E, C);
- E := Homonym (E);
- end loop;
- end if;
- end if;
+ if Is_Generic_Instance (E)
+ and then Is_Subprogram (E)
+ and then Present (Alias (E))
+ then
+ Suppress_Unsuppress_Echeck (Alias (E), C);
+ end if;
+
+ -- Move to next homonym
+ E := Homonym (E);
+ exit when No (E);
+
+ -- If we are within a package specification, the
+ -- pragma only applies to homonyms in the same scope.
+
+ exit when In_Package_Spec
+ and then Scope (E) /= Current_Scope;
+ end loop;
+ end if;
end Process_Suppress_Unsuppress;
------------------
@@ -3241,6 +3380,12 @@ package body Sem_Prag is
Set_Is_Exported (E);
+ -- Generate a reference for entity explicitly, because the
+ -- identifier may be overloaded and name resolution will not
+ -- generate one.
+
+ Generate_Reference (E, Arg);
+
-- Deal with exporting non-library level entity
if not Is_Library_Level_Entity (E) then
@@ -3255,14 +3400,25 @@ package body Sem_Prag is
else
Set_Is_Public (E);
Set_Is_Statically_Allocated (E);
+
+ if Warn_On_Export_Import then
+ Error_Msg_NE
+ ("?& has been made static as a result of Export", Arg, E);
+ Error_Msg_N
+ ("\this usage is non-standard and non-portable", Arg);
+ end if;
end if;
end if;
- if Inside_A_Generic then
+ if Warn_On_Export_Import and then Is_Type (E) then
Error_Msg_NE
- ("all instances of& will have the same external name?", Arg, E);
+ ("exporting a type has no effect?", Arg, E);
end if;
+ if Warn_On_Export_Import and Inside_A_Generic then
+ Error_Msg_NE
+ ("all instances of& will have the same external name?", Arg, E);
+ end if;
end Set_Exported;
----------------------------------------------
@@ -3509,7 +3665,11 @@ package body Sem_Prag is
begin
if not Is_Pragma_Name (Chars (N)) then
- Error_Pragma ("unrecognized pragma%!?");
+ if Warn_On_Unrecognized_Pragma then
+ Error_Pragma ("unrecognized pragma%!?");
+ else
+ raise Pragma_Exit;
+ end if;
else
Prag_Id := Get_Pragma_Id (Chars (N));
end if;
@@ -3675,7 +3835,7 @@ package body Sem_Prag is
Error_Pragma_Arg ("ambiguous argument for pragma%", Exp);
else
- Resolve (Exp, Etype (Exp));
+ Resolve (Exp);
end if;
Next (Arg);
@@ -3912,7 +4072,6 @@ package body Sem_Prag is
else
Error_Pragma_Arg ("inappropriate argument for pragma%", Arg1);
end if;
-
end Asynchronous;
------------
@@ -4006,9 +4165,33 @@ package body Sem_Prag is
Check_Ada_83_Warning;
Check_No_Identifiers;
Check_Arg_Count (2);
- Check_Interrupt_Or_Attach_Handler;
- Analyze_And_Resolve (Expression (Arg2), RTE (RE_Interrupt_Id));
- Process_Interrupt_Or_Attach_Handler;
+
+ if No_Run_Time_Mode then
+ Error_Msg_CRT ("Attach_Handler pragma", N);
+ else
+ Check_Interrupt_Or_Attach_Handler;
+
+ -- The expression that designates the attribute may
+ -- depend on a discriminant, and is therefore a per-
+ -- object expression, to be expanded in the init proc.
+ -- If expansion is enabled, perform semantic checks
+ -- on a copy only.
+
+ if Expander_Active then
+ declare
+ Temp : Node_Id := New_Copy_Tree (Expression (Arg2));
+ begin
+ Set_Parent (Temp, N);
+ Pre_Analyze_And_Resolve (Temp, RTE (RE_Interrupt_ID));
+ end;
+
+ else
+ Analyze (Expression (Arg2));
+ Resolve (Expression (Arg2), RTE (RE_Interrupt_ID));
+ end if;
+
+ Process_Interrupt_Or_Attach_Handler;
+ end if;
--------------------
-- C_Pass_By_Copy --
@@ -4070,6 +4253,55 @@ package body Sem_Prag is
-- Processing for this pragma is shared with Psect_Object
+ --------------------------
+ -- Compile_Time_Warning --
+ --------------------------
+
+ -- pragma Compile_Time_Warning
+ -- (boolean_EXPRESSION, static_string_EXPRESSION);
+
+ when Pragma_Compile_Time_Warning => Compile_Time_Warning : declare
+ Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (2);
+ Check_No_Identifiers;
+ Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+ Analyze_And_Resolve (Arg1x, Standard_Boolean);
+
+ if Compile_Time_Known_Value (Arg1x) then
+ if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
+ String_To_Name_Buffer (Strval (Get_Pragma_Arg (Arg2)));
+ Add_Char_To_Name_Buffer ('?');
+
+ declare
+ Msg : String (1 .. Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
+
+ B : Natural;
+
+ begin
+ -- This loop looks for multiple lines separated by
+ -- ASCII.LF and breaks them into continuation error
+ -- messages marked with the usual back slash.
+
+ B := 1;
+ for S in 2 .. Msg'Length - 1 loop
+ if Msg (S) = ASCII.LF then
+ Msg (S) := '?';
+ Error_Msg_N (Msg (B .. S), Arg1);
+ B := S;
+ Msg (B) := '\';
+ end if;
+ end loop;
+
+ Error_Msg_N (Msg (B .. Msg'Length), Arg1);
+ end;
+ end if;
+ end if;
+ end Compile_Time_Warning;
+
----------------------------
-- Complex_Representation --
----------------------------
@@ -4132,7 +4364,7 @@ package body Sem_Prag is
when Pragma_Component_Alignment => Component_AlignmentP : declare
Args : Args_List (1 .. 2);
- Names : Name_List (1 .. 2) := (
+ Names : constant Name_List (1 .. 2) := (
Name_Form,
Name_Name);
@@ -4364,8 +4596,8 @@ package body Sem_Prag is
-- Since a CPP type has no direct link to its associated tag
-- most tags checks cannot be performed
- Set_Suppress_Tag_Checks (Typ);
- Set_Suppress_Tag_Checks (Class_Wide_Type (Typ));
+ Set_Kill_Tag_Checks (Typ);
+ Set_Kill_Tag_Checks (Class_Wide_Type (Typ));
-- Get rid of the _tag component when there was one.
-- It is only useful for regular tagged types
@@ -4539,9 +4771,10 @@ package body Sem_Prag is
Analyze_And_Resolve (Arg, Any_Integer);
if not Is_Static_Expression (Arg) then
- Error_Pragma_Arg
- ("third argument of pragma% must be a static expression",
+ Flag_Non_Static_Expr
+ ("third argument of pragma CPP_Virtual must be static!",
Arg3);
+ raise Pragma_Exit;
else
V := Expr_Value (Expression (Arg3));
@@ -4651,8 +4884,10 @@ package body Sem_Prag is
Analyze_And_Resolve (Arg, Any_Integer);
if not Is_Static_Expression (Arg) then
- Error_Pragma_Arg
- ("entry count for pragma% must be a static expression", Arg3);
+ Flag_Non_Static_Expr
+ ("entry count for pragma CPP_Vtable must be a static " &
+ "expression!", Arg3);
+ raise Pragma_Exit;
else
V := Expr_Value (Expression (Arg3));
@@ -4664,7 +4899,6 @@ package body Sem_Prag is
Set_DT_Entry_Count (DTC, V);
end if;
end if;
-
end CPP_Vtable;
-----------
@@ -4849,6 +5083,16 @@ package body Sem_Prag is
Next (Arg);
end loop Outer;
+
+ -- Give a warning if operating in static mode with -gnatwl
+ -- (elaboration warnings eanbled) switch set.
+
+ if Elab_Warnings and not Dynamic_Elaboration_Checks then
+ Error_Msg_N
+ ("?use of pragma Elaborate may not be safe", N);
+ Error_Msg_N
+ ("?use pragma Elaborate_All instead if possible", N);
+ end if;
end Elaborate;
-------------------
@@ -4918,6 +5162,7 @@ package body Sem_Prag is
end loop Innr;
if Citem = N then
+ Set_Error_Posted (N);
Error_Pragma_Arg
("argument of pragma% is not with'ed unit", Arg);
end if;
@@ -5009,7 +5254,7 @@ package body Sem_Prag is
when Pragma_Eliminate => Eliminate : declare
Args : Args_List (1 .. 5);
- Names : Name_List (1 .. 5) := (
+ Names : constant Name_List (1 .. 5) := (
Name_Unit_Name,
Name_Entity,
Name_Parameter_Types,
@@ -5049,6 +5294,15 @@ package body Sem_Prag is
Homonym_Number);
end Eliminate;
+ --------------------------
+ -- Explicit_Overriding --
+ --------------------------
+
+ when Pragma_Explicit_Overriding =>
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Count (0);
+ Explicit_Overriding := True;
+
------------
-- Export --
------------
@@ -5089,7 +5343,7 @@ package body Sem_Prag is
when Pragma_Export_Exception => Export_Exception : declare
Args : Args_List (1 .. 4);
- Names : Name_List (1 .. 4) := (
+ Names : constant Name_List (1 .. 4) := (
Name_Internal,
Name_External,
Name_Form,
@@ -5115,7 +5369,6 @@ package body Sem_Prag is
if not Is_VMS_Exception (Entity (Internal)) then
Set_Exported (Entity (Internal), Internal);
end if;
-
end Export_Exception;
---------------------
@@ -5126,13 +5379,39 @@ package body Sem_Prag is
-- [Internal =>] LOCAL_NAME,
-- [, [External =>] EXTERNAL_SYMBOL,]
-- [, [Parameter_Types =>] (PARAMETER_TYPES)]
- -- [, [Result_Type =>] SUBTYPE_MARK]
+ -- [, [Result_Type =>] TYPE_DESIGNATOR]
-- [, [Mechanism =>] MECHANISM]
-- [, [Result_Mechanism =>] MECHANISM_NAME]);
+ -- EXTERNAL_SYMBOL ::=
+ -- IDENTIFIER
+ -- | static_string_EXPRESSION
+
+ -- PARAMETER_TYPES ::=
+ -- null
+ -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
+
+ -- TYPE_DESIGNATOR ::=
+ -- subtype_NAME
+ -- | subtype_Name ' Access
+
+ -- MECHANISM ::=
+ -- MECHANISM_NAME
+ -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
+
+ -- MECHANISM_ASSOCIATION ::=
+ -- [formal_parameter_NAME =>] MECHANISM_NAME
+
+ -- MECHANISM_NAME ::=
+ -- Value
+ -- | Reference
+ -- | Descriptor [([Class =>] CLASS_NAME)]
+
+ -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
+
when Pragma_Export_Function => Export_Function : declare
Args : Args_List (1 .. 6);
- Names : Name_List (1 .. 6) := (
+ Names : constant Name_List (1 .. 6) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
@@ -5168,9 +5447,35 @@ package body Sem_Prag is
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Size =>] EXTERNAL_SYMBOL]);
+ -- EXTERNAL_SYMBOL ::=
+ -- IDENTIFIER
+ -- | static_string_EXPRESSION
+
+ -- PARAMETER_TYPES ::=
+ -- null
+ -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
+
+ -- TYPE_DESIGNATOR ::=
+ -- subtype_NAME
+ -- | subtype_Name ' Access
+
+ -- MECHANISM ::=
+ -- MECHANISM_NAME
+ -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
+
+ -- MECHANISM_ASSOCIATION ::=
+ -- [formal_parameter_NAME =>] MECHANISM_NAME
+
+ -- MECHANISM_NAME ::=
+ -- Value
+ -- | Reference
+ -- | Descriptor [([Class =>] CLASS_NAME)]
+
+ -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
+
when Pragma_Export_Object => Export_Object : declare
Args : Args_List (1 .. 3);
- Names : Name_List (1 .. 3) := (
+ Names : constant Name_List (1 .. 3) := (
Name_Internal,
Name_External,
Name_Size);
@@ -5198,9 +5503,35 @@ package body Sem_Prag is
-- [, [Parameter_Types =>] (PARAMETER_TYPES)]
-- [, [Mechanism =>] MECHANISM]);
+ -- EXTERNAL_SYMBOL ::=
+ -- IDENTIFIER
+ -- | static_string_EXPRESSION
+
+ -- PARAMETER_TYPES ::=
+ -- null
+ -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
+
+ -- TYPE_DESIGNATOR ::=
+ -- subtype_NAME
+ -- | subtype_Name ' Access
+
+ -- MECHANISM ::=
+ -- MECHANISM_NAME
+ -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
+
+ -- MECHANISM_ASSOCIATION ::=
+ -- [formal_parameter_NAME =>] MECHANISM_NAME
+
+ -- MECHANISM_NAME ::=
+ -- Value
+ -- | Reference
+ -- | Descriptor [([Class =>] CLASS_NAME)]
+
+ -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
+
when Pragma_Export_Procedure => Export_Procedure : declare
Args : Args_List (1 .. 4);
- Names : Name_List (1 .. 4) := (
+ Names : constant Name_List (1 .. 4) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
@@ -5221,6 +5552,24 @@ package body Sem_Prag is
Arg_Mechanism => Mechanism);
end Export_Procedure;
+ ------------------
+ -- Export_Value --
+ ------------------
+
+ -- pragma Export_Value (
+ -- [Value =>] static_integer_EXPRESSION,
+ -- [Link_Name =>] static_string_EXPRESSION);
+
+ when Pragma_Export_Value =>
+ GNAT_Pragma;
+ Check_Arg_Count (2);
+
+ Check_Optional_Identifier (Arg1, Name_Value);
+ Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
+
+ Check_Optional_Identifier (Arg2, Name_Link_Name);
+ Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+
-----------------------------
-- Export_Valued_Procedure --
-----------------------------
@@ -5231,10 +5580,36 @@ package body Sem_Prag is
-- [, [Parameter_Types =>] (PARAMETER_TYPES)]
-- [, [Mechanism =>] MECHANISM]);
+ -- EXTERNAL_SYMBOL ::=
+ -- IDENTIFIER
+ -- | static_string_EXPRESSION
+
+ -- PARAMETER_TYPES ::=
+ -- null
+ -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
+
+ -- TYPE_DESIGNATOR ::=
+ -- subtype_NAME
+ -- | subtype_Name ' Access
+
+ -- MECHANISM ::=
+ -- MECHANISM_NAME
+ -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
+
+ -- MECHANISM_ASSOCIATION ::=
+ -- [formal_parameter_NAME =>] MECHANISM_NAME
+
+ -- MECHANISM_NAME ::=
+ -- Value
+ -- | Reference
+ -- | Descriptor [([Class =>] CLASS_NAME)]
+
+ -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
+
when Pragma_Export_Valued_Procedure =>
Export_Valued_Procedure : declare
Args : Args_List (1 .. 4);
- Names : Name_List (1 .. 4) := (
+ Names : constant Name_List (1 .. 4) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
@@ -5286,6 +5661,10 @@ package body Sem_Prag is
else
System_Extend_Pragma_Arg := Arg1;
+
+ if not GNAT_Mode then
+ System_Extend_Unit := Arg1;
+ end if;
end if;
else
Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
@@ -5387,8 +5766,8 @@ package body Sem_Prag is
-- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
when Pragma_Finalize_Storage_Only => Finalize_Storage : declare
- Assoc : Node_Id := Arg1;
- Type_Id : Node_Id := Expression (Assoc);
+ Assoc : constant Node_Id := Arg1;
+ Type_Id : constant Node_Id := Expression (Assoc);
Typ : Entity_Id;
begin
@@ -5551,16 +5930,6 @@ package body Sem_Prag is
Str := Expr_Value_S (Expression (Arg1));
- -- For pragma Ident, preserve DEC compatibility by limiting
- -- the length to 31 characters.
-
- if Prag_Id = Pragma_Ident
- and then String_Length (Strval (Str)) > 31
- then
- Error_Pragma_Arg
- ("argument for pragma% is too long, maximum is 31", Arg1);
- end if;
-
declare
CS : Node_Id;
GP : Node_Id;
@@ -5591,7 +5960,7 @@ package body Sem_Prag is
-- For Comment, we concatenate the string, unless we
-- want to preserve the tree structure for ASIS.
- elsif not Tree_Output then
+ elsif not ASIS_Mode then
Start_String (Strval (CS));
Store_String_Char (' ');
Store_String_Chars (Strval (Str));
@@ -5668,7 +6037,7 @@ package body Sem_Prag is
when Pragma_Import_Exception => Import_Exception : declare
Args : Args_List (1 .. 4);
- Names : Name_List (1 .. 4) := (
+ Names : constant Name_List (1 .. 4) := (
Name_Internal,
Name_External,
Name_Form,
@@ -5711,9 +6080,35 @@ package body Sem_Prag is
-- [, [Result_Mechanism =>] MECHANISM_NAME]
-- [, [First_Optional_Parameter =>] IDENTIFIER]);
+ -- EXTERNAL_SYMBOL ::=
+ -- IDENTIFIER
+ -- | static_string_EXPRESSION
+
+ -- PARAMETER_TYPES ::=
+ -- null
+ -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
+
+ -- TYPE_DESIGNATOR ::=
+ -- subtype_NAME
+ -- | subtype_Name ' Access
+
+ -- MECHANISM ::=
+ -- MECHANISM_NAME
+ -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
+
+ -- MECHANISM_ASSOCIATION ::=
+ -- [formal_parameter_NAME =>] MECHANISM_NAME
+
+ -- MECHANISM_NAME ::=
+ -- Value
+ -- | Reference
+ -- | Descriptor [([Class =>] CLASS_NAME)]
+
+ -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
+
when Pragma_Import_Function => Import_Function : declare
Args : Args_List (1 .. 7);
- Names : Name_List (1 .. 7) := (
+ Names : constant Name_List (1 .. 7) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
@@ -5752,9 +6147,13 @@ package body Sem_Prag is
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Size =>] EXTERNAL_SYMBOL]);
+ -- EXTERNAL_SYMBOL ::=
+ -- IDENTIFIER
+ -- | static_string_EXPRESSION
+
when Pragma_Import_Object => Import_Object : declare
Args : Args_List (1 .. 3);
- Names : Name_List (1 .. 3) := (
+ Names : constant Name_List (1 .. 3) := (
Name_Internal,
Name_External,
Name_Size);
@@ -5783,9 +6182,35 @@ package body Sem_Prag is
-- [, [Mechanism =>] MECHANISM]
-- [, [First_Optional_Parameter =>] IDENTIFIER]);
+ -- EXTERNAL_SYMBOL ::=
+ -- IDENTIFIER
+ -- | static_string_EXPRESSION
+
+ -- PARAMETER_TYPES ::=
+ -- null
+ -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
+
+ -- TYPE_DESIGNATOR ::=
+ -- subtype_NAME
+ -- | subtype_Name ' Access
+
+ -- MECHANISM ::=
+ -- MECHANISM_NAME
+ -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
+
+ -- MECHANISM_ASSOCIATION ::=
+ -- [formal_parameter_NAME =>] MECHANISM_NAME
+
+ -- MECHANISM_NAME ::=
+ -- Value
+ -- | Reference
+ -- | Descriptor [([Class =>] CLASS_NAME)]
+
+ -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
+
when Pragma_Import_Procedure => Import_Procedure : declare
Args : Args_List (1 .. 5);
- Names : Name_List (1 .. 5) := (
+ Names : constant Name_List (1 .. 5) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
@@ -5820,10 +6245,36 @@ package body Sem_Prag is
-- [, [Mechanism =>] MECHANISM]
-- [, [First_Optional_Parameter =>] IDENTIFIER]);
+ -- EXTERNAL_SYMBOL ::=
+ -- IDENTIFIER
+ -- | static_string_EXPRESSION
+
+ -- PARAMETER_TYPES ::=
+ -- null
+ -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
+
+ -- TYPE_DESIGNATOR ::=
+ -- subtype_NAME
+ -- | subtype_Name ' Access
+
+ -- MECHANISM ::=
+ -- MECHANISM_NAME
+ -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
+
+ -- MECHANISM_ASSOCIATION ::=
+ -- [formal_parameter_NAME =>] MECHANISM_NAME
+
+ -- MECHANISM_NAME ::=
+ -- Value
+ -- | Reference
+ -- | Descriptor [([Class =>] CLASS_NAME)]
+
+ -- CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
+
when Pragma_Import_Valued_Procedure =>
Import_Valued_Procedure : declare
Args : Args_List (1 .. 5);
- Names : Name_List (1 .. 5) := (
+ Names : constant Name_List (1 .. 5) := (
Name_Internal,
Name_External,
Name_Parameter_Types,
@@ -5857,8 +6308,12 @@ package body Sem_Prag is
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
- Init_Or_Norm_Scalars := True;
- Initialize_Scalars := True;
+ Check_Restriction (No_Initialize_Scalars, N);
+
+ if not Restrictions (No_Initialize_Scalars) then
+ Init_Or_Norm_Scalars := True;
+ Initialize_Scalars := True;
+ end if;
------------
-- Inline --
@@ -5873,14 +6328,16 @@ package body Sem_Prag is
if Inline_Active then
Process_Inline (True);
- -- Pragma is active in a predefined file in no run time mode
+ -- Pragma is active in a predefined file in config run time mode
- elsif No_Run_Time
+ elsif Configurable_Run_Time_Mode
and then
Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
then
Process_Inline (True);
+ -- Otherwise inlining is not active
+
else
Process_Inline (False);
end if;
@@ -6058,8 +6515,13 @@ package body Sem_Prag is
Check_Ada_83_Warning;
Check_Arg_Count (1);
Check_No_Identifiers;
- Check_Interrupt_Or_Attach_Handler;
- Process_Interrupt_Or_Attach_Handler;
+
+ if No_Run_Time_Mode then
+ Error_Msg_CRT ("Interrupt_Handler pragma", N);
+ else
+ Check_Interrupt_Or_Attach_Handler;
+ Process_Interrupt_Or_Attach_Handler;
+ end if;
------------------------
-- Interrupt_Priority --
@@ -6079,13 +6541,11 @@ package body Sem_Prag is
Check_Arg_Count (1);
Check_No_Identifiers;
- -- Set In_Default_Expression for per-object case???
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
- Analyze_And_Resolve (Arg, Standard_Integer);
- if Expander_Active then
- Rewrite (Arg,
- Convert_To (RTE (RE_Interrupt_Priority), Arg));
- end if;
+ Analyze_Per_Use_Expression (Arg, RTE (RE_Interrupt_Priority));
end if;
if Nkind (P) /= N_Task_Definition
@@ -6103,6 +6563,134 @@ package body Sem_Prag is
end if;
end Interrupt_Priority;
+ ---------------------
+ -- Interrupt_State --
+ ---------------------
+
+ -- pragma Interrupt_State (
+ -- [Name =>] INTERRUPT_ID,
+ -- [State =>] INTERRUPT_STATE);
+
+ -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
+ -- INTERRUPT_STATE => System | Runtime | User
+
+ -- Note: if the interrupt id is given as an identifier, then
+ -- it must be one of the identifiers in Ada.Interrupts.Names.
+ -- Otherwise it is given as a static integer expression which
+ -- must be in the range of Ada.Interrupts.Interrupt_ID.
+
+ when Pragma_Interrupt_State => Interrupt_State : declare
+
+ Int_Id : constant Entity_Id := RTE (RE_Interrupt_ID);
+ -- This is the entity Ada.Interrupts.Interrupt_ID;
+
+ State_Type : Character;
+ -- Set to 's'/'r'/'u' for System/Runtime/User
+
+ IST_Num : Pos;
+ -- Index to entry in Interrupt_States table
+
+ Int_Val : Uint;
+ -- Value of interrupt
+
+ Arg1X : constant Node_Id := Get_Pragma_Arg (Arg1);
+ -- The first argument to the pragma
+
+ Int_Ent : Entity_Id;
+ -- Interrupt entity in Ada.Interrupts.Names
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (2);
+
+ Check_Optional_Identifier (Arg1, Name_Name);
+ Check_Optional_Identifier (Arg2, "state");
+ Check_Arg_Is_Identifier (Arg2);
+
+ -- First argument is identifier
+
+ if Nkind (Arg1X) = N_Identifier then
+
+ -- Search list of names in Ada.Interrupts.Names
+
+ Int_Ent := First_Entity (RTE (RE_Names));
+ loop
+ if No (Int_Ent) then
+ Error_Pragma_Arg ("invalid interrupt name", Arg1);
+
+ elsif Chars (Int_Ent) = Chars (Arg1X) then
+ Int_Val := Expr_Value (Constant_Value (Int_Ent));
+ exit;
+ end if;
+
+ Next_Entity (Int_Ent);
+ end loop;
+
+ -- First argument is not an identifier, so it must be a
+ -- static expression of type Ada.Interrupts.Interrupt_ID.
+
+ else
+ Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
+ Int_Val := Expr_Value (Arg1X);
+
+ if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
+ or else
+ Int_Val > Expr_Value (Type_High_Bound (Int_Id))
+ then
+ Error_Pragma_Arg
+ ("value not in range of type " &
+ """Ada.Interrupts.Interrupt_'I'D""", Arg1);
+ end if;
+ end if;
+
+ -- Check OK state
+
+ case Chars (Get_Pragma_Arg (Arg2)) is
+ when Name_Runtime => State_Type := 'r';
+ when Name_System => State_Type := 's';
+ when Name_User => State_Type := 'u';
+
+ when others =>
+ Error_Pragma_Arg ("invalid interrupt state", Arg2);
+ end case;
+
+ -- Check if entry is already stored
+
+ IST_Num := Interrupt_States.First;
+ loop
+ -- If entry not found, add it
+
+ if IST_Num > Interrupt_States.Last then
+ Interrupt_States.Append
+ ((Interrupt_Number => UI_To_Int (Int_Val),
+ Interrupt_State => State_Type,
+ Pragma_Loc => Loc));
+ exit;
+
+ -- Case of entry for the same entry
+
+ elsif Int_Val = Interrupt_States.Table (IST_Num).
+ Interrupt_Number
+ then
+ -- If state matches, done, no need to make redundant entry
+
+ exit when
+ State_Type = Interrupt_States.Table (IST_Num).
+ Interrupt_State;
+
+ -- Otherwise if state does not match, error
+
+ Error_Msg_Sloc :=
+ Interrupt_States.Table (IST_Num).Pragma_Loc;
+ Error_Pragma_Arg
+ ("state conflicts with that given at #", Arg2);
+ exit;
+ end if;
+
+ IST_Num := IST_Num + 1;
+ end loop;
+ end Interrupt_State;
+
----------------------
-- Java_Constructor --
----------------------
@@ -6217,6 +6805,38 @@ package body Sem_Prag is
end if;
end Java_Interface;
+ ----------------
+ -- Keep_Names --
+ ----------------
+
+ -- pragma Keep_Names ([On => ] local_NAME);
+
+ when Pragma_Keep_Names => Keep_Names : declare
+ Arg : Node_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Optional_Identifier (Arg1, Name_On);
+ Check_Arg_Is_Local_Name (Arg1);
+
+ Arg := Expression (Arg1);
+ Analyze (Arg);
+
+ if Etype (Arg) = Any_Type then
+ return;
+ end if;
+
+ if not Is_Entity_Name (Arg)
+ or else Ekind (Entity (Arg)) /= E_Enumeration_Type
+ then
+ Error_Pragma_Arg
+ ("pragma% requires a local enumeration type", Arg1);
+ end if;
+
+ Set_Discard_Names (Entity (Arg), False);
+ end Keep_Names;
+
-------------
-- License --
-------------
@@ -6287,9 +6907,8 @@ package body Sem_Prag is
C : constant Char_Code := Get_Char_Code (' ');
S : constant String_Id :=
Strval (Expr_Value_S (Expression (Arg)));
-
+ L : constant Nat := String_Length (S);
F : Nat := 1;
- L : Nat := String_Length (S);
procedure Skip_Spaces;
-- Advance F past any spaces
@@ -6456,9 +7075,16 @@ package body Sem_Prag is
then
Error_Msg_Sloc := Locking_Policy_Sloc;
Error_Pragma ("locking policy incompatible with policy#");
+
+ -- Set new policy, but always preserve System_Location since
+ -- we like the error message with the run time name.
+
else
Locking_Policy := LP;
- Locking_Policy_Sloc := Loc;
+
+ if Locking_Policy_Sloc /= System_Location then
+ Locking_Policy_Sloc := Loc;
+ end if;
end if;
end;
@@ -6563,7 +7189,7 @@ package body Sem_Prag is
when Pragma_Main => Main : declare
Args : Args_List (1 .. 3);
- Names : Name_List (1 .. 3) := (
+ Names : constant Name_List (1 .. 3) := (
Name_Stack_Size,
Name_Task_Stack_Size_Default,
Name_Time_Slicing_Enabled);
@@ -6610,7 +7236,7 @@ package body Sem_Prag is
when Pragma_Main_Storage => Main_Storage : declare
Args : Args_List (1 .. 2);
- Names : Name_List (1 .. 2) := (
+ Names : constant Name_List (1 .. 2) := (
Name_Working_Storage,
Name_Top_Guard);
@@ -6662,7 +7288,7 @@ package body Sem_Prag is
-- pragma No_Return (procedure_LOCAL_NAME);
- when Pragma_No_Return => declare
+ when Pragma_No_Return => No_Return : declare
Id : Node_Id;
E : Entity_Id;
Found : Boolean;
@@ -6702,7 +7328,32 @@ package body Sem_Prag is
if not Found then
Error_Pragma ("no procedures found for pragma%");
end if;
- end;
+ end No_Return;
+
+ -----------------
+ -- Obsolescent --
+ -----------------
+
+ -- pragma Obsolescent [(static_string_EXPRESSION)];
+
+ when Pragma_Obsolescent => Obsolescent : declare
+ begin
+ GNAT_Pragma;
+ Check_At_Most_N_Arguments (1);
+ Check_No_Identifiers;
+
+ if Arg_Count = 1 then
+ Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ end if;
+
+ if No (Prev (N))
+ or else (Nkind (Prev (N))) /= N_Subprogram_Declaration
+ then
+ Error_Pragma
+ ("pragma% misplaced, must immediately " &
+ "follow subprogram spec");
+ end if;
+ end Obsolescent;
-----------------
-- No_Run_Time --
@@ -6710,11 +7361,24 @@ package body Sem_Prag is
-- pragma No_Run_Time
+ -- Note: this pragma is retained for backwards compatibiltiy.
+ -- See body of Rtsfind for full details on its handling.
+
when Pragma_No_Run_Time =>
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
Check_Arg_Count (0);
- Set_No_Run_Time_Mode;
+
+ No_Run_Time_Mode := True;
+ Configurable_Run_Time_Mode := True;
+
+ if Ttypes.System_Word_Size = 32 then
+ Duration_32_Bits_On_Target := True;
+ end if;
+
+ Restrictions (No_Finalization) := True;
+ Restrictions (No_Exception_Handlers) := True;
+ Restriction_Parameters (Max_Tasks) := Uint_0;
-----------------------
-- Normalize_Scalars --
@@ -6744,6 +7408,25 @@ package body Sem_Prag is
Check_Arg_Count (1);
Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
+ -------------------------
+ -- Optional_Overriding --
+ -------------------------
+
+ -- These pragmas are treated as part of the previous subprogram
+ -- declaration, and analyzed immediately after it (see sem_ch6,
+ -- Check_Overriding_Operation). If the pragma has not been analyzed
+ -- yet, it appears in the wrong place.
+
+ when Pragma_Optional_Overriding =>
+ Error_Msg_N ("pragma must appear immediately after subprogram", N);
+
+ ----------------
+ -- Overriding --
+ ----------------
+
+ when Pragma_Overriding =>
+ Error_Msg_N ("pragma must appear immediately after subprogram", N);
+
----------
-- Pack --
----------
@@ -6751,7 +7434,7 @@ package body Sem_Prag is
-- pragma Pack (first_subtype_LOCAL_NAME);
when Pragma_Pack => Pack : declare
- Assoc : Node_Id := Arg1;
+ Assoc : constant Node_Id := Arg1;
Type_Id : Node_Id;
Typ : Entity_Id;
@@ -6790,7 +7473,6 @@ package body Sem_Prag is
-- till that point (i.e. right now it may be unfrozen).
elsif Is_Array_Type (Typ) then
-
if Has_Aliased_Components (Base_Type (Typ)) then
Error_Pragma
("pragma% ignored, cannot pack aliased components?");
@@ -6807,7 +7489,7 @@ package body Sem_Prag is
-- Record type. For record types, the pack is always effective
- else -- Is_Record_Type (Typ)
+ else pragma Assert (Is_Record_Type (Typ));
if not Rep_Item_Too_Late (Typ, N) then
Set_Has_Pragma_Pack (Base_Type (Typ));
Set_Is_Packed (Base_Type (Typ));
@@ -6862,6 +7544,104 @@ package body Sem_Prag is
Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
Polling_Required := (Chars (Expression (Arg1)) = Name_On);
+ ---------------------
+ -- Persistent_Data --
+ ---------------------
+
+ when Pragma_Persistent_Data => declare
+ Ent : Entity_Id;
+
+ begin
+ -- Register the pragma as applying to the compilation unit.
+ -- Individual Persistent_Object pragmas for relevant objects
+ -- are generated the end of the compilation.
+
+ GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Count (0);
+ Ent := Find_Lib_Unit_Name;
+ Set_Is_Preelaborated (Ent);
+ end;
+
+ ------------------------
+ -- Persistent_Object --
+ ------------------------
+
+ when Pragma_Persistent_Object => declare
+ Decl : Node_Id;
+ Ent : Entity_Id;
+ MA : Node_Id;
+ Str : String_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Library_Level_Local_Name (Arg1);
+ if not Is_Entity_Name (Expression (Arg1))
+ or else
+ (Ekind (Entity (Expression (Arg1))) /= E_Variable
+ and then Ekind (Entity (Expression (Arg1))) /= E_Constant)
+ then
+ Error_Pragma_Arg ("pragma only applies to objects", Arg1);
+ end if;
+
+ Ent := Entity (Expression (Arg1));
+ Decl := Parent (Ent);
+
+ if Nkind (Decl) /= N_Object_Declaration then
+ return;
+ end if;
+
+ -- Placement of the object depends on whether there is
+ -- an initial value or none. If the No_Initialization flag
+ -- is set, the initialization has been transformed into
+ -- assignments, which is disallowed elaboration code.
+
+ if No_Initialization (Decl) then
+ Error_Msg_N
+ ("initialization for persistent object"
+ & "must be static expression", Decl);
+ return;
+ end if;
+
+ if No (Expression (Decl)) then
+ Start_String;
+ Store_String_Chars ("section ("".persistent.bss"")");
+ Str := End_String;
+
+ else
+ if not Is_OK_Static_Expression (Expression (Decl)) then
+ Flag_Non_Static_Expr
+ ("initialization for persistent object"
+ & "must be static expression!", Expression (Decl));
+ return;
+ end if;
+
+ Start_String;
+ Store_String_Chars ("section ("".persistent.data"")");
+ Str := End_String;
+ end if;
+
+ MA :=
+ Make_Pragma
+ (Sloc (N),
+ Name_Machine_Attribute,
+ New_List
+ (Make_Pragma_Argument_Association
+ (Sloc => Sloc (Arg1),
+ Expression => New_Occurrence_Of (Ent, Sloc (Ent))),
+ Make_Pragma_Argument_Association
+ (Sloc => Sloc (Arg1),
+ Expression =>
+ Make_String_Literal
+ (Sloc => Sloc (Arg1),
+ Strval => Str))));
+
+ Insert_After (N, MA);
+ Analyze (MA);
+ Set_Has_Gigi_Rep_Item (Ent);
+ end;
+
------------------
-- Preelaborate --
------------------
@@ -6871,9 +7651,9 @@ package body Sem_Prag is
-- Set the flag Is_Preelaborated of program unit name entity
when Pragma_Preelaborate => Preelaborate : declare
+ Pa : constant Node_Id := Parent (N);
+ Pk : constant Node_Kind := Nkind (Pa);
Ent : Entity_Id;
- Pa : Node_Id := Parent (N);
- Pk : Node_Kind := Nkind (Pa);
begin
Check_Ada_83_Warning;
@@ -6913,23 +7693,20 @@ package body Sem_Prag is
Check_No_Identifiers;
Check_Arg_Count (1);
- Arg := Expression (Arg1);
- Analyze_And_Resolve (Arg, Standard_Integer);
-
- if not Is_Static_Expression (Arg) then
- Check_Restriction (Static_Priorities, Arg);
- end if;
-
-- Subprogram case
if Nkind (P) = N_Subprogram_Body then
Check_In_Main_Program;
+ Arg := Expression (Arg1);
+ Analyze_And_Resolve (Arg, Standard_Integer);
+
-- Must be static
if not Is_Static_Expression (Arg) then
- Error_Pragma_Arg
- ("main subprogram priority is not static", Arg1);
+ Flag_Non_Static_Expr
+ ("main subprogram priority is not static!", Arg);
+ raise Pragma_Exit;
-- If constraint error, then we already signalled an error
@@ -6962,9 +7739,16 @@ package body Sem_Prag is
or else
Nkind (P) = N_Task_Definition
then
- if Expander_Active then
- Rewrite (Arg,
- Convert_To (RTE (RE_Any_Priority), Arg));
+ Arg := Expression (Arg1);
+
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
+
+ Analyze_Per_Use_Expression (Arg, Standard_Integer);
+
+ if not Is_Static_Expression (Arg) then
+ Check_Restriction (Static_Priorities, Arg);
end if;
-- Anything else is incorrect
@@ -7014,7 +7798,7 @@ package body Sem_Prag is
when Pragma_Psect_Object | Pragma_Common_Object =>
Psect_Object : declare
Args : Args_List (1 .. 3);
- Names : Name_List (1 .. 3) := (
+ Names : constant Name_List (1 .. 3) := (
Name_Internal,
Name_External,
Name_Size);
@@ -7041,7 +7825,7 @@ package body Sem_Prag is
--------------------
procedure Check_Too_Long (Arg : Node_Id) is
- X : Node_Id := Original_Node (Arg);
+ X : constant Node_Id := Original_Node (Arg);
begin
if Nkind (X) /= N_String_Literal
@@ -7122,6 +7906,7 @@ package body Sem_Prag is
if Ekind (Ent) = E_Component
and then Nkind (Decl) = N_Component_Declaration
and then Present (Expression (Decl))
+ and then Warn_On_Export_Import
then
Error_Msg_N
("?object for pragma % has defaults", R_Internal);
@@ -7220,6 +8005,7 @@ package body Sem_Prag is
(Make_Pragma_Argument_Association
(Sloc => Sloc (R_Internal),
Expression => R_Internal),
+
Make_Pragma_Argument_Association
(Sloc => Sloc (R_External),
Expression =>
@@ -7243,6 +8029,7 @@ package body Sem_Prag is
(Make_Pragma_Argument_Association
(Sloc => Sloc (R_Internal),
Expression => R_Internal),
+
Make_Pragma_Argument_Association
(Sloc => Sloc (R_External),
Expression =>
@@ -7298,20 +8085,26 @@ package body Sem_Prag is
-- Loop through homonyms (overloadings) of referenced entity
E := Entity (E_Id);
- while Present (E) loop
- Def_Id := Get_Base_Subprogram (E);
- if Ekind (Def_Id) /= E_Function
- and then Ekind (Def_Id) /= E_Generic_Function
- and then Ekind (Def_Id) /= E_Operator
- then
- Error_Pragma_Arg ("pragma% requires a function name", Arg1);
- end if;
+ if Present (E) then
+ loop
+ Def_Id := Get_Base_Subprogram (E);
- Set_Is_Pure (Def_Id);
- Set_Has_Pragma_Pure_Function (Def_Id);
- E := Homonym (E);
- end loop;
+ if Ekind (Def_Id) /= E_Function
+ and then Ekind (Def_Id) /= E_Generic_Function
+ and then Ekind (Def_Id) /= E_Operator
+ then
+ Error_Pragma_Arg
+ ("pragma% requires a function name", Arg1);
+ end if;
+
+ Set_Is_Pure (Def_Id);
+ Set_Has_Pragma_Pure_Function (Def_Id);
+
+ E := Homonym (E);
+ exit when No (E) or else Scope (E) /= Current_Scope;
+ end loop;
+ end if;
end Pure_Function;
--------------------
@@ -7337,9 +8130,16 @@ package body Sem_Prag is
then
Error_Msg_Sloc := Queuing_Policy_Sloc;
Error_Pragma ("queuing policy incompatible with policy#");
+
+ -- Set new policy, but always preserve System_Location since
+ -- we like the error message with the run time name.
+
else
Queuing_Policy := QP;
- Queuing_Policy_Sloc := Loc;
+
+ if Queuing_Policy_Sloc /= System_Location then
+ Queuing_Policy_Sloc := Loc;
+ end if;
end if;
end;
@@ -7418,21 +8218,25 @@ package body Sem_Prag is
-- Ravenscar --
---------------
+ -- pragma Ravenscar;
+
when Pragma_Ravenscar =>
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
- Set_Ravenscar;
+ Set_Ravenscar (N);
-------------------------
-- Restricted_Run_Time --
-------------------------
+ -- pragma Restricted_Run_Time;
+
when Pragma_Restricted_Run_Time =>
GNAT_Pragma;
Check_Arg_Count (0);
Check_Valid_Configuration_Pragma;
- Set_Restricted_Profile;
+ Set_Restricted_Profile (N);
------------------
-- Restrictions --
@@ -7458,7 +8262,6 @@ package body Sem_Prag is
Check_Valid_Configuration_Pragma;
Arg := Arg1;
-
while Present (Arg) loop
Id := Chars (Arg);
Expr := Expression (Arg);
@@ -7486,7 +8289,13 @@ package body Sem_Prag is
end if;
Restrictions (R_Id) := True;
- Restrictions_Loc (R_Id) := Sloc (N);
+
+ -- Set location, but preserve location of system
+ -- restriction for nice error msg with run time name
+
+ if Restrictions_Loc (R_Id) /= System_Location then
+ Restrictions_Loc (R_Id) := Sloc (N);
+ end if;
-- Record the restriction if we are in the main unit,
-- or in the extended main unit. The reason that we
@@ -7523,12 +8332,16 @@ package body Sem_Prag is
Error_Pragma_Arg
("invalid restriction parameter identifier", Arg);
- elsif not Is_OK_Static_Expression (Expr)
- or else not Is_Integer_Type (Etype (Expr))
+ elsif not Is_OK_Static_Expression (Expr) then
+ Flag_Non_Static_Expr
+ ("value must be static expression!", Expr);
+ raise Pragma_Exit;
+
+ elsif not Is_Integer_Type (Etype (Expr))
or else Expr_Value (Expr) < 0
then
Error_Pragma_Arg
- ("value must be non-negative static integer", Arg);
+ ("value must be non-negative integer", Arg);
-- Restriction pragma is active
@@ -7540,7 +8353,7 @@ package body Sem_Prag is
if Restriction_Parameters (RP_Id) = No_Uint
or else Val < Restriction_Parameters (RP_Id)
then
- Restriction_Parameters (RP_Id) := Expr_Value (Expr);
+ Restriction_Parameters (RP_Id) := Val;
Restriction_Parameters_Loc (RP_Id) := Sloc (N);
end if;
end if;
@@ -7550,6 +8363,56 @@ package body Sem_Prag is
end loop;
end Restrictions_Pragma;
+ --------------------------
+ -- Restriction_Warnings --
+ --------------------------
+
+ -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
+
+ -- RESTRICTION ::= restriction_IDENTIFIER
+
+ when Pragma_Restriction_Warnings => Restriction_Warn : declare
+ Arg : Node_Id;
+ R_Id : Restriction_Id;
+ Expr : Node_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (1);
+ Check_Valid_Configuration_Pragma;
+ Check_No_Identifiers;
+
+ Arg := Arg1;
+ while Present (Arg) loop
+ Expr := Expression (Arg);
+
+ if Nkind (Expr) /= N_Identifier then
+ Error_Pragma_Arg
+ ("invalid form for restriction", Arg);
+
+ else
+ R_Id := Get_Restriction_Id (Chars (Expr));
+
+ if R_Id = Not_A_Restriction_Id then
+ Error_Pragma_Arg
+ ("invalid restriction identifier", Arg);
+
+ -- Restriction is active
+
+ else
+ if Implementation_Restriction (R_Id) then
+ Check_Restriction
+ (No_Implementation_Restrictions, Arg);
+ end if;
+
+ Restriction_Warnings (R_Id) := True;
+ end if;
+ end if;
+
+ Next (Arg);
+ end loop;
+ end Restriction_Warn;
+
----------------
-- Reviewable --
----------------
@@ -7633,6 +8496,40 @@ package body Sem_Prag is
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
+ ------------------------------
+ -- Source_File_Name_Project --
+ ------------------------------
+
+ -- pragma Source_File_Name_Project (
+ -- [UNIT_NAME =>] unit_NAME,
+ -- [BODY_FILE_NAME | SPEC_FILE_NAME] => STRING_LITERAL);
+
+ -- No processing here. Processing was completed during parsing,
+ -- since we need to have file names set as early as possible.
+ -- Units are loaded well before semantic processing starts.
+
+ -- The only processing we defer to this point is the check
+ -- for correct placement.
+
+ when Pragma_Source_File_Name_Project =>
+ GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
+
+ -- Check that a pragma Source_File_Name_Project is used only
+ -- in a configuration pragmas file.
+ -- Pragmas Source_File_Name_Project should only be generated
+ -- by the Project Manager in configuration pragmas files.
+
+ -- This is really an ugly test. It seems to depend on some
+ -- accidental and undocumented property. At the very least
+ -- it needs to be documented, but it would be better to have
+ -- a clean way of testing if we are in a configuration file???
+
+ if Present (Parent (N)) then
+ Error_Pragma
+ ("pragma% can only appear in a configuration pragmas file");
+ end if;
+
----------------------
-- Source_Reference --
----------------------
@@ -7652,20 +8549,23 @@ package body Sem_Prag is
-- pragma Storage_Size (EXPRESSION);
when Pragma_Storage_Size => Storage_Size : declare
- P : constant Node_Id := Parent (N);
- X : Node_Id;
+ P : constant Node_Id := Parent (N);
+ Arg : Node_Id;
begin
Check_No_Identifiers;
Check_Arg_Count (1);
- -- Set In_Default_Expression for per-object case???
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default Expressions" in sem.ads.
- X := Expression (Arg1);
- Analyze_And_Resolve (X, Any_Integer);
+ -- Set In_Default_Expression for per-object case ???
+
+ Arg := Expression (Arg1);
+ Analyze_Per_Use_Expression (Arg, Any_Integer);
- if not Is_Static_Expression (X) then
- Check_Restriction (Static_Storage_Size, X);
+ if not Is_Static_Expression (Arg) then
+ Check_Restriction (Static_Storage_Size, Arg);
end if;
if Nkind (P) /= N_Task_Definition then
@@ -7866,7 +8766,7 @@ package body Sem_Prag is
S := Strval (A);
declare
- Slen : Natural := Natural (String_Length (S));
+ Slen : constant Natural := Natural (String_Length (S));
Options : String (1 .. Slen);
J : Natural;
@@ -7960,6 +8860,18 @@ package body Sem_Prag is
Check_Optional_Identifier (Arg1, Name_Entity);
Set_Debug_Info_Off (Entity (Get_Pragma_Arg (Arg1)));
+ ----------------------------------
+ -- Suppress_Exception_Locations --
+ ----------------------------------
+
+ -- pragma Suppress_Exception_Locations;
+
+ when Pragma_Suppress_Exception_Locations =>
+ GNAT_Pragma;
+ Check_Arg_Count (0);
+ Check_Valid_Configuration_Pragma;
+ Exception_Locations_Suppressed := True;
+
-----------------------------
-- Suppress_Initialization --
-----------------------------
@@ -8041,9 +8953,16 @@ package body Sem_Prag is
Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
Error_Pragma
("task dispatching policy incompatible with policy#");
+
+ -- Set new policy, but always preserve System_Location since
+ -- we like the error message with the run time name.
+
else
Task_Dispatching_Policy := DP;
- Task_Dispatching_Policy_Sloc := Loc;
+
+ if Task_Dispatching_Policy_Sloc /= System_Location then
+ Task_Dispatching_Policy_Sloc := Loc;
+ end if;
end if;
end;
@@ -8120,7 +9039,7 @@ package body Sem_Prag is
when Pragma_Task_Storage => Task_Storage : declare
Args : Args_List (1 .. 2);
- Names : Name_List (1 .. 2) := (
+ Names : constant Name_List (1 .. 2) := (
Name_Task_Type,
Name_Top_Guard);
@@ -8132,6 +9051,12 @@ package body Sem_Prag is
begin
GNAT_Pragma;
Gather_Associations (Names, Args);
+
+ if No (Task_Type) then
+ Error_Pragma
+ ("missing task_type argument for pragma%");
+ end if;
+
Check_Arg_Is_Local_Name (Task_Type);
Ent := Entity (Task_Type);
@@ -8217,7 +9142,7 @@ package body Sem_Prag is
when Pragma_Title => Title : declare
Args : Args_List (1 .. 2);
- Names : Name_List (1 .. 2) := (
+ Names : constant Name_List (1 .. 2) := (
Name_Title,
Name_Subtitle);
@@ -8239,8 +9164,8 @@ package body Sem_Prag is
-- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
when Pragma_Unchecked_Union => Unchecked_Union : declare
- Assoc : Node_Id := Arg1;
- Type_Id : Node_Id := Expression (Assoc);
+ Assoc : constant Node_Id := Arg1;
+ Type_Id : constant Node_Id := Expression (Assoc);
Typ : Entity_Id;
Discr : Entity_Id;
Tdef : Node_Id;
@@ -8287,6 +9212,7 @@ package body Sem_Prag is
elsif Is_Limited_Type (Typ) then
Error_Msg_N
("Unchecked_Union must not be limited record type", Typ);
+ Explain_Limited_Type (Typ, Typ);
return;
else
@@ -8379,13 +9305,11 @@ package body Sem_Prag is
end loop;
end if;
- Set_Is_Unchecked_Union (Typ, True);
- Set_Suppress_Discriminant_Checks (Typ, True);
- Set_Convention (Typ, Convention_C);
+ Set_Is_Unchecked_Union (Typ, True);
+ Set_Convention (Typ, Convention_C);
Set_Has_Unchecked_Union (Base_Type (Typ), True);
Set_Is_Unchecked_Union (Base_Type (Typ), True);
-
end Unchecked_Union;
------------------------
@@ -8399,8 +9323,10 @@ package body Sem_Prag is
-- appears in the body, not in the spec).
when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
- Cunitent : Entity_Id := Cunit_Entity (Get_Source_Unit (Loc));
- Ent_Kind : Entity_Kind := Ekind (Cunitent);
+ Cunitent : constant Entity_Id :=
+ Cunit_Entity (Get_Source_Unit (Loc));
+ Ent_Kind : constant Entity_Kind :=
+ Ekind (Cunitent);
begin
GNAT_Pragma;
@@ -8424,12 +9350,22 @@ package body Sem_Prag is
-- Universal_Data --
--------------------
- -- pragma Universal_Data;
+ -- pragma Universal_Data [(library_unit_NAME)];
when Pragma_Universal_Data =>
GNAT_Pragma;
- Check_Arg_Count (0);
- Check_Valid_Library_Unit_Pragma;
+
+ -- If this is a configuration pragma, then set the universal
+ -- addressing option, otherwise confirm that the pragma
+ -- satisfies the requirements of library unit pragma placement
+ -- and leave it to the GNAAMP back end to detect the pragma
+ -- (avoids transitive setting of the option due to withed units).
+
+ if Is_Configuration_Pragma then
+ Universal_Addressing_On_AAMP := True;
+ else
+ Check_Valid_Library_Unit_Pragma;
+ end if;
if not AAMP_On_Target then
Error_Pragma ("?pragma% ignored (applies only to AAMP)");
@@ -8444,6 +9380,7 @@ package body Sem_Prag is
when Pragma_Unreferenced => Unreferenced : declare
Arg_Node : Node_Id;
Arg_Expr : Node_Id;
+ Arg_Ent : Entity_Id;
begin
GNAT_Pragma;
@@ -8466,7 +9403,18 @@ package body Sem_Prag is
Arg_Expr := Get_Pragma_Arg (Arg_Node);
if Is_Entity_Name (Arg_Expr) then
- Set_Has_Pragma_Unreferenced (Entity (Arg_Expr));
+ Arg_Ent := Entity (Arg_Expr);
+
+ -- If the entity is overloaded, the pragma applies to the
+ -- most recent overloading, as documented. In this case,
+ -- name resolution does not generate a reference, so it
+ -- must be done here explicitly.
+
+ if Is_Overloaded (Arg_Expr) then
+ Generate_Reference (Arg_Ent, N);
+ end if;
+
+ Set_Has_Pragma_Unreferenced (Arg_Ent);
end if;
Next (Arg_Node);
@@ -8529,7 +9477,7 @@ package body Sem_Prag is
S := Strval (A);
declare
- Slen : Natural := Natural (String_Length (S));
+ Slen : constant Natural := Natural (String_Length (S));
Options : String (1 .. Slen);
J : Natural;
@@ -8587,7 +9535,7 @@ package body Sem_Prag is
-- pragma Warnings (On | Off, [LOCAL_NAME])
- when Pragma_Warnings =>
+ when Pragma_Warnings => Warnings : begin
GNAT_Pragma;
Check_At_Least_N_Arguments (1);
Check_At_Most_N_Arguments (2);
@@ -8640,6 +9588,7 @@ package body Sem_Prag is
end if;
end;
end if;
+ end Warnings;
-------------------
-- Weak_External --
@@ -8675,13 +9624,31 @@ package body Sem_Prag is
end if;
end Weak_External;
+ --------------------
+ -- Unknown_Pragma --
+ --------------------
+
+ -- Should be impossible, since the case of an unknown pragma is
+ -- separately processed before the case statement is entered.
+
+ when Unknown_Pragma =>
+ raise Program_Error;
+
end case;
exception
when Pragma_Exit => null;
-
end Analyze_Pragma;
+ ---------------------------------
+ -- Delay_Config_Pragma_Analyze --
+ ---------------------------------
+
+ function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
+ begin
+ return Chars (N) = Name_Interrupt_State;
+ end Delay_Config_Pragma_Analyze;
+
-------------------------
-- Get_Base_Subprogram --
-------------------------
@@ -8707,15 +9674,193 @@ package body Sem_Prag is
return Result;
end Get_Base_Subprogram;
- ---------------------------
- -- Is_Generic_Subprogram --
- ---------------------------
+ -----------------------------------------
+ -- Is_Non_Significant_Pragma_Reference --
+ -----------------------------------------
+
+ -- This function makes use of the following static table which indicates
+ -- whether a given pragma is significant. A value of -1 in this table
+ -- indicates that the reference is significant. A value of zero indicates
+ -- than appearence as any argument is insignificant, a positive value
+ -- indicates that appearence in that parameter position is significant.
+
+ Sig_Flags : array (Pragma_Id) of Int :=
+ (Pragma_AST_Entry => -1,
+ Pragma_Abort_Defer => -1,
+ Pragma_Ada_83 => -1,
+ Pragma_Ada_95 => -1,
+ Pragma_All_Calls_Remote => -1,
+ Pragma_Annotate => -1,
+ Pragma_Assert => -1,
+ Pragma_Asynchronous => -1,
+ Pragma_Atomic => 0,
+ Pragma_Atomic_Components => 0,
+ Pragma_Attach_Handler => -1,
+ Pragma_CPP_Class => 0,
+ Pragma_CPP_Constructor => 0,
+ Pragma_CPP_Virtual => 0,
+ Pragma_CPP_Vtable => 0,
+ Pragma_C_Pass_By_Copy => 0,
+ Pragma_Comment => 0,
+ Pragma_Common_Object => -1,
+ Pragma_Compile_Time_Warning => -1,
+ Pragma_Complex_Representation => 0,
+ Pragma_Component_Alignment => -1,
+ Pragma_Controlled => 0,
+ Pragma_Convention => 0,
+ Pragma_Convention_Identifier => 0,
+ Pragma_Debug => -1,
+ Pragma_Discard_Names => 0,
+ Pragma_Elaborate => -1,
+ Pragma_Elaborate_All => -1,
+ Pragma_Elaborate_Body => -1,
+ Pragma_Elaboration_Checks => -1,
+ Pragma_Eliminate => -1,
+ Pragma_Explicit_Overriding => -1,
+ Pragma_Export => -1,
+ Pragma_Export_Exception => -1,
+ Pragma_Export_Function => -1,
+ Pragma_Export_Object => -1,
+ Pragma_Export_Procedure => -1,
+ Pragma_Export_Value => -1,
+ Pragma_Export_Valued_Procedure => -1,
+ Pragma_Extend_System => -1,
+ Pragma_Extensions_Allowed => -1,
+ Pragma_External => -1,
+ Pragma_External_Name_Casing => -1,
+ Pragma_Finalize_Storage_Only => 0,
+ Pragma_Float_Representation => 0,
+ Pragma_Ident => -1,
+ Pragma_Import => +2,
+ Pragma_Import_Exception => 0,
+ Pragma_Import_Function => 0,
+ Pragma_Import_Object => 0,
+ Pragma_Import_Procedure => 0,
+ Pragma_Import_Valued_Procedure => 0,
+ Pragma_Initialize_Scalars => -1,
+ Pragma_Inline => 0,
+ Pragma_Inline_Always => 0,
+ Pragma_Inline_Generic => 0,
+ Pragma_Inspection_Point => -1,
+ Pragma_Interface => +2,
+ Pragma_Interface_Name => +2,
+ Pragma_Interrupt_Handler => -1,
+ Pragma_Interrupt_Priority => -1,
+ Pragma_Interrupt_State => -1,
+ Pragma_Java_Constructor => -1,
+ Pragma_Java_Interface => -1,
+ Pragma_Keep_Names => 0,
+ Pragma_License => -1,
+ Pragma_Link_With => -1,
+ Pragma_Linker_Alias => -1,
+ Pragma_Linker_Options => -1,
+ Pragma_Linker_Section => -1,
+ Pragma_List => -1,
+ Pragma_Locking_Policy => -1,
+ Pragma_Long_Float => -1,
+ Pragma_Machine_Attribute => -1,
+ Pragma_Main => -1,
+ Pragma_Main_Storage => -1,
+ Pragma_Memory_Size => -1,
+ Pragma_No_Return => 0,
+ Pragma_No_Run_Time => -1,
+ Pragma_Normalize_Scalars => -1,
+ Pragma_Obsolescent => 0,
+ Pragma_Optimize => -1,
+ Pragma_Optional_Overriding => -1,
+ Pragma_Overriding => -1,
+ Pragma_Pack => 0,
+ Pragma_Page => -1,
+ Pragma_Passive => -1,
+ Pragma_Polling => -1,
+ Pragma_Persistent_Data => -1,
+ Pragma_Persistent_Object => -1,
+ Pragma_Preelaborate => -1,
+ Pragma_Priority => -1,
+ Pragma_Propagate_Exceptions => -1,
+ Pragma_Psect_Object => -1,
+ Pragma_Pure => 0,
+ Pragma_Pure_Function => 0,
+ Pragma_Queuing_Policy => -1,
+ Pragma_Ravenscar => -1,
+ Pragma_Remote_Call_Interface => -1,
+ Pragma_Remote_Types => -1,
+ Pragma_Restricted_Run_Time => -1,
+ Pragma_Restriction_Warnings => -1,
+ Pragma_Restrictions => -1,
+ Pragma_Reviewable => -1,
+ Pragma_Share_Generic => -1,
+ Pragma_Shared => -1,
+ Pragma_Shared_Passive => -1,
+ Pragma_Source_File_Name => -1,
+ Pragma_Source_File_Name_Project => -1,
+ Pragma_Source_Reference => -1,
+ Pragma_Storage_Size => -1,
+ Pragma_Storage_Unit => -1,
+ Pragma_Stream_Convert => -1,
+ Pragma_Style_Checks => -1,
+ Pragma_Subtitle => -1,
+ Pragma_Suppress => 0,
+ Pragma_Suppress_Exception_Locations => 0,
+ Pragma_Suppress_All => -1,
+ Pragma_Suppress_Debug_Info => 0,
+ Pragma_Suppress_Initialization => 0,
+ Pragma_System_Name => -1,
+ Pragma_Task_Dispatching_Policy => -1,
+ Pragma_Task_Info => -1,
+ Pragma_Task_Name => -1,
+ Pragma_Task_Storage => 0,
+ Pragma_Time_Slice => -1,
+ Pragma_Title => -1,
+ Pragma_Unchecked_Union => -1,
+ Pragma_Unimplemented_Unit => -1,
+ Pragma_Universal_Data => -1,
+ Pragma_Unreferenced => -1,
+ Pragma_Unreserve_All_Interrupts => -1,
+ Pragma_Unsuppress => 0,
+ Pragma_Use_VADS_Size => -1,
+ Pragma_Validity_Checks => -1,
+ Pragma_Volatile => 0,
+ Pragma_Volatile_Components => 0,
+ Pragma_Warnings => -1,
+ Pragma_Weak_External => 0,
+ Unknown_Pragma => 0);
+
+ function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean is
+ P : Node_Id;
+ C : Int;
+ A : Node_Id;
- function Is_Generic_Subprogram (Id : Entity_Id) return Boolean is
begin
- return Ekind (Id) = E_Generic_Procedure
- or else Ekind (Id) = E_Generic_Function;
- end Is_Generic_Subprogram;
+ P := Parent (N);
+
+ if Nkind (P) /= N_Pragma_Argument_Association then
+ return False;
+
+ else
+ C := Sig_Flags (Get_Pragma_Id (Chars (Parent (P))));
+
+ case C is
+ when -1 =>
+ return False;
+
+ when 0 =>
+ return True;
+
+ when others =>
+ A := First (Pragma_Argument_Associations (Parent (P)));
+ for J in 1 .. C - 1 loop
+ if No (A) then
+ return False;
+ end if;
+
+ Next (A);
+ end loop;
+
+ return A = P;
+ end case;
+ end if;
+ end Is_Non_Significant_Pragma_Reference;
------------------------------
-- Is_Pragma_String_Literal --
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index d1ec46e19a5..9ff4ede80a2 100644
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1997 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,6 +33,24 @@ package Sem_Prag is
procedure Analyze_Pragma (N : Node_Id);
-- Analyze procedure for pragma reference node N
+ function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean;
+ -- N is a pragma appearing in a configuration pragma file. Most
+ -- such pragmas are analyzed when the file is read, before parsing
+ -- and analyzing the main unit. However, the analysis of certain
+ -- pragmas results in adding information to the compiled main unit,
+ -- and this cannot be done till the main unit is processed. Such
+ -- pragmas return True from this function and in Frontend pragmas
+ -- where Delay_Config_Pragma_Analyze is True have their analysis
+ -- delayed until after the main program is parsed and analyzed.
+
+ function Is_Non_Significant_Pragma_Reference (N : Node_Id) return Boolean;
+ -- The node N is a node for an entity and the issue is whether the
+ -- occurrence is a reference for the purposes of giving warnings
+ -- about unreferenced variables. This function returns True if the
+ -- reference is not a reference from this point of view (e.g. the
+ -- occurrence in a pragma Pack) and False if it is a real reference
+ -- (e.g. the occcurrence in a pragma Export);
+
function Is_Pragma_String_Literal (Par : Node_Id) return Boolean;
-- Given an N_Pragma_Argument_Association node, Par, which has the form
-- of an operator symbol, determines whether or not it should be treated
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 6df80d22570..68c45f65409 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,6 +32,7 @@ with Einfo; use Einfo;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Ch7; use Exp_Ch7;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Itypes; use Itypes;
@@ -60,6 +61,7 @@ with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
+with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Targparm; use Targparm;
@@ -105,8 +107,8 @@ package body Sem_Res is
procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id);
-- If the type of the object being initialized uses the secondary stack
-- directly or indirectly, create a transient scope for the call to the
- -- Init_Proc. This is because we do not create transient scopes for the
- -- initialization of individual components within the init_proc itself.
+ -- init proc. This is because we do not create transient scopes for the
+ -- initialization of individual components within the init proc itself.
-- Could be optimized away perhaps?
function Is_Predefined_Op (Nam : Entity_Id) return Boolean;
@@ -174,6 +176,9 @@ package body Sem_Res is
-- A call to a user-defined intrinsic operator is rewritten as a call
-- to the corresponding predefined operator, with suitable conversions.
+ procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);
+ -- Ditto, for unary operators (only arithmetic ones).
+
procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
-- If an operator node resolves to a call to a user-defined operator,
-- rewrite the node as a function call.
@@ -197,7 +202,7 @@ package body Sem_Res is
-- not a N_String_Literal node, then the call has no effect.
procedure Set_Slice_Subtype (N : Node_Id);
- -- Build subtype of array type, with the range specified by the slice.
+ -- Build subtype of array type, with the range specified by the slice
function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id;
-- A universal_fixed expression in an universal context is unambiguous
@@ -247,7 +252,7 @@ package body Sem_Res is
procedure Analyze_And_Resolve (N : Node_Id) is
begin
Analyze (N);
- Resolve (N, Etype (N));
+ Resolve (N);
end Analyze_And_Resolve;
procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is
@@ -263,12 +268,12 @@ package body Sem_Res is
Typ : Entity_Id;
Suppress : Check_Id)
is
- Scop : Entity_Id := Current_Scope;
+ Scop : constant Entity_Id := Current_Scope;
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
@@ -278,12 +283,12 @@ package body Sem_Res is
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Analyze_And_Resolve (N, Typ);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
@@ -305,12 +310,12 @@ package body Sem_Res is
(N : Node_Id;
Suppress : Check_Id)
is
- Scop : Entity_Id := Current_Scope;
+ Scop : constant Entity_Id := Current_Scope;
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
@@ -320,12 +325,12 @@ package body Sem_Res is
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Analyze_And_Resolve (N);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
@@ -416,6 +421,10 @@ package body Sem_Res is
-- any array whose index type covered the whole range of
-- the type would likely raise Storage_Error.
+ ------------------------
+ -- Large_Storage_Type --
+ ------------------------
+
function Large_Storage_Type (T : Entity_Id) return Boolean is
begin
return
@@ -490,8 +499,8 @@ package body Sem_Res is
-- Warn about the danger
Error_Msg_N
- ("creation of object of this type may raise Storage_Error?",
- N);
+ ("creation of & object may raise Storage_Error?",
+ Scope (Disc));
<<No_Danger>>
null;
@@ -535,15 +544,16 @@ package body Sem_Res is
if (Nkind (P) = N_Subtype_Indication
and then
(Nkind (Parent (P)) = N_Component_Declaration
- or else Nkind (Parent (P)) = N_Derived_Type_Definition)
+ or else
+ Nkind (Parent (P)) = N_Derived_Type_Definition)
and then D = Constraint (P))
-- The constraint itself may be given by a subtype indication,
-- rather than by a more common discrete range.
or else (Nkind (P) = N_Subtype_Indication
- and then Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint)
-
+ and then
+ Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint)
or else Nkind (P) = N_Entry_Declaration
or else Nkind (D) = N_Defining_Identifier
then
@@ -558,21 +568,8 @@ package body Sem_Res is
--------------------------------
procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is
- Orig_Node : Node_Id := Original_Node (N);
-
begin
- if Comes_From_Source (Orig_Node)
- and then not In_Open_Scopes (Scope (T))
- and then not Is_Potentially_Use_Visible (T)
- and then not In_Use (T)
- and then not In_Use (Scope (T))
- and then (not Present (Entity (N))
- or else Ekind (Entity (N)) /= E_Function)
- and then (Nkind (Orig_Node) /= N_Function_Call
- or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
- or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
- and then not In_Instance
- then
+ if Is_Invisible_Operator (N, T) then
Error_Msg_NE
("operator for} is not directly visible!", N, First_Subtype (T));
Error_Msg_N ("use clause would make operation legal!", N);
@@ -678,10 +675,8 @@ package body Sem_Res is
end if;
end loop;
- Warn_On_Instance := True;
Error_Msg_N ("possible infinite recursion?", N);
Error_Msg_N ("\Storage_Error may be raised at run time?", N);
- Warn_On_Instance := False;
return True;
end Check_Infinite_Recursion;
@@ -691,7 +686,7 @@ package body Sem_Res is
-------------------------------
procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is
- Typ : Entity_Id := Etype (First_Formal (Nam));
+ Typ : constant Entity_Id := Etype (First_Formal (Nam));
function Uses_SS (T : Entity_Id) return Boolean;
-- Check whether the creation of an object of the type will involve
@@ -725,7 +720,11 @@ package body Sem_Res is
then
Expr := Expression (Parent (Comp));
- if Nkind (Expr) = N_Function_Call
+ -- The expression for a dynamic component may be
+ -- rewritten as a dereference. Retrieve original
+ -- call.
+
+ if Nkind (Original_Node (Expr)) = N_Function_Call
and then Requires_Transient_Scope (Etype (Expr))
then
return True;
@@ -779,6 +778,8 @@ package body Sem_Res is
then
return;
end if;
+
+ Require_Entity (N);
end if;
-- Rewrite as call if overloadable entity that is (or could be, in
@@ -806,10 +807,11 @@ package body Sem_Res is
or else
(Nkind (N) = N_Selected_Component
and then (Ekind (Entity (Selector_Name (N))) = E_Function
- or else ((Ekind (Entity (Selector_Name (N))) = E_Entry
- or else
- Ekind (Entity (Selector_Name (N))) = E_Procedure)
- and then Is_Overloaded (Selector_Name (N)))))
+ or else
+ ((Ekind (Entity (Selector_Name (N))) = E_Entry
+ or else
+ Ekind (Entity (Selector_Name (N))) = E_Procedure)
+ and then Is_Overloaded (Selector_Name (N)))))
-- If one of the above three conditions is met, rewrite as call.
-- Apply the rewriting only once.
@@ -999,10 +1001,6 @@ package body Sem_Res is
end if;
end Type_In_P;
- ---------------------------
- -- Operand_Type_In_Scope --
- ---------------------------
-
-- Start of processing for Make_Call_Into_Operator
begin
@@ -1157,11 +1155,37 @@ package body Sem_Res is
end if;
Set_Chars (Op_Node, Op_Name);
- Set_Etype (Op_Node, Base_Type (Etype (N)));
+
+ if not Is_Private_Type (Etype (N)) then
+ Set_Etype (Op_Node, Base_Type (Etype (N)));
+ else
+ Set_Etype (Op_Node, Etype (N));
+ end if;
+
Set_Entity (Op_Node, Op_Id);
Generate_Reference (Op_Id, N, ' ');
Rewrite (N, Op_Node);
- Resolve (N, Typ);
+
+ -- If this is an arithmetic operator and the result type is private,
+ -- the operands and the result must be wrapped in conversion to
+ -- expose the underlying numeric type and expand the proper checks,
+ -- e.g. on division.
+
+ if Is_Private_Type (Typ) then
+ case Nkind (N) is
+ when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
+ N_Op_Expon | N_Op_Mod | N_Op_Rem =>
+ Resolve_Intrinsic_Operator (N, Typ);
+
+ when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
+ Resolve_Intrinsic_Unary_Operator (N, Typ);
+
+ when others =>
+ Resolve (N, Typ);
+ end case;
+ else
+ Resolve (N, Typ);
+ end if;
-- For predefined operators on literals, the operation freezes
-- their type.
@@ -1331,6 +1355,7 @@ package body Sem_Res is
Seen : Entity_Id := Empty; -- prevent junk warning
Ctx_Type : Entity_Id := Typ;
Expr_Type : Entity_Id := Empty; -- prevent junk warning
+ Err_Type : Entity_Id := Empty;
Ambiguous : Boolean := False;
procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id);
@@ -1493,9 +1518,14 @@ package body Sem_Res is
end if;
end if;
- if Attr = Attribute_Access
- or else Attr = Attribute_Unchecked_Access
- or else Attr = Attribute_Unrestricted_Access
+ -- If we are generating code for a distributed program.
+ -- perform semantic checks against the corresponding
+ -- remote entities.
+
+ if (Attr = Attribute_Access
+ or else Attr = Attribute_Unchecked_Access
+ or else Attr = Attribute_Unrestricted_Access)
+ and then Expander_Active
then
Check_Subtype_Conformant
(New_Id => Entity (Prefix (N)),
@@ -1559,8 +1589,13 @@ package body Sem_Res is
-- We are only interested in interpretations that are compatible
-- with the expected type, any other interpretations are ignored
- if Covers (Typ, It.Typ) then
+ if not Covers (Typ, It.Typ) then
+ if Debug_Flag_V then
+ Write_Str (" interpretation incompatible with context");
+ Write_Eol;
+ end if;
+ else
-- First matching interpretation
if not Found then
@@ -1569,7 +1604,7 @@ package body Sem_Res is
Seen := It.Nam;
Expr_Type := It.Typ;
- -- Matching intepretation that is not the first, maybe an
+ -- Matching interpretation that is not the first, maybe an
-- error, but there are some cases where preference rules are
-- used to choose between the two possibilities. These and
-- some more obscure cases are handled in Disambiguate.
@@ -1578,8 +1613,18 @@ package body Sem_Res is
Error_Msg_Sloc := Sloc (Seen);
It1 := Disambiguate (N, I1, I, Typ);
- if It1 = No_Interp then
+ -- Disambiguation has succeeded. Skip the remaining
+ -- interpretations.
+ if It1 /= No_Interp then
+ Seen := It1.Nam;
+ Expr_Type := It1.Typ;
+
+ while Present (It.Typ) loop
+ Get_Next_Interp (I, It);
+ end loop;
+
+ else
-- Before we issue an ambiguity complaint, check for
-- the case of a subprogram call where at least one
-- of the arguments is Any_Type, and if so, suppress
@@ -1633,23 +1678,61 @@ package body Sem_Res is
Error_Msg_NE
("ambiguous expression (cannot resolve&)!",
N, It.Nam);
+
Error_Msg_N
("possible interpretation#!", N);
Ambiguous := True;
end if;
Error_Msg_Sloc := Sloc (It.Nam);
- Error_Msg_N ("possible interpretation#!", N);
- -- Disambiguation has succeeded. Skip the remaining
- -- interpretations.
- else
- Seen := It1.Nam;
- Expr_Type := It1.Typ;
+ -- By default, the error message refers to the candidate
+ -- interpretation. But if it is a predefined operator,
+ -- it is implicitly declared at the declaration of
+ -- the type of the operand. Recover the sloc of that
+ -- declaration for the error message.
+
+ if Nkind (N) in N_Op
+ and then Scope (It.Nam) = Standard_Standard
+ and then not Is_Overloaded (Right_Opnd (N))
+ and then Scope (Base_Type (Etype (Right_Opnd (N))))
+ /= Standard_Standard
+ then
+ Err_Type := First_Subtype (Etype (Right_Opnd (N)));
+
+ if Comes_From_Source (Err_Type)
+ and then Present (Parent (Err_Type))
+ then
+ Error_Msg_Sloc := Sloc (Parent (Err_Type));
+ end if;
+
+ elsif Nkind (N) in N_Binary_Op
+ and then Scope (It.Nam) = Standard_Standard
+ and then not Is_Overloaded (Left_Opnd (N))
+ and then Scope (Base_Type (Etype (Left_Opnd (N))))
+ /= Standard_Standard
+ then
+ Err_Type := First_Subtype (Etype (Left_Opnd (N)));
+
+ if Comes_From_Source (Err_Type)
+ and then Present (Parent (Err_Type))
+ then
+ Error_Msg_Sloc := Sloc (Parent (Err_Type));
+ end if;
+ else
+ Err_Type := Empty;
+ end if;
+
+ if Nkind (N) in N_Op
+ and then Scope (It.Nam) = Standard_Standard
+ and then Present (Err_Type)
+ then
+ Error_Msg_N
+ ("possible interpretation (predefined)#!", N);
+ else
+ Error_Msg_N ("possible interpretation#!", N);
+ end if;
- while Present (It.Typ) loop
- Get_Next_Interp (I, It);
- end loop;
end if;
end if;
@@ -1708,13 +1791,6 @@ package body Sem_Res is
Set_Etype (Name (N), Expr_Type);
end if;
- -- Here if interpetation is incompatible with context type
-
- else
- if Debug_Flag_V then
- Write_Str (" intepretation incompatible with context");
- Write_Eol;
- end if;
end if;
-- Move to next interpretation
@@ -1785,7 +1861,6 @@ package body Sem_Res is
elsif Nkind (N) = N_Aggregate
and then Etype (N) = Any_Composite
then
-
-- Disable expansion in any case. If there is a type mismatch
-- it may be fatal to try to expand the aggregate. The flag
-- would otherwise be set to false when the error is posted.
@@ -1822,6 +1897,10 @@ package body Sem_Res is
end if;
end Check_Aggr;
+ ----------------
+ -- Check_Elmt --
+ ----------------
+
procedure Check_Elmt (Aelmt : Node_Id) is
begin
-- If we have a nested aggregate, go inside it (to
@@ -1839,7 +1918,7 @@ package body Sem_Res is
if not Is_Overloaded (Aelmt)
and then Etype (Aelmt) /= Any_Fixed
then
- Resolve (Aelmt, Etype (Aelmt));
+ Resolve (Aelmt);
end if;
if Etype (Aelmt) = Any_Type then
@@ -2081,7 +2160,7 @@ package body Sem_Res is
Set_Is_Overloaded (N, False);
-- Freeze expression type, entity if it is a name, and designated
- -- type if it is an allocator (RM 13.14(9,10)).
+ -- type if it is an allocator (RM 13.14(10,11,13)).
-- Now that the resolution of the type of the node is complete,
-- and we did not detect an error, we can expand this node. We
@@ -2100,16 +2179,19 @@ package body Sem_Res is
Expand (N);
end if;
-
end Resolve;
+ -------------
+ -- Resolve --
+ -------------
+
-- Version with check(s) suppressed
procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
@@ -2119,16 +2201,27 @@ package body Sem_Res is
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Resolve (N, Typ);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Resolve;
+ -------------
+ -- Resolve --
+ -------------
+
+ -- Version with implicit type
+
+ procedure Resolve (N : Node_Id) is
+ begin
+ Resolve (N, Etype (N));
+ end Resolve;
+
---------------------
-- Resolve_Actuals --
---------------------
@@ -2146,6 +2239,11 @@ package body Sem_Res is
-- an instance of the default expression. The insertion is always
-- a named association.
+ function Same_Ancestor (T1, T2 : Entity_Id) return Boolean;
+ -- Check whether T1 and T2, or their full views, are derived from a
+ -- common type. Used to enforce the restrictions on array conversions
+ -- of AI95-00246.
+
--------------------
-- Insert_Default --
--------------------
@@ -2155,13 +2253,17 @@ package body Sem_Res is
Assoc : Node_Id;
begin
- -- Note that we do a full New_Copy_Tree, so that any associated
- -- Itypes are properly copied. This may not be needed any more,
- -- but it does no harm as a safety measure! Defaults of a generic
- -- formal may be out of bounds of the corresponding actual (see
- -- cc1311b) and an additional check may be required.
+ -- Missing argument in call, nothing to insert
- if Present (Default_Value (F)) then
+ if No (Default_Value (F)) then
+ return;
+
+ else
+ -- Note that we do a full New_Copy_Tree, so that any associated
+ -- Itypes are properly copied. This may not be needed any more,
+ -- but it does no harm as a safety measure! Defaults of a generic
+ -- formal may be out of bounds of the corresponding actual (see
+ -- cc1311b) and an additional check may be required.
Actval := New_Copy_Tree (Default_Value (F),
New_Scope => Current_Scope, New_Sloc => Loc);
@@ -2194,9 +2296,6 @@ package body Sem_Res is
end if;
Set_Parent (Actval, N);
- Analyze_And_Resolve (Actval, Etype (Actval));
- else
- Set_Parent (Actval, N);
-- Resolve aggregates with their base type, to avoid scope
-- anomalies: the subtype was first built in the suprogram
@@ -2209,6 +2308,28 @@ package body Sem_Res is
else
Analyze_And_Resolve (Actval, Etype (Actval));
end if;
+
+ else
+ Set_Parent (Actval, N);
+
+ -- See note above concerning aggregates.
+
+ if Nkind (Actval) = N_Aggregate
+ and then Has_Discriminants (Etype (Actval))
+ then
+ Analyze_And_Resolve (Actval, Base_Type (Etype (Actval)));
+
+ -- Resolve entities with their own type, which may differ
+ -- from the type of a reference in a generic context (the
+ -- view swapping mechanism did not anticipate the re-analysis
+ -- of default values in calls).
+
+ elsif Is_Entity_Name (Actval) then
+ Analyze_And_Resolve (Actval, Etype (Entity (Actval)));
+
+ else
+ Analyze_And_Resolve (Actval, Etype (Actval));
+ end if;
end if;
-- If default is a tag indeterminate function call, propagate
@@ -2220,9 +2341,6 @@ package body Sem_Res is
Set_Is_Controlling_Actual (Actval);
end if;
- else
- -- Missing argument in call, nothing to insert.
- return;
end if;
-- If the default expression raises constraint error, then just
@@ -2276,6 +2394,30 @@ package body Sem_Res is
Prev := Actval;
end Insert_Default;
+ -------------------
+ -- Same_Ancestor --
+ -------------------
+
+ function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is
+ FT1 : Entity_Id := T1;
+ FT2 : Entity_Id := T2;
+
+ begin
+ if Is_Private_Type (T1)
+ and then Present (Full_View (T1))
+ then
+ FT1 := Full_View (T1);
+ end if;
+
+ if Is_Private_Type (T2)
+ and then Present (Full_View (T2))
+ then
+ FT2 := Full_View (T2);
+ end if;
+
+ return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2));
+ end Same_Ancestor;
+
-- Start of processing for Resolve_Actuals
begin
@@ -2283,13 +2425,15 @@ package body Sem_Res is
F := First_Formal (Nam);
while Present (F) loop
+ if No (A) and then Needs_No_Actuals (Nam) then
+ null;
-- If we have an error in any actual or formal, indicated by
-- a type of Any_Type, then abandon resolution attempt, and
-- set result type to Any_Type.
- if (No (A) or else Etype (A) = Any_Type or else Etype (F) = Any_Type)
- and then Total_Errors_Detected /= 0
+ elsif (Present (A) and then Etype (A) = Any_Type)
+ or else Etype (F) = Any_Type
then
Set_Etype (N, Any_Type);
return;
@@ -2316,54 +2460,91 @@ package body Sem_Res is
then
if Ekind (F) = E_In_Out_Parameter
and then Is_Array_Type (Etype (F))
- and then Has_Aliased_Components (Etype (Expression (A)))
- /= Has_Aliased_Components (Etype (F))
then
- Error_Msg_N
- ("both component types in a view conversion must be"
- & " aliased, or neither", A);
+ if Has_Aliased_Components (Etype (Expression (A)))
+ /= Has_Aliased_Components (Etype (F))
+ then
+ Error_Msg_N
+ ("both component types in a view conversion must be"
+ & " aliased, or neither", A);
+
+ elsif not Same_Ancestor (Etype (F), Etype (Expression (A)))
+ and then
+ (Is_By_Reference_Type (Etype (F))
+ or else Is_By_Reference_Type (Etype (Expression (A))))
+ then
+ Error_Msg_N
+ ("view conversion between unrelated by_reference "
+ & "array types not allowed (\A\I-00246)?", A);
+ end if;
end if;
if Conversion_OK (A)
or else Valid_Conversion (A, Etype (A), Expression (A))
then
- Resolve (Expression (A), Etype (Expression (A)));
+ Resolve (Expression (A));
end if;
else
+ if Nkind (A) = N_Type_Conversion
+ and then Is_Array_Type (Etype (F))
+ and then not Same_Ancestor (Etype (F), Etype (Expression (A)))
+ and then
+ (Is_Limited_Type (Etype (F))
+ or else Is_Limited_Type (Etype (Expression (A))))
+ then
+ Error_Msg_N
+ ("Conversion between unrelated limited array types "
+ & "not allowed (\A\I-00246)?", A);
+
+ -- Disable explanation (which produces additional errors)
+ -- until AI is approved and warning becomes an error.
+
+ -- if Is_Limited_Type (Etype (F)) then
+ -- Explain_Limited_Type (Etype (F), A);
+ -- end if;
+
+ -- if Is_Limited_Type (Etype (Expression (A))) then
+ -- Explain_Limited_Type (Etype (Expression (A)), A);
+ -- end if;
+ end if;
+
Resolve (A, Etype (F));
end if;
A_Typ := Etype (A);
F_Typ := Etype (F);
- if Ekind (F) /= E_In_Parameter
- and then not Is_OK_Variable_For_Out_Formal (A)
- then
- -- Specialize error message for protected procedure call
- -- within function call of the same protected object.
-
- if Is_Entity_Name (A)
- and then Chars (Entity (A)) = Name_uObject
- and then Ekind (Current_Scope) = E_Function
- and then Convention (Current_Scope) = Convention_Protected
- and then Ekind (Nam) /= E_Function
+ -- Perform error checks for IN and IN OUT parameters
+
+ if Ekind (F) /= E_Out_Parameter then
+
+ -- Check unset reference. For scalar parameters, it is clearly
+ -- wrong to pass an uninitialized value as either an IN or
+ -- IN-OUT parameter. For composites, it is also clearly an
+ -- error to pass a completely uninitialized value as an IN
+ -- parameter, but the case of IN OUT is trickier. We prefer
+ -- not to give a warning here. For example, suppose there is
+ -- a routine that sets some component of a record to False.
+ -- It is perfectly reasonable to make this IN-OUT and allow
+ -- either initialized or uninitialized records to be passed
+ -- in this case.
+
+ -- For partially initialized composite values, we also avoid
+ -- warnings, since it is quite likely that we are passing a
+ -- partially initialized value and only the initialized fields
+ -- will in fact be read in the subprogram.
+
+ if Is_Scalar_Type (A_Typ)
+ or else (Ekind (F) = E_In_Parameter
+ and then not Is_Partially_Initialized_Type (A_Typ))
then
- Error_Msg_N ("within protected function, protected " &
- "object is constant", A);
- Error_Msg_N ("\cannot call operation that may modify it", A);
- else
- Error_Msg_NE ("actual for& must be a variable", A, F);
+ Check_Unset_Reference (A);
end if;
- end if;
- if Etype (A) = Any_Type then
- Set_Etype (N, Any_Type);
- return;
- end if;
-
- if Ekind (F) /= E_Out_Parameter then
- Check_Unset_Reference (A);
+ -- In Ada 83 we cannot pass an OUT parameter as an IN
+ -- or IN OUT actual to a nested call, since this is a
+ -- case of reading an out parameter, which is not allowed.
if Ada_83
and then Is_Entity_Name (A)
@@ -2373,6 +2554,23 @@ package body Sem_Res is
end if;
end if;
+ if Ekind (F) /= E_In_Parameter
+ and then not Is_OK_Variable_For_Out_Formal (A)
+ then
+ Error_Msg_NE ("actual for& must be a variable", A, F);
+
+ if Is_Entity_Name (A) then
+ Kill_Checks (Entity (A));
+ else
+ Kill_All_Checks;
+ end if;
+ end if;
+
+ if Etype (A) = Any_Type then
+ Set_Etype (N, Any_Type);
+ return;
+ end if;
+
-- Apply appropriate range checks for in, out, and in-out
-- parameters. Out and in-out parameters also need a separate
-- check, if there is a type conversion, to make sure the return
@@ -2421,7 +2619,6 @@ package body Sem_Res is
if Ekind (F) = E_Out_Parameter
or else Ekind (F) = E_In_Out_Parameter
then
-
if Nkind (A) = N_Type_Conversion then
if Is_Scalar_Type (A_Typ) then
Apply_Scalar_Range_Check
@@ -2536,15 +2733,21 @@ package body Sem_Res is
end if;
Prev := A;
+
+ if Ekind (F) /= E_Out_Parameter then
+ Check_Unset_Reference (A);
+ end if;
+
Next_Actual (A);
+ -- Case where actual is not present
+
else
Insert_Default;
end if;
Next_Formal (F);
end loop;
-
end Resolve_Actuals;
-----------------------
@@ -2605,6 +2808,16 @@ package body Sem_Res is
Resolve (Expression (E), Etype (E));
Check_Unset_Reference (Expression (E));
+ -- A qualified expression requires an exact match of the type,
+ -- class-wide matching is not allowed.
+
+ if (Is_Class_Wide_Type (Etype (Expression (E)))
+ or else Is_Class_Wide_Type (Etype (E)))
+ and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
+ then
+ Wrong_Type (Expression (E), Etype (E));
+ end if;
+
-- For a subtype mark or subtype indication, freeze the subtype
else
@@ -2703,11 +2916,12 @@ package body Sem_Res is
-- Used for resolving all arithmetic operators except exponentiation
procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is
- L : constant Node_Id := Left_Opnd (N);
- R : constant Node_Id := Right_Opnd (N);
- T : Entity_Id;
- TL : Entity_Id := Base_Type (Etype (L));
- TR : Entity_Id := Base_Type (Etype (R));
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+ TL : constant Entity_Id := Base_Type (Etype (L));
+ TR : constant Entity_Id := Base_Type (Etype (R));
+ T : Entity_Id;
+ Rop : Node_Id;
B_Typ : constant Entity_Id := Base_Type (Typ);
-- We do the resolution using the base type, because intermediate values
@@ -2724,9 +2938,6 @@ package body Sem_Res is
procedure Set_Operand_Type (N : Node_Id);
-- Set operand type to T if universal
- function Universal_Interpretation (N : Node_Id) return Entity_Id;
- -- Find universal type of operand, if any.
-
-----------------------------
-- Is_Integer_Or_Universal --
-----------------------------
@@ -2836,7 +3047,6 @@ package body Sem_Res is
Get_First_Interp (N, Index, It);
while Present (It.Typ) loop
-
if Base_Type (It.Typ) = Base_Type (Standard_Integer) then
if Analyzed (N) then
@@ -2868,7 +3078,7 @@ package body Sem_Res is
end if;
else
- Resolve (N, Etype (N));
+ Resolve (N);
end if;
end Set_Mixed_Mode_Operand;
@@ -2885,50 +3095,13 @@ package body Sem_Res is
end if;
end Set_Operand_Type;
- ------------------------------
- -- Universal_Interpretation --
- ------------------------------
-
- function Universal_Interpretation (N : Node_Id) return Entity_Id is
- Index : Interp_Index;
- It : Interp;
-
- begin
- if not Is_Overloaded (N) then
-
- if Etype (N) = Universal_Integer
- or else Etype (N) = Universal_Real
- then
- return Etype (N);
- else
- return Empty;
- end if;
-
- else
- Get_First_Interp (N, Index, It);
-
- while Present (It.Typ) loop
-
- if It.Typ = Universal_Integer
- or else It.Typ = Universal_Real
- then
- return It.Typ;
- end if;
-
- Get_Next_Interp (Index, It);
- end loop;
-
- return Empty;
- end if;
- end Universal_Interpretation;
-
-- Start of processing for Resolve_Arithmetic_Op
begin
if Comes_From_Source (N)
and then Ekind (Entity (N)) = E_Function
and then Is_Imported (Entity (N))
- and then Present (First_Rep_Item (Entity (N)))
+ and then Is_Intrinsic_Subprogram (Entity (N))
then
Resolve_Intrinsic_Operator (N, Typ);
return;
@@ -3072,7 +3245,7 @@ package body Sem_Res is
Set_Operand_Type (R);
end if;
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, Typ);
Eval_Arithmetic_Op (N);
-- Set overflow and division checking bit. Much cleverer code needed
@@ -3082,21 +3255,39 @@ package body Sem_Res is
if Nkind (N) in N_Op then
if not Overflow_Checks_Suppressed (Etype (N)) then
- Set_Do_Overflow_Check (N);
+ Enable_Overflow_Check (N);
end if;
+ -- Give warning if explicit division by zero
+
if (Nkind (N) = N_Op_Divide
or else Nkind (N) = N_Op_Rem
or else Nkind (N) = N_Op_Mod)
and then not Division_Checks_Suppressed (Etype (N))
then
- Set_Do_Division_Check (N);
+ Rop := Right_Opnd (N);
+
+ if Compile_Time_Known_Value (Rop)
+ and then ((Is_Integer_Type (Etype (Rop))
+ and then Expr_Value (Rop) = Uint_0)
+ or else
+ (Is_Real_Type (Etype (Rop))
+ and then Expr_Value_R (Rop) = Ureal_0))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "division by zero?", CE_Divide_By_Zero,
+ Loc => Sloc (Right_Opnd (N)));
+
+ -- Otherwise just set the flag to check at run time
+
+ else
+ Set_Do_Division_Check (N);
+ end if;
end if;
end if;
Check_Unset_Reference (L);
Check_Unset_Reference (R);
-
end Resolve_Arithmetic_Op;
------------------
@@ -3111,6 +3302,7 @@ package body Sem_Res is
It : Interp;
Norm_OK : Boolean;
Scop : Entity_Id;
+ Decl : Node_Id;
begin
-- The context imposes a unique interpretation with type Typ on
@@ -3136,7 +3328,6 @@ package body Sem_Res is
Nam := Empty;
while Present (It.Typ) loop
-
if Covers (Typ, Etype (It.Typ)) then
Nam := It.Typ;
exit;
@@ -3156,6 +3347,14 @@ package body Sem_Res is
Resolve (Subp, Nam);
end if;
+ -- For an indirect call, we always invalidate checks, since we
+ -- do not know whether the subprogram is local or global. Yes
+ -- we could do better here, e.g. by knowing that there are no
+ -- local subprograms, but it does not seem worth the effort.
+ -- Similarly, we kill al knowledge of current constant values.
+
+ Kill_Current_Values;
+
-- If this is a procedure call which is really an entry call, do
-- the conversion of the procedure call to an entry call. Protected
-- operations use the same circuitry because the name in the call
@@ -3168,6 +3367,11 @@ package body Sem_Res is
then
Resolve_Entry_Call (N, Typ);
Check_Elab_Call (N);
+
+ -- Kill checks and constant values, as above for indirect case
+ -- Who knows what happens when another task is activated?
+
+ Kill_Current_Values;
return;
-- Normal subprogram call with name established in Resolve
@@ -3219,6 +3423,51 @@ package body Sem_Res is
end;
end if;
+ -- If the subprogram is not global, then kill all checks. This is
+ -- a bit conservative, since in many cases we could do better, but
+ -- it is not worth the effort. Similarly, we kill constant values.
+ -- However we do not need to do this for internal entities (unless
+ -- they are inherited user-defined subprograms), since they are not
+ -- in the business of molesting global values.
+
+ if not Is_Library_Level_Entity (Nam)
+ and then (Comes_From_Source (Nam)
+ or else (Present (Alias (Nam))
+ and then Comes_From_Source (Alias (Nam))))
+ then
+ Kill_Current_Values;
+ end if;
+
+ -- Check for call to obsolescent subprogram
+
+ if Warn_On_Obsolescent_Feature then
+ Decl := Parent (Parent (Nam));
+
+ if Nkind (Decl) = N_Subprogram_Declaration
+ and then Is_List_Member (Decl)
+ and then Nkind (Next (Decl)) = N_Pragma
+ then
+ declare
+ P : constant Node_Id := Next (Decl);
+
+ begin
+ if Chars (P) = Name_Obsolescent then
+ Error_Msg_NE ("call to obsolescent subprogram&?", N, Nam);
+
+ if Pragma_Argument_Associations (P) /= No_List then
+ Name_Buffer (1) := '|';
+ Name_Buffer (2) := '?';
+ Name_Len := 2;
+ Add_String_To_Name_Buffer
+ (Strval (Expression
+ (First (Pragma_Argument_Associations (P)))));
+ Error_Msg_N (Name_Buffer (1 .. Name_Len), N);
+ end if;
+ end if;
+ end;
+ end if;
+ end if;
+
-- Check that a procedure call does not occur in the context
-- of the entry call statement of a conditional or timed
-- entry call. Note that the case of a call to a subprogram
@@ -3235,6 +3484,19 @@ package body Sem_Res is
Error_Msg_N ("entry call required in select statement", N);
end if;
+ -- Check that this is not a call to a protected procedure or
+ -- entry from within a protected function.
+
+ if Ekind (Current_Scope) = E_Function
+ and then Ekind (Scope (Current_Scope)) = E_Protected_Type
+ and then Ekind (Nam) /= E_Function
+ and then Scope (Nam) = Scope (Current_Scope)
+ then
+ Error_Msg_N ("within protected function, protected " &
+ "object is constant", N);
+ Error_Msg_N ("\cannot call operation that may modify it", N);
+ end if;
+
-- Freeze the subprogram name if not in default expression. Note
-- that we freeze procedure calls as well as function calls.
-- Procedure calls are not frozen according to the rules (RM
@@ -3253,7 +3515,6 @@ package body Sem_Res is
-- subprogram being called.
if Is_Predefined_Op (Nam) then
-
if Etype (N) /= Universal_Fixed then
Set_Etype (N, Typ);
end if;
@@ -3261,6 +3522,9 @@ package body Sem_Res is
-- If the subprogram returns an array type, and the context
-- requires the component type of that array type, the node is
-- really an indexing of the parameterless call. Resolve as such.
+ -- A pathological case occurs when the type of the component is
+ -- an access to the array type. In this case the call is truly
+ -- ambiguous.
elsif Needs_No_Actuals (Nam)
and then
@@ -3274,25 +3538,36 @@ package body Sem_Res is
then
declare
Index_Node : Node_Id;
+ New_Subp : Node_Id;
+ Ret_Type : constant Entity_Id := Etype (Nam);
begin
-
- if Component_Type (Etype (Nam)) /= Any_Type then
- Index_Node :=
- Make_Indexed_Component (Loc,
- Prefix =>
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Nam, Loc)),
- Expressions => Parameter_Associations (N));
-
- -- Since we are correcting a node classification error made by
- -- the parser, we call Replace rather than Rewrite.
-
- Replace (N, Index_Node);
- Set_Etype (Prefix (N), Etype (Nam));
- Set_Etype (N, Typ);
- Resolve_Indexed_Component (N, Typ);
- Check_Elab_Call (Prefix (N));
+ if Is_Access_Type (Ret_Type)
+ and then Ret_Type = Component_Type (Designated_Type (Ret_Type))
+ then
+ Error_Msg_N
+ ("cannot disambiguate function call and indexing", N);
+ else
+ New_Subp := Relocate_Node (Subp);
+ Set_Entity (Subp, Nam);
+
+ if Component_Type (Ret_Type) /= Any_Type then
+ Index_Node :=
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Function_Call (Loc,
+ Name => New_Subp),
+ Expressions => Parameter_Associations (N));
+
+ -- Since we are correcting a node classification error made
+ -- by the parser, we call Replace rather than Rewrite.
+
+ Replace (N, Index_Node);
+ Set_Etype (Prefix (N), Ret_Type);
+ Set_Etype (N, Typ);
+ Resolve_Indexed_Component (N, Typ);
+ Check_Elab_Call (Prefix (N));
+ end if;
end if;
return;
@@ -3391,8 +3666,9 @@ package body Sem_Res is
return;
end if;
- -- Create a transient scope if the resulting type requires it.
- -- There are 3 notable exceptions: in init_procs, the transient scope
+ -- Create a transient scope if the resulting type requires it
+
+ -- There are 3 notable exceptions: in init procs, the transient scope
-- overhead is not needed and even incorrect due to the actual expansion
-- of adjust calls; the second case is enumeration literal pseudo calls,
-- the other case is intrinsic subprograms (Unchecked_Conversion and
@@ -3401,7 +3677,7 @@ package body Sem_Res is
-- If this is an initialization call for a type whose initialization
-- uses the secondary stack, we also need to create a transient scope
- -- for it, precisely because we will not do it within the init_proc
+ -- for it, precisely because we will not do it within the init proc
-- itself.
if Expander_Active
@@ -3414,7 +3690,7 @@ package body Sem_Res is
Establish_Transient_Scope
(N, Sec_Stack => not Functions_Return_By_DSP_On_Target);
- elsif Chars (Nam) = Name_uInit_Proc
+ elsif Is_Init_Proc (Nam)
and then not Within_Init_Proc
then
Check_Initialization_Call (N, Nam);
@@ -3445,7 +3721,7 @@ package body Sem_Res is
Copy_Node (Subp, N);
Resolve_Entity_Name (N, Typ);
- -- Avoid validation, since it is a static function call.
+ -- Avoid validation, since it is a static function call
return;
end if;
@@ -3471,7 +3747,6 @@ package body Sem_Res is
-- If we fall through we definitely have a non-static call
Check_Elab_Call (N);
-
end Resolve_Call;
-------------------------------
@@ -3539,7 +3814,6 @@ package body Sem_Res is
Error_Msg_NE
("character not defined for }", N, First_Subtype (B_Typ));
-
end Resolve_Character_Literal;
---------------------------
@@ -3547,7 +3821,9 @@ package body Sem_Res is
---------------------------
-- Context requires a boolean type, and plays no role in resolution.
- -- Processing identical to that for equality operators.
+ -- Processing identical to that for equality operators. The result
+ -- type is the base type, which matters when pathological subtypes of
+ -- booleans with limited ranges are used.
procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is
L : constant Node_Id := Left_Opnd (N);
@@ -3570,11 +3846,10 @@ package body Sem_Res is
end if;
end if;
- Set_Etype (N, Typ);
+ Set_Etype (N, Base_Type (Typ));
Generate_Reference (T, N, ' ');
if T /= Any_Type then
-
if T = Any_String
or else T = Any_Composite
or else T = Any_Character
@@ -3600,11 +3875,10 @@ package body Sem_Res is
Resolve (R, T);
Check_Unset_Reference (L);
Check_Unset_Reference (R);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, T);
Eval_Relational_Op (N);
end if;
end if;
-
end Resolve_Comparison_Op;
------------------------------------
@@ -3697,8 +3971,8 @@ package body Sem_Res is
-- away if either bounds of R are a Constraint_Error.
declare
- L : Node_Id := Low_Bound (R);
- H : Node_Id := High_Bound (R);
+ L : constant Node_Id := Low_Bound (R);
+ H : constant Node_Id := High_Bound (R);
begin
if Nkind (L) = N_Raise_Constraint_Error then
@@ -3839,10 +4113,10 @@ package body Sem_Res is
-----------------------
function Actual_Index_Type (E : Entity_Id) return Entity_Id is
- Typ : Entity_Id := Entry_Index_Type (E);
- Tsk : Entity_Id := Scope (E);
- Lo : Node_Id := Type_Low_Bound (Typ);
- Hi : Node_Id := Type_High_Bound (Typ);
+ Typ : constant Entity_Id := Entry_Index_Type (E);
+ Tsk : constant Entity_Id := Scope (E);
+ Lo : constant Node_Id := Type_Low_Bound (Typ);
+ Hi : constant Node_Id := Type_High_Bound (Typ);
New_T : Entity_Id;
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
@@ -3858,7 +4132,7 @@ package body Sem_Res is
-----------------------------
function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
- Typ : Entity_Id := Etype (Bound);
+ Typ : constant Entity_Id := Etype (Bound);
Ref : Node_Id;
begin
@@ -3986,10 +4260,10 @@ package body Sem_Res is
-- protected type.
declare
- Pref : Node_Id := Prefix (Entry_Name);
+ Pref : constant Node_Id := Prefix (Entry_Name);
+ Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name));
I : Interp_Index;
It : Interp;
- Ent : Entity_Id := Entity (Selector_Name (Entry_Name));
begin
Get_First_Interp (Pref, I, It);
@@ -4007,13 +4281,11 @@ package body Sem_Res is
end if;
if Nkind (Entry_Name) = N_Selected_Component then
- Resolve (Prefix (Entry_Name), Etype (Prefix (Entry_Name)));
+ Resolve (Prefix (Entry_Name));
else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
Nam := Entity (Selector_Name (Prefix (Entry_Name)));
- Resolve (Prefix (Prefix (Entry_Name)),
- Etype (Prefix (Prefix (Entry_Name))));
-
+ Resolve (Prefix (Prefix (Entry_Name)));
Index := First (Expressions (Entry_Name));
Resolve (Index, Entry_Index_Type (Nam));
@@ -4026,7 +4298,6 @@ package body Sem_Res is
Apply_Range_Check (Index, Actual_Index_Type (Nam));
end if;
end if;
-
end Resolve_Entry;
------------------------
@@ -4044,6 +4315,11 @@ package body Sem_Res is
Was_Over : Boolean;
begin
+ -- We kill all checks here, because it does not seem worth the
+ -- effort to do anything better, an entry call is a big operation.
+
+ Kill_All_Checks;
+
-- Processing of the name is similar for entry calls and protected
-- operation calls. Once the entity is determined, we can complete
-- the resolution of the actuals.
@@ -4096,6 +4372,14 @@ package body Sem_Res is
Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name)));
end if;
+ -- We cannot in general check the maximum depth of protected entry
+ -- calls at compile time. But we can tell that any protected entry
+ -- call at all violates a specified nesting depth of zero.
+
+ if Is_Protected_Type (Scope (Nam)) then
+ Check_Restriction (Max_Entry_Queue_Depth, N);
+ end if;
+
-- Use context type to disambiguate a protected function that can be
-- called without actuals and that returns an array type, and where
-- the argument list may be an indexing of the returned value.
@@ -4135,11 +4419,13 @@ package body Sem_Res is
end if;
-- The operation name may have been overloaded. Order the actuals
- -- according to the formals of the resolved entity.
+ -- according to the formals of the resolved entity, and set the
+ -- return type to that of the operation.
if Was_Over then
Normalize_Actuals (N, Nam, False, Norm_OK);
pragma Assert (Norm_OK);
+ Set_Etype (N, Etype (Nam));
end if;
Resolve_Actuals (N, Nam);
@@ -4155,7 +4441,6 @@ package body Sem_Res is
-- call where an entry call is expected.
if Ekind (Nam) = E_Procedure then
-
if Nkind (Parent (N)) = N_Entry_Call_Alternative
and then N = Entry_Call_Statement (Parent (N))
then
@@ -4215,7 +4500,6 @@ package body Sem_Res is
Establish_Transient_Scope (N,
Sec_Stack => not Functions_Return_By_DSP_On_Target);
end if;
-
end Resolve_Entry_Call;
-------------------------
@@ -4330,9 +4614,19 @@ package body Sem_Res is
Resolve (L, T);
Resolve (R, T);
+
+ if Warn_On_Redundant_Constructs
+ and then Comes_From_Source (N)
+ and then Is_Entity_Name (R)
+ and then Entity (R) = Standard_True
+ and then Comes_From_Source (R)
+ then
+ Error_Msg_N ("comparison with True is redundant?", R);
+ end if;
+
Check_Unset_Reference (L);
Check_Unset_Reference (R);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, T);
-- If this is an inequality, it may be the implicit inequality
-- created for a user-defined operation, in which case the corres-
@@ -4391,7 +4685,7 @@ package body Sem_Res is
Set_Etype (N, Designated_Type (It.Typ));
else
- Resolve (P, Etype (P));
+ Resolve (P);
end if;
if Is_Access_Type (Etype (P)) then
@@ -4529,7 +4823,6 @@ package body Sem_Res is
end if;
Eval_Indexed_Component (N);
-
end Resolve_Indexed_Component;
-----------------------------
@@ -4547,9 +4840,10 @@ package body Sem_Res is
---------------------------------
procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is
- Op : Entity_Id;
- Arg1 : Node_Id := Left_Opnd (N);
- Arg2 : Node_Id := Right_Opnd (N);
+ Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
+ Op : Entity_Id;
+ Arg1 : Node_Id;
+ Arg2 : Node_Id;
begin
Op := Entity (N);
@@ -4561,17 +4855,94 @@ package body Sem_Res is
Set_Entity (N, Op);
- if Typ /= Etype (Arg1) or else Typ = Etype (Arg2) then
- Rewrite (Left_Opnd (N), Convert_To (Typ, Arg1));
- Rewrite (Right_Opnd (N), Convert_To (Typ, Arg2));
+ -- If the operand type is private, rewrite with suitable
+ -- conversions on the operands and the result, to expose
+ -- the proper underlying numeric type.
- Analyze (Left_Opnd (N));
- Analyze (Right_Opnd (N));
- end if;
+ if Is_Private_Type (Typ) then
+ Arg1 := Unchecked_Convert_To (Btyp, Left_Opnd (N));
+
+ if Nkind (N) = N_Op_Expon then
+ Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N));
+ else
+ Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
+ end if;
+
+ Save_Interps (Left_Opnd (N), Expression (Arg1));
+ Save_Interps (Right_Opnd (N), Expression (Arg2));
- Resolve_Arithmetic_Op (N, Typ);
+ Set_Left_Opnd (N, Arg1);
+ Set_Right_Opnd (N, Arg2);
+
+ Set_Etype (N, Btyp);
+ Rewrite (N, Unchecked_Convert_To (Typ, N));
+ Resolve (N, Typ);
+
+ elsif Typ /= Etype (Left_Opnd (N))
+ or else Typ /= Etype (Right_Opnd (N))
+ then
+ -- Add explicit conversion where needed, and save interpretations
+ -- if operands are overloaded.
+
+ Arg1 := Convert_To (Typ, Left_Opnd (N));
+ Arg2 := Convert_To (Typ, Right_Opnd (N));
+
+ if Nkind (Arg1) = N_Type_Conversion then
+ Save_Interps (Left_Opnd (N), Expression (Arg1));
+ end if;
+
+ if Nkind (Arg2) = N_Type_Conversion then
+ Save_Interps (Right_Opnd (N), Expression (Arg2));
+ end if;
+
+ Rewrite (Left_Opnd (N), Arg1);
+ Rewrite (Right_Opnd (N), Arg2);
+ Analyze (Arg1);
+ Analyze (Arg2);
+ Resolve_Arithmetic_Op (N, Typ);
+
+ else
+ Resolve_Arithmetic_Op (N, Typ);
+ end if;
end Resolve_Intrinsic_Operator;
+ --------------------------------------
+ -- Resolve_Intrinsic_Unary_Operator --
+ --------------------------------------
+
+ procedure Resolve_Intrinsic_Unary_Operator
+ (N : Node_Id;
+ Typ : Entity_Id)
+ is
+ Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
+ Op : Entity_Id;
+ Arg2 : Node_Id;
+
+ begin
+ Op := Entity (N);
+
+ while Scope (Op) /= Standard_Standard loop
+ Op := Homonym (Op);
+ pragma Assert (Present (Op));
+ end loop;
+
+ Set_Entity (N, Op);
+
+ if Is_Private_Type (Typ) then
+ Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N));
+ Save_Interps (Right_Opnd (N), Expression (Arg2));
+
+ Set_Right_Opnd (N, Arg2);
+
+ Set_Etype (N, Btyp);
+ Rewrite (N, Unchecked_Convert_To (Typ, N));
+ Resolve (N, Typ);
+
+ else
+ Resolve_Unary_Op (N, Typ);
+ end if;
+ end Resolve_Intrinsic_Unary_Operator;
+
------------------------
-- Resolve_Logical_Op --
------------------------
@@ -4620,7 +4991,7 @@ package body Sem_Res is
Check_Unset_Reference (Right_Opnd (N));
Set_Etype (N, B_Typ);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Logical_Op (N);
end Resolve_Logical_Op;
@@ -4798,6 +5169,10 @@ package body Sem_Res is
Resolve (Arg, Component_Type (Typ));
+ if Nkind (Arg) = N_String_Literal then
+ Set_Etype (Arg, Component_Type (Typ));
+ end if;
+
if Arg = Left_Opnd (N) then
Set_Is_Component_Left_Opnd (N);
else
@@ -4819,6 +5194,7 @@ package body Sem_Res is
if Is_Limited_Composite (Btyp) then
Error_Msg_N ("concatenation not available for limited array", N);
+ Explain_Limited_Type (Btyp, N);
end if;
-- If the operands are themselves concatenations, resolve them as
@@ -4845,7 +5221,7 @@ package body Sem_Res is
(Op2, Is_Component_Right_Opnd (N));
end if;
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, Typ);
if Is_String_Type (Typ) then
Eval_Concatenation (N);
@@ -4880,6 +5256,15 @@ package body Sem_Res is
return;
end if;
+ if Comes_From_Source (N)
+ and then Ekind (Entity (N)) = E_Function
+ and then Is_Imported (Entity (N))
+ and then Is_Intrinsic_Subprogram (Entity (N))
+ then
+ Resolve_Intrinsic_Operator (N, Typ);
+ return;
+ end if;
+
if Etype (Left_Opnd (N)) = Universal_Integer
or else Etype (Left_Opnd (N)) = Universal_Real
then
@@ -4896,7 +5281,7 @@ package body Sem_Res is
Check_Unset_Reference (Right_Opnd (N));
Set_Etype (N, B_Typ);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Op_Expon (N);
-- Set overflow checking bit. Much cleverer code needed here eventually
@@ -4905,10 +5290,9 @@ package body Sem_Res is
if Nkind (N) in N_Op then
if not Overflow_Checks_Suppressed (Etype (N)) then
- Set_Do_Overflow_Check (N, True);
+ Enable_Overflow_Check (N);
end if;
end if;
-
end Resolve_Op_Expon;
--------------------
@@ -4971,9 +5355,7 @@ package body Sem_Res is
Set_Etype (N, Any_Type);
return;
- elsif (Typ = Universal_Integer
- or else Typ = Any_Modular)
- then
+ elsif Typ = Universal_Integer or else Typ = Any_Modular then
if Parent_Is_Boolean then
Error_Msg_N
("operand of not must be enclosed in parentheses",
@@ -4996,7 +5378,7 @@ package body Sem_Res is
Resolve (Right_Opnd (N), B_Typ);
Check_Unset_Reference (Right_Opnd (N));
Set_Etype (N, B_Typ);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Op_Not (N);
end if;
end Resolve_Op_Not;
@@ -5077,6 +5459,21 @@ package body Sem_Res is
Check_Non_Static_Context (L);
Check_Non_Static_Context (H);
+ -- If bounds are static, constant-fold them, so size computations
+ -- are identical between front-end and back-end. Do not perform this
+ -- transformation while analyzing generic units, as type information
+ -- would then be lost when reanalyzing the constant node in the
+ -- instance.
+
+ if Is_Discrete_Type (Typ) and then Expander_Active then
+ if Is_OK_Static_Expression (L) then
+ Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L));
+ end if;
+
+ if Is_OK_Static_Expression (H) then
+ Fold_Uint (H, Expr_Value (H), Is_Static_Expression (H));
+ end if;
+ end if;
end Resolve_Range;
--------------------------
@@ -5165,7 +5562,7 @@ package body Sem_Res is
-- result in transformations of normal assignments into reference
-- sequences that otherwise fail to notice the modification.
- if Is_Entity_Name (P) and then Is_Volatile (Entity (P)) then
+ if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then
Note_Possible_Modification (P);
end if;
end Resolve_Reference;
@@ -5188,7 +5585,7 @@ package body Sem_Res is
function Init_Component return Boolean;
-- Check whether this is the initialization of a component within an
- -- init_proc (by assignment or call to another init_proc). If true,
+ -- init proc (by assignment or call to another init proc). If true,
-- there is no need for a discriminant check.
--------------------
@@ -5272,7 +5669,6 @@ package body Sem_Res is
end if;
Get_Next_Interp (I, It);
-
end loop Search;
Resolve (P, It1.Typ);
@@ -5280,7 +5676,7 @@ package body Sem_Res is
Set_Entity (S, Comp1);
else
- -- Resolve prefix with its type.
+ -- Resolve prefix with its type
Resolve (P, T);
end if;
@@ -5295,6 +5691,9 @@ package body Sem_Res is
end if;
if Has_Discriminants (T)
+ and then (Ekind (Entity (S)) = E_Component
+ or else
+ Ekind (Entity (S)) = E_Discriminant)
and then Present (Original_Record_Component (Entity (S)))
and then Ekind (Original_Record_Component (Entity (S))) = E_Component
and then Present (Discriminant_Checking_Func
@@ -5315,6 +5714,7 @@ package body Sem_Res is
if Nkind (P) = N_Type_Conversion
and then Ekind (Entity (S)) = E_Discriminant
+ and then Is_Discrete_Type (Typ)
then
Set_Etype (N, Base_Type (Typ));
end if;
@@ -5344,7 +5744,7 @@ package body Sem_Res is
Check_Unset_Reference (R);
Set_Etype (N, B_Typ);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Shift (N);
end Resolve_Shift;
@@ -5460,7 +5860,6 @@ package body Sem_Res is
Set_Slice_Subtype (N);
Eval_Slice (N);
-
end Resolve_Slice;
----------------------------
@@ -5655,7 +6054,7 @@ package body Sem_Res is
-- heavy artillery for this situation, but it is hard work to avoid.
declare
- Lits : List_Id := New_List;
+ Lits : constant List_Id := New_List;
P : Source_Ptr := Loc + 1;
C : Char_Code;
@@ -5710,6 +6109,8 @@ package body Sem_Res is
Operand : Node_Id;
Opnd_Type : Entity_Id;
Rop : Node_Id;
+ Orig_N : Node_Id;
+ Orig_T : Node_Id;
begin
Operand := Expression (N);
@@ -5764,7 +6165,7 @@ package body Sem_Res is
end if;
Opnd_Type := Etype (Operand);
- Resolve (Operand, Opnd_Type);
+ Resolve (Operand);
-- Note: we do the Eval_Type_Conversion call before applying the
-- required checks for a subtype conversion. This is important,
@@ -5792,16 +6193,34 @@ package body Sem_Res is
end if;
-- Issue warning for conversion of simple object to its own type
+ -- We have to test the original nodes, since they may have been
+ -- rewritten by various optimizations.
+
+ Orig_N := Original_Node (N);
if Warn_On_Redundant_Constructs
- and then Comes_From_Source (N)
- and then Nkind (N) = N_Type_Conversion
- and then Is_Entity_Name (Expression (N))
- and then Etype (Entity (Expression (N))) = Target_Type
+ and then Comes_From_Source (Orig_N)
+ and then Nkind (Orig_N) = N_Type_Conversion
then
- Error_Msg_NE
- ("?useless conversion, & has this type",
- N, Entity (Expression (N)));
+ Orig_N := Original_Node (Expression (Orig_N));
+ Orig_T := Target_Type;
+
+ -- If the node is part of a larger expression, the Target_Type
+ -- may not be the original type of the node if the context is a
+ -- condition. Recover original type to see if conversion is needed.
+
+ if Is_Boolean_Type (Orig_T)
+ and then Nkind (Parent (N)) in N_Op
+ then
+ Orig_T := Etype (Parent (N));
+ end if;
+
+ if Is_Entity_Name (Orig_N)
+ and then Etype (Entity (Orig_N)) = Orig_T
+ then
+ Error_Msg_NE
+ ("?useless conversion, & has this type", N, Entity (Orig_N));
+ end if;
end if;
end Resolve_Type_Conversion;
@@ -5810,30 +6229,57 @@ package body Sem_Res is
----------------------
procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is
- B_Typ : Entity_Id := Base_Type (Typ);
- R : constant Node_Id := Right_Opnd (N);
+ B_Typ : constant Entity_Id := Base_Type (Typ);
+ R : constant Node_Id := Right_Opnd (N);
+ OK : Boolean;
+ Lo : Uint;
+ Hi : Uint;
begin
+ -- Generate warning for expressions like abs (x mod 2)
+
+ if Warn_On_Redundant_Constructs
+ and then Nkind (N) = N_Op_Abs
+ then
+ Determine_Range (Right_Opnd (N), OK, Lo, Hi);
+
+ if OK and then Hi >= Lo and then Lo >= 0 then
+ Error_Msg_N
+ ("?abs applied to known non-negative value has no effect", N);
+ end if;
+ end if;
+
-- Generate warning for expressions like -5 mod 3
if Paren_Count (N) = 0
and then Nkind (N) = N_Op_Minus
and then Nkind (Right_Opnd (N)) = N_Op_Mod
+ and then Comes_From_Source (N)
then
Error_Msg_N
("?unary minus expression should be parenthesized here", N);
end if;
+ if Comes_From_Source (N)
+ and then Ekind (Entity (N)) = E_Function
+ and then Is_Imported (Entity (N))
+ and then Is_Intrinsic_Subprogram (Entity (N))
+ then
+ Resolve_Intrinsic_Unary_Operator (N, Typ);
+ return;
+ end if;
+
if Etype (R) = Universal_Integer
- or else Etype (R) = Universal_Real
+ or else Etype (R) = Universal_Real
then
Check_For_Visible_Operator (N, B_Typ);
end if;
Set_Etype (N, B_Typ);
Resolve (R, B_Typ);
+
Check_Unset_Reference (R);
- Generate_Operator_Reference (N);
+ Generate_Operator_Reference (N, B_Typ);
Eval_Unary_Op (N);
-- Set overflow checking bit. Much cleverer code needed here eventually
@@ -5842,10 +6288,9 @@ package body Sem_Res is
if Nkind (N) in N_Op then
if not Overflow_Checks_Suppressed (Etype (N)) then
- Set_Do_Overflow_Check (N, True);
+ Enable_Overflow_Check (N);
end if;
end if;
-
end Resolve_Unary_Op;
----------------------------------
@@ -5887,8 +6332,8 @@ package body Sem_Res is
------------------------------
procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is
- Loc : Source_Ptr := Sloc (N);
- Actuals : List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (N);
+ Actuals : constant List_Id := New_List;
New_N : Node_Id;
begin
@@ -5919,17 +6364,21 @@ package body Sem_Res is
Op_Node : Node_Id;
begin
- if Chars (N) /= Nam then
-
- -- Rewrite the operator node using the real operator, not its
- -- renaming.
+ -- Rewrite the operator node using the real operator, not its
+ -- renaming. Exclude user-defined intrinsic operations, which
+ -- are treated separately.
+ if Ekind (Op) /= E_Function then
Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N));
Set_Chars (Op_Node, Nam);
Set_Etype (Op_Node, Etype (N));
Set_Entity (Op_Node, Op);
Set_Right_Opnd (Op_Node, Right_Opnd (N));
+ -- Indicate that both the original entity and its renaming
+ -- are referenced at this point.
+
+ Generate_Reference (Entity (N), N);
Generate_Reference (Op, N);
if Is_Binary then
@@ -5953,8 +6402,8 @@ package body Sem_Res is
procedure Set_Slice_Subtype (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Index_List : constant List_Id := New_List;
Index : Node_Id;
- Index_List : List_Id := New_List;
Index_Subtype : Entity_Id;
Index_Type : Entity_Id;
Slice_Subtype : Entity_Id;
@@ -6072,10 +6521,9 @@ package body Sem_Res is
T1 := Standard_Duration;
- Scop := Current_Scope;
-
-- Look for fixed-point types in enclosing scopes.
+ Scop := Current_Scope;
while Scop /= Standard_Standard loop
T2 := First_Entity (Scop);
@@ -6103,7 +6551,6 @@ package body Sem_Res is
Item := First (Context_Items (Cunit (Current_Sem_Unit)));
while Present (Item) loop
-
if Nkind (Item) = N_With_Clause then
Scop := Entity (Name (Item));
T2 := First_Entity (Scop);
@@ -6149,7 +6596,7 @@ package body Sem_Res is
Operand : Node_Id)
return Boolean
is
- Target_Type : Entity_Id := Base_Type (Target);
+ Target_Type : constant Entity_Id := Base_Type (Target);
Opnd_Type : Entity_Id := Etype (Operand);
function Conversion_Check
@@ -6315,14 +6762,16 @@ package body Sem_Res is
else
declare
- Target_Index : Node_Id := First_Index (Target_Type);
- Opnd_Index : Node_Id := First_Index (Opnd_Type);
+ Target_Index : Node_Id := First_Index (Target_Type);
+ Opnd_Index : Node_Id := First_Index (Opnd_Type);
Target_Index_Type : Entity_Id;
Opnd_Index_Type : Entity_Id;
- Target_Comp_Type : Entity_Id := Component_Type (Target_Type);
- Opnd_Comp_Type : Entity_Id := Component_Type (Opnd_Type);
+ Target_Comp_Type : constant Entity_Id :=
+ Component_Type (Target_Type);
+ Opnd_Comp_Type : constant Entity_Id :=
+ Component_Type (Opnd_Type);
begin
while Present (Target_Index) and then Present (Opnd_Index) loop
diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads
index 1205ce15f6b..895b54dbb67 100644
--- a/gcc/ada/sem_res.ads
+++ b/gcc/ada/sem_res.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-1999 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- --
@@ -28,8 +28,7 @@
-- package Sem_Aggr contains the actual resolution routines for aggregates,
-- which are separated off since aggregate processing is complex.
-with Snames; use Snames;
-with Types; use Types;
+with Types; use Types;
package Sem_Res is
@@ -46,7 +45,7 @@ package Sem_Res is
-- Since in practice a lot of semantic analysis has to be postponed until
-- types are known (e.g. static folding, setting of suppress flags), the
- -- Resolve routines also complete the semantic analyze, and also call the
+ -- Resolve routines also complete the semantic analysis, and call the
-- expander for possibly expansion of the completely type resolved node.
procedure Resolve (N : Node_Id; Typ : Entity_Id);
@@ -59,6 +58,13 @@ package Sem_Res is
-- If a Suppress argument is present, then the resolution is done with the
-- specified check suppressed (can be All_Checks to suppress all checks).
+ procedure Resolve (N : Node_Id);
+ pragma Inline (Resolve);
+ -- A version of Resolve where the type to be used for resolution is
+ -- taken from the Etype (N). This is commonly used in cases where the
+ -- context does not add anything and the first pass of analysis found
+ -- the correct expected type.
+
procedure Resolve_Discrete_Subtype_Indication
(N : Node_Id;
Typ : Entity_Id);
@@ -92,8 +98,7 @@ package Sem_Res is
-- Several forms of names can denote calls to entities without para-
-- meters. The context determines whether the name denotes the entity
-- or a call to it. When it is a call, the node must be rebuilt
- -- accordingly (deprocedured, in A68 terms) and renalyzed to obtain
- -- possible interpretations.
+ -- accordingly and renalyzed to obtain possible interpretations.
--
-- The name may be that of an overloadable construct, or it can be an
-- explicit dereference of a prefix that denotes an access to subprogram.
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index 8666ae706ee..105dc53bc55 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -25,6 +25,7 @@
------------------------------------------------------------------------------
with Atree; use Atree;
+with Alloc;
with Debug; use Debug;
with Einfo; use Einfo;
with Errout; use Errout;
@@ -38,10 +39,70 @@ with Sem_Util; use Sem_Util;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Snames; use Snames;
+with Table;
with Uintp; use Uintp;
package body Sem_Type is
+ ---------------------
+ -- Data Structures --
+ ---------------------
+
+ -- The following data structures establish a mapping between nodes and
+ -- their interpretations. An overloaded node has an entry in Interp_Map,
+ -- which in turn contains a pointer into the All_Interp array. The
+ -- interpretations of a given node are contiguous in All_Interp. Each
+ -- set of interpretations is terminated with the marker No_Interp.
+ -- In order to speed up the retrieval of the interpretations of an
+ -- overloaded node, the Interp_Map table is accessed by means of a simple
+ -- hashing scheme, and the entries in Interp_Map are chained. The heads
+ -- of clash lists are stored in array Headers.
+
+ -- Headers Interp_Map All_Interp
+ --
+ -- _ ------- ----------
+ -- |_| |_____| --->|interp1 |
+ -- |_|---------->|node | | |interp2 |
+ -- |_| |index|---------| |nointerp|
+ -- |_| |next | | |
+ -- |-----| | |
+ -- ------- ----------
+
+ -- This scheme does not currently reclaim interpretations. In principle,
+ -- after a unit is compiled, all overloadings have been resolved, and the
+ -- candidate interpretations should be deleted. This should be easier
+ -- now than with the previous scheme???
+
+ package All_Interp is new Table.Table (
+ Table_Component_Type => Interp,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => Alloc.All_Interp_Initial,
+ Table_Increment => Alloc.All_Interp_Increment,
+ Table_Name => "All_Interp");
+
+ type Interp_Ref is record
+ Node : Node_Id;
+ Index : Interp_Index;
+ Next : Int;
+ end record;
+
+ Header_Size : constant Int := 2 ** 12;
+ No_Entry : constant Int := -1;
+ Headers : array (0 .. Header_Size) of Int := (others => No_Entry);
+
+ package Interp_Map is new Table.Table (
+ Table_Component_Type => Interp_Ref,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => Alloc.Interp_Map_Initial,
+ Table_Increment => Alloc.Interp_Map_Increment,
+ Table_Name => "Interp_Map");
+
+ function Hash (N : Node_Id) return Int;
+ -- A trivial hashing function for nodes, used to insert an overloaded
+ -- node into the Interp_Map table.
+
-------------------------------------
-- Handling of Overload Resolution --
-------------------------------------
@@ -95,8 +156,11 @@ package body Sem_Type is
pragma Warnings (Off, All_Overloads);
-- Debugging procedure: list full contents of Overloads table.
- function Universal_Interpretation (Opnd : Node_Id) return Entity_Id;
- -- Yields universal_Integer or Universal_Real if this is a candidate.
+ procedure New_Interps (N : Node_Id);
+ -- Initialize collection of interpretations for the given node, which is
+ -- either an overloaded entity, or an operation whose arguments have
+ -- multiple intepretations. Interpretations can be added to only one
+ -- node at a time.
function Specific_Type (T1, T2 : Entity_Id) return Entity_Id;
-- If T1 and T2 are compatible, return the one that is not
@@ -211,7 +275,6 @@ package body Sem_Type is
All_Interp.Table (All_Interp.Last) := (Name, Typ);
All_Interp.Increment_Last;
All_Interp.Table (All_Interp.Last) := No_Interp;
-
end Add_Entry;
----------------------------
@@ -341,7 +404,9 @@ package body Sem_Type is
-- node. In both cases add a new interpretation to the table.
elsif Interp_Map.Last < 0
- or else Interp_Map.Table (Interp_Map.Last).Node /= N
+ or else
+ (Interp_Map.Table (Interp_Map.Last).Node /= N
+ and then not Is_Overloaded (N))
then
New_Interps (N);
@@ -359,7 +424,7 @@ package body Sem_Type is
else
-- Overloaded prefix in indexed or selected component,
- -- or call whose name is an expression or another call.
+ -- or call whose name is an expresion or another call.
Add_Entry (Etype (N), Etype (N));
end if;
@@ -522,6 +587,30 @@ package body Sem_Type is
------------
function Covers (T1, T2 : Entity_Id) return Boolean is
+
+ function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean;
+ -- In an instance the proper view may not always be correct for
+ -- private types, but private and full view are compatible. This
+ -- removes spurious errors from nested instantiations that involve,
+ -- among other things, types derived from private types.
+
+ ----------------------
+ -- Full_View_Covers --
+ ----------------------
+
+ function Full_View_Covers (Typ1, Typ2 : Entity_Id) return Boolean is
+ begin
+ return
+ Is_Private_Type (Typ1)
+ and then
+ ((Present (Full_View (Typ1))
+ and then Covers (Full_View (Typ1), Typ2))
+ or else Base_Type (Typ1) = Typ2
+ or else Base_Type (Typ2) = Typ1);
+ end Full_View_Covers;
+
+ -- Start of processing for Covers
+
begin
-- If either operand missing, then this is an error, but ignore
-- it (and pretend we have a cover) if errors already detected,
@@ -642,6 +731,10 @@ package body Sem_Type is
then
return True;
+ -- The context can be a remote access type, and the expression the
+ -- corresponding source type declared in a categorized package, or
+ -- viceversa.
+
elsif Is_Record_Type (T1)
and then (Is_Remote_Call_Interface (T1)
or else Is_Remote_Types (T1))
@@ -649,6 +742,13 @@ package body Sem_Type is
then
return Covers (Corresponding_Remote_Type (T1), T2);
+ elsif Is_Record_Type (T2)
+ and then (Is_Remote_Call_Interface (T2)
+ or else Is_Remote_Types (T2))
+ and then Present (Corresponding_Remote_Type (T2))
+ then
+ return Covers (Corresponding_Remote_Type (T2), T1);
+
elsif Ekind (T2) = E_Access_Attribute_Type
and then (Ekind (Base_Type (T1)) = E_General_Access_Type
or else Ekind (Base_Type (T1)) = E_Access_Type)
@@ -665,9 +765,11 @@ package body Sem_Type is
elsif Ekind (T2) = E_Allocator_Type
and then Is_Access_Type (T1)
- and then Covers (Designated_Type (T1), Designated_Type (T2))
then
- return True;
+ return Covers (Designated_Type (T1), Designated_Type (T2))
+ or else
+ (From_With_Type (Designated_Type (T1))
+ and then Covers (Designated_Type (T2), Designated_Type (T1)));
-- A boolean operation on integer literals is compatible with a
-- modular context.
@@ -701,17 +803,10 @@ package body Sem_Type is
then
return True;
- -- In an instance the proper view may not always be correct for
- -- private types, but private and full view are compatible. This
- -- removes spurious errors from nested instantiations that involve,
- -- among other things, types derived from privated types.
-
elsif In_Instance
- and then Is_Private_Type (T1)
- and then ((Present (Full_View (T1))
- and then Covers (Full_View (T1), T2))
- or else Base_Type (T1) = T2
- or else Base_Type (T2) = T1)
+ and then
+ (Full_View_Covers (T1, T2)
+ or else Full_View_Covers (T2, T1))
then
return True;
@@ -729,6 +824,37 @@ package body Sem_Type is
then
return True;
+ elsif From_With_Type (T1) then
+
+ -- If the expected type is the non-limited view of a type, the
+ -- expression may have the limited view.
+
+ if Ekind (T1) = E_Incomplete_Type then
+ return Covers (Non_Limited_View (T1), T2);
+
+ elsif Ekind (T1) = E_Class_Wide_Type then
+ return
+ Covers (Class_Wide_Type (Non_Limited_View (Etype (T1))), T2);
+ else
+ return False;
+ end if;
+
+ elsif From_With_Type (T2) then
+
+ -- If units in the context have Limited_With clauses on each other,
+ -- either type might have a limited view. Checks performed elsewhere
+ -- verify that the context type is the non-limited view.
+
+ if Ekind (T2) = E_Incomplete_Type then
+ return Covers (T1, Non_Limited_View (T2));
+
+ elsif Ekind (T2) = E_Class_Wide_Type then
+ return
+ Covers (T1, Class_Wide_Type (Non_Limited_View (Etype (T2))));
+ else
+ return False;
+ end if;
+
-- Otherwise it doesn't cover!
else
@@ -753,6 +879,12 @@ package body Sem_Type is
Predef_Subp : Entity_Id;
User_Subp : Entity_Id;
+ function Is_Actual_Subprogram (S : Entity_Id) return Boolean;
+ -- Determine whether a subprogram is an actual in an enclosing
+ -- instance. An overloading between such a subprogram and one
+ -- declared outside the instance is resolved in favor of the first,
+ -- because it resolved in the generic.
+
function Matches (Actual, Formal : Node_Id) return Boolean;
-- Look for exact type match in an instance, to remove spurious
-- ambiguities when two formal types have the same actual.
@@ -776,6 +908,14 @@ package body Sem_Type is
-- pathology in the other direction with calls whose multiple overloaded
-- actuals make them truly unresolvable.
+ function Is_Actual_Subprogram (S : Entity_Id) return Boolean is
+ begin
+ return In_Open_Scopes (Scope (S))
+ and then
+ (Is_Generic_Instance (Scope (S))
+ or else Is_Wrapper_Package (Scope (S)));
+ end Is_Actual_Subprogram;
+
-------------
-- Matches --
-------------
@@ -850,9 +990,23 @@ package body Sem_Type is
and then Has_Compatible_Type (Act1, Standard_Boolean)
and then Etype (F1) = Standard_Boolean
then
+ -- If the two candidates are the original ones, the
+ -- ambiguity is real. Otherwise keep the original,
+ -- further calls to Disambiguate will take care of
+ -- others in the list of candidates.
if It1 /= No_Interp then
- return No_Interp;
+ if It = Disambiguate.It1
+ or else It = Disambiguate.It2
+ then
+ if It1 = Disambiguate.It1
+ or else It1 = Disambiguate.It2
+ then
+ return No_Interp;
+ else
+ It1 := It;
+ end if;
+ end if;
elsif Present (Act2)
and then Nkind (Act2) in N_Op
@@ -1090,15 +1244,29 @@ package body Sem_Type is
-- and the actuals in the call, to recover the unambiguous match
-- in the original generic.
+ -- The ambiguity can also be due to an overloading between a formal
+ -- subprogram and a subprogram declared outside the generic. If the
+ -- node is overloaded, it did not resolve to the global entity in
+ -- the generic, and we choose the formal subprogram.
+
elsif In_Instance then
- if (Nkind (N) = N_Function_Call
- or else Nkind (N) = N_Procedure_Call_Statement)
+ if Nkind (N) = N_Function_Call
+ or else Nkind (N) = N_Procedure_Call_Statement
then
declare
- Actual : Node_Id;
- Formal : Entity_Id;
+ Actual : Node_Id;
+ Formal : Entity_Id;
+ Is_Act1 : constant Boolean := Is_Actual_Subprogram (Nam1);
+ Is_Act2 : constant Boolean := Is_Actual_Subprogram (Nam2);
begin
+ if Is_Act1 and then not Is_Act2 then
+ return It1;
+
+ elsif Is_Act2 and then not Is_Act1 then
+ return It2;
+ end if;
+
Actual := First_Actual (N);
Formal := First_Formal (Nam1);
while Present (Actual) loop
@@ -1250,9 +1418,9 @@ package body Sem_Type is
----------------------
function Find_Unique_Type (L : Node_Id; R : Node_Id) return Entity_Id is
+ T : constant Entity_Id := Etype (L);
I : Interp_Index;
It : Interp;
- T : Entity_Id := Etype (L);
TR : Entity_Id := Any_Type;
begin
@@ -1314,6 +1482,7 @@ package body Sem_Type is
I : out Interp_Index;
It : out Interp)
is
+ Map_Ptr : Int;
Int_Ind : Interp_Index;
O_N : Node_Id;
@@ -1332,12 +1501,16 @@ package body Sem_Type is
O_N := N;
end if;
- for Index in 0 .. Interp_Map.Last loop
- if Interp_Map.Table (Index).Node = O_N then
- Int_Ind := Interp_Map.Table (Index).Index;
+ Map_Ptr := Headers (Hash (O_N));
+
+ while Present (Interp_Map.Table (Map_Ptr).Node) loop
+ if Interp_Map.Table (Map_Ptr).Node = O_N then
+ Int_Ind := Interp_Map.Table (Map_Ptr).Index;
It := All_Interp.Table (Int_Ind);
I := Int_Ind;
return;
+ else
+ Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
end if;
end loop;
@@ -1376,16 +1549,22 @@ package body Sem_Type is
if Nkind (N) = N_Subtype_Indication
or else not Is_Overloaded (N)
then
- return Covers (Typ, Etype (N))
- or else (not Is_Tagged_Type (Typ)
- and then Ekind (Typ) /= E_Anonymous_Access_Type
- and then Covers (Etype (N), Typ));
+ return
+ Covers (Typ, Etype (N))
+ or else
+ (not Is_Tagged_Type (Typ)
+ and then Ekind (Typ) /= E_Anonymous_Access_Type
+ and then Covers (Etype (N), Typ));
else
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
- if Covers (Typ, It.Typ)
+ if (Covers (Typ, It.Typ)
+ and then
+ (Scope (It.Nam) /= Standard_Standard
+ or else not Is_Invisible_Operator (N, Base_Type (Typ))))
+
or else (not Is_Tagged_Type (Typ)
and then Ekind (Typ) /= E_Anonymous_Access_Type
and then Covers (It.Typ, Typ))
@@ -1400,6 +1579,18 @@ package body Sem_Type is
end if;
end Has_Compatible_Type;
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (N : Node_Id) return Int is
+ begin
+ -- Nodes have a size that is power of two, so to select significant
+ -- bits only we remove the low-order bits.
+
+ return ((Int (N) / 2 ** 5) mod Header_Size);
+ end Hash;
+
--------------
-- Hides_Op --
--------------
@@ -1424,6 +1615,7 @@ package body Sem_Type is
begin
All_Interp.Init;
Interp_Map.Init;
+ Headers := (others => No_Entry);
end Init_Interp_Tables;
---------------------
@@ -1530,10 +1722,15 @@ package body Sem_Type is
Par := Etype (T2);
loop
- if Base_Type (T1) = Base_Type (Par)
+ -- If there was a error on the type declaration, do not recurse
+
+ if Error_Posted (Par) then
+ return False;
+
+ elsif Base_Type (T1) = Base_Type (Par)
or else (Is_Private_Type (T1)
- and then Present (Full_View (T1))
- and then Base_Type (Par) = Base_Type (Full_View (T1)))
+ and then Present (Full_View (T1))
+ and then Base_Type (Par) = Base_Type (Full_View (T1)))
then
return True;
@@ -1552,6 +1749,47 @@ package body Sem_Type is
end if;
end Is_Ancestor;
+ ---------------------------
+ -- Is_Invisible_Operator --
+ ---------------------------
+
+ function Is_Invisible_Operator
+ (N : Node_Id;
+ T : Entity_Id)
+ return Boolean
+ is
+ Orig_Node : constant Node_Id := Original_Node (N);
+
+ begin
+ if Nkind (N) not in N_Op then
+ return False;
+
+ elsif not Comes_From_Source (N) then
+ return False;
+
+ elsif No (Universal_Interpretation (Right_Opnd (N))) then
+ return False;
+
+ elsif Nkind (N) in N_Binary_Op
+ and then No (Universal_Interpretation (Left_Opnd (N)))
+ then
+ return False;
+
+ else return
+ Is_Numeric_Type (T)
+ and then not In_Open_Scopes (Scope (T))
+ and then not Is_Potentially_Use_Visible (T)
+ and then not In_Use (T)
+ and then not In_Use (Scope (T))
+ and then
+ (Nkind (Orig_Node) /= N_Function_Call
+ or else Nkind (Name (Orig_Node)) /= N_Expanded_Name
+ or else Entity (Prefix (Name (Orig_Node))) /= Scope (T))
+
+ and then not In_Instance;
+ end if;
+ end Is_Invisible_Operator;
+
-------------------
-- Is_Subtype_Of --
-------------------
@@ -1572,16 +1810,79 @@ package body Sem_Type is
return False;
end Is_Subtype_Of;
+ ------------------
+ -- List_Interps --
+ ------------------
+
+ procedure List_Interps (Nam : Node_Id; Err : Node_Id) is
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (Nam, Index, It);
+ while Present (It.Nam) loop
+ if Scope (It.Nam) = Standard_Standard
+ and then Scope (It.Typ) /= Standard_Standard
+ then
+ Error_Msg_Sloc := Sloc (Parent (It.Typ));
+ Error_Msg_NE (" & (inherited) declared#!", Err, It.Nam);
+
+ else
+ Error_Msg_Sloc := Sloc (It.Nam);
+ Error_Msg_NE (" & declared#!", Err, It.Nam);
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+ end List_Interps;
+
-----------------
-- New_Interps --
-----------------
procedure New_Interps (N : Node_Id) is
+ Map_Ptr : Int;
+
begin
- Interp_Map.Increment_Last;
All_Interp.Increment_Last;
- Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last);
All_Interp.Table (All_Interp.Last) := No_Interp;
+
+ Map_Ptr := Headers (Hash (N));
+
+ if Map_Ptr = No_Entry then
+
+ -- Place new node at end of table
+
+ Interp_Map.Increment_Last;
+ Headers (Hash (N)) := Interp_Map.Last;
+
+ else
+ -- Place node at end of chain, or locate its previous entry.
+
+ loop
+ if Interp_Map.Table (Map_Ptr).Node = N then
+
+ -- Node is already in the table, and is being rewritten.
+ -- Start a new interp section, retain hash link.
+
+ Interp_Map.Table (Map_Ptr).Node := N;
+ Interp_Map.Table (Map_Ptr).Index := All_Interp.Last;
+ Set_Is_Overloaded (N, True);
+ return;
+
+ else
+ exit when Interp_Map.Table (Map_Ptr).Next = No_Entry;
+ Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
+ end if;
+ end loop;
+
+ -- Chain the new node.
+
+ Interp_Map.Increment_Last;
+ Interp_Map.Table (Map_Ptr).Next := Interp_Map.Last;
+ end if;
+
+ Interp_Map.Table (Interp_Map.Last) := (N, All_Interp.Last, No_Entry);
Set_Is_Overloaded (N, True);
end New_Interps;
@@ -1774,14 +2075,27 @@ package body Sem_Type is
------------------
procedure Save_Interps (Old_N : Node_Id; New_N : Node_Id) is
+ Map_Ptr : Int;
+ O_N : Node_Id := Old_N;
+
begin
if Is_Overloaded (Old_N) then
- for Index in 0 .. Interp_Map.Last loop
- if Interp_Map.Table (Index).Node = Old_N then
- Interp_Map.Table (Index).Node := New_N;
- exit;
- end if;
+ if Nkind (Old_N) = N_Selected_Component
+ and then Is_Overloaded (Selector_Name (Old_N))
+ then
+ O_N := Selector_Name (Old_N);
+ end if;
+
+ Map_Ptr := Headers (Hash (O_N));
+
+ while Interp_Map.Table (Map_Ptr).Node /= O_N loop
+ Map_Ptr := Interp_Map.Table (Map_Ptr).Next;
+ pragma Assert (Map_Ptr /= No_Entry);
end loop;
+
+ New_Interps (New_N);
+ Interp_Map.Table (Interp_Map.Last).Index :=
+ Interp_Map.Table (Map_Ptr).Index;
end if;
end Save_Interps;
@@ -1813,7 +2127,7 @@ package body Sem_Type is
-- Start of processing for Specific_Type
begin
- if (T1 = Any_Type or else T2 = Any_Type) then
+ if T1 = Any_Type or else T2 = Any_Type then
return Any_Type;
end if;
@@ -1832,42 +2146,42 @@ package body Sem_Type is
then
return B1;
- elsif (T2 = Any_String and then Is_String_Type (T1)) then
+ elsif T2 = Any_String and then Is_String_Type (T1) then
return B1;
- elsif (T1 = Any_String and then Is_String_Type (T2)) then
+ elsif T1 = Any_String and then Is_String_Type (T2) then
return B2;
- elsif (T2 = Any_Character and then Is_Character_Type (T1)) then
+ elsif T2 = Any_Character and then Is_Character_Type (T1) then
return B1;
- elsif (T1 = Any_Character and then Is_Character_Type (T2)) then
+ elsif T1 = Any_Character and then Is_Character_Type (T2) then
return B2;
- elsif (T1 = Any_Access
- and then (Is_Access_Type (T2) or else Is_Remote_Access (T2)))
+ elsif T1 = Any_Access
+ and then (Is_Access_Type (T2) or else Is_Remote_Access (T2))
then
return T2;
- elsif (T2 = Any_Access
- and then (Is_Access_Type (T1) or else Is_Remote_Access (T1)))
+ elsif T2 = Any_Access
+ and then (Is_Access_Type (T1) or else Is_Remote_Access (T1))
then
return T1;
- elsif (T2 = Any_Composite
- and then Ekind (T1) in E_Array_Type .. E_Record_Subtype)
+ elsif T2 = Any_Composite
+ and then Ekind (T1) in E_Array_Type .. E_Record_Subtype
then
return T1;
- elsif (T1 = Any_Composite
- and then Ekind (T2) in E_Array_Type .. E_Record_Subtype)
+ elsif T1 = Any_Composite
+ and then Ekind (T2) in E_Array_Type .. E_Record_Subtype
then
return T2;
- elsif (T1 = Any_Modular and then Is_Modular_Integer_Type (T2)) then
+ elsif T1 = Any_Modular and then Is_Modular_Integer_Type (T2) then
return T2;
- elsif (T2 = Any_Modular and then Is_Modular_Integer_Type (T1)) then
+ elsif T2 = Any_Modular and then Is_Modular_Integer_Type (T1) then
return T1;
-- Special cases for equality operators (all other predefined
@@ -1920,47 +2234,6 @@ package body Sem_Type is
end if;
end Specific_Type;
- ------------------------------
- -- Universal_Interpretation --
- ------------------------------
-
- function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
- Index : Interp_Index;
- It : Interp;
-
- begin
- -- The argument may be a formal parameter of an operator or subprogram
- -- with multiple interpretations, or else an expression for an actual.
-
- if Nkind (Opnd) = N_Defining_Identifier
- or else not Is_Overloaded (Opnd)
- then
- if Etype (Opnd) = Universal_Integer
- or else Etype (Opnd) = Universal_Real
- then
- return Etype (Opnd);
- else
- return Empty;
- end if;
-
- else
- Get_First_Interp (Opnd, Index, It);
-
- while Present (It.Typ) loop
-
- if It.Typ = Universal_Integer
- or else It.Typ = Universal_Real
- then
- return It.Typ;
- end if;
-
- Get_Next_Interp (Index, It);
- end loop;
-
- return Empty;
- end if;
- end Universal_Interpretation;
-
-----------------------
-- Valid_Boolean_Arg --
-----------------------
@@ -1994,15 +2267,27 @@ package body Sem_Type is
function Valid_Comparison_Arg (T : Entity_Id) return Boolean is
begin
- return Is_Discrete_Type (T)
+
+ if T = Any_Composite then
+ return False;
+ elsif Is_Discrete_Type (T)
or else Is_Real_Type (T)
- or else (Is_Array_Type (T) and then Number_Dimensions (T) = 1
- and then Is_Discrete_Type (Component_Type (T))
- and then (not Is_Private_Composite (T)
- or else In_Instance)
- and then (not Is_Limited_Composite (T)
- or else In_Instance))
- or else Is_String_Type (T);
+ then
+ return True;
+ elsif Is_Array_Type (T)
+ and then Number_Dimensions (T) = 1
+ and then Is_Discrete_Type (Component_Type (T))
+ and then (not Is_Private_Composite (T)
+ or else In_Instance)
+ and then (not Is_Limited_Composite (T)
+ or else In_Instance)
+ then
+ return True;
+ elsif Is_String_Type (T) then
+ return True;
+ else
+ return False;
+ end if;
end Valid_Comparison_Arg;
---------------------
@@ -2036,4 +2321,19 @@ package body Sem_Type is
end if;
end Write_Overloads;
+ -----------------------
+ -- Write_Interp_Ref --
+ -----------------------
+
+ procedure Write_Interp_Ref (Map_Ptr : Int) is
+ begin
+ Write_Str (" Node: ");
+ Write_Int (Int (Interp_Map.Table (Map_Ptr).Node));
+ Write_Str (" Index: ");
+ Write_Int (Int (Interp_Map.Table (Map_Ptr).Index));
+ Write_Str (" Next: ");
+ Write_Int (Int (Interp_Map.Table (Map_Ptr).Next));
+ Write_Eol;
+ end Write_Interp_Ref;
+
end Sem_Type;
diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads
index 75908572e9b..b30791bc093 100644
--- a/gcc/ada/sem_type.ads
+++ b/gcc/ada/sem_type.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -27,8 +27,6 @@
-- This unit contains the routines used to handle type determination,
-- including the routine used to support overload resolution.
-with Alloc;
-with Table;
with Types; use Types;
package Sem_Type is
@@ -72,36 +70,8 @@ package Sem_Type is
No_Interp : constant Interp := (Empty, Empty);
- package All_Interp is new Table.Table (
- Table_Component_Type => Interp,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => Alloc.All_Interp_Initial,
- Table_Increment => Alloc.All_Interp_Increment,
- Table_Name => "All_Interp");
-
- -- The following data structures establish a mapping between nodes and
- -- their interpretations. Eventually the Interp_Index corresponding to
- -- the first interpretation of a node may be stored directly in the
- -- corresponding node.
-
subtype Interp_Index is Int;
- type Interp_Ref is record
- Node : Node_Id;
- Index : Interp_Index;
- end record;
-
- package Interp_Map is new Table.Table (
- Table_Component_Type => Interp_Ref,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => Alloc.Interp_Map_Initial,
- Table_Increment => Alloc.Interp_Map_Increment,
- Table_Name => "Interp_Map");
-
- -- For now Interp_Map is searched sequentially
-
----------------------
-- Error Reporting --
----------------------
@@ -130,11 +100,17 @@ package Sem_Type is
-- already been stored in N. If the name is an expanded name, the homonyms
-- are only those that belong to the same scope.
- procedure New_Interps (N : Node_Id);
- -- Initialize collection of interpretations for the given node, which is
- -- either an overloaded entity, or an operation whose arguments have
- -- multiple intepretations. Interpretations can be added to only one
- -- node at a time.
+ function Is_Invisible_Operator
+ (N : Node_Id;
+ T : Entity_Id)
+ return Boolean;
+ -- Check whether a predefined operation with universal operands appears
+ -- in a context in which the operators of the expected type are not
+ -- visible.
+
+ procedure List_Interps (Nam : Node_Id; Err : Node_Id);
+ -- List candidate interpretations of an overloaded name. Used for
+ -- various error reports.
procedure Add_One_Interp
(N : Node_Id;
@@ -186,7 +162,7 @@ package Sem_Type is
-- New_N, its new copy. It has no effect in the non-overloaded case.
function Covers (T1, T2 : Entity_Id) return Boolean;
- -- This is the basic type compatibility routine. T1 is the expexted
+ -- This is the basic type compatibility routine. T1 is the expected
-- type, imposed by context, and T2 is the actual type. The processing
-- reflects both the definition of type coverage and the rules
-- for operand matching.
@@ -253,6 +229,10 @@ package Sem_Type is
-- A valid argument of a boolean operator is either some boolean type,
-- or a one-dimensional array of boolean type.
+ procedure Write_Interp_Ref (Map_Ptr : Int);
+ -- Debugging procedure to display entry in Interp_Map. Would not be
+ -- needed if it were possible to debug instantiations of Table.
+
procedure Write_Overloads (N : Node_Id);
-- Debugging procedure to output info on possibly overloaded entities
-- for specified node.
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 45c02c50767..e5cb289288b 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.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- --
@@ -26,10 +26,13 @@
with Atree; use Atree;
with Casing; use Casing;
+with Checks; use Checks;
with Debug; use Debug;
with Errout; use Errout;
with Elists; use Elists;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
+with Fname; use Fname;
with Freeze; use Freeze;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
@@ -63,21 +66,30 @@ package body Sem_Util is
-----------------------
function Build_Component_Subtype
- (C : List_Id;
- Loc : Source_Ptr;
- T : Entity_Id)
- return Node_Id;
+ (C : List_Id;
+ Loc : Source_Ptr;
+ T : Entity_Id) return Node_Id;
-- This function builds the subtype for Build_Actual_Subtype_Of_Component
-- and Build_Discriminal_Subtype_Of_Component. C is a list of constraints,
-- Loc is the source location, T is the original subtype.
+ function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean;
+ -- Subsidiary to Is_Fully_Initialized_Type. For an unconstrained type
+ -- with discriminants whose default values are static, examine only the
+ -- components in the selected variant to determine whether all of them
+ -- have a default.
+
+ function Has_Null_Extension (T : Entity_Id) return Boolean;
+ -- T is a derived tagged type. Check whether the type extension is null.
+ -- If the parent type is fully initialized, T can be treated as such.
+
--------------------------------
-- Add_Access_Type_To_Process --
--------------------------------
- procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id)
- is
+ procedure Add_Access_Type_To_Process (E : Entity_Id; A : Entity_Id) is
L : Elist_Id;
+
begin
Ensure_Freeze_Node (E);
L := Access_Types_To_Process (Freeze_Node (E));
@@ -110,7 +122,8 @@ package body Sem_Util is
Ent : Entity_Id := Empty;
Typ : Entity_Id := Empty;
Loc : Source_Ptr := No_Location;
- Rep : Boolean := True)
+ Rep : Boolean := True;
+ Warn : Boolean := False)
is
Stat : constant Boolean := Is_Static_Expression (N);
Rtyp : Entity_Id;
@@ -122,7 +135,7 @@ package body Sem_Util is
Rtyp := Typ;
end if;
- if No (Compile_Time_Constraint_Error (N, Msg, Ent, Loc))
+ if No (Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn))
or else not Rep
then
return;
@@ -152,9 +165,8 @@ package body Sem_Util is
--------------------------
function Build_Actual_Subtype
- (T : Entity_Id;
- N : Node_Or_Entity_Id)
- return Node_Id
+ (T : Entity_Id;
+ N : Node_Or_Entity_Id) return Node_Id
is
Obj : Node_Id;
@@ -181,7 +193,7 @@ package body Sem_Util is
-- Build an array subtype declaration with the nominal
-- subtype and the bounds of the actual. Add the declaration
- -- in front of the local declarations for the subprogram,for
+ -- in front of the local declarations for the subprogram, for
-- analysis before any reference to the formal in the body.
Lo :=
@@ -204,7 +216,8 @@ package body Sem_Util is
end loop;
-- If the type has unknown discriminants there is no constrained
- -- subtype to build.
+ -- subtype to build. This is never called for a formal or for a
+ -- lhs, so returning the type is ok ???
elsif Has_Unknown_Discriminants (T) then
return T;
@@ -258,9 +271,8 @@ package body Sem_Util is
---------------------------------------
function Build_Actual_Subtype_Of_Component
- (T : Entity_Id;
- N : Node_Id)
- return Node_Id
+ (T : Entity_Id;
+ N : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
P : constant Node_Id := Prefix (N);
@@ -286,7 +298,7 @@ package body Sem_Util is
-----------------------------------
function Build_Actual_Array_Constraint return List_Id is
- Constraints : List_Id := New_List;
+ Constraints : constant List_Id := New_List;
Indx : Node_Id;
Hi : Node_Id;
Lo : Node_Id;
@@ -340,7 +352,7 @@ package body Sem_Util is
------------------------------------
function Build_Actual_Record_Constraint return List_Id is
- Constraints : List_Id := New_List;
+ Constraints : constant List_Id := New_List;
D : Elmt_Id;
D_Val : Node_Id;
@@ -367,7 +379,10 @@ package body Sem_Util is
-- Start of processing for Build_Actual_Subtype_Of_Component
begin
- if Nkind (N) = N_Explicit_Dereference then
+ if In_Default_Expression then
+ return Empty;
+
+ elsif Nkind (N) = N_Explicit_Dereference then
if Is_Composite_Type (T)
and then not Is_Constrained (T)
and then not (Is_Class_Wide_Type (T)
@@ -397,7 +412,6 @@ package body Sem_Util is
end if;
if Ekind (Deaccessed_T) = E_Array_Subtype then
-
Id := First_Index (Deaccessed_T);
Indx_Type := Underlying_Type (Etype (Id));
@@ -436,7 +450,6 @@ package body Sem_Util is
-- If none of the above, the actual and nominal subtypes are the same.
return Empty;
-
end Build_Actual_Subtype_Of_Component;
-----------------------------
@@ -444,10 +457,9 @@ package body Sem_Util is
-----------------------------
function Build_Component_Subtype
- (C : List_Id;
- Loc : Source_Ptr;
- T : Entity_Id)
- return Node_Id
+ (C : List_Id;
+ Loc : Source_Ptr;
+ T : Entity_Id) return Node_Id
is
Subt : Entity_Id;
Decl : Node_Id;
@@ -477,8 +489,7 @@ package body Sem_Util is
--------------------------------------------
function Build_Discriminal_Subtype_Of_Component
- (T : Entity_Id)
- return Node_Id
+ (T : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (T);
D : Elmt_Id;
@@ -498,7 +509,7 @@ package body Sem_Util is
----------------------------------------
function Build_Discriminal_Array_Constraint return List_Id is
- Constraints : List_Id := New_List;
+ Constraints : constant List_Id := New_List;
Indx : Node_Id;
Hi : Node_Id;
Lo : Node_Id;
@@ -537,14 +548,13 @@ package body Sem_Util is
-----------------------------------------
function Build_Discriminal_Record_Constraint return List_Id is
- Constraints : List_Id := New_List;
- D : Elmt_Id;
- D_Val : Node_Id;
+ Constraints : constant List_Id := New_List;
+ D : Elmt_Id;
+ D_Val : Node_Id;
begin
D := First_Elmt (Discriminant_Constraint (T));
while Present (D) loop
-
if Denotes_Discriminant (Node (D)) then
D_Val :=
New_Occurrence_Of (Discriminal (Entity (Node (D))), Loc);
@@ -564,11 +574,9 @@ package body Sem_Util is
begin
if Ekind (T) = E_Array_Subtype then
-
Id := First_Index (T);
while Present (Id) loop
-
if Denotes_Discriminant (Type_Low_Bound (Etype (Id))) or else
Denotes_Discriminant (Type_High_Bound (Etype (Id)))
then
@@ -585,7 +593,6 @@ package body Sem_Util is
then
D := First_Elmt (Discriminant_Constraint (T));
while Present (D) loop
-
if Denotes_Discriminant (Node (D)) then
return Build_Component_Subtype
(Build_Discriminal_Record_Constraint, Loc, T);
@@ -598,7 +605,6 @@ package body Sem_Util is
-- If none of the above, the actual and nominal subtypes are the same.
return Empty;
-
end Build_Discriminal_Subtype_Of_Component;
------------------------------
@@ -672,6 +678,7 @@ package body Sem_Util is
-- assign a value to the variable in the binder main.
Set_Is_True_Constant (Elab_Ent, False);
+ Set_Current_Value (Elab_Ent, Empty);
-- We do not want any further qualification of the name (if we did
-- not do this, we would pick up the name of the generic package
@@ -708,9 +715,7 @@ package body Sem_Util is
return not Do_Discriminant_Check (Expr);
when N_Attribute_Reference =>
- if Do_Overflow_Check (Expr)
- or else Do_Access_Check (Expr)
- then
+ if Do_Overflow_Check (Expr) then
return False;
elsif No (Expressions (Expr)) then
@@ -812,15 +817,41 @@ package body Sem_Util is
procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id) is
begin
if Ekind (T) = E_Incomplete_Type then
- Error_Msg_NE
- ("premature usage of incomplete}", N, First_Subtype (T));
+
+ -- If the type is available through a limited_with_clause,
+ -- verify that its full view has been analyzed.
+
+ if From_With_Type (T)
+ and then Present (Non_Limited_View (T))
+ and then Ekind (Non_Limited_View (T)) /= E_Incomplete_Type
+ then
+ -- The non-limited view is fully declared
+ null;
+
+ else
+ Error_Msg_NE
+ ("premature usage of incomplete}", N, First_Subtype (T));
+ end if;
elsif Has_Private_Component (T)
and then not Is_Generic_Type (Root_Type (T))
and then not In_Default_Expression
then
- Error_Msg_NE
- ("premature usage of incomplete}", N, First_Subtype (T));
+
+ -- Special case: if T is the anonymous type created for a single
+ -- task or protected object, use the name of the source object.
+
+ if Is_Concurrent_Type (T)
+ and then not Comes_From_Source (T)
+ and then Nkind (N) = N_Object_Declaration
+ then
+ Error_Msg_NE ("type of& has incomplete component", N,
+ Defining_Identifier (N));
+
+ else
+ Error_Msg_NE
+ ("premature usage of incomplete}", N, First_Subtype (T));
+ end if;
end if;
end Check_Fully_Declared;
@@ -847,7 +878,7 @@ package body Sem_Util is
while Present (S) and then S /= Standard_Standard loop
if Is_Protected_Type (S) then
if Restricted_Profile then
- Insert_Before (N,
+ Insert_Before_And_Analyze (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Potentially_Blocking_Operation));
Error_Msg_N ("potentially blocking operation, " &
@@ -1006,9 +1037,7 @@ package body Sem_Util is
B_Scope := System_Aux_Id;
Id := First_Entity (System_Aux_Id);
end if;
-
end loop;
-
end if;
return Op_List;
@@ -1022,12 +1051,12 @@ package body Sem_Util is
(N : Node_Id;
Msg : String;
Ent : Entity_Id := Empty;
- Loc : Source_Ptr := No_Location)
- return Node_Id
+ Loc : Source_Ptr := No_Location;
+ Warn : Boolean := False) return Node_Id
is
Msgc : String (1 .. Msg'Length + 2);
Msgl : Natural;
- Warn : Boolean;
+ Wmsg : Boolean;
P : Node_Id;
Msgs : Boolean;
Eloc : Source_Ptr;
@@ -1056,28 +1085,26 @@ package body Sem_Util is
-- Message is a warning, even in Ada 95 case
if Msg (Msg'Length) = '?' then
- Warn := True;
+ Wmsg := True;
-- In Ada 83, all messages are warnings. In the private part and
-- the body of an instance, constraint_checks are only warnings.
+ -- We also make this a warning if the Warn parameter is set.
- elsif Ada_83 and then Comes_From_Source (N) then
-
+ elsif Warn or else (Ada_83 and then Comes_From_Source (N)) then
Msgl := Msgl + 1;
Msgc (Msgl) := '?';
- Warn := True;
+ Wmsg := True;
elsif In_Instance_Not_Visible then
-
Msgl := Msgl + 1;
Msgc (Msgl) := '?';
- Warn := True;
- Warn_On_Instance := True;
+ Wmsg := True;
-- Otherwise we have a real error message (Ada 95 static case)
else
- Warn := False;
+ Wmsg := False;
end if;
-- Should we generate a warning? The answer is not quite yes. The
@@ -1118,7 +1145,7 @@ package body Sem_Util is
Error_Msg_NEL (Msgc (1 .. Msgl), N, Etype (N), Eloc);
end if;
- if Warn then
+ if Wmsg then
if Inside_Init_Proc then
Error_Msg_NEL
("\& will be raised for objects of this type!?",
@@ -1217,16 +1244,8 @@ package body Sem_Util is
Scop : constant Entity_Id := Current_Scope;
begin
- if Ekind (Scop) = E_Function
- or else
- Ekind (Scop) = E_Procedure
- or else
- Ekind (Scop) = E_Generic_Function
- or else
- Ekind (Scop) = E_Generic_Procedure
- then
+ if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) then
return Scop;
-
else
return Enclosing_Subprogram (Scop);
end if;
@@ -1343,11 +1362,35 @@ package body Sem_Util is
-- Denotes_Discriminant --
--------------------------
- function Denotes_Discriminant (N : Node_Id) return Boolean is
+ function Denotes_Discriminant
+ (N : Node_Id;
+ Check_Protected : Boolean := False) return Boolean
+ is
+ E : Entity_Id;
begin
- return Is_Entity_Name (N)
- and then Present (Entity (N))
- and then Ekind (Entity (N)) = E_Discriminant;
+ if not Is_Entity_Name (N)
+ or else No (Entity (N))
+ then
+ return False;
+ else
+ E := Entity (N);
+ end if;
+
+ -- If we are checking for a protected type, the discriminant may have
+ -- been rewritten as the corresponding discriminal of the original type
+ -- or of the corresponding concurrent record, depending on whether we
+ -- are in the spec or body of the protected type.
+
+ return Ekind (E) = E_Discriminant
+ or else
+ (Check_Protected
+ and then Ekind (E) = E_In_Parameter
+ and then Present (Discriminal_Link (E))
+ and then
+ (Is_Protected_Type (Scope (Discriminal_Link (E)))
+ or else
+ Is_Concurrent_Record_Type (Scope (Discriminal_Link (E)))));
+
end Denotes_Discriminant;
-----------------------------
@@ -1369,11 +1412,10 @@ package body Sem_Util is
function Designate_Same_Unit
(Name1 : Node_Id;
- Name2 : Node_Id)
- return Boolean
+ Name2 : Node_Id) return Boolean
is
- K1 : Node_Kind := Nkind (Name1);
- K2 : Node_Kind := Nkind (Name2);
+ K1 : constant Node_Kind := Nkind (Name1);
+ K2 : constant Node_Kind := Nkind (Name2);
function Prefix_Node (N : Node_Id) return Node_Id;
-- Returns the parent unit name node of a defining program unit name
@@ -1384,6 +1426,10 @@ package body Sem_Util is
-- name or the selector node if N is a selected component or an
-- expanded name.
+ -----------------
+ -- Prefix_Node --
+ -----------------
+
function Prefix_Node (N : Node_Id) return Node_Id is
begin
if Nkind (N) = N_Defining_Program_Unit_Name then
@@ -1394,6 +1440,10 @@ package body Sem_Util is
end if;
end Prefix_Node;
+ -----------------
+ -- Select_Node --
+ -----------------
+
function Select_Node (N : Node_Id) return Node_Id is
begin
if Nkind (N) = N_Defining_Program_Unit_Name then
@@ -1439,8 +1489,7 @@ package body Sem_Util is
----------------------------
function Enclosing_Generic_Body
- (E : Entity_Id)
- return Node_Id
+ (E : Entity_Id) return Node_Id
is
P : Node_Id;
Decl : Node_Id;
@@ -1631,6 +1680,7 @@ package body Sem_Util is
declare
Prev : Entity_Id;
Prev_Vis : Entity_Id;
+ Decl : constant Node_Id := Parent (E);
begin
-- If E is an implicit declaration, it cannot be the first
@@ -1638,33 +1688,51 @@ package body Sem_Util is
Prev := First_Entity (Current_Scope);
- while Next_Entity (Prev) /= E loop
+ while Present (Prev)
+ and then Next_Entity (Prev) /= E
+ loop
Next_Entity (Prev);
end loop;
- Set_Next_Entity (Prev, Next_Entity (E));
+ if No (Prev) then
- if No (Next_Entity (Prev)) then
- Set_Last_Entity (Current_Scope, Prev);
- end if;
+ -- If E is not on the entity chain of the current scope,
+ -- it is an implicit declaration in the generic formal
+ -- part of a generic subprogram. When analyzing the body,
+ -- the generic formals are visible but not on the entity
+ -- chain of the subprogram. The new entity will become
+ -- the visible one in the body.
+
+ pragma Assert
+ (Nkind (Parent (Decl)) = N_Generic_Subprogram_Declaration);
+ null;
- if E = Current_Entity (E) then
- Prev_Vis := Empty;
else
- Prev_Vis := Current_Entity (E);
- while Homonym (Prev_Vis) /= E loop
- Prev_Vis := Homonym (Prev_Vis);
- end loop;
- end if;
+ Set_Next_Entity (Prev, Next_Entity (E));
+
+ if No (Next_Entity (Prev)) then
+ Set_Last_Entity (Current_Scope, Prev);
+ end if;
+
+ if E = Current_Entity (E) then
+ Prev_Vis := Empty;
+
+ else
+ Prev_Vis := Current_Entity (E);
+ while Homonym (Prev_Vis) /= E loop
+ Prev_Vis := Homonym (Prev_Vis);
+ end loop;
+ end if;
- if Present (Prev_Vis) then
+ if Present (Prev_Vis) then
- -- Skip E in the visibility chain
+ -- Skip E in the visibility chain
- Set_Homonym (Prev_Vis, Homonym (E));
+ Set_Homonym (Prev_Vis, Homonym (E));
- else
- Set_Name_Entity_Id (Chars (E), Homonym (E));
+ else
+ Set_Name_Entity_Id (Chars (E), Homonym (E));
+ end if;
end if;
end;
@@ -1829,8 +1897,8 @@ package body Sem_Util is
-- Warn if new entity hides an old one
if Warn_On_Hiding
- and then Length_Of_Name (Chars (C)) /= 1
and then Present (C)
+ and then Length_Of_Name (Chars (C)) /= 1
and then Comes_From_Source (C)
and then Comes_From_Source (Def_Id)
and then In_Extended_Main_Source_Unit (Def_Id)
@@ -1838,17 +1906,60 @@ package body Sem_Util is
Error_Msg_Sloc := Sloc (C);
Error_Msg_N ("declaration hides &#?", Def_Id);
end if;
-
end Enter_Name;
+ --------------------------
+ -- Explain_Limited_Type --
+ --------------------------
+
+ procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id) is
+ C : Entity_Id;
+
+ begin
+ -- For array, component type must be limited
+
+ if Is_Array_Type (T) then
+ Error_Msg_Node_2 := T;
+ Error_Msg_NE
+ ("component type& of type& is limited", N, Component_Type (T));
+ Explain_Limited_Type (Component_Type (T), N);
+
+ elsif Is_Record_Type (T) then
+
+ -- No need for extra messages if explicit limited record
+
+ if Is_Limited_Record (Base_Type (T)) then
+ return;
+ end if;
+
+ -- Otherwise find a limited component
+
+ C := First_Component (T);
+ while Present (C) loop
+ if Is_Limited_Type (Etype (C)) then
+ Error_Msg_Node_2 := T;
+ Error_Msg_NE ("\component& of type& has limited type", N, C);
+ Explain_Limited_Type (Etype (C), N);
+ return;
+ end if;
+
+ Next_Component (C);
+ end loop;
+
+ -- It's odd if the loop falls through, but this is only an extra
+ -- error message, so we just let it go and ignore the situation.
+
+ return;
+ end if;
+ end Explain_Limited_Type;
+
-------------------------------------
-- Find_Corresponding_Discriminant --
-------------------------------------
function Find_Corresponding_Discriminant
- (Id : Node_Id;
- Typ : Entity_Id)
- return Entity_Id
+ (Id : Node_Id;
+ Typ : Entity_Id) return Entity_Id
is
Par_Disc : Entity_Id;
Old_Disc : Entity_Id;
@@ -1878,6 +1989,84 @@ package body Sem_Util is
raise Program_Error;
end Find_Corresponding_Discriminant;
+ -----------------------------
+ -- Find_Static_Alternative --
+ -----------------------------
+
+ function Find_Static_Alternative (N : Node_Id) return Node_Id is
+ Expr : constant Node_Id := Expression (N);
+ Val : constant Uint := Expr_Value (Expr);
+ Alt : Node_Id;
+ Choice : Node_Id;
+
+ begin
+ Alt := First (Alternatives (N));
+
+ Search : loop
+ if Nkind (Alt) /= N_Pragma then
+ Choice := First (Discrete_Choices (Alt));
+
+ while Present (Choice) loop
+
+ -- Others choice, always matches
+
+ if Nkind (Choice) = N_Others_Choice then
+ exit Search;
+
+ -- Range, check if value is in the range
+
+ elsif Nkind (Choice) = N_Range then
+ exit Search when
+ Val >= Expr_Value (Low_Bound (Choice))
+ and then
+ Val <= Expr_Value (High_Bound (Choice));
+
+ -- Choice is a subtype name. Note that we know it must
+ -- be a static subtype, since otherwise it would have
+ -- been diagnosed as illegal.
+
+ elsif Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ exit Search when Is_In_Range (Expr, Etype (Choice));
+
+ -- Choice is a subtype indication
+
+ elsif Nkind (Choice) = N_Subtype_Indication then
+ declare
+ C : constant Node_Id := Constraint (Choice);
+ R : constant Node_Id := Range_Expression (C);
+
+ begin
+ exit Search when
+ Val >= Expr_Value (Low_Bound (R))
+ and then
+ Val <= Expr_Value (High_Bound (R));
+ end;
+
+ -- Choice is a simple expression
+
+ else
+ exit Search when Val = Expr_Value (Choice);
+ end if;
+
+ Next (Choice);
+ end loop;
+ end if;
+
+ Next (Alt);
+ pragma Assert (Present (Alt));
+ end loop Search;
+
+ -- The above loop *must* terminate by finding a match, since
+ -- we know the case statement is valid, and the value of the
+ -- expression is known at compile time. When we fall out of
+ -- the loop, Alt points to the alternative that we know will
+ -- be selected at run time.
+
+ return Alt;
+ end Find_Static_Alternative;
+
------------------
-- First_Actual --
------------------
@@ -1904,12 +2093,16 @@ package body Sem_Util is
-------------------------
function Full_Qualified_Name (E : Entity_Id) return String_Id is
-
Res : String_Id;
+ pragma Warnings (Off, Res);
function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id;
-- Compute recursively the qualified name without NUL at the end.
+ ----------------------------------
+ -- Internal_Full_Qualified_Name --
+ ----------------------------------
+
function Internal_Full_Qualified_Name (E : Entity_Id) return String_Id is
Ent : Entity_Id := E;
Parent_Name : String_Id := No_String;
@@ -1953,6 +2146,8 @@ package body Sem_Util is
return End_String;
end Internal_Full_Qualified_Name;
+ -- Start of processing for Full_Qualified_Name
+
begin
Res := Internal_Full_Qualified_Name (E);
Store_String_Char (Get_Char_Code (ASCII.nul));
@@ -2033,32 +2228,48 @@ package body Sem_Util is
if No (Next (Assoc)) then
if not Is_Constrained (Typ)
and then Is_Derived_Type (Typ)
- and then Present (Girder_Constraint (Typ))
+ and then Present (Stored_Constraint (Typ))
then
-- If the type is a tagged type with inherited discriminants,
- -- use the girder constraint on the parent in order to find
+ -- use the stored constraint on the parent in order to find
-- the values of discriminants that are otherwise hidden by an
-- explicit constraint. Renamed discriminants are handled in
-- the code above.
+ -- If several parent discriminants are renamed by a single
+ -- discriminant of the derived type, the call to obtain the
+ -- Corresponding_Discriminant field only retrieves the last
+ -- of them. We recover the constraint on the others from the
+ -- Stored_Constraint as well.
+
declare
D : Entity_Id;
C : Elmt_Id;
begin
D := First_Discriminant (Etype (Typ));
- C := First_Elmt (Girder_Constraint (Typ));
+ C := First_Elmt (Stored_Constraint (Typ));
while Present (D)
and then Present (C)
loop
if Chars (Discrim_Name) = Chars (D) then
- Assoc :=
- Make_Component_Association (Sloc (Typ),
- New_List
- (New_Occurrence_Of (D, Sloc (Typ))),
- Duplicate_Subexpr_No_Checks (Node (C)));
+ if Is_Entity_Name (Node (C))
+ and then Entity (Node (C)) = Entity (Discrim)
+ then
+ -- D is renamed by Discrim, whose value is
+ -- given in Assoc.
+
+ null;
+
+ else
+ Assoc :=
+ Make_Component_Association (Sloc (Typ),
+ New_List
+ (New_Occurrence_Of (D, Sloc (Typ))),
+ Duplicate_Subexpr_No_Checks (Node (C)));
+ end if;
exit Find_Constraint;
end if;
@@ -2082,8 +2293,10 @@ package body Sem_Util is
Discrim_Value := Expression (Assoc);
if not Is_OK_Static_Expression (Discrim_Value) then
- Error_Msg_NE
- ("value for discriminant & must be static", Discrim_Value, Discrim);
+ Error_Msg_FE
+ ("value for discriminant & must be static!",
+ Discrim_Value, Discrim);
+ Why_Not_Static (Discrim_Value);
Report_Errors := True;
return;
end if;
@@ -2189,6 +2402,14 @@ package body Sem_Util is
if In_Default_Expression then
return Typ;
+ elsif Is_Private_Type (Typ)
+ and then not Has_Discriminants (Typ)
+ then
+ -- If the type has no discriminants, there is no subtype to
+ -- build, even if the underlying type is discriminated.
+
+ return Typ;
+
-- Else build the actual subtype
else
@@ -2276,7 +2497,6 @@ package body Sem_Util is
return
Make_String_Literal (Sloc (E),
Strval => String_From_Name_Buffer);
-
end Get_Default_External_Name;
---------------------------
@@ -2284,10 +2504,9 @@ package body Sem_Util is
---------------------------
function Get_Enum_Lit_From_Pos
- (T : Entity_Id;
- Pos : Uint;
- Loc : Source_Ptr)
- return Node_Id
+ (T : Entity_Id;
+ Pos : Uint;
+ Loc : Source_Ptr) return Node_Id
is
Lit : Node_Id;
P : constant Nat := UI_To_Int (Pos);
@@ -2456,6 +2675,43 @@ package body Sem_Util is
and then Includes_Infinities (Scalar_Range (E));
end Has_Infinities;
+ ------------------------
+ -- Has_Null_Extension --
+ ------------------------
+
+ function Has_Null_Extension (T : Entity_Id) return Boolean is
+ B : constant Entity_Id := Base_Type (T);
+ Comps : Node_Id;
+ Ext : Node_Id;
+
+ begin
+ if Nkind (Parent (B)) = N_Full_Type_Declaration
+ and then Present (Record_Extension_Part (Type_Definition (Parent (B))))
+ then
+ Ext := Record_Extension_Part (Type_Definition (Parent (B)));
+
+ if Present (Ext) then
+ if Null_Present (Ext) then
+ return True;
+ else
+ Comps := Component_List (Ext);
+
+ -- The null component list is rewritten during analysis to
+ -- include the parent component. Any other component indicates
+ -- that the extension was not originally null.
+
+ return Null_Present (Comps)
+ or else No (Next (First (Component_Items (Comps))));
+ end if;
+ else
+ return False;
+ end if;
+
+ else
+ return False;
+ end if;
+ end Has_Null_Extension;
+
---------------------------
-- Has_Private_Component --
---------------------------
@@ -2667,6 +2923,29 @@ package body Sem_Util is
return False;
end In_Instance_Visible_Part;
+ ----------------------
+ -- In_Packiage_Body --
+ ----------------------
+
+ function In_Package_Body return Boolean is
+ S : Entity_Id := Current_Scope;
+
+ begin
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Ekind (S) = E_Package
+ and then In_Package_Body (S)
+ then
+ return True;
+ else
+ S := Scope (S);
+ end if;
+ end loop;
+
+ return False;
+ end In_Package_Body;
+
--------------------------------------
-- In_Subprogram_Or_Concurrent_Unit --
--------------------------------------
@@ -2684,8 +2963,7 @@ package body Sem_Util is
if K in Subprogram_Kind
or else K in Concurrent_Kind
- or else K = E_Generic_Procedure
- or else K = E_Generic_Function
+ or else K in Generic_Subprogram_Kind
then
return True;
@@ -2695,7 +2973,6 @@ package body Sem_Util is
E := Scope (E);
end loop;
-
end In_Subprogram_Or_Concurrent_Unit;
---------------------
@@ -2711,6 +2988,45 @@ package body Sem_Util is
and then not In_Private_Part (Scope_Id);
end In_Visible_Part;
+ ---------------------------------
+ -- Insert_Explicit_Dereference --
+ ---------------------------------
+
+ procedure Insert_Explicit_Dereference (N : Node_Id) is
+ New_Prefix : constant Node_Id := Relocate_Node (N);
+ I : Interp_Index;
+ It : Interp;
+ T : Entity_Id;
+
+ begin
+ Save_Interps (N, New_Prefix);
+ Rewrite (N,
+ Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix));
+
+ Set_Etype (N, Designated_Type (Etype (New_Prefix)));
+
+ if Is_Overloaded (New_Prefix) then
+
+ -- The deference is also overloaded, and its interpretations are the
+ -- designated types of the interpretations of the original node.
+
+ Set_Etype (N, Any_Type);
+ Get_First_Interp (New_Prefix, I, It);
+
+ while Present (It.Nam) loop
+ T := It.Typ;
+
+ if Is_Access_Type (T) then
+ Add_One_Interp (N, Designated_Type (T), Designated_Type (T));
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ End_Interp_List;
+ end if;
+ end Insert_Explicit_Dereference;
+
-------------------
-- Is_AAMP_Float --
-------------------
@@ -2795,7 +3111,7 @@ package body Sem_Util is
or else Nkind (Obj) = N_Type_Conversion
then
return Is_Tagged_Type (Etype (Obj))
- or else Is_Aliased_View (Expression (Obj));
+ and then Is_Aliased_View (Expression (Obj));
elsif Nkind (Obj) = N_Explicit_Dereference then
return Nkind (Original_Node (Obj)) /= N_Function_Call;
@@ -2873,8 +3189,7 @@ package body Sem_Util is
----------------------------------------------
function Is_Dependent_Component_Of_Mutable_Object
- (Object : Node_Id)
- return Boolean
+ (Object : Node_Id) return Boolean
is
P : Node_Id;
Prefix_Type : Entity_Id;
@@ -3009,6 +3324,25 @@ package body Sem_Util is
return False;
end Is_Dependent_Component_Of_Mutable_Object;
+ ---------------------
+ -- Is_Dereferenced --
+ ---------------------
+
+ function Is_Dereferenced (N : Node_Id) return Boolean is
+ P : constant Node_Id := Parent (N);
+
+ begin
+ return
+ (Nkind (P) = N_Selected_Component
+ or else
+ Nkind (P) = N_Explicit_Dereference
+ or else
+ Nkind (P) = N_Indexed_Component
+ or else
+ Nkind (P) = N_Slice)
+ and then Prefix (P) = N;
+ end Is_Dereferenced;
+
--------------
-- Is_False --
--------------
@@ -3106,7 +3440,56 @@ package body Sem_Util is
return False;
+ -- Record types
+
elsif Is_Record_Type (Typ) then
+ if Has_Discriminants (Typ)
+ and then
+ Present (Discriminant_Default_Value (First_Discriminant (Typ)))
+ and then Is_Fully_Initialized_Variant (Typ)
+ then
+ return True;
+ end if;
+
+ -- Controlled records are considered to be fully initialized if
+ -- there is a user defined Initialize routine. This may not be
+ -- entirely correct, but as the spec notes, we are guessing here
+ -- what is best from the point of view of issuing warnings.
+
+ if Is_Controlled (Typ) then
+ declare
+ Utyp : constant Entity_Id := Underlying_Type (Typ);
+
+ begin
+ if Present (Utyp) then
+ declare
+ Init : constant Entity_Id :=
+ (Find_Prim_Op
+ (Underlying_Type (Typ), Name_Initialize));
+
+ begin
+ if Present (Init)
+ and then Comes_From_Source (Init)
+ and then not
+ Is_Predefined_File_Name
+ (File_Name (Get_Source_File_Index (Sloc (Init))))
+ then
+ return True;
+
+ elsif Has_Null_Extension (Typ)
+ and then
+ Is_Fully_Initialized_Type
+ (Etype (Base_Type (Typ)))
+ then
+ return True;
+ end if;
+ end;
+ end if;
+ end;
+ end if;
+
+ -- Otherwise see if all record components are initialized
+
declare
Ent : Entity_Id;
@@ -3114,7 +3497,10 @@ package body Sem_Util is
Ent := First_Entity (Typ);
while Present (Ent) loop
- if Ekind (Ent) = E_Component
+ if Chars (Ent) = Name_uController then
+ null;
+
+ elsif Ekind (Ent) = E_Component
and then (No (Parent (Ent))
or else No (Expression (Parent (Ent))))
and then not Is_Fully_Initialized_Type (Etype (Ent))
@@ -3151,6 +3537,95 @@ package body Sem_Util is
end if;
end Is_Fully_Initialized_Type;
+ ----------------------------------
+ -- Is_Fully_Initialized_Variant --
+ ----------------------------------
+
+ function Is_Fully_Initialized_Variant (Typ : Entity_Id) return Boolean is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Comp_Elmt : Elmt_Id;
+ Comp_Id : Node_Id;
+ Comp_List : Node_Id;
+ Discr : Entity_Id;
+ Discr_Val : Node_Id;
+ Constraints : List_Id := New_List;
+ Components : Elist_Id := New_Elmt_List;
+ Report_Errors : Boolean;
+
+ begin
+ if Serious_Errors_Detected > 0 then
+ return False;
+ end if;
+
+ if Is_Record_Type (Typ)
+ and then Nkind (Parent (Typ)) = N_Full_Type_Declaration
+ and then Nkind (Type_Definition (Parent (Typ))) = N_Record_Definition
+ then
+ Comp_List := Component_List (Type_Definition (Parent (Typ)));
+ Discr := First_Discriminant (Typ);
+
+ while Present (Discr) loop
+ if Nkind (Parent (Discr)) = N_Discriminant_Specification then
+ Discr_Val := Expression (Parent (Discr));
+ if not Is_OK_Static_Expression (Discr_Val) then
+ return False;
+ else
+ Append_To (Constraints,
+ Make_Component_Association (Loc,
+ Choices => New_List (New_Occurrence_Of (Discr, Loc)),
+ Expression => New_Copy (Discr_Val)));
+
+ end if;
+ else
+ return False;
+ end if;
+
+ Next_Discriminant (Discr);
+ end loop;
+
+ Gather_Components
+ (Typ => Typ,
+ Comp_List => Comp_List,
+ Governed_By => Constraints,
+ Into => Components,
+ Report_Errors => Report_Errors);
+
+ -- Check that each component present is fully initialized.
+
+ Comp_Elmt := First_Elmt (Components);
+
+ while Present (Comp_Elmt) loop
+ Comp_Id := Node (Comp_Elmt);
+
+ if Ekind (Comp_Id) = E_Component
+ and then (No (Parent (Comp_Id))
+ or else No (Expression (Parent (Comp_Id))))
+ and then not Is_Fully_Initialized_Type (Etype (Comp_Id))
+ then
+ return False;
+ end if;
+
+ Next_Elmt (Comp_Elmt);
+ end loop;
+
+ return True;
+
+ elsif Is_Private_Type (Typ) then
+ declare
+ U : constant Entity_Id := Underlying_Type (Typ);
+
+ begin
+ if No (U) then
+ return False;
+ else
+ return Is_Fully_Initialized_Variant (U);
+ end if;
+ end;
+ else
+ return False;
+ end if;
+ end Is_Fully_Initialized_Variant;
+
----------------------------
-- Is_Inherited_Operation --
----------------------------
@@ -3173,6 +3648,17 @@ package body Sem_Util is
function Is_Library_Level_Entity (E : Entity_Id) return Boolean is
begin
+ -- The following is a small optimization, and it also handles
+ -- properly discriminals, which in task bodies might appear in
+ -- expressions before the corresponding procedure has been
+ -- created, and which therefore do not have an assigned scope.
+
+ if Ekind (E) in Formal_Kind then
+ return False;
+ end if;
+
+ -- Normal test is simply that the enclosing dynamic scope is Standard
+
return Enclosing_Dynamic_Scope (E) = Standard_Standard;
end Is_Library_Level_Entity;
@@ -3204,6 +3690,60 @@ package body Sem_Util is
end if;
end Is_Local_Variable_Reference;
+ ---------------
+ -- Is_Lvalue --
+ ---------------
+
+ function Is_Lvalue (N : Node_Id) return Boolean is
+ P : constant Node_Id := Parent (N);
+
+ begin
+ case Nkind (P) is
+
+ -- Test left side of assignment
+
+ when N_Assignment_Statement =>
+ return N = Name (P);
+
+ -- Test prefix of component or attribute
+
+ when N_Attribute_Reference |
+ N_Expanded_Name |
+ N_Explicit_Dereference |
+ N_Indexed_Component |
+ N_Reference |
+ N_Selected_Component |
+ N_Slice =>
+ return N = Prefix (P);
+
+ -- Test subprogram parameter (we really should check the
+ -- parameter mode, but it is not worth the trouble)
+
+ when N_Function_Call |
+ N_Procedure_Call_Statement |
+ N_Accept_Statement |
+ N_Parameter_Association =>
+ return True;
+
+ -- Test for appearing in a conversion that itself appears
+ -- in an lvalue context, since this should be an lvalue.
+
+ when N_Type_Conversion =>
+ return Is_Lvalue (P);
+
+ -- Test for appearence in object renaming declaration
+
+ when N_Object_Renaming_Declaration =>
+ return True;
+
+ -- All other references are definitely not Lvalues
+
+ when others =>
+ return False;
+
+ end case;
+ end Is_Lvalue;
+
-------------------------
-- Is_Object_Reference --
-------------------------
@@ -3218,12 +3758,12 @@ package body Sem_Util is
when N_Indexed_Component | N_Slice =>
return Is_Object_Reference (Prefix (N));
- -- In Ada95, a function call is a constant object.
+ -- In Ada95, a function call is a constant object
when N_Function_Call =>
return True;
- -- A reference to the stream attribute Input is a function call.
+ -- A reference to the stream attribute Input is a function call
when N_Attribute_Reference =>
return Attribute_Name (N) = Name_Input;
@@ -3315,7 +3855,7 @@ package body Sem_Util is
-- If this node is rewritten, then test the original form, if that is
-- OK, then we consider the rewritten node OK (for example, if the
-- original node is a conversion, then Is_Variable will not be true
- -- but we still want to allow the conversion if it converts a variable.
+ -- but we still want to allow the conversion if it converts a variable).
elsif Original_Node (AV) /= AV then
return Is_OK_Variable_For_Out_Formal (Original_Node (AV));
@@ -3484,16 +4024,16 @@ package body Sem_Util is
-----------------------------------------
function Is_Remote_Access_To_Class_Wide_Type
- (E : Entity_Id)
- return Boolean
+ (E : Entity_Id) return Boolean
is
D : Entity_Id;
function Comes_From_Limited_Private_Type_Declaration
(E : Entity_Id)
return Boolean;
- -- Check if the original declaration is a limited private one and
- -- if all the derivations have been using private extensions.
+ -- Check that the type is declared by a limited type declaration,
+ -- or else is derived from a Remote_Type ancestor through private
+ -- extensions.
-------------------------------------------------
-- Comes_From_Limited_Private_Type_Declaration --
@@ -3511,7 +4051,12 @@ package body Sem_Util is
end if;
if Nkind (N) = N_Private_Extension_Declaration then
- return Comes_From_Limited_Private_Type_Declaration (Etype (E));
+ return
+ Comes_From_Limited_Private_Type_Declaration (Etype (E))
+ or else
+ (Is_Remote_Types (Etype (E))
+ and then Is_Limited_Record (Etype (E))
+ and then Has_Private_Declaration (Etype (E)));
end if;
return False;
@@ -3542,8 +4087,7 @@ package body Sem_Util is
-----------------------------------------
function Is_Remote_Access_To_Subprogram_Type
- (E : Entity_Id)
- return Boolean
+ (E : Entity_Id) return Boolean
is
begin
return (Ekind (E) = E_Access_Subprogram_Type
@@ -3713,6 +4257,10 @@ package body Sem_Util is
-- must test for the case of a reference of a constant access
-- type, which can never be a variable.
+ ---------------------------
+ -- In_Protected_Function --
+ ---------------------------
+
function In_Protected_Function (E : Entity_Id) return Boolean is
Prot : constant Entity_Id := Scope (E);
S : Entity_Id;
@@ -3738,6 +4286,10 @@ package body Sem_Util is
end if;
end In_Protected_Function;
+ ------------------------
+ -- Is_Variable_Prefix --
+ ------------------------
+
function Is_Variable_Prefix (P : Node_Id) return Boolean is
begin
if Is_Access_Type (Etype (P)) then
@@ -3801,13 +4353,18 @@ package body Sem_Util is
return Is_Variable_Prefix (Prefix (Orig_Node))
and then Is_Variable (Selector_Name (Orig_Node));
- -- For an explicit dereference, we must check whether the type
- -- is ACCESS CONSTANT, since if it is, then it is not a variable.
+ -- For an explicit dereference, the type of the prefix cannot
+ -- be an access to constant or an access to subprogram.
when N_Explicit_Dereference =>
- return Is_Access_Type (Etype (Prefix (Orig_Node)))
- and then not
- Is_Access_Constant (Root_Type (Etype (Prefix (Orig_Node))));
+ declare
+ Typ : constant Entity_Id := Etype (Prefix (Orig_Node));
+
+ begin
+ return Is_Access_Type (Typ)
+ and then not Is_Access_Constant (Root_Type (Typ))
+ and then Ekind (Typ) /= E_Access_Subprogram_Type;
+ end;
-- The type conversion is the case where we do not deal with the
-- context dependent special case of an actual parameter. Thus
@@ -3853,19 +4410,38 @@ package body Sem_Util is
function Is_Volatile_Prefix (N : Node_Id) return Boolean;
-- If prefix is an implicit dereference, examine designated type.
+ ------------------------
+ -- Is_Volatile_Prefix --
+ ------------------------
+
function Is_Volatile_Prefix (N : Node_Id) return Boolean is
+ Typ : constant Entity_Id := Etype (N);
+
begin
- if Is_Access_Type (Etype (N)) then
- return Has_Volatile_Components (Designated_Type (Etype (N)));
+ if Is_Access_Type (Typ) then
+ declare
+ Dtyp : constant Entity_Id := Designated_Type (Typ);
+
+ begin
+ return Is_Volatile (Dtyp)
+ or else Has_Volatile_Components (Dtyp);
+ end;
+
else
return Object_Has_Volatile_Components (N);
end if;
end Is_Volatile_Prefix;
+ ------------------------------------
+ -- Object_Has_Volatile_Components --
+ ------------------------------------
+
function Object_Has_Volatile_Components (N : Node_Id) return Boolean is
+ Typ : constant Entity_Id := Etype (N);
+
begin
- if Is_Volatile (Etype (N))
- or else Has_Volatile_Components (Etype (N))
+ if Is_Volatile (Typ)
+ or else Has_Volatile_Components (Typ)
then
return True;
@@ -3903,6 +4479,80 @@ package body Sem_Util is
end if;
end Is_Volatile_Object;
+ -------------------------
+ -- Kill_Current_Values --
+ -------------------------
+
+ procedure Kill_Current_Values is
+ S : Entity_Id;
+
+ procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id);
+ -- Clear current value for entity E and all entities chained to E
+
+ -------------------------------------------
+ -- Kill_Current_Values_For_Entity_Chain --
+ -------------------------------------------
+
+ procedure Kill_Current_Values_For_Entity_Chain (E : Entity_Id) is
+ Ent : Entity_Id;
+
+ begin
+ Ent := E;
+ while Present (Ent) loop
+ if Is_Object (Ent) then
+ Set_Current_Value (Ent, Empty);
+
+ if not Can_Never_Be_Null (Ent) then
+ Set_Is_Known_Non_Null (Ent, False);
+ end if;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end Kill_Current_Values_For_Entity_Chain;
+
+ -- Start of processing for Kill_Current_Values
+
+ begin
+ -- Kill all saved checks, a special case of killing saved values
+
+ Kill_All_Checks;
+
+ -- Loop through relevant scopes, which includes the current scope and
+ -- any parent scopes if the current scope is a block or a package.
+
+ S := Current_Scope;
+ Scope_Loop : loop
+
+ -- Clear current values of all entities in current scope
+
+ Kill_Current_Values_For_Entity_Chain (First_Entity (S));
+
+ -- If scope is a package, also clear current values of all
+ -- private entities in the scope.
+
+ if Ekind (S) = E_Package
+ or else
+ Ekind (S) = E_Generic_Package
+ or else
+ Is_Concurrent_Type (S)
+ then
+ Kill_Current_Values_For_Entity_Chain (First_Private_Entity (S));
+ end if;
+
+ -- If this is a block or nested package, deal with parent
+
+ if Ekind (S) = E_Block
+ or else (Ekind (S) = E_Package
+ and then not Is_Library_Level_Entity (S))
+ then
+ S := Scope (S);
+ else
+ exit Scope_Loop;
+ end if;
+ end loop Scope_Loop;
+ end Kill_Current_Values;
+
--------------------------
-- Kill_Size_Check_Code --
--------------------------
@@ -3928,8 +4578,7 @@ package body Sem_Util is
Related_Id : Entity_Id;
Suffix : Character;
Suffix_Index : Nat := 0;
- Prefix : Character := ' ')
- return Entity_Id
+ Prefix : Character := ' ') return Entity_Id
is
N : constant Entity_Id :=
Make_Defining_Identifier (Sloc_Value,
@@ -3957,8 +4606,7 @@ package body Sem_Util is
(Kind : Entity_Kind;
Scope_Id : Entity_Id;
Sloc_Value : Source_Ptr;
- Id_Char : Character)
- return Entity_Id
+ Id_Char : Character) return Entity_Id
is
N : constant Entity_Id :=
Make_Defining_Identifier (Sloc_Value, New_Internal_Name (Id_Char));
@@ -4059,10 +4707,14 @@ package body Sem_Util is
function Reporting return Boolean;
-- Determines if an error is to be reported. To report an error, we
-- need Report to be True, and also we do not report errors caused
- -- by calls to Init_Proc's that occur within other Init_Proc's. Such
+ -- by calls to init procs that occur within other init procs. Such
-- errors must always be cascaded errors, since if all the types are
-- declared correctly, the compiler will certainly build decent calls!
+ -----------
+ -- Chain --
+ -----------
+
procedure Chain (A : Node_Id) is
begin
if No (Last) then
@@ -4079,6 +4731,10 @@ package body Sem_Util is
Set_Next_Named_Actual (Last, Empty);
end Chain;
+ ---------------
+ -- Reporting --
+ ---------------
+
function Reporting return Boolean is
begin
if not Report then
@@ -4087,7 +4743,7 @@ package body Sem_Util is
elsif not Within_Init_Proc then
return True;
- elsif Chars (Entity (Name (N))) = Name_uInit_Proc then
+ elsif Is_Init_Proc (Entity (Name (N))) then
return False;
else
@@ -4139,7 +4795,11 @@ package body Sem_Util is
-- Too many actuals: will not work.
if Reporting then
- Error_Msg_N ("too many arguments in call", N);
+ if Is_Entity_Name (Name (N)) then
+ Error_Msg_N ("too many arguments in call to&", Name (N));
+ else
+ Error_Msg_N ("too many arguments in call", N);
+ end if;
end if;
Success := False;
@@ -4205,7 +4865,8 @@ package body Sem_Util is
or else No (Default_Value (Formal))
then
if Reporting then
- if Comes_From_Source (S)
+ if (Comes_From_Source (S)
+ or else Sloc (S) = Standard_Location)
and then Is_Overloadable (S)
then
Error_Msg_Name_1 := Chars (S);
@@ -4213,6 +4874,19 @@ package body Sem_Util is
Error_Msg_NE
("missing argument for parameter & " &
"in call to % declared #", N, Formal);
+
+ elsif Is_Overloadable (S) then
+ Error_Msg_Name_1 := Chars (S);
+
+ -- Point to type derivation that
+ -- generated the operation.
+
+ Error_Msg_Sloc := Sloc (Parent (S));
+
+ Error_Msg_NE
+ ("missing argument for parameter & " &
+ "in call to % (inherited) #", N, Formal);
+
else
Error_Msg_NE
("missing argument for parameter &", N, Formal);
@@ -4249,7 +4923,8 @@ package body Sem_Util is
and then Actual /= Last
and then No (Next_Named_Actual (Actual))
then
- Error_Msg_N ("Unmatched actual in call", Actual);
+ Error_Msg_N ("unmatched actual & in call",
+ Selector_Name (Actual));
exit;
end if;
@@ -4272,12 +4947,28 @@ package body Sem_Util is
procedure Set_Ref (E : Entity_Id; N : Node_Id);
-- Internal routine to note modification on entity E by node N
+ -- Has no effect if entity E does not represent an object.
+
+ -------------
+ -- Set_Ref --
+ -------------
procedure Set_Ref (E : Entity_Id; N : Node_Id) is
begin
- Set_Not_Source_Assigned (E, False);
- Set_Is_True_Constant (E, False);
- Generate_Reference (E, N, 'm');
+ if Is_Object (E) then
+ if Comes_From_Source (N) then
+ Set_Never_Set_In_Source (E, False);
+ end if;
+
+ Set_Is_True_Constant (E, False);
+ Set_Current_Value (E, Empty);
+ Generate_Reference (E, N, 'm');
+ Kill_Checks (E);
+
+ if not Can_Never_Be_Null (E) then
+ Set_Is_Known_Non_Null (E, False);
+ end if;
+ end if;
end Set_Ref;
-- Start of processing for Note_Possible_Modification
@@ -4290,21 +4981,32 @@ package body Sem_Util is
-- Test for node rewritten as dereference (e.g. accept parameter)
if Nkind (Exp) = N_Explicit_Dereference
- and then Is_Entity_Name (Original_Node (Exp))
+ and then not Comes_From_Source (Exp)
then
- Set_Ref (Entity (Original_Node (Exp)), Original_Node (Exp));
- return;
+ Exp := Original_Node (Exp);
+ end if;
- elsif Is_Entity_Name (Exp) then
+ -- Now look for entity being referenced
+
+ if Is_Entity_Name (Exp) then
Ent := Entity (Exp);
if (Ekind (Ent) = E_Variable or else Ekind (Ent) = E_Constant)
and then Present (Renamed_Object (Ent))
then
+ Set_Never_Set_In_Source (Ent, False);
+ Set_Is_True_Constant (Ent, False);
+ Set_Current_Value (Ent, Empty);
+
+ if not Can_Never_Be_Null (Ent) then
+ Set_Is_Known_Non_Null (Ent, False);
+ end if;
+
Exp := Renamed_Object (Ent);
else
Set_Ref (Ent, Exp);
+ Kill_Checks (Ent);
return;
end if;
@@ -4404,7 +5106,9 @@ package body Sem_Util is
return Type_Access_Level (Etype (Prefix (Obj)));
end if;
- elsif Nkind (Obj) = N_Type_Conversion then
+ elsif Nkind (Obj) = N_Type_Conversion
+ or else Nkind (Obj) = N_Unchecked_Type_Conversion
+ then
return Object_Access_Level (Expression (Obj));
-- Function results are objects, so we get either the access level
@@ -4443,8 +5147,7 @@ package body Sem_Util is
function Trace_Components
(T : Entity_Id;
- Check : Boolean)
- return Entity_Id;
+ Check : Boolean) return Entity_Id;
-- Recursive function that does the work, and checks against circular
-- definition for each subcomponent type.
@@ -4666,7 +5369,9 @@ package body Sem_Util is
-- and generate an l-type cross-reference entry for the label
if Label_Ref then
- Style.Check_Identifier (Endl, Ent);
+ if Style_Check then
+ Style.Check_Identifier (Endl, Ent);
+ end if;
Generate_Reference (Ent, Endl, 'l', Set_Ref => False);
end if;
@@ -4727,6 +5432,34 @@ package body Sem_Util is
return Token_Node;
end Real_Convert;
+ ---------------------
+ -- Rep_To_Pos_Flag --
+ ---------------------
+
+ function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id is
+ begin
+ if Range_Checks_Suppressed (E) then
+ return New_Occurrence_Of (Standard_False, Loc);
+ else
+ return New_Occurrence_Of (Standard_True, Loc);
+ end if;
+ end Rep_To_Pos_Flag;
+
+ --------------------
+ -- Require_Entity --
+ --------------------
+
+ procedure Require_Entity (N : Node_Id) is
+ begin
+ if Is_Entity_Name (N) and then No (Entity (N)) then
+ if Total_Errors_Detected /= 0 then
+ Set_Entity (N, Any_Id);
+ else
+ raise Program_Error;
+ end if;
+ end if;
+ end Require_Entity;
+
------------------------------
-- Requires_Transient_Scope --
------------------------------
@@ -4790,16 +5523,18 @@ package body Sem_Util is
procedure Reset_Analyzed_Flags (N : Node_Id) is
function Clear_Analyzed
- (N : Node_Id)
- return Traverse_Result;
+ (N : Node_Id) return Traverse_Result;
-- Function used to reset Analyzed flags in tree. Note that we do
-- not reset Analyzed flags in entities, since there is no need to
-- renalalyze entities, and indeed, it is wrong to do so, since it
-- can result in generating auxiliary stuff more than once.
+ --------------------
+ -- Clear_Analyzed --
+ --------------------
+
function Clear_Analyzed
- (N : Node_Id)
- return Traverse_Result
+ (N : Node_Id) return Traverse_Result
is
begin
if not Has_Extension (N) then
@@ -4813,6 +5548,7 @@ package body Sem_Util is
new Traverse_Func (Clear_Analyzed);
Discard : Traverse_Result;
+ pragma Warnings (Off, Discard);
-- Start of processing for Reset_Analyzed_Flags
@@ -4820,6 +5556,94 @@ package body Sem_Util is
Discard := Reset_Analyzed (N);
end Reset_Analyzed_Flags;
+ ---------------------------
+ -- Safe_To_Capture_Value --
+ ---------------------------
+
+ function Safe_To_Capture_Value
+ (N : Node_Id;
+ Ent : Entity_Id) return Boolean
+ is
+ begin
+ -- The only entities for which we track constant values are variables,
+ -- out parameters and in out parameters, so check if we have this case.
+
+ if Ekind (Ent) /= E_Variable
+ and then
+ Ekind (Ent) /= E_Out_Parameter
+ and then
+ Ekind (Ent) /= E_In_Out_Parameter
+ then
+ return False;
+ end if;
+
+ -- Skip volatile and aliased variables, since funny things might
+ -- be going on in these cases which we cannot necessarily track.
+
+ if Treat_As_Volatile (Ent) or else Is_Aliased (Ent) then
+ return False;
+ end if;
+
+ -- OK, all above conditions are met. We also require that the scope
+ -- of the reference be the same as the scope of the entity, not
+ -- counting packages and blocks.
+
+ declare
+ E_Scope : constant Entity_Id := Scope (Ent);
+ R_Scope : Entity_Id;
+
+ begin
+ R_Scope := Current_Scope;
+ while R_Scope /= Standard_Standard loop
+ exit when R_Scope = E_Scope;
+
+ if Ekind (R_Scope) /= E_Package
+ and then
+ Ekind (R_Scope) /= E_Block
+ then
+ return False;
+ else
+ R_Scope := Scope (R_Scope);
+ end if;
+ end loop;
+ end;
+
+ -- We also require that the reference does not appear in a context
+ -- where it is not sure to be executed (i.e. a conditional context
+ -- or an exception handler).
+
+ declare
+ P : Node_Id;
+
+ begin
+ P := Parent (N);
+ while Present (P) loop
+ if Nkind (P) = N_If_Statement
+ or else
+ Nkind (P) = N_Case_Statement
+ or else
+ Nkind (P) = N_Exception_Handler
+ or else
+ Nkind (P) = N_Selective_Accept
+ or else
+ Nkind (P) = N_Conditional_Entry_Call
+ or else
+ Nkind (P) = N_Timed_Entry_Call
+ or else
+ Nkind (P) = N_Asynchronous_Select
+ then
+ return False;
+ else
+ P := Parent (P);
+ end if;
+ end loop;
+ end;
+
+ -- OK, looks safe to set value
+
+ return True;
+ end Safe_To_Capture_Value;
+
---------------
-- Same_Name --
---------------
@@ -4966,10 +5790,8 @@ package body Sem_Util is
while not Comes_From_Source (Val_Actual)
and then Nkind (Val_Actual) in N_Entity
and then (Ekind (Val_Actual) = E_Enumeration_Literal
- or else Ekind (Val_Actual) = E_Function
- or else Ekind (Val_Actual) = E_Generic_Function
- or else Ekind (Val_Actual) = E_Procedure
- or else Ekind (Val_Actual) = E_Generic_Procedure)
+ or else Is_Subprogram (Val_Actual)
+ or else Is_Generic_Subprogram (Val_Actual))
and then Present (Alias (Val_Actual))
loop
Val_Actual := Alias (Val_Actual);
@@ -4982,7 +5804,6 @@ package body Sem_Util is
if Chars (Nod) = Chars (Val_Actual) then
Style.Check_Identifier (Nod, Val_Actual);
end if;
-
end if;
Set_Entity (N, Val);
@@ -5064,7 +5885,6 @@ package body Sem_Util is
then
Set_Is_Unsigned_Type (T1, Is_Unsigned_Type (T2));
end if;
-
Set_Alignment (T1, Alignment (T2));
end Set_Size_Info;
@@ -5094,7 +5914,8 @@ package body Sem_Util is
return No_Uint;
else
- Error_Msg_N ("static integer expression required here", N);
+ Flag_Non_Static_Expr
+ ("static integer expression required here", N);
return No_Uint;
end if;
end Static_Integer;
@@ -5249,6 +6070,7 @@ package body Sem_Util is
and then Nkind (N) /= N_Package_Instantiation
and then Nkind (N) /= N_Package_Renaming_Declaration
and then Nkind (N) /= N_Procedure_Instantiation
+ and then Nkind (N) /= N_Protected_Body
and then Nkind (N) /= N_Subprogram_Declaration
and then Nkind (N) /= N_Subprogram_Body
and then Nkind (N) /= N_Subprogram_Body_Stub
@@ -5264,6 +6086,47 @@ package body Sem_Util is
return N;
end Unit_Declaration_Node;
+ ------------------------------
+ -- Universal_Interpretation --
+ ------------------------------
+
+ function Universal_Interpretation (Opnd : Node_Id) return Entity_Id is
+ Index : Interp_Index;
+ It : Interp;
+
+ begin
+ -- The argument may be a formal parameter of an operator or subprogram
+ -- with multiple interpretations, or else an expression for an actual.
+
+ if Nkind (Opnd) = N_Defining_Identifier
+ or else not Is_Overloaded (Opnd)
+ then
+ if Etype (Opnd) = Universal_Integer
+ or else Etype (Opnd) = Universal_Real
+ then
+ return Etype (Opnd);
+ else
+ return Empty;
+ end if;
+
+ else
+ Get_First_Interp (Opnd, Index, It);
+
+ while Present (It.Typ) loop
+
+ if It.Typ = Universal_Integer
+ or else It.Typ = Universal_Real
+ then
+ return It.Typ;
+ end if;
+
+ Get_Next_Interp (Index, It);
+ end loop;
+
+ return Empty;
+ end if;
+ end Universal_Interpretation;
+
----------------------
-- Within_Init_Proc --
----------------------
@@ -5281,7 +6144,7 @@ package body Sem_Util is
end if;
end loop;
- return Chars (S) = Name_uInit_Proc;
+ return Is_Init_Proc (S);
end Within_Init_Proc;
----------------
@@ -5368,6 +6231,9 @@ package body Sem_Util is
elsif In_Instance then
if Etype (Etype (Expr)) = Etype (Expected_Type)
+ and then
+ (Has_Private_Declaration (Expected_Type)
+ or else Has_Private_Declaration (Etype (Expr)))
and then No (Parent (Expected_Type))
then
return;
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index f0f518c104c..925b5c4d468 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -50,7 +50,8 @@ package Sem_Util is
Ent : Entity_Id := Empty;
Typ : Entity_Id := Empty;
Loc : Source_Ptr := No_Location;
- Rep : Boolean := True);
+ Rep : Boolean := True;
+ Warn : Boolean := False);
-- N is a subexpression which will raise constraint error when evaluated
-- at runtime. Msg is a message that explains the reason for raising the
-- exception. The last character is ? if the message is always a warning,
@@ -67,27 +68,27 @@ package Sem_Util is
-- normally references Etype (N), unless the Ent argument is given
-- explicitly, in which case it is used instead. The type of the raise
-- node that is built is normally Etype (N), but if the Typ parameter
- -- is present, this is used instead.
+ -- is present, this is used instead. Warn is normally False. If it is
+ -- True then the message is treated as a warning even though it does
+ -- not end with a ? (this is used when the caller wants to parametrize
+ -- whether an error or warning is given.
function Build_Actual_Subtype
- (T : Entity_Id;
- N : Node_Or_Entity_Id)
- return Node_Id;
+ (T : Entity_Id;
+ N : Node_Or_Entity_Id) return Node_Id;
-- Build an anonymous subtype for an entity or expression, using the
-- bounds of the entity or the discriminants of the enclosing record.
-- T is the type for which the actual subtype is required, and N is either
-- a defining identifier, or any subexpression.
function Build_Actual_Subtype_Of_Component
- (T : Entity_Id;
- N : Node_Id)
- return Node_Id;
+ (T : Entity_Id;
+ N : Node_Id) return Node_Id;
-- Determine whether a selected component has a type that depends on
-- discriminants, and build actual subtype for it if so.
function Build_Discriminal_Subtype_Of_Component
- (T : Entity_Id)
- return Node_Id;
+ (T : Entity_Id) return Node_Id;
-- Determine whether a record component has a type that depends on
-- discriminants, and build actual subtype for it if so.
@@ -128,11 +129,13 @@ package Sem_Util is
(N : Node_Id;
Msg : String;
Ent : Entity_Id := Empty;
- Loc : Source_Ptr := No_Location)
- return Node_Id;
+ Loc : Source_Ptr := No_Location;
+ Warn : Boolean := False) return Node_Id;
-- Subsidiary to Apply_Compile_Time_Constraint_Error and Checks routines.
-- Does not modify any nodes, but generates a warning (or error) message.
- -- For convenience, the function always returns its first argument.
+ -- For convenience, the function always returns its first argument. The
+ -- message is a warning if the message ends with ?, or we are operating
+ -- in Ada 83 mode, or if the Warn parameter is set to True.
procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id);
-- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag
@@ -164,10 +167,14 @@ package Sem_Util is
-- then the defining entity is obtained from the defining unit name
-- ignoring any child unit prefixes.
- function Denotes_Discriminant (N : Node_Id) return Boolean;
- -- Returns True if node N is an N_Identifier node for a discriminant.
- -- Returns False for any other kind of node, or for an N_Identifier
- -- node that does not denote a discriminant.
+ function Denotes_Discriminant
+ (N : Node_Id;
+ Check_Protected : Boolean := False) return Boolean;
+ -- Returns True if node N is an Entity_Name node for a discriminant.
+ -- If the flag Check_Protected is true, function also returns true
+ -- when N denotes the discriminal of the discriminant of a protected
+ -- type. This is necessary to disable some optimizations on private
+ -- components of protected types.
function Depends_On_Discriminant (N : Node_Id) return Boolean;
-- Returns True if N denotes a discriminant or if N is a range, a subtype
@@ -176,15 +183,13 @@ package Sem_Util is
function Designate_Same_Unit
(Name1 : Node_Id;
- Name2 : Node_Id)
- return Boolean;
+ Name2 : Node_Id) return Boolean;
-- Return true if Name1 and Name2 designate the same unit name;
-- each of these names is supposed to be a selected component name,
-- an expanded name, a defining program unit name or an identifier
function Enclosing_Generic_Body
- (E : Entity_Id)
- return Node_Id;
+ (E : Entity_Id) return Node_Id;
-- Returns the Node_Id associated with the innermost enclosing
-- generic body, if any. If none, then returns Empty.
@@ -212,10 +217,15 @@ package Sem_Util is
-- Note: Enter_Name is not used for overloadable entities, instead
-- these are entered using Sem_Ch6.Enter_Overloadable_Entity.
+ procedure Explain_Limited_Type (T : Entity_Id; N : Node_Id);
+ -- This procedure is called after issuing a message complaining
+ -- about an inappropriate use of limited type T. If useful, it
+ -- adds additional continuation lines to the message explaining
+ -- why type T is limited. Messages are placed at node N.
+
function Find_Corresponding_Discriminant
(Id : Node_Id;
- Typ : Entity_Id)
- return Entity_Id;
+ Typ : Entity_Id) return Entity_Id;
-- Because discriminants may have different names in a generic unit
-- and in an instance, they are resolved positionally when possible.
-- A reference to a discriminant carries the discriminant that it
@@ -238,6 +248,11 @@ package Sem_Util is
-- Generates the string literal corresponding to the E's full qualified
-- name in upper case. An ASCII.NUL is appended as the last character
+ function Find_Static_Alternative (N : Node_Id) return Node_Id;
+ -- N is a case statement whose expression is a compile-time value.
+ -- Determine the alternative chosen, so that the code of non-selected
+ -- alternatives, and the warnings that may apply to them, are removed.
+
procedure Gather_Components
(Typ : Entity_Id;
Comp_List : Node_Id;
@@ -310,10 +325,9 @@ package Sem_Util is
-- may be set to Error if there was an earlier error in the range.
function Get_Enum_Lit_From_Pos
- (T : Entity_Id;
- Pos : Uint;
- Loc : Source_Ptr)
- return Entity_Id;
+ (T : Entity_Id;
+ Pos : Uint;
+ Loc : Source_Ptr) return Entity_Id;
-- This function obtains the E_Enumeration_Literal entity for the
-- specified value from the enumneration type or subtype T. The
-- second argument is the Pos value, which is assumed to be in range.
@@ -370,6 +384,9 @@ package Sem_Util is
-- Returns True if current scope is within the visible part of a package
-- instance, where several additional semantic checks apply.
+ function In_Package_Body return Boolean;
+ -- Returns True if current scope is within a package body
+
function In_Subprogram_Or_Concurrent_Unit return Boolean;
-- Determines if the current scope is within a subprogram compilation
-- unit (inside a subprogram declaration, subprogram body, or generic
@@ -382,6 +399,12 @@ package Sem_Util is
-- package specification. The package must be on the scope stack, and the
-- corresponding private part must not.
+ procedure Insert_Explicit_Dereference (N : Node_Id);
+ -- In a context that requires a composite or subprogram type and
+ -- where a prefix is an access type, rewrite the access type node
+ -- N (which is the prefix, e.g. of an indexed component) as an
+ -- explicit dereference.
+
function Is_AAMP_Float (E : Entity_Id) return Boolean;
-- Defined for all type entities. Returns True only for the base type
-- of float types with AAMP format. The particular format is determined
@@ -391,15 +414,6 @@ package Sem_Util is
-- the dependency of Einfo on Targparm which would be required for a
-- synthesized attribute.
- function Is_Dependent_Component_Of_Mutable_Object
- (Object : Node_Id)
- return Boolean;
- -- Returns True if Object is the name of a subcomponent that
- -- depends on discriminants of a variable whose nominal subtype
- -- is unconstrained and not indefinite, and the variable is
- -- not aliased. Otherwise returns False. The nodes passed
- -- to this function are assumed to denote objects.
-
function Is_Actual_Parameter (N : Node_Id) return Boolean;
-- Determines if N is an actual parameter in a subprogram call.
@@ -411,6 +425,20 @@ package Sem_Util is
-- Determines if the given node denotes an atomic object in the sense
-- of the legality checks described in RM C.6(12).
+ function Is_Dependent_Component_Of_Mutable_Object
+ (Object : Node_Id) return Boolean;
+ -- Returns True if Object is the name of a subcomponent that
+ -- depends on discriminants of a variable whose nominal subtype
+ -- is unconstrained and not indefinite, and the variable is
+ -- not aliased. Otherwise returns False. The nodes passed
+ -- to this function are assumed to denote objects.
+
+ function Is_Dereferenced (N : Node_Id) return Boolean;
+ -- N is a subexpression node of an access type. This function returns
+ -- true if N appears as the prefix of a node that does a dereference
+ -- of the access value (selected/indexed component, explicit dereference
+ -- or a slice), and false otherwise.
+
function Is_False (U : Uint) return Boolean;
-- The argument is a Uint value which is the Boolean'Pos value of a
-- Boolean operand (i.e. is either 0 for False, or 1 for True). This
@@ -424,12 +452,25 @@ package Sem_Util is
-- Typ is a type entity. This function returns true if this type is
-- fully initialized, meaning that an object of the type is fully
-- initialized. Note that initialization resulting from the use of
- -- pragma Normalized_Scalars does not count.
+ -- pragma Normalized_Scalars does not count. Note that this is only
+ -- used for the purpose of issuing warnings for objects that are
+ -- potentially referenced uninitialized. This means that the result
+ -- returned is not crucial, but probably should err on the side of
+ -- thinking things are fully initialized if it does not know.
function Is_Inherited_Operation (E : Entity_Id) return Boolean;
-- E is a subprogram. Return True is E is an implicit operation inherited
-- by a derived type declarations.
+ function Is_Lvalue (N : Node_Id) return Boolean;
+ -- Determines if N could be an lvalue (e.g. an assignment left hand side).
+ -- This determination is conservative, it must never answer False if N is
+ -- an lvalue, but it can answer True when N is not an lvalue. An lvalue is
+ -- defined as any expression which appears in a context where a name is
+ -- required by the syntax, and the identity, rather than merely the value
+ -- of the node is needed (for example, the prefix of an attribute is in
+ -- this category).
+
function Is_Library_Level_Entity (E : Entity_Id) return Boolean;
-- A library-level declaration is one that is accessible from Standard,
-- i.e. a library unit or an entity declared in a library package.
@@ -472,7 +513,7 @@ package Sem_Util is
function Is_Selector_Name (N : Node_Id) return Boolean;
-- Given an N_Identifier node N, determines if it is a Selector_Name.
-- As described in Sinfo, Selector_Names are special because they
- -- represent use of the N_Identifier node for a true identifier, when
+ -- represent use of the N_Identifier node for a true identifer, when
-- normally such nodes represent a direct name.
function Is_Statement (N : Node_Id) return Boolean;
@@ -501,7 +542,24 @@ package Sem_Util is
function Is_Volatile_Object (N : Node_Id) return Boolean;
-- Determines if the given node denotes an volatile object in the sense
- -- of the legality checks described in RM C.6(12).
+ -- of the legality checks described in RM C.6(12). Note that the test
+ -- here is for something actually declared as volatile, not for an object
+ -- that gets treated as volatile (see Einfo.Treat_As_Volatile).
+
+ procedure Kill_Current_Values;
+ -- This procedure is called to clear all constant indications from all
+ -- entities in the current scope and in any parent scopes if the current
+ -- scope is a block or a pacakage (and that recursion continues to the
+ -- top scope that is not a block or a package). This is used when the
+ -- sequential flow-of-control assumption is violated (occurence of a
+ -- label, head of a loop, or start of an exception handler). The effect
+ -- of the call is to clear the Constant_Value field (but we do not need
+ -- to clear the Is_True_Constant flag, since that only gets reset if
+ -- there really is an assignment somewhere in the entity scope). This
+ -- procedure also calls Kill_All_Checks, since this is a special case
+ -- of needing to forget saved values. This procedure also clears any
+ -- Is_Known_Non_Null flags in variables, constants or parameters
+ -- since these are also not known to be valid.
procedure Kill_Size_Check_Code (E : Entity_Id);
-- Called when an address clause or pragma Import is applied to an
@@ -516,8 +574,7 @@ package Sem_Util is
Related_Id : Entity_Id;
Suffix : Character;
Suffix_Index : Nat := 0;
- Prefix : Character := ' ')
- return Entity_Id;
+ Prefix : Character := ' ') return Entity_Id;
-- This function creates an N_Defining_Identifier node for an internal
-- created entity, such as an implicit type or subtype, or a record
-- initialization procedure. The entity name is constructed with a call
@@ -531,8 +588,7 @@ package Sem_Util is
(Kind : Entity_Kind;
Scope_Id : Entity_Id;
Sloc_Value : Source_Ptr;
- Id_Char : Character)
- return Entity_Id;
+ Id_Char : Character) return Entity_Id;
-- This function is similar to New_External_Entity, except that the
-- name is constructed by New_Internal_Name (Id_Char). This is used
-- when the resulting entity does not have to be referenced as a
@@ -557,7 +613,7 @@ package Sem_Util is
Report : Boolean;
Success : out Boolean);
-- Reorders lists of actuals according to names of formals, value returned
- -- in Success indicates success of reordering. For more details, see body.
+ -- in Success indicates sucess of reordering. For more details, see body.
-- Errors are reported only if Report is set to True.
procedure Note_Possible_Modification (N : Node_Id);
@@ -596,6 +652,26 @@ package Sem_Util is
-- S is a possibly signed syntactically valid real literal. The result
-- returned is an N_Real_Literal node representing the literal value.
+ function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id;
+ -- This is used to construct the second argument in a call to Rep_To_Pos
+ -- which is Standard_True if range checks are enabled (E is an entity to
+ -- which the Range_Checks_Suppressed test is applied), and Standard_False
+ -- if range checks are suppressed. Loc is the location for the node that
+ -- is returned (which is a New_Occurrence of the appropriate entity).
+ --
+ -- Note: one might think that it would be fine to always use True and
+ -- to ignore the suppress in this case, but it is generally better to
+ -- believe a request to suppress exceptions if possible, and further
+ -- more there is at least one case in the generated code (the code for
+ -- array assignment in a loop) that depends on this suppression.
+
+ procedure Require_Entity (N : Node_Id);
+ -- N is a node which should have an entity value if it is an entity name.
+ -- If not, then check if there were previous errors. If so, just fill
+ -- in with Any_Id and ignore. Otherwise signal a program error exception.
+ -- This is used as a defense mechanism against ill-formed trees caused by
+ -- previous errors (particularly in -gnatq mode).
+
function Requires_Transient_Scope (Id : Entity_Id) return Boolean;
-- E is a type entity. The result is True when temporaries of this
-- type need to be wrapped in a transient scope to be reclaimed
@@ -606,6 +682,18 @@ package Sem_Util is
procedure Reset_Analyzed_Flags (N : Node_Id);
-- Reset the Analyzed flags in all nodes of the tree whose root is N
+ function Safe_To_Capture_Value
+ (N : Node_Id;
+ Ent : Entity_Id)
+ return Boolean;
+ -- The caller is interested in capturing a value (either the current
+ -- value, or an indication that the value is non-null) for the given
+ -- entity Ent. This value can only be captured if sequential execution
+ -- semantics can be properly guaranteed so that a subsequent reference
+ -- will indeed be sure that this current value indication is correct.
+ -- The node N is the construct which resulted in the possible capture
+ -- of the value (this is used to check if we are in a conditional).
+
function Same_Name (N1, N2 : Node_Id) return Boolean;
-- Determine if two (possibly expanded) names are the same name
@@ -693,12 +781,15 @@ package Sem_Util is
function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
-- Unit_Id is the simple name of a program unit, this function returns
-- the corresponding xxx_Declaration node for the entity. Also applies
- -- to the body entities for subprograms in tasks, in which case it
- -- returns the subprogram or task body node for it. The unit may be
- -- a child unit with any number of ancestors.
+ -- to the body entities for subprograms, tasks and protected units, in
+ -- which case it returns the subprogram, task or protected body node
+ -- for it. The unit may be a child unit with any number of ancestors.
+
+ function Universal_Interpretation (Opnd : Node_Id) return Entity_Id;
+ -- Yields universal_Integer or Universal_Real if this is a candidate.
function Within_Init_Proc return Boolean;
- -- Determines if Current_Scope is within an Init_Proc
+ -- Determines if Current_Scope is within an init proc
procedure Wrong_Type (Expr : Node_Id; Expected_Type : Entity_Id);
-- Output error message for incorrectly typed expression. Expr is the
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 2e191b3e435..b77d49b9940 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-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- --
@@ -33,6 +33,7 @@ with Lib; use Lib;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
+with Sem_Ch8; use Sem_Ch8;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
@@ -53,6 +54,13 @@ package body Sem_Warn is
Table_Increment => Alloc.Unreferenced_Entities_Increment,
Table_Name => "Unreferenced_Entities");
+ ------------------------------
+ -- Handling of Conditionals --
+ ------------------------------
+
+ -- Note: this is work in progress, the data structures and general
+ -- approach are defined, but are not in use yet. ???
+
-- One entry is made in the following table for each branch of
-- a conditional, e.g. an if-then-elsif-else-endif structure
-- creates three entries in this table.
@@ -118,6 +126,22 @@ package body Sem_Warn is
Table_Increment => Alloc.Conditional_Stack_Increment,
Table_Name => "Conditional_Stack");
+ pragma Warnings (Off, Branch_Table);
+ pragma Warnings (Off, Conditional_Table);
+ pragma Warnings (Off, Conditional_Stack);
+ -- Not yet referenced, see note above ???
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean;
+ -- This returns true if the entity E is declared within a generic package.
+ -- The point of this is to detect variables which are not assigned within
+ -- the generic, but might be assigned outside the package for any given
+ -- instance. These are cases where we leave the warnings to be posted
+ -- for the instance, when we will know more.
+
function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean;
-- This function traverses the expression tree represented by the node
-- N and determines if any sub-operand is a reference to an entity for
@@ -131,7 +155,12 @@ package body Sem_Warn is
procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty) is
E1 : Entity_Id;
UR : Node_Id;
- PU : Node_Id;
+
+ function Missing_Subunits return Boolean;
+ -- We suppress warnings when there are missing subunits, because this
+ -- may generate too many false positives: entities in a parent may
+ -- only be referenced in one of the subunits. We make an exception
+ -- for subunits that contain no other stubs.
procedure Output_Reference_Error (M : String);
-- Used to output an error message. Deals with posting the error on
@@ -142,6 +171,49 @@ package body Sem_Warn is
-- from another unit. This is true for entities in packages that are
-- at the library level.
+ -----------------------
+ -- Missing_Subunits --
+ -----------------------
+
+ function Missing_Subunits return Boolean is
+ D : Node_Id;
+
+ begin
+ if not Unloaded_Subunits then
+
+ -- Normal compilation, all subunits are present
+
+ return False;
+
+ elsif E /= Main_Unit_Entity then
+
+ -- No warnings on a stub that is not the main unit
+
+ return True;
+
+ elsif Nkind (Unit_Declaration_Node (E)) in N_Proper_Body then
+ D := First (Declarations (Unit_Declaration_Node (E)));
+
+ while Present (D) loop
+
+ -- No warnings if the proper body contains nested stubs
+
+ if Nkind (D) in N_Body_Stub then
+ return True;
+ end if;
+
+ Next (D);
+ end loop;
+
+ return False;
+
+ else
+ -- Missing stubs elsewhere
+
+ return True;
+ end if;
+ end Missing_Subunits;
+
----------------------------
-- Output_Reference_Error --
----------------------------
@@ -189,18 +261,20 @@ package body Sem_Warn is
----------------------------
function Publicly_Referenceable (Ent : Entity_Id) return Boolean is
- P : Node_Id;
+ P : Node_Id;
+ Prev : Node_Id;
begin
-- Examine parents to look for a library level package spec
-- But if we find a body or block or other similar construct
-- along the way, we cannot be referenced.
- P := Parent (Ent);
+ Prev := Ent;
+ P := Parent (Ent);
loop
case Nkind (P) is
- -- If we get to top of tree, then publicly referencable
+ -- If we get to top of tree, then publicly referenceable
when N_Empty =>
return True;
@@ -210,14 +284,31 @@ package body Sem_Warn is
-- have access to the entities in the generic package. Note
-- that the package itself may not be instantiated, but then
-- we will get a warning for the package entity
+ -- Note that generic formal parameters are themselves not
+ -- publicly referenceable in an instance, and warnings on
+ -- them are useful.
when N_Generic_Package_Declaration =>
- return True;
+ return
+ not Is_List_Member (Prev)
+ or else List_Containing (Prev)
+ /= Generic_Formal_Declarations (P);
+
+ -- if we reach a subprogram body, entity is not referenceable
+ -- unless it is the defining entity of the body. This will
+ -- happen, e.g. when a function is an attribute renaming that
+ -- is rewritten as a body.
+
+ when N_Subprogram_Body =>
+ if Ent /= Defining_Entity (P) then
+ return False;
+ else
+ P := Parent (P);
+ end if;
- -- If we reach any body, then definitely not referenceable
+ -- If we reach any other body, definitely not referenceable
when N_Package_Body |
- N_Subprogram_Body |
N_Task_Body |
N_Entry_Body |
N_Protected_Body |
@@ -228,7 +319,8 @@ package body Sem_Warn is
-- For all other cases, keep looking up tree
when others =>
- P := Parent (P);
+ Prev := P;
+ P := Parent (P);
end case;
end loop;
end Publicly_Referenceable;
@@ -240,14 +332,17 @@ package body Sem_Warn is
-- any real errors so far (this last check avoids junk messages
-- resulting from errors, e.g. a subunit that is not loaded).
+ if Warning_Mode = Suppress
+ or else Serious_Errors_Detected /= 0
+ then
+ return;
+ end if;
+
-- We also skip the messages if any subunits were not loaded (see
-- comment in Sem_Ch10 to understand how this is set, and why it is
-- necessary to suppress the warnings in this case).
- if Warning_Mode = Suppress
- or else Serious_Errors_Detected /= 0
- or else Unloaded_Subunits
- then
+ if Missing_Subunits then
return;
end if;
@@ -271,6 +366,7 @@ package body Sem_Warn is
-- Post warning if this object not assigned. Note that we
-- do not consider the implicit initialization of an access
-- type to be the assignment of a value for this purpose.
+
-- If the entity is an out parameter of the current subprogram
-- body, check the warning status of the parameter in the spec.
@@ -280,51 +376,83 @@ package body Sem_Warn is
then
null;
- elsif Not_Source_Assigned (E1) then
- Output_Reference_Error ("& is never assigned a value?");
+ elsif Never_Set_In_Source (E1)
+ and then not Generic_Package_Spec_Entity (E1)
+ then
+ if Warn_On_No_Value_Assigned then
- -- Deal with special case where this variable is hidden
- -- by a loop variable
+ -- Do not output complaint about never being assigned a
+ -- value if a pragma Unreferenced applies to the variable
+ -- or if it is a parameter, to the corresponding spec.
- if Ekind (E1) = E_Variable
- and then Present (Hiding_Loop_Variable (E1))
- then
- Error_Msg_Sloc := Sloc (E1);
- Error_Msg_N
- ("declaration hides &#?",
- Hiding_Loop_Variable (E1));
- Error_Msg_N
- ("for loop implicitly declares loop variable?",
- Hiding_Loop_Variable (E1));
- end if;
+ if Has_Pragma_Unreferenced (E1)
+ or else (Is_Formal (E1)
+ and then Present (Spec_Entity (E1))
+ and then
+ Has_Pragma_Unreferenced (Spec_Entity (E1)))
+ then
+ null;
+
+ -- Pragma Unreferenced not set, so output message
+ else
+ Output_Reference_Error
+ ("& is never assigned a value?");
+
+ -- Deal with special case where this variable is
+ -- hidden by a loop variable
+
+ if Ekind (E1) = E_Variable
+ and then Present (Hiding_Loop_Variable (E1))
+ then
+ Error_Msg_Sloc := Sloc (E1);
+ Error_Msg_N
+ ("declaration hides &#?",
+ Hiding_Loop_Variable (E1));
+ Error_Msg_N
+ ("for loop implicitly declares loop variable?",
+ Hiding_Loop_Variable (E1));
+ end if;
+ end if;
+ end if;
goto Continue;
+
+ -- Case of variable that could be a constant. Note that we
+ -- never signal such messages for generic package entities,
+ -- since a given instance could have modifications outside
+ -- the package.
+
+ elsif Warn_On_Constant
+ and then Ekind (E1) = E_Variable
+ and then Is_True_Constant (E1)
+ and then not Generic_Package_Spec_Entity (E1)
+ then
+ Error_Msg_N
+ ("& is not modified, could be declared constant?", E1);
end if;
-- Check for unset reference, note that we exclude access
-- types from this check, since access types do always have
-- a null value, and that seems legitimate in this case.
- UR := Unset_Reference (E1);
- if Present (UR) then
+ if Ekind (E1) = E_Out_Parameter
+ and then Present (Spec_Entity (E1))
+ then
+ UR := Unset_Reference (Spec_Entity (E1));
+ else
+ UR := Unset_Reference (E1);
+ end if;
+
+ if Warn_On_No_Value_Assigned and then Present (UR) then
- -- For access types, the only time we complain is when
- -- we have a dereference (of a null value)
+ -- For access types, the only time we made a UR entry
+ -- was for a dereference, and so we post the appropriate
+ -- warning here. The issue is not that the value is not
+ -- initialized here, but that it is null.
if Is_Access_Type (Etype (E1)) then
- PU := Parent (UR);
-
- if (Nkind (PU) = N_Selected_Component
- or else
- Nkind (PU) = N_Explicit_Dereference
- or else
- Nkind (PU) = N_Indexed_Component)
- and then
- Prefix (PU) = UR
- then
- Error_Msg_N ("& may be null?", UR);
- goto Continue;
- end if;
+ Error_Msg_NE ("& may be null?", UR, E1);
+ goto Continue;
-- For other than access type, go back to original node
-- to deal with case where original unset reference
@@ -343,14 +471,28 @@ package body Sem_Warn is
UR := Expression (UR);
end loop;
- Error_Msg_N
- ("& may be referenced before it has a value?", UR);
+ -- Here we issue the warning, all checks completed
+
+ if Nkind (Parent (UR)) = N_Selected_Component then
+ Error_Msg_Node_2 := Selector_Name (Parent (UR));
+ Error_Msg_N
+ ("`&.&` may be referenced before it has a value?",
+ UR);
+ else
+ Error_Msg_N
+ ("& may be referenced before it has a value?",
+ UR);
+ end if;
+
goto Continue;
end if;
end if;
end if;
- -- Then check for unreferenced variables
+ -- Then check for unreferenced entities. Note that we are only
+ -- interested in entities which do not have the Referenced flag
+ -- set. The Referenced_As_LHS flag is interesting only if the
+ -- Referenced flag is not set.
if not Referenced (E1)
@@ -358,10 +500,15 @@ package body Sem_Warn is
and then ((Check_Unreferenced and then not Is_Formal (E1))
or else
- (Check_Unreferenced_Formals and then Is_Formal (E1)))
+ (Check_Unreferenced_Formals and then Is_Formal (E1))
+ or else
+ (Warn_On_Modified_Unread
+ and then Referenced_As_LHS (E1)))
- -- Warnings are placed on objects, types, subprograms,
- -- labels, and enumeration literals.
+ -- Labels, and enumeration literals, and exceptions. The
+ -- warnings are also placed on local packages that cannot
+ -- be referenced from elsewhere, including those declared
+ -- within a package body.
and then (Is_Object (E1)
or else
@@ -369,15 +516,20 @@ package body Sem_Warn is
or else
Ekind (E1) = E_Label
or else
+ Ekind (E1) = E_Exception
+ or else
Ekind (E1) = E_Named_Integer
or else
Ekind (E1) = E_Named_Real
or else
- Is_Overloadable (E1))
-
- -- We only place warnings for the extended main unit
-
- and then In_Extended_Main_Source_Unit (E1)
+ Is_Overloadable (E1)
+ or else
+ (Ekind (E1) = E_Package
+ and then
+ (Ekind (E) = E_Function
+ or else Ekind (E) = E_Package_Body
+ or else Ekind (E) = E_Procedure
+ or else Ekind (E) = E_Block)))
-- Exclude instantiations, since there is no reason why
-- every entity in an instantiation should be referenced.
@@ -397,10 +549,14 @@ package body Sem_Warn is
Referenced (Spec_Entity (E1)))
-- Consider private type referenced if full view is referenced
+ -- If there is not full view, this is a generic type on which
+ -- warnings are also useful.
- and then not (Is_Private_Type (E1)
- and then
- Referenced (Full_View (E1)))
+ and then
+ not (Is_Private_Type (E1)
+ and then
+ Present (Full_View (E1))
+ and then Referenced (Full_View (E1)))
-- Don't worry about full view, only about private type
@@ -465,14 +621,37 @@ package body Sem_Warn is
(Unreferenced_Entities.Last) := E1;
end if;
end if;
+
+ -- Generic units are referenced in the generic body,
+ -- but if they are not public and never instantiated
+ -- we want to force a warning on them. We treat them
+ -- as redundant constructs to minimize noise.
+
+ elsif Is_Generic_Subprogram (E1)
+ and then not Is_Instantiated (E1)
+ and then not Publicly_Referenceable (E1)
+ and then Instantiation_Depth (Sloc (E1)) = 0
+ and then Warn_On_Redundant_Constructs
+ then
+ Unreferenced_Entities.Increment_Last;
+ Unreferenced_Entities.Table (Unreferenced_Entities.Last) := E1;
+
+ -- Force warning on entity.
+
+ Set_Referenced (E1, False);
end if;
end if;
- -- Recurse into nested package or block
+ -- Recurse into nested package or block. Do not recurse into a
+ -- formal package, because the correponding body is not analyzed.
<<Continue>>
- if (Ekind (E1) = E_Package
- and then Nkind (Parent (E1)) = N_Package_Specification)
+ if ((Ekind (E1) = E_Package or else Ekind (E1) = E_Generic_Package)
+ and then Nkind (Parent (E1)) = N_Package_Specification
+ and then
+ Nkind (Original_Node (Unit_Declaration_Node (E1)))
+ /= N_Formal_Package_Declaration)
+
or else Ekind (E1) = E_Block
then
Check_References (E1);
@@ -494,6 +673,16 @@ package body Sem_Warn is
return;
end if;
+ -- Ignore reference to non-scalar if not from source. Almost always
+ -- such references are bogus (e.g. calls to init procs to set
+ -- default discriminant values).
+
+ if not Comes_From_Source (N)
+ and then not Is_Scalar_Type (Etype (N))
+ then
+ return;
+ end if;
+
-- Otherwise see what kind of node we have. If the entity already
-- has an unset reference, it is not necessarily the earliest in
-- the text, because resolution of the prefix of selected components
@@ -503,20 +692,48 @@ package body Sem_Warn is
-- unset reference, we check whether N is earlier before proceeding.
case Nkind (N) is
-
when N_Identifier | N_Expanded_Name =>
declare
- E : constant Entity_Id := Entity (N);
+ E : constant Entity_Id := Entity (N);
begin
if (Ekind (E) = E_Variable
or else Ekind (E) = E_Out_Parameter)
- and then Not_Source_Assigned (E)
+ and then Never_Set_In_Source (E)
and then (No (Unset_Reference (E))
or else Earlier_In_Extended_Unit
(Sloc (N), Sloc (Unset_Reference (E))))
and then not Warnings_Off (E)
then
+ -- We may have an unset reference. The first test is
+ -- whether we are accessing a discriminant of a record
+ -- or a component with default initialization. Both of
+ -- these cases can be ignored, since the actual object
+ -- that is referenced is definitely initialized. Note
+ -- that this covers the case of reading discriminants
+ -- of an out parameter, which is OK even in Ada 83.
+
+ -- Note that we are only interested in a direct reference
+ -- to a record component here. If the reference is via an
+ -- access type, then the access object is being referenced,
+ -- not the record, and still deserves an unset reference.
+
+ if Nkind (Parent (N)) = N_Selected_Component
+ and not Is_Access_Type (Etype (N))
+ then
+ declare
+ ES : constant Entity_Id :=
+ Entity (Selector_Name (Parent (N)));
+
+ begin
+ if Ekind (ES) = E_Discriminant
+ or else Present (Expression (Declaration_Node (ES)))
+ then
+ return;
+ end if;
+ end;
+ end if;
+
-- Here we have a potential unset reference. But before we
-- get worried about it, we have to make sure that the
-- entity declaration is in the same procedure as the
@@ -529,18 +746,6 @@ package body Sem_Warn is
-- As always, it is possible to construct cases where the
-- warning is wrong, that is why it is a warning!
- -- If the entity is an out_parameter, it is ok to read its
- -- its discriminants (that was true in Ada83) so suppress
- -- the message in that case as well.
-
- if Ekind (E) = E_Out_Parameter
- and then Nkind (Parent (N)) = N_Selected_Component
- and then Ekind (Entity (Selector_Name (Parent (N))))
- = E_Discriminant
- then
- return;
- end if;
-
declare
SR : Entity_Id;
SE : constant Entity_Id := Scope (E);
@@ -559,8 +764,119 @@ package body Sem_Warn is
SR := Scope (SR);
end loop;
+ -- Case of reference has an access type. This is a
+ -- special case since access types are always set to
+ -- null so cannot be truly uninitialized, but we still
+ -- want to warn about cases of obvious null dereference.
+
+ if Is_Access_Type (Etype (N)) then
+ declare
+ P : Node_Id;
+
+ function Process
+ (N : Node_Id)
+ return Traverse_Result;
+ -- Process function for instantation of Traverse
+ -- below. Checks if N contains reference to E
+ -- other than a dereference.
+
+ function Ref_In (Nod : Node_Id) return Boolean;
+ -- Determines whether Nod contains a reference
+ -- to the entity E that is not a dereference.
+
+ function Process
+ (N : Node_Id)
+ return Traverse_Result
+ is
+ begin
+ if Is_Entity_Name (N)
+ and then Entity (N) = E
+ and then not Is_Dereferenced (N)
+ then
+ return Abandon;
+ else
+ return OK;
+ end if;
+ end Process;
+
+ function Ref_In (Nod : Node_Id) return Boolean is
+ function Traverse is new Traverse_Func (Process);
+
+ begin
+ return Traverse (Nod) = Abandon;
+ end Ref_In;
+
+ begin
+ -- Don't bother if we are inside an instance,
+ -- since the compilation of the generic template
+ -- is where the warning should be issued.
+
+ if In_Instance then
+ return;
+ end if;
+
+ -- Don't bother if this is not the main unit.
+ -- If we try to give this warning for with'ed
+ -- units, we get some false positives, since
+ -- we do not record references in other units.
+
+ if not In_Extended_Main_Source_Unit (E)
+ or else
+ not In_Extended_Main_Source_Unit (N)
+ then
+ return;
+ end if;
+
+ -- We are only interested in deferences
+
+ if not Is_Dereferenced (N) then
+ return;
+ end if;
+
+ -- One more check, don't bother with references
+ -- that are inside conditional statements or while
+ -- loops if the condition references the entity in
+ -- question. This avoids most false positives.
+
+ P := Parent (N);
+ loop
+ P := Parent (P);
+ exit when No (P);
+
+ if (Nkind (P) = N_If_Statement
+ or else
+ Nkind (P) = N_Elsif_Part)
+ and then Ref_In (Condition (P))
+ then
+ return;
+
+ elsif Nkind (P) = N_Loop_Statement
+ and then Present (Iteration_Scheme (P))
+ and then
+ Ref_In (Condition (Iteration_Scheme (P)))
+ then
+ return;
+ end if;
+ end loop;
+ end;
+ end if;
+
+ -- Here we definitely have a case for giving a warning
+ -- for a reference to an unset value. But we don't give
+ -- the warning now. Instead we set the Unset_Reference
+ -- field of the identifier involved. The reason for this
+ -- is that if we find the variable is never ever assigned
+ -- a value then that warning is more important and there
+ -- is no point in giving the reference warning.
+
+ -- If this is an identifier, set the field directly
+
if Nkind (N) = N_Identifier then
Set_Unset_Reference (E, N);
+
+ -- Otherwise it is an expanded name, so set the field
+ -- of the actual identifier for the reference.
+
else
Set_Unset_Reference (E, Selector_Name (N));
end if;
@@ -568,9 +884,21 @@ package body Sem_Warn is
end if;
end;
- when N_Indexed_Component | N_Selected_Component | N_Slice =>
+ when N_Indexed_Component | N_Slice =>
Check_Unset_Reference (Prefix (N));
- return;
+
+ when N_Selected_Component =>
+
+ if Present (Entity (Selector_Name (N)))
+ and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
+ then
+ -- A discriminant is always initialized
+
+ null;
+
+ else
+ Check_Unset_Reference (Prefix (N));
+ end if;
when N_Type_Conversion | N_Qualified_Expression =>
Check_Unset_Reference (Expression (N));
@@ -605,6 +933,16 @@ package body Sem_Warn is
Is_Visible_Renaming : Boolean := False;
Pack : Entity_Id;
+ procedure Check_Inner_Package (Pack : Entity_Id);
+ -- Pack is a package local to a unit in a with_clause. Both the
+ -- unit and Pack are referenced. If none of the entities in Pack
+ -- are referenced, then the only occurrence of Pack is in a use
+ -- clause or a pragma, and a warning is worthwhile as well.
+
+ function Check_System_Aux return Boolean;
+ -- Before giving a warning on a with_clause for System, check
+ -- whether a system extension is present.
+
function Find_Package_Renaming
(P : Entity_Id;
L : Entity_Id) return Entity_Id;
@@ -613,6 +951,93 @@ package body Sem_Warn is
-- not warn that the context clause could be moved to the body,
-- because the renaming may be intented to re-export the unit.
+ -------------------------
+ -- Check_Inner_Package --
+ -------------------------
+
+ procedure Check_Inner_Package (Pack : Entity_Id) is
+ E : Entity_Id;
+ Un : constant Node_Id := Sinfo.Unit (Cnode);
+
+ function Check_Use_Clause (N : Node_Id) return Traverse_Result;
+ -- If N is a use_clause for Pack, emit warning.
+
+ procedure Check_Use_Clauses is new
+ Traverse_Proc (Check_Use_Clause);
+
+ ----------------------
+ -- Check_Use_Clause --
+ ----------------------
+
+ function Check_Use_Clause (N : Node_Id) return Traverse_Result is
+ Nam : Node_Id;
+
+ begin
+ if Nkind (N) = N_Use_Package_Clause then
+ Nam := First (Names (N));
+
+ while Present (Nam) loop
+ if Entity (Nam) = Pack then
+ Error_Msg_Qual_Level := 1;
+ Error_Msg_NE
+ ("no entities of package& are referenced?",
+ Nam, Pack);
+ Error_Msg_Qual_Level := 0;
+ end if;
+
+ Next (Nam);
+ end loop;
+ end if;
+
+ return OK;
+ end Check_Use_Clause;
+
+ -- Start of processing for Check_Inner_Package
+
+ begin
+ E := First_Entity (Pack);
+
+ while Present (E) loop
+ if Referenced (E) then
+ return;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+
+ -- No entities of the package are referenced. Check whether
+ -- the reference to the package itself is a use clause, and
+ -- if so place a warning on it.
+
+ Check_Use_Clauses (Un);
+ end Check_Inner_Package;
+
+ ----------------------
+ -- Check_System_Aux --
+ ----------------------
+
+ function Check_System_Aux return Boolean is
+ Ent : Entity_Id;
+
+ begin
+ if Chars (Lunit) = Name_System
+ and then Scope (Lunit) = Standard_Standard
+ and then Present_System_Aux
+ then
+ Ent := First_Entity (System_Aux_Id);
+
+ while Present (Ent) loop
+ if Referenced (Ent) then
+ return True;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end if;
+
+ return False;
+ end Check_System_Aux;
+
---------------------------
-- Find_Package_Renaming --
---------------------------
@@ -666,11 +1091,11 @@ package body Sem_Warn is
if not In_Extended_Main_Source_Unit (Cnode) then
return;
- -- In No_Run_Time_Mode, we remove the bodies of non-
- -- inlined subprograms, which may lead to spurious
- -- warnings, clearly undesirable.
+ -- In configurable run time mode, we remove the bodies of
+ -- non-inlined subprograms, which may lead to spurious warnings,
+ -- which are clearly undesirable.
- elsif No_Run_Time
+ elsif Configurable_Run_Time_Mode
and then Is_Predefined_File_Name (Unit_File_Name (Unit))
then
return;
@@ -680,7 +1105,6 @@ package body Sem_Warn is
Item := First (Context_Items (Cnode));
while Present (Item) loop
-
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
and then In_Extended_Main_Source_Unit (Item)
@@ -750,8 +1174,7 @@ package body Sem_Warn is
-- Otherwise see if any entities have been referenced
else
- Ent := First_Entity (Lunit);
-
+ Ent := First_Entity (Lunit);
loop
-- No more entities, and we did not find one
-- that was referenced. Means we have a definite
@@ -765,6 +1188,9 @@ package body Sem_Warn is
if Unit = Spec_Unit then
Set_No_Entities_Ref_In_Spec (Item);
+ elsif Check_System_Aux then
+ null;
+
-- Else give the warning
else
@@ -793,8 +1219,9 @@ package body Sem_Warn is
-- Case of next entity is referenced
- elsif Referenced (Ent) then
-
+ elsif Referenced (Ent)
+ or else Referenced_As_LHS (Ent)
+ then
-- This means that the with is indeed fine, in
-- that it is definitely needed somewhere, and
-- we can quite worrying about this one.
@@ -823,6 +1250,10 @@ package body Sem_Warn is
Name (Item));
else
+ if Ekind (Ent) = E_Package then
+ Check_Inner_Package (Ent);
+ end if;
+
exit;
end if;
@@ -913,6 +1344,37 @@ package body Sem_Warn is
end if;
end Check_Unused_Withs;
+ ---------------------------------
+ -- Generic_Package_Spec_Entity --
+ ---------------------------------
+
+ function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean is
+ S : Entity_Id;
+
+ begin
+ if Is_Package_Body_Entity (E) then
+ return False;
+
+ else
+ S := Scope (E);
+
+ loop
+ if S = Standard_Standard then
+ return False;
+
+ elsif Ekind (S) = E_Generic_Package then
+ return True;
+
+ elsif Ekind (S) = E_Package then
+ S := Scope (S);
+
+ else
+ return False;
+ end if;
+ end loop;
+ end if;
+ end Generic_Package_Spec_Entity;
+
-------------------------------------
-- Operand_Has_Warnings_Suppressed --
-------------------------------------
@@ -974,15 +1436,34 @@ package body Sem_Warn is
E := Unreferenced_Entities.Table (J);
if not Referenced (E) and then not Warnings_Off (E) then
-
case Ekind (E) is
when E_Variable =>
- if Present (Renamed_Object (E))
- and then Comes_From_Source (Renamed_Object (E))
+
+ -- Case of variable that is assigned but not read. We
+ -- suppress the message if the variable is volatile or
+ -- has an address clause.
+
+ if Referenced_As_LHS (E)
+ and then No (Address_Clause (E))
+ and then not Is_Volatile (E)
then
- Error_Msg_N ("renamed variable & is not referenced?", E);
+ if Warn_On_Modified_Unread then
+ Error_Msg_N
+ ("variable & is assigned but never read?", E);
+ end if;
+
+ -- Normal case of neither assigned nor read
+
else
- Error_Msg_N ("variable & is not referenced?", E);
+ if Present (Renamed_Object (E))
+ and then Comes_From_Source (Renamed_Object (E))
+ then
+ Error_Msg_N
+ ("renamed variable & is not referenced?", E);
+ else
+ Error_Msg_N
+ ("variable & is not referenced?", E);
+ end if;
end if;
when E_Constant =>
@@ -1020,6 +1501,13 @@ package body Sem_Warn is
when E_Procedure =>
Error_Msg_N ("procedure & is not referenced?", E);
+ when E_Generic_Procedure =>
+ Error_Msg_N
+ ("generic procedure & is never instantiated?", E);
+
+ when E_Generic_Function =>
+ Error_Msg_N ("generic function & is never instantiated?", E);
+
when Type_Kind =>
Error_Msg_N ("type & is not referenced?", E);
@@ -1040,6 +1528,13 @@ package body Sem_Warn is
P : Node_Id;
begin
+ -- Argument replacement in an inlined body can make conditions
+ -- static. Do not emit warnings in this case.
+
+ if In_Inlined_Body then
+ return;
+ end if;
+
if Constant_Condition_Warnings
and then Nkind (C) = N_Identifier
and then
diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb
index 1652e6eb732..4c2a6dcdfc4 100644
--- a/gcc/ada/sfn_scan.adb
+++ b/gcc/ada/sfn_scan.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -38,6 +38,13 @@ package body SFN_Scan is
use ASCII;
-- Allow easy access to control character definitions
+ EOF : constant Character := ASCII.SUB;
+ -- The character SUB (16#1A#) is used in DOS and other systems derived
+ -- from DOS (OS/2, NT etc) to signal the end of a text file. If this
+ -- character appears as the last character of a file scanned by a call
+ -- to Scan_SFN_Pragmas, then it is ignored, otherwise it is treated as
+ -- an illegal character.
+
type String_Ptr is access String;
S : String_Ptr;
@@ -184,7 +191,22 @@ package body SFN_Scan is
function At_EOF return Boolean is
begin
- return P > S'Last;
+ -- Immediate return (False) if before last character of file
+
+ if P < S'Last then
+ return False;
+
+ -- Special case: DOS EOF character as last character of file is
+ -- allowed and treated as an end of file.
+
+ elsif P = S'Last then
+ return S (P) = EOF;
+
+ -- If beyond last character of file, then definitely at EOF
+
+ else
+ return True;
+ end if;
end At_EOF;
---------------------
diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index f782b3ddf45..22b8137ed39 100644
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.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- --
@@ -222,7 +222,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
return Flag15 (N);
end Assignment_OK;
@@ -322,10 +322,18 @@ package body Sinfo is
(N : Node_Id) return Name_Id is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Has_Chars);
+ or else NT (N).Nkind in N_Has_Chars);
return Name1 (N);
end Chars;
+ function Check_Address_Alignment
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Definition_Clause);
+ return Flag11 (N);
+ end Check_Address_Alignment;
+
function Choice_Parameter
(N : Node_Id) return Node_Id is
begin
@@ -419,6 +427,14 @@ package body Sinfo is
return List3 (N);
end Condition_Actions;
+ function Config_Pragmas
+ (N : Node_Id) return List_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit_Aux);
+ return List4 (N);
+ end Config_Pragmas;
+
function Constant_Present
(N : Node_Id) return Boolean is
begin
@@ -481,6 +497,7 @@ package body Sinfo is
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Declaration
or else NT (N).Nkind = N_Generic_Package_Declaration
or else NT (N).Nkind = N_Generic_Subprogram_Declaration
or else NT (N).Nkind = N_Package_Body_Stub
@@ -744,18 +761,6 @@ package body Sinfo is
return Node5 (N);
end Discriminant_Type;
- function Do_Access_Check
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Explicit_Dereference
- or else NT (N).Nkind = N_Indexed_Component
- or else NT (N).Nkind = N_Selected_Component
- or else NT (N).Nkind = N_Slice);
- return Flag11 (N);
- end Do_Access_Check;
-
function Do_Accessibility_Check
(N : Node_Id) return Boolean is
begin
@@ -798,7 +803,7 @@ package body Sinfo is
(N : Node_Id) return Boolean is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Op
+ or else NT (N).Nkind in N_Op
or else NT (N).Nkind = N_Attribute_Reference
or else NT (N).Nkind = N_Type_Conversion);
return Flag17 (N);
@@ -808,7 +813,7 @@ package body Sinfo is
(N : Node_Id) return Boolean is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
return Flag9 (N);
end Do_Range_Check;
@@ -920,7 +925,7 @@ package body Sinfo is
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Has_Entity
+ or else NT (N).Nkind in N_Has_Entity
or else NT (N).Nkind = N_Freeze_Entity);
return Node4 (N);
end Entity;
@@ -978,7 +983,7 @@ package body Sinfo is
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Has_Etype);
+ or else NT (N).Nkind in N_Has_Etype);
return Node5 (N);
end Etype;
@@ -1263,7 +1268,7 @@ package body Sinfo is
(N : Node_Id) return Boolean is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Op
+ or else NT (N).Nkind in N_Op
or else NT (N).Nkind = N_Character_Literal
or else NT (N).Nkind = N_Expanded_Name
or else NT (N).Nkind = N_Identifier
@@ -1342,7 +1347,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_With_Clause);
- return Flag17 (N);
+ return Flag16 (N);
end Implicit_With;
function In_Present
@@ -1409,10 +1414,18 @@ package body Sinfo is
(N : Node_Id) return Boolean is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
return Flag16 (N);
end Is_Controlling_Actual;
+ function Is_In_Discriminant_Check
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Selected_Component);
+ return Flag11 (N);
+ end Is_In_Discriminant_Check;
+
function Is_Machine_Number
(N : Node_Id) return Boolean is
begin
@@ -1421,11 +1434,19 @@ package body Sinfo is
return Flag11 (N);
end Is_Machine_Number;
+ function Is_Null_Loop
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Loop_Statement);
+ return Flag16 (N);
+ end Is_Null_Loop;
+
function Is_Overloaded
(N : Node_Id) return Boolean is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
return Flag5 (N);
end Is_Overloaded;
@@ -1449,7 +1470,7 @@ package body Sinfo is
(N : Node_Id) return Boolean is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
return Flag6 (N);
end Is_Static_Expression;
@@ -1535,7 +1556,7 @@ package body Sinfo is
or else NT (N).Nkind = N_In
or else NT (N).Nkind = N_Not_In
or else NT (N).Nkind = N_Or_Else
- or else NT (N).Nkind in N_Binary_Op);
+ or else NT (N).Nkind in N_Binary_Op);
return Node2 (N);
end Left_Opnd;
@@ -1552,13 +1573,23 @@ package body Sinfo is
return Node4 (N);
end Library_Unit;
+ function Limited_View_Installed
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Package_Specification
+ or else NT (N).Nkind = N_With_Clause);
+ return Flag18 (N);
+ end Limited_View_Installed;
+
function Limited_Present
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Formal_Private_Type_Definition
or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Record_Definition);
+ or else NT (N).Nkind = N_Record_Definition
+ or else NT (N).Nkind = N_With_Clause);
return Flag17 (N);
end Limited_Present;
@@ -1631,7 +1662,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Subtype_Indication
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
return Flag8 (N);
end Must_Not_Freeze;
@@ -1740,6 +1771,14 @@ package body Sinfo is
return Flag13 (N);
end No_Initialization;
+ function No_Truncation
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+ return Flag17 (N);
+ end No_Truncation;
+
function Null_Present
(N : Node_Id) return Boolean is
begin
@@ -1782,6 +1821,15 @@ package body Sinfo is
return Node2 (N);
end Original_Discriminant;
+ function Original_Entity
+ (N : Node_Id) return Entity_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Integer_Literal
+ or else NT (N).Nkind = N_Real_Literal);
+ return Node2 (N);
+ end Original_Entity;
+
function Others_Discrete_Choices
(N : Node_Id) return List_Id is
begin
@@ -2000,7 +2048,7 @@ package body Sinfo is
(N : Node_Id) return Boolean is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
return Flag7 (N);
end Raises_Constraint_Error;
@@ -2087,7 +2135,7 @@ package body Sinfo is
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Op
+ or else NT (N).Nkind in N_Op
or else NT (N).Nkind = N_And_Then
or else NT (N).Nkind = N_In
or else NT (N).Nkind = N_Not_In
@@ -2597,7 +2645,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Object_Declaration
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
Set_Flag15 (N, Val);
end Set_Assignment_OK;
@@ -2697,10 +2745,18 @@ package body Sinfo is
(N : Node_Id; Val : Name_Id) is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Has_Chars);
+ or else NT (N).Nkind in N_Has_Chars);
Set_Name1 (N, Val);
end Set_Chars;
+ procedure Set_Check_Address_Alignment
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Attribute_Definition_Clause);
+ Set_Flag11 (N, Val);
+ end Set_Check_Address_Alignment;
+
procedure Set_Choice_Parameter
(N : Node_Id; Val : Node_Id) is
begin
@@ -2794,6 +2850,14 @@ package body Sinfo is
Set_List3 (N, Val); -- semantic field, no parent set
end Set_Condition_Actions;
+ procedure Set_Config_Pragmas
+ (N : Node_Id; Val : List_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Compilation_Unit_Aux);
+ Set_List4_With_Parent (N, Val);
+ end Set_Config_Pragmas;
+
procedure Set_Constant_Present
(N : Node_Id; Val : Boolean := True) is
begin
@@ -2856,6 +2920,7 @@ package body Sinfo is
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Entry_Declaration
or else NT (N).Nkind = N_Generic_Package_Declaration
or else NT (N).Nkind = N_Generic_Subprogram_Declaration
or else NT (N).Nkind = N_Package_Body_Stub
@@ -3118,18 +3183,6 @@ package body Sinfo is
Set_Node5_With_Parent (N, Val);
end Set_Discriminant_Type;
- procedure Set_Do_Access_Check
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Attribute_Reference
- or else NT (N).Nkind = N_Explicit_Dereference
- or else NT (N).Nkind = N_Indexed_Component
- or else NT (N).Nkind = N_Selected_Component
- or else NT (N).Nkind = N_Slice);
- Set_Flag11 (N, Val);
- end Set_Do_Access_Check;
-
procedure Set_Do_Accessibility_Check
(N : Node_Id; Val : Boolean := True) is
begin
@@ -3172,7 +3225,7 @@ package body Sinfo is
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Op
+ or else NT (N).Nkind in N_Op
or else NT (N).Nkind = N_Attribute_Reference
or else NT (N).Nkind = N_Type_Conversion);
Set_Flag17 (N, Val);
@@ -3182,7 +3235,7 @@ package body Sinfo is
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
Set_Flag9 (N, Val);
end Set_Do_Range_Check;
@@ -3294,7 +3347,7 @@ package body Sinfo is
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Has_Entity
+ or else NT (N).Nkind in N_Has_Entity
or else NT (N).Nkind = N_Freeze_Entity);
Set_Node4 (N, Val); -- semantic field, no parent set
end Set_Entity;
@@ -3352,7 +3405,7 @@ package body Sinfo is
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Has_Etype);
+ or else NT (N).Nkind in N_Has_Etype);
Set_Node5 (N, Val); -- semantic field, no parent set
end Set_Etype;
@@ -3637,7 +3690,7 @@ package body Sinfo is
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Op
+ or else NT (N).Nkind in N_Op
or else NT (N).Nkind = N_Character_Literal
or else NT (N).Nkind = N_Expanded_Name
or else NT (N).Nkind = N_Identifier
@@ -3716,7 +3769,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_With_Clause);
- Set_Flag17 (N, Val);
+ Set_Flag16 (N, Val);
end Set_Implicit_With;
procedure Set_In_Present
@@ -3783,10 +3836,18 @@ package body Sinfo is
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
Set_Flag16 (N, Val);
end Set_Is_Controlling_Actual;
+ procedure Set_Is_In_Discriminant_Check
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Selected_Component);
+ Set_Flag11 (N, Val);
+ end Set_Is_In_Discriminant_Check;
+
procedure Set_Is_Machine_Number
(N : Node_Id; Val : Boolean := True) is
begin
@@ -3795,11 +3856,19 @@ package body Sinfo is
Set_Flag11 (N, Val);
end Set_Is_Machine_Number;
+ procedure Set_Is_Null_Loop
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Loop_Statement);
+ Set_Flag16 (N, Val);
+ end Set_Is_Null_Loop;
+
procedure Set_Is_Overloaded
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
Set_Flag5 (N, Val);
end Set_Is_Overloaded;
@@ -3823,7 +3892,7 @@ package body Sinfo is
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
Set_Flag6 (N, Val);
end Set_Is_Static_Expression;
@@ -3909,7 +3978,7 @@ package body Sinfo is
or else NT (N).Nkind = N_In
or else NT (N).Nkind = N_Not_In
or else NT (N).Nkind = N_Or_Else
- or else NT (N).Nkind in N_Binary_Op);
+ or else NT (N).Nkind in N_Binary_Op);
Set_Node2_With_Parent (N, Val);
end Set_Left_Opnd;
@@ -3926,13 +3995,23 @@ package body Sinfo is
Set_Node4 (N, Val); -- semantic field, no parent set
end Set_Library_Unit;
+ procedure Set_Limited_View_Installed
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Package_Specification
+ or else NT (N).Nkind = N_With_Clause);
+ Set_Flag18 (N, Val);
+ end Set_Limited_View_Installed;
+
procedure Set_Limited_Present
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Formal_Private_Type_Definition
or else NT (N).Nkind = N_Private_Type_Declaration
- or else NT (N).Nkind = N_Record_Definition);
+ or else NT (N).Nkind = N_Record_Definition
+ or else NT (N).Nkind = N_With_Clause);
Set_Flag17 (N, Val);
end Set_Limited_Present;
@@ -4005,7 +4084,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Subtype_Indication
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
Set_Flag8 (N, Val);
end Set_Must_Not_Freeze;
@@ -4114,6 +4193,14 @@ package body Sinfo is
Set_Flag13 (N, Val);
end Set_No_Initialization;
+ procedure Set_No_Truncation
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Unchecked_Type_Conversion);
+ Set_Flag17 (N, Val);
+ end Set_No_Truncation;
+
procedure Set_Null_Present
(N : Node_Id; Val : Boolean := True) is
begin
@@ -4156,6 +4243,15 @@ package body Sinfo is
Set_Node2 (N, Val); -- semantic field, no parent set
end Set_Original_Discriminant;
+ procedure Set_Original_Entity
+ (N : Node_Id; Val : Entity_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Integer_Literal
+ or else NT (N).Nkind = N_Real_Literal);
+ Set_Node2 (N, Val); -- semantic field, no parent set
+ end Set_Original_Entity;
+
procedure Set_Others_Discrete_Choices
(N : Node_Id; Val : List_Id) is
begin
@@ -4374,7 +4470,7 @@ package body Sinfo is
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Subexpr);
+ or else NT (N).Nkind in N_Subexpr);
Set_Flag7 (N, Val);
end Set_Raises_Constraint_Error;
@@ -4461,7 +4557,7 @@ package body Sinfo is
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
- or else NT (N).Nkind in N_Op
+ or else NT (N).Nkind in N_Op
or else NT (N).Nkind = N_And_Then
or else NT (N).Nkind = N_In
or else NT (N).Nkind = N_Not_In
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 7f3fe5cf6c4..014228b5a9c 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -74,8 +74,7 @@ package Sinfo is
-- The field chosen must be consistent in all places, and, for a node
-- that is a subexpression, must not overlap any of the standard
- -- expression fields. In the body, the calls to the Dcheck_Node debug
- -- procedure will need cross-references adding in alphabetical order.
+ -- expression fields.
-- In addition, if any of the standard expression fields is changed, then
-- the utiliy program which creates the Treeprs spec (in file treeprs.ads)
@@ -86,9 +85,9 @@ package Sinfo is
-- Add it to the documentation in the appropriate place
-- Add its fields to this documentation section
-- Define it in the appropriate classification in Node_Kind
- -- In the body (sinfo), add entries to the Dcheck calls for all
- -- its fields (except standard expression fields) to include
- -- the new node in the debug cross-reference list
+ -- In the body (sinfo), add entries to the access functions for all
+ -- its fields (except standard expression fields) to include the new
+ -- node in the checks.
-- Add an appropriate section to the case statement in sprint.adb
-- Add an appropriate section to the case statement in sem.adb
-- Add an appropraite section to the case statement in exp_util.adb
@@ -615,6 +614,15 @@ package Sinfo is
-- and thus the result is passed by reference rather than copied
-- another time.
+ -- Check_Address_Alignment (Flag11-Sem)
+ -- A flag present in N_Attribute_Definition clause for a 'Address
+ -- attribute definition. This flag is set if a dynamic check should
+ -- be generated at the freeze point for the entity to which this
+ -- address clause applies. The reason that we need this flag is that
+ -- we want to check for range checks being suppressed at the point
+ -- where the attribute definition clause is given, rather than
+ -- testing this at the freeze point.
+
-- Compile_Time_Known_Aggregate (Flag18-Sem)
-- Present in N_Aggregate nodes. Set for aggregates which can be
-- fully evaluated at compile time without raising constraint error.
@@ -653,12 +661,10 @@ package Sinfo is
-- result, with no regard to the small operand.
-- Corresponding_Body (Node5-Sem)
- -- This field is set in subprogram declarations, where it is needed
- -- if a pragma Inline is present and the subprogram is called, in
- -- generic declarations if the generic is instantiated, and also in
- -- package declarations that contain inlined subprograms that are
- -- called, or generic declarations that are instantiated. It points
- -- to the defining entity for the corresponding body.
+ -- This field is set in subprogram declarations, package declarations,
+ -- entry declarations of protected types, and in generic units. It
+ -- points to the defining entity for the corresponding body (NOT the
+ -- node for the body itself).
-- Corresponding_Generic_Association (Node5-Sem)
-- This field is defined for object declarations and object renaming
@@ -724,14 +730,6 @@ package Sinfo is
-- discriminant checking functions are constructed. The purpose is to
-- avoid attempting to set these functions more than once.
- -- Do_Access_Check (Flag11-Sem)
- -- This flag is set on nodes with a Prefix field that can be an object
- -- of an access type. If the flag is set, it indicates that a check is
- -- required to ensure that the value of the referenced object is not
- -- null. The actual check (which may be explicit or implicit by means
- -- of some trap), is generated by Gigi (all the front end does is to
- -- set this flag to request the trap).
-
-- Do_Accessibility_Check (Flag13-Sem)
-- This flag is set on N_Parameter_Specification nodes to indicate
-- that an accessibility check is required for the parameter. It is
@@ -740,8 +738,8 @@ package Sinfo is
-- Do_Discriminant_Check (Flag13-Sem)
-- This flag is set on N_Selected_Component nodes to indicate that a
-- discriminant check is required using the discriminant check routine
- -- associated with the selector. The actual check is dealt with by
- -- Gigi (all the front end does is to set the flag).
+ -- associated with the selector. The actual check is generated by the
+ -- expander when processing selected components.
-- Do_Division_Check (Flag13-Sem)
-- This flag is set on a division operator (/ mod rem) to indicate
@@ -796,7 +794,7 @@ package Sinfo is
-- The expression of a type conversion. In this case the range check
-- is against the target type of the conversion. See also the use of
-- Do_Overflow_Check on a type conversion. The distinction is that
- -- the ovrflow check protects against a value that is outside the
+ -- the overflow check protects against a value that is outside the
-- range of the target base type, whereas a range check checks that
-- the resulting value (which is a value of the base type of the
-- target type), satisfies the range constraint of the target type.
@@ -1039,7 +1037,7 @@ package Sinfo is
-- introduced by these use clauses have priority over global ones,
-- and outer entities must be explicitly hidden/restored on exit.
- -- Implicit_With (Flag17-Sem)
+ -- Implicit_With (Flag16-Sem)
-- This flag is set in the N_With_Clause node that is implicitly
-- generated for runtime units that are loaded by the expander, and
-- also for package System, if it is loaded implicitly by a use of
@@ -1076,11 +1074,24 @@ package Sinfo is
-- in a dispatching call. It is off in all other cases. See Sem_Disp
-- for details of its use.
+ -- Is_In_Discriminant_Check (Flag11-Sem)
+ -- This flag is present in a selected component, and is used to
+ -- indicate that the reference occurs within a discriminant check.
+ -- The significance is that optimizations based on assuming that
+ -- the discriminant check has a correct value cannot be performed
+ -- in this case (or the disriminant check may be optimized away!)
+
-- Is_Machine_Number (Flag11-Sem)
-- This flag is set in an N_Real_Literal node to indicate that the
-- value is a machine number. This avoids some unnecessary cases
-- of converting real literals to machine numbers.
+ -- Is_Null_Loop (Flag16-Sem)
+ -- This flag is set in an N_Loop_Statement node if the corresponding
+ -- loop can be determined to be null at compile time. This is used to
+ -- suppress any warnings that would otherwise be issued inside the
+ -- loop since they are probably not useful.
+
-- Is_Power_Of_2_For_Shift (Flag13-Sem)
-- A flag present only in N_Op_Expon nodes. It is set when the
-- exponentiation is of the forma 2 ** N, where the type of N is
@@ -1178,6 +1189,14 @@ package Sinfo is
-- Used to collect actions that must be executed within the loop because
-- they may need to be evaluated anew each time through.
+ -- Limited_View_Installed (Flag18-Sem)
+ -- Present in With_Clauses and in package specifications. If set on a
+ -- with_clause, it indicates that this clause has created the current
+ -- limited view of the designated package. On a package specification,
+ -- it indicates that the limited view has already been created because
+ -- the package is mentioned in a limited_with_clause in the closure of
+ -- the unit being compiled.
+
-- Must_Be_Byte_Aligned (Flag14-Sem)
-- This flag is present in N_Attribute_Reference nodes. It can be set
-- only for the Address and Unrestricted_Access attributes. If set it
@@ -1185,8 +1204,12 @@ package Sinfo is
-- on a byte (more accurately a storage unit) boundary. If necessary,
-- a copy of the object is to be made before taking the address (this
-- copy is in the current scope on the stack frame). This is used for
- -- certainly cases of code generated by the expander that passes
+ -- certain cases of code generated by the expander that passes
-- parameters by address.
+ --
+ -- The reason the copy is not made by the front end is that the back
+ -- end has more information about type layout and may be able to (but
+ -- is not guaranteed to) prevent making unnecessary copies.
-- Must_Not_Freeze (Flag8-Sem)
-- A flag present in all expression nodes. Normally expressions cause
@@ -1227,7 +1250,7 @@ package Sinfo is
-- No_Ctrl_Actions (Flag7-Sem)
-- Present in N_Assignment_Statement to indicate that no finalize nor
-- nor adjust should take place on this assignment eventhough the rhs
- -- is controlled. This is used in init_procs and aggregate expansions
+ -- is controlled. This is used in init procs and aggregate expansions
-- where the generated assignments are more initialisations than real
-- assignments.
@@ -1242,11 +1265,23 @@ package Sinfo is
-- No_Initialization (Flag13-Sem)
-- Present in N_Object_Declaration & N_Allocator to indicate
-- that the object must not be initialized (by Initialize or a
- -- call to _init_proc). This is needed for controlled aggregates.
+ -- call to an init proc). This is needed for controlled aggregates.
-- When the Object declaration has an expression, this flag means
-- that this expression should not be taken into account (needed
-- for in place initialization with aggregates)
+ -- No_Truncation (Flag17-Sem)
+ -- Present in N_Unchecked_Type_Conversion node. This flag has an effect
+ -- only if the RM_Size of the source is greater than the RM_Size of the
+ -- target for scalar operands. Normally in such a case we truncate some
+ -- higher order bits of the source, and then sign/zero extend the result
+ -- to form the output value. But if this flag is set, then we do not do
+ -- any truncation, so for example, if an 8 bit input is converted to a
+ -- 5 bit result which is in fact stored in 8 bits, then the high order
+ -- three bits of the target result will be copied from the source. This
+ -- is used for properly setting out of range values for use by pragmas
+ -- Initialize_Scalars and Normalize_Scalars.
+
-- OK_For_Stream (Flag4-Sem)
-- Present in N_Attribute_Definition clauses for stream attributes. If
-- set, indicates that the attribute is permitted even though the type
@@ -1260,10 +1295,19 @@ package Sinfo is
-- Original_Discriminant (Node2-Sem)
-- Present in identifiers. Used in references to discriminants that
-- appear in generic units. Because the names of the discriminants
- -- may be different in an instance, we use this field to recover the
+ -- may be different in an instance, we use this field to recover the
-- position of the discriminant in the original type, and replace it
-- with the discriminant at the same position in the instantiated type.
+ -- Original_Entity (Node2-Sem)
+ -- Present in numeric literals. Used to denote the named number that
+ -- has been constant-folded into the given literal. If literal is from
+ -- source, or the result of some other constant-folding operation, then
+ -- Original_Entity is empty. This field is needed to handle properly
+ -- named numbers in generic units, where the Associated_Node field
+ -- interferes with the Entity field, making it impossible to preserve
+ -- the original entity at the point of instantiation (ASIS problem).
+
-- Others_Discrete_Choices (List1-Sem)
-- When a case statement or variant is analyzed, the semantic checks
-- determine the actual list of choices that correspond to an others
@@ -1598,12 +1642,16 @@ package Sinfo is
-- N_Integer_Literal
-- Sloc points to literal
+ -- Original_Entity (Node2-Sem) If not Empty, holds Named_Number that
+ -- has been constant-folded into its literal value.
-- Intval (Uint3) contains integer value of literal
-- plus fields for expression
-- Print_In_Hex (Flag13-Sem)
-- N_Real_Literal
-- Sloc points to literal
+ -- Original_Entity (Node2-Sem) If not Empty, holds Named_Number that
+ -- has been constant-folded into its literal value.
-- Realval (Ureal3) contains real value of literal
-- Corresponding_Integer_Value (Uint4-Sem)
-- Is_Machine_Number (Flag11-Sem)
@@ -1900,6 +1948,16 @@ package Sinfo is
-- Note: the contents of the Expression field must be ignored (i.e.
-- treated as though it were Empty) if No_Initialization is set True.
+ -- Note: the back end places some restrictions on the form of the
+ -- Expression field. If the object being declared is Atomic, then
+ -- the Expression may not have the form of an aggregate (since this
+ -- might cause the back end to generate separate assignments). It
+ -- also cannot be a reference to an object marked as a true constant
+ -- (Is_True_Constant flag set), where the object is itself initalized
+ -- with an aggregate. If necessary the front end must generate an
+ -- extra temporary (with Is_True_Constant set False), and initialize
+ -- this temporary as required (the temporary itself is not atomic).
+
-- N_Object_Declaration
-- Sloc points to first identifier
-- Defining_Identifier (Node1)
@@ -2685,7 +2743,6 @@ package Sinfo is
-- N_Explicit_Dereference
-- Sloc points to ALL
-- Prefix (Node3)
- -- Do_Access_Check (Flag11-Sem)
-- plus fields for expression
-------------------------------
@@ -2708,7 +2765,6 @@ package Sinfo is
-- Sloc contains a copy of the Sloc value of the Prefix
-- Prefix (Node3)
-- Expressions (List1)
- -- Do_Access_Check (Flag11-Sem)
-- plus fields for expression
-- Note: if any of the subscripts requires a range check, then the
@@ -2733,7 +2789,6 @@ package Sinfo is
-- Sloc points to first token of prefix
-- Prefix (Node3)
-- Discrete_Range (Node4)
- -- Do_Access_Check (Flag11-Sem)
-- plus fields for expression
-------------------------------
@@ -2751,8 +2806,8 @@ package Sinfo is
-- Prefix (Node3)
-- Selector_Name (Node2)
-- Associated_Node (Node4-Sem)
- -- Do_Access_Check (Flag11-Sem)
-- Do_Discriminant_Check (Flag13-Sem)
+ -- Is_In_Discriminant_Check (Flag11-Sem)
-- plus fields for expression
--------------------------
@@ -2831,7 +2886,6 @@ package Sinfo is
-- Expressions (List1) (set to No_List if no associated expressions)
-- Entity (Node4-Sem) used if the attribute yields a type
-- Associated_Node (Node4-Sem)
- -- Do_Access_Check (Flag11-Sem)
-- Do_Overflow_Check (Flag17-Sem)
-- Redundant_Use (Flag13-Sem)
-- OK_For_Stream (Flag4-Sem)
@@ -3353,9 +3407,9 @@ package Sinfo is
-- Sloc points to first token of subtype mark
-- Subtype_Mark (Node4)
-- Expression (Node3)
- -- Do_Overflow_Check (Flag17-Sem)
-- Do_Tag_Check (Flag13-Sem)
-- Do_Length_Check (Flag4-Sem)
+ -- Do_Overflow_Check (Flag17-Sem)
-- Float_Truncate (Flag11-Sem)
-- Rounded_Result (Flag18-Sem)
-- Conversion_OK (Flag14-Sem)
@@ -3505,6 +3559,16 @@ package Sinfo is
-- is set in the Expression (right hand side), with the check being
-- done against the type of the Name (left hand side).
+ -- Note: the back end places some restrictions on the form of the
+ -- Expression field. If the object being assigned to is Atomic, then
+ -- the Expression may not have the form of an aggregate (since this
+ -- might cause the back end to generate separate assignments). It
+ -- also cannot be a reference to an object marked as a true constant
+ -- (Is_True_Constant flag set), where the object is itself initalized
+ -- with an aggregate. If necessary the front end must generate an
+ -- extra temporary (with Is_True_Constant set False), and initialize
+ -- this temporary as required (the temporary itself is not atomic).
+
-----------------------
-- 5.3 If Statement --
-----------------------
@@ -3608,6 +3672,7 @@ package Sinfo is
-- Statements (List3)
-- End_Label (Node4)
-- Has_Created_Identifier (Flag15)
+ -- Is_Null_Loop (Flag16)
--------------------------
-- 5.5 Iteration Scheme --
@@ -4083,6 +4148,7 @@ package Sinfo is
-- part present)
-- End_Label (Node4)
-- Generic_Parent (Node5-Sem)
+ -- Limited_View_Installed (Flag18-Sem)
-----------------------
-- 7.1 Package Body --
@@ -4464,6 +4530,7 @@ package Sinfo is
-- Defining_Identifier (Node1)
-- Discrete_Subtype_Definition (Node4) (set to Empty if not present)
-- Parameter_Specifications (List3) (set to No_List if no formal part)
+ -- Corresponding_Body (Node5-Sem)
-----------------------------
-- 9.5.2 Accept statement --
@@ -4912,6 +4979,7 @@ package Sinfo is
-- Declarations (List2) (set to No_List if no global declarations)
-- Actions (List1) (set to No_List if no actions)
-- Pragmas_After (List5) pragmas after unit (set to No_List if none)
+ -- Config_Pragmas (List4) config pragmas (set to Empty_List if none)
--------------------------
-- 10.1.1 Library Item --
@@ -5003,7 +5071,9 @@ package Sinfo is
-- Context_Installed (Flag13-Sem)
-- Elaborate_Present (Flag4-Sem)
-- Elaborate_All_Present (Flag15-Sem)
- -- Implicit_With (Flag17-Sem)
+ -- Implicit_With (Flag16-Sem)
+ -- Limited_Present (Flag17) set if LIMITED is present
+ -- Limited_View_Installed (Flag18-Sem)
-- Unreferenced_In_Spec (Flag7-Sem)
-- No_Entities_Ref_In_Spec (Flag8-Sem)
@@ -5621,13 +5691,28 @@ package Sinfo is
-- In Ada 83, the expression must be a simple expression and the
-- local name must be a direct name.
- -- Note: The only attribute definition clause that is processed
- -- by Gigi is the alignment clause (for all other cases, the
- -- information is extracted by the front end and either results
- -- in setting entity information, e.g. Esize for the Size case,
- -- or in appropriate expansion actions (e.g. in the storage size
- -- case). For the alignment case, Gigi requires that the expression
- -- be an integer literal.
+ -- Note: the only attribute definition clause that is processed by
+ -- gigi is an address clause. For all other cases, the information
+ -- is extracted by the front end and either results in setting entity
+ -- information, e.g. Esize for the Size clause, or in appropriate
+ -- expansion actions (e.g. in the case of Storage_Size).
+
+ -- For an address clause, Gigi constructs the appropriate addressing
+ -- code. It also ensures that no aliasing optimizations are made
+ -- for the object for which the address clause appears.
+
+ -- Note: for an address clause used to achieve an overlay:
+
+ -- A : Integer;
+ -- B : Integer;
+ -- for B'Address use A'Address;
+
+ -- the above rule means that Gigi will ensure that no optimizations
+ -- will be made for B that would violate the implementation advice
+ -- of RM 13.3(19). However, this advice applies only to B and not
+ -- to A, which seems unfortunate. The GNAT front end will mark the
+ -- object A as volatile to also prevent unwanted optimization
+ -- assumptions based on no aliasing being made for B.
-- N_Attribute_Definition_Clause
-- Sloc points to FOR
@@ -5636,6 +5721,7 @@ package Sinfo is
-- Expression (Node3) the expression or name
-- Next_Rep_Item (Node4-Sem)
-- From_At_Mod (Flag4-Sem)
+ -- Check_Address_Alignment (Flag11-Sem)
---------------------------------------------
-- 13.4 Enumeration representation clause --
@@ -6216,6 +6302,7 @@ package Sinfo is
-- Subtype_Mark (Node4)
-- Expression (Node3)
-- Kill_Range_Check (Flag11-Sem)
+ -- No_Truncation (Flag17-Sem)
-- plus fields for expression
-- Note: in the case where a debug source file is generated, the Sloc
@@ -6334,12 +6421,16 @@ package Sinfo is
-- N_Has_Etype, N_Has_Chars, N_Has_Entity
N_Op_Add,
N_Op_Concat,
- N_Op_Divide,
N_Op_Expon,
+ N_Op_Subtract,
+
+ -- N_Binary_Op, N_Op, N_Subexpr, N_Has_Treat_Fixed_As_Integer
+ -- N_Has_Etype, N_Has_Chars, N_Has_Entity
+
+ N_Op_Divide,
N_Op_Mod,
N_Op_Multiply,
N_Op_Rem,
- N_Op_Subtract,
-- N_Binary_Op, N_Op, N_Subexpr, N_Has_Etype
-- N_Has_Entity, N_Has_Chars, N_Op_Boolean
@@ -6651,6 +6742,10 @@ package Sinfo is
N_Error ..
N_Subtype_Indication;
+ subtype N_Has_Treat_Fixed_As_Integer is Node_Kind range
+ N_Op_Divide ..
+ N_Op_Rem;
+
subtype N_Later_Decl_Item is Node_Kind range
N_Task_Type_Declaration ..
N_Generic_Subprogram_Declaration;
@@ -6829,6 +6924,9 @@ package Sinfo is
function Chars
(N : Node_Id) return Name_Id; -- Name1
+ function Check_Address_Alignment
+ (N : Node_Id) return Boolean; -- Flag11
+
function Choice_Parameter
(N : Node_Id) return Node_Id; -- Node2
@@ -6859,6 +6957,9 @@ package Sinfo is
function Condition_Actions
(N : Node_Id) return List_Id; -- List3
+ function Config_Pragmas
+ (N : Node_Id) return List_Id; -- List4
+
function Constant_Present
(N : Node_Id) return Boolean; -- Flag17
@@ -6952,9 +7053,6 @@ package Sinfo is
function Discriminant_Type
(N : Node_Id) return Node_Id; -- Node5
- function Do_Access_Check
- (N : Node_Id) return Boolean; -- Flag11
-
function Do_Accessibility_Check
(N : Node_Id) return Boolean; -- Flag13
@@ -7142,7 +7240,7 @@ package Sinfo is
(N : Node_Id) return Node_Id; -- Node1
function Implicit_With
- (N : Node_Id) return Boolean; -- Flag17
+ (N : Node_Id) return Boolean; -- Flag16
function In_Present
(N : Node_Id) return Boolean; -- Flag15
@@ -7168,9 +7266,15 @@ package Sinfo is
function Is_Controlling_Actual
(N : Node_Id) return Boolean; -- Flag16
+ function Is_In_Discriminant_Check
+ (N : Node_Id) return Boolean; -- Flag11
+
function Is_Machine_Number
(N : Node_Id) return Boolean; -- Flag11
+ function Is_Null_Loop
+ (N : Node_Id) return Boolean; -- Flag16
+
function Is_Overloaded
(N : Node_Id) return Boolean; -- Flag5
@@ -7216,6 +7320,9 @@ package Sinfo is
function Library_Unit
(N : Node_Id) return Node_Id; -- Node4
+ function Limited_View_Installed
+ (N : Node_Id) return Boolean; -- Flag18
+
function Limited_Present
(N : Node_Id) return Boolean; -- Flag17
@@ -7270,6 +7377,9 @@ package Sinfo is
function No_Initialization
(N : Node_Id) return Boolean; -- Flag13
+ function No_Truncation
+ (N : Node_Id) return Boolean; -- Flag17
+
function Null_Present
(N : Node_Id) return Boolean; -- Flag13
@@ -7285,6 +7395,9 @@ package Sinfo is
function Original_Discriminant
(N : Node_Id) return Node_Id; -- Node2
+ function Original_Entity
+ (N : Node_Id) return Entity_Id; -- Node2
+
function Others_Discrete_Choices
(N : Node_Id) return List_Id; -- List1
@@ -7585,6 +7698,9 @@ package Sinfo is
procedure Set_Chars
(N : Node_Id; Val : Name_Id); -- Name1
+ procedure Set_Check_Address_Alignment
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
procedure Set_Choice_Parameter
(N : Node_Id; Val : Node_Id); -- Node2
@@ -7615,6 +7731,9 @@ package Sinfo is
procedure Set_Condition_Actions
(N : Node_Id; Val : List_Id); -- List3
+ procedure Set_Config_Pragmas
+ (N : Node_Id; Val : List_Id); -- List4
+
procedure Set_Constant_Present
(N : Node_Id; Val : Boolean := True); -- Flag17
@@ -7708,9 +7827,6 @@ package Sinfo is
procedure Set_Discriminant_Type
(N : Node_Id; Val : Node_Id); -- Node5
- procedure Set_Do_Access_Check
- (N : Node_Id; Val : Boolean := True); -- Flag11
-
procedure Set_Do_Accessibility_Check
(N : Node_Id; Val : Boolean := True); -- Flag13
@@ -7898,7 +8014,7 @@ package Sinfo is
(N : Node_Id; Val : Node_Id); -- Node1
procedure Set_Implicit_With
- (N : Node_Id; Val : Boolean := True); -- Flag17
+ (N : Node_Id; Val : Boolean := True); -- Flag16
procedure Set_In_Present
(N : Node_Id; Val : Boolean := True); -- Flag15
@@ -7924,9 +8040,15 @@ package Sinfo is
procedure Set_Is_Controlling_Actual
(N : Node_Id; Val : Boolean := True); -- Flag16
+ procedure Set_Is_In_Discriminant_Check
+ (N : Node_Id; Val : Boolean := True); -- Flag11
+
procedure Set_Is_Machine_Number
(N : Node_Id; Val : Boolean := True); -- Flag11
+ procedure Set_Is_Null_Loop
+ (N : Node_Id; Val : Boolean := True); -- Flag16
+
procedure Set_Is_Overloaded
(N : Node_Id; Val : Boolean := True); -- Flag5
@@ -7972,6 +8094,9 @@ package Sinfo is
procedure Set_Left_Opnd
(N : Node_Id; Val : Node_Id); -- Node2
+ procedure Set_Limited_View_Installed
+ (N : Node_Id; Val : Boolean := True); -- Flag18
+
procedure Set_Limited_Present
(N : Node_Id; Val : Boolean := True); -- Flag17
@@ -8026,6 +8151,9 @@ package Sinfo is
procedure Set_No_Initialization
(N : Node_Id; Val : Boolean := True); -- Flag13
+ procedure Set_No_Truncation
+ (N : Node_Id; Val : Boolean := True); -- Flag17
+
procedure Set_Null_Present
(N : Node_Id; Val : Boolean := True); -- Flag13
@@ -8041,6 +8169,9 @@ package Sinfo is
procedure Set_Original_Discriminant
(N : Node_Id; Val : Node_Id); -- Node2
+ procedure Set_Original_Entity
+ (N : Node_Id; Val : Entity_Id); -- Node2
+
procedure Set_Others_Discrete_Choices
(N : Node_Id; Val : List_Id); -- List1
@@ -8299,6 +8430,7 @@ package Sinfo is
pragma Inline (Box_Present);
pragma Inline (Char_Literal_Value);
pragma Inline (Chars);
+ pragma Inline (Check_Address_Alignment);
pragma Inline (Choice_Parameter);
pragma Inline (Choices);
pragma Inline (Compile_Time_Known_Aggregate);
@@ -8309,6 +8441,7 @@ package Sinfo is
pragma Inline (Component_Name);
pragma Inline (Condition);
pragma Inline (Condition_Actions);
+ pragma Inline (Config_Pragmas);
pragma Inline (Constant_Present);
pragma Inline (Constraint);
pragma Inline (Constraints);
@@ -8340,7 +8473,6 @@ package Sinfo is
pragma Inline (Discrete_Subtype_Definitions);
pragma Inline (Discriminant_Specifications);
pragma Inline (Discriminant_Type);
- pragma Inline (Do_Access_Check);
pragma Inline (Do_Accessibility_Check);
pragma Inline (Do_Discriminant_Check);
pragma Inline (Do_Length_Check);
@@ -8412,7 +8544,9 @@ package Sinfo is
pragma Inline (Is_Component_Left_Opnd);
pragma Inline (Is_Component_Right_Opnd);
pragma Inline (Is_Controlling_Actual);
+ pragma Inline (Is_In_Discriminant_Check);
pragma Inline (Is_Machine_Number);
+ pragma Inline (Is_Null_Loop);
pragma Inline (Is_Overloaded);
pragma Inline (Is_Power_Of_2_For_Shift);
pragma Inline (Is_Protected_Subprogram_Body);
@@ -8428,6 +8562,7 @@ package Sinfo is
pragma Inline (Library_Unit);
pragma Inline (Label_Construct);
pragma Inline (Left_Opnd);
+ pragma Inline (Limited_View_Installed);
pragma Inline (Limited_Present);
pragma Inline (Literals);
pragma Inline (Loop_Actions);
@@ -8446,11 +8581,13 @@ package Sinfo is
pragma Inline (No_Ctrl_Actions);
pragma Inline (No_Entities_Ref_In_Spec);
pragma Inline (No_Initialization);
+ pragma Inline (No_Truncation);
pragma Inline (Null_Present);
pragma Inline (Null_Record_Present);
pragma Inline (Object_Definition);
pragma Inline (OK_For_Stream);
pragma Inline (Original_Discriminant);
+ pragma Inline (Original_Entity);
pragma Inline (Others_Discrete_Choices);
pragma Inline (Out_Present);
pragma Inline (Parameter_Associations);
@@ -8548,6 +8685,7 @@ package Sinfo is
pragma Inline (Set_Box_Present);
pragma Inline (Set_Char_Literal_Value);
pragma Inline (Set_Chars);
+ pragma Inline (Set_Check_Address_Alignment);
pragma Inline (Set_Choice_Parameter);
pragma Inline (Set_Choices);
pragma Inline (Set_Compile_Time_Known_Aggregate);
@@ -8558,6 +8696,7 @@ package Sinfo is
pragma Inline (Set_Component_Name);
pragma Inline (Set_Condition);
pragma Inline (Set_Condition_Actions);
+ pragma Inline (Set_Config_Pragmas);
pragma Inline (Set_Constant_Present);
pragma Inline (Set_Constraint);
pragma Inline (Set_Constraints);
@@ -8589,7 +8728,6 @@ package Sinfo is
pragma Inline (Set_Discrete_Subtype_Definitions);
pragma Inline (Set_Discriminant_Specifications);
pragma Inline (Set_Discriminant_Type);
- pragma Inline (Set_Do_Access_Check);
pragma Inline (Set_Do_Accessibility_Check);
pragma Inline (Set_Do_Discriminant_Check);
pragma Inline (Set_Do_Length_Check);
@@ -8661,7 +8799,9 @@ package Sinfo is
pragma Inline (Set_Is_Component_Left_Opnd);
pragma Inline (Set_Is_Component_Right_Opnd);
pragma Inline (Set_Is_Controlling_Actual);
+ pragma Inline (Set_Is_In_Discriminant_Check);
pragma Inline (Set_Is_Machine_Number);
+ pragma Inline (Set_Is_Null_Loop);
pragma Inline (Set_Is_Overloaded);
pragma Inline (Set_Is_Power_Of_2_For_Shift);
pragma Inline (Set_Is_Protected_Subprogram_Body);
@@ -8677,6 +8817,7 @@ package Sinfo is
pragma Inline (Set_Library_Unit);
pragma Inline (Set_Label_Construct);
pragma Inline (Set_Left_Opnd);
+ pragma Inline (Set_Limited_View_Installed);
pragma Inline (Set_Limited_Present);
pragma Inline (Set_Literals);
pragma Inline (Set_Loop_Actions);
@@ -8694,11 +8835,13 @@ package Sinfo is
pragma Inline (Set_No_Ctrl_Actions);
pragma Inline (Set_No_Entities_Ref_In_Spec);
pragma Inline (Set_No_Initialization);
+ pragma Inline (Set_No_Truncation);
pragma Inline (Set_Null_Present);
pragma Inline (Set_Null_Record_Present);
pragma Inline (Set_Object_Definition);
pragma Inline (Set_OK_For_Stream);
pragma Inline (Set_Original_Discriminant);
+ pragma Inline (Set_Original_Entity);
pragma Inline (Set_Others_Discrete_Choices);
pragma Inline (Set_Out_Present);
pragma Inline (Set_Parameter_Associations);
diff --git a/gcc/ada/sinfo.h b/gcc/ada/sinfo.h
index 7874b7ce037..fd5d13d2b89 100644
--- a/gcc/ada/sinfo.h
+++ b/gcc/ada/sinfo.h
@@ -6,10 +6,7 @@
/* */
/* C Header File */
/* */
-/* Generated by xsinfo revision using */
-/* sinfo.ads revision 1.439 */
-/* */
-/* 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- */
@@ -54,12 +51,12 @@
#define N_Character_Literal 17
#define N_Op_Add 18
#define N_Op_Concat 19
- #define N_Op_Divide 20
- #define N_Op_Expon 21
- #define N_Op_Mod 22
- #define N_Op_Multiply 23
- #define N_Op_Rem 24
- #define N_Op_Subtract 25
+ #define N_Op_Expon 20
+ #define N_Op_Subtract 21
+ #define N_Op_Divide 22
+ #define N_Op_Mod 23
+ #define N_Op_Multiply 24
+ #define N_Op_Rem 25
#define N_Op_And 26
#define N_Op_Eq 27
#define N_Op_Ge 28
@@ -284,6 +281,9 @@
SUBTYPE (N_Has_Etype, Node_Kind,
N_Error,
N_Subtype_Indication)
+ SUBTYPE (N_Has_Treat_Fixed_As_Integer, Node_Kind,
+ N_Op_Divide,
+ N_Op_Rem)
SUBTYPE (N_Later_Decl_Item, Node_Kind,
N_Task_Type_Declaration,
N_Generic_Subprogram_Declaration)
@@ -389,6 +389,8 @@
{ return Char_Code2 (N); }
INLINE Name_Id Chars (Node_Id N)
{ return Name1 (N); }
+ INLINE Boolean Check_Address_Alignment (Node_Id N)
+ { return Flag11 (N); }
INLINE Node_Id Choice_Parameter (Node_Id N)
{ return Node2 (N); }
INLINE List_Id Choices (Node_Id N)
@@ -409,6 +411,8 @@
{ return Node1 (N); }
INLINE List_Id Condition_Actions (Node_Id N)
{ return List3 (N); }
+ INLINE List_Id Config_Pragmas (Node_Id N)
+ { return List4 (N); }
INLINE Boolean Constant_Present (Node_Id N)
{ return Flag17 (N); }
INLINE Node_Id Constraint (Node_Id N)
@@ -471,8 +475,6 @@
{ return List4 (N); }
INLINE Node_Id Discriminant_Type (Node_Id N)
{ return Node5 (N); }
- INLINE Boolean Do_Access_Check (Node_Id N)
- { return Flag11 (N); }
INLINE Boolean Do_Accessibility_Check (Node_Id N)
{ return Flag13 (N); }
INLINE Boolean Do_Discriminant_Check (Node_Id N)
@@ -598,7 +600,7 @@
INLINE Node_Id Identifier (Node_Id N)
{ return Node1 (N); }
INLINE Boolean Implicit_With (Node_Id N)
- { return Flag17 (N); }
+ { return Flag16 (N); }
INLINE Boolean In_Present (Node_Id N)
{ return Flag15 (N); }
INLINE Boolean Includes_Infinities (Node_Id N)
@@ -615,8 +617,12 @@
{ return Flag14 (N); }
INLINE Boolean Is_Controlling_Actual (Node_Id N)
{ return Flag16 (N); }
+ INLINE Boolean Is_In_Discriminant_Check (Node_Id N)
+ { return Flag11 (N); }
INLINE Boolean Is_Machine_Number (Node_Id N)
{ return Flag11 (N); }
+ INLINE Boolean Is_Null_Loop (Node_Id N)
+ { return Flag16 (N); }
INLINE Boolean Is_Overloaded (Node_Id N)
{ return Flag5 (N); }
INLINE Boolean Is_Power_Of_2_For_Shift (Node_Id N)
@@ -647,6 +653,8 @@
{ return Flag6 (N); }
INLINE Node_Id Library_Unit (Node_Id N)
{ return Node4 (N); }
+ INLINE Boolean Limited_View_Installed (Node_Id N)
+ { return Flag18 (N); }
INLINE Boolean Limited_Present (Node_Id N)
{ return Flag17 (N); }
INLINE List_Id Literals (Node_Id N)
@@ -683,6 +691,8 @@
{ return Flag8 (N); }
INLINE Boolean No_Initialization (Node_Id N)
{ return Flag13 (N); }
+ INLINE Boolean No_Truncation (Node_Id N)
+ { return Flag17 (N); }
INLINE Boolean Null_Present (Node_Id N)
{ return Flag13 (N); }
INLINE Boolean Null_Record_Present (Node_Id N)
@@ -693,6 +703,8 @@
{ return Flag4 (N); }
INLINE Node_Id Original_Discriminant (Node_Id N)
{ return Node2 (N); }
+ INLINE Entity_Id Original_Entity (Node_Id N)
+ { return Node2 (N); }
INLINE List_Id Others_Discrete_Choices (Node_Id N)
{ return List1 (N); }
INLINE Boolean Out_Present (Node_Id N)
diff --git a/gcc/ada/sinput-c.adb b/gcc/ada/sinput-c.adb
new file mode 100644
index 00000000000..b443b4bf885
--- /dev/null
+++ b/gcc/ada/sinput-c.adb
@@ -0,0 +1,200 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N P U T . P --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Unchecked_Conversion;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Namet; use Namet;
+with Opt; use Opt;
+with System; use System;
+
+package body Sinput.C is
+
+ ---------------
+ -- Load_File --
+ ---------------
+
+ function Load_File (Path : String) return Source_File_Index is
+ Src : Source_Buffer_Ptr;
+ X : Source_File_Index;
+ Lo : Source_Ptr;
+ Hi : Source_Ptr;
+
+ Source_File_FD : File_Descriptor;
+ -- The file descriptor for the current source file. A negative value
+ -- indicates failure to open the specified source file.
+
+ Len : Integer;
+ -- Length of file. Assume no more than 2 gigabytes of source!
+
+ Actual_Len : Integer;
+
+ Path_Id : Name_Id;
+ File_Id : Name_Id;
+
+ begin
+ if Path = "" then
+ return No_Source_File;
+ end if;
+
+ Source_File.Increment_Last;
+ X := Source_File.Last;
+
+ if X = Source_File.First then
+ Lo := First_Source_Ptr;
+ else
+ Lo := Source_File.Table (X - 1).Source_Last + 1;
+ end if;
+
+ Name_Len := Path'Length;
+ Name_Buffer (1 .. Name_Len) := Path;
+ Path_Id := Name_Find;
+ Name_Buffer (Name_Len + 1) := ASCII.NUL;
+
+ -- Open the source FD, note that we open in binary mode, because as
+ -- documented in the spec, the caller is expected to handle either
+ -- DOS or Unix mode files, and there is no point in wasting time on
+ -- text translation when it is not required.
+
+ Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
+
+ if Source_File_FD = Invalid_FD then
+ Source_File.Decrement_Last;
+ return No_Source_File;
+
+ end if;
+
+ Len := Integer (File_Length (Source_File_FD));
+
+ -- Set Hi so that length is one more than the physical length,
+ -- allowing for the extra EOF character at the end of the buffer
+
+ Hi := Lo + Source_Ptr (Len);
+
+ -- Do the actual read operation
+
+ declare
+ subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
+ -- Physical buffer allocated
+
+ type Actual_Source_Ptr is access Actual_Source_Buffer;
+ -- This is the pointer type for the physical buffer allocated
+
+ Actual_Ptr : Actual_Source_Ptr := new Actual_Source_Buffer;
+ -- And this is the actual physical buffer
+
+ begin
+ -- Allocate source buffer, allowing extra character at end for EOF
+
+ -- Some systems (e.g. VMS) have file types that require one
+ -- read per line, so read until we get the Len bytes or until
+ -- there are no more characters.
+
+ Hi := Lo;
+ loop
+ Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
+ Hi := Hi + Source_Ptr (Actual_Len);
+ exit when Actual_Len = Len or Actual_Len <= 0;
+ end loop;
+
+ Actual_Ptr (Hi) := EOF;
+
+ -- Now we need to work out the proper virtual origin pointer to
+ -- return. This is exactly Actual_Ptr (0)'Address, but we have
+ -- to be careful to suppress checks to compute this address.
+
+ declare
+ pragma Suppress (All_Checks);
+
+ function To_Source_Buffer_Ptr is new
+ Ada.Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+ begin
+ Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
+ end;
+ end;
+
+ -- Read is complete, close the file and we are done (no need to test
+ -- status from close, since we have successfully read the file!)
+
+ Close (Source_File_FD);
+
+ -- Get the file name, without path information
+
+ declare
+ Index : Positive := Path'Last;
+
+ begin
+ while Index > Path'First loop
+ exit when Path (Index - 1) = '/';
+ exit when Path (Index - 1) = Directory_Separator;
+ Index := Index - 1;
+ end loop;
+
+ Name_Len := Path'Last - Index + 1;
+ Name_Buffer (1 .. Name_Len) := Path (Index .. Path'Last);
+ File_Id := Name_Find;
+ end;
+
+ declare
+ S : Source_File_Record renames Source_File.Table (X);
+
+ begin
+ S := (Debug_Source_Name => File_Id,
+ File_Name => File_Id,
+ File_Type => Config,
+ First_Mapped_Line => No_Line_Number,
+ Full_Debug_Name => Path_Id,
+ Full_File_Name => Path_Id,
+ Full_Ref_Name => Path_Id,
+ Identifier_Casing => Unknown,
+ Inlined_Body => False,
+ Instantiation => No_Location,
+ Keyword_Casing => Unknown,
+ Last_Source_Line => 1,
+ License => Unknown,
+ Lines_Table => null,
+ Lines_Table_Max => 1,
+ Logical_Lines_Table => null,
+ Num_SRef_Pragmas => 0,
+ Reference_Name => File_Id,
+ Sloc_Adjust => 0,
+ Source_Checksum => 0,
+ Source_First => Lo,
+ Source_Last => Hi,
+ Source_Text => Src,
+ Template => No_Source_File,
+ Time_Stamp => Empty_Time_Stamp);
+
+ Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
+ S.Lines_Table (1) := Lo;
+ end;
+
+ Set_Source_File_Index_Table (X);
+ return X;
+ end Load_File;
+
+end Sinput.C;
diff --git a/gcc/ada/sinput-c.ads b/gcc/ada/sinput-c.ads
new file mode 100644
index 00000000000..7ed12cd1e5b
--- /dev/null
+++ b/gcc/ada/sinput-c.ads
@@ -0,0 +1,39 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S I N P U T . P --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This child package contains a procedure to load files.
+
+-- It is used by Sinput.P to load project files, and by GPrep to load
+-- preprocessor definition files and input files.
+
+with Types; use Types;
+
+package Sinput.C is
+
+ function Load_File (Path : String) return Source_File_Index;
+ -- Load a file into memory and Initialize the Scans state.
+
+end Sinput.C;
diff --git a/gcc/ada/sinput-d.adb b/gcc/ada/sinput-d.adb
index 36c80d17e20..af0cafc4c68 100644
--- a/gcc/ada/sinput-d.adb
+++ b/gcc/ada/sinput-d.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-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- --
@@ -24,8 +24,8 @@
-- --
------------------------------------------------------------------------------
-with Osint; use Osint;
-with Osint.C; use Osint.C;
+with Osint; use Osint;
+with Osint.C; use Osint.C;
package body Sinput.D is
@@ -48,8 +48,9 @@ package body Sinput.D is
-- in memory for subsequent access.
Read_Source_File
- (S.Debug_Source_Name, S.Source_First, S.Source_Last, Src);
+ (S.Full_Debug_Name, S.Source_First, S.Source_Last, Src);
S.Source_Text := Src;
+ Set_Source_File_Index_Table (Dfile);
end Close_Debug_Source;
-------------------------
@@ -70,7 +71,8 @@ package body Sinput.D is
begin
S := Source_File.Table (Source);
- S.Debug_Source_Name := Create_Debug_File (S.File_Name);
+ S.Full_Debug_Name := Create_Debug_File (S.File_Name);
+ S.Debug_Source_Name := Strip_Directory (S.Full_Debug_Name);
S.Source_First := Loc;
S.Source_Last := Loc;
S.Lines_Table := null;
@@ -98,12 +100,14 @@ package body Sinput.D is
if Str'Length = 0 and then Loc = S.Source_First then
return;
- -- Here we write the line, and update the source record entry
+ -- Here we write the line, compute the source location for the
+ -- following line, allocate its table entry, and update the source
+ -- record entry.
else
Write_Debug_Info (Str (Str'First .. Str'Last - 1));
- Add_Line_Tables_Entry (S, Loc);
Loc := Loc - 1 + Source_Ptr (Str'Length + Debug_File_Eol_Length);
+ Add_Line_Tables_Entry (S, Loc);
S.Source_Last := Loc;
end if;
end Write_Debug_Line;
diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb
index fa5819ff30a..aa05461a282 100644
--- a/gcc/ada/sinput-l.adb
+++ b/gcc/ada/sinput-l.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- --
@@ -25,34 +25,64 @@
------------------------------------------------------------------------------
with Alloc;
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Namet; use Namet;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Errout; use Errout;
+with Namet; use Namet;
with Opt;
-with Osint; use Osint;
-with Output; use Output;
-with Scans; use Scans;
-with Scn; use Scn;
-with Sinfo; use Sinfo;
-with System; use System;
+with Osint; use Osint;
+with Output; use Output;
+with Prep; use Prep;
+with Prepcomp; use Prepcomp;
+with Scans; use Scans;
+with Scn; use Scn;
+with Sinfo; use Sinfo;
+with System; use System;
with Unchecked_Conversion;
package body Sinput.L is
- -- Routines to support conversion between types Lines_Table_Ptr
- -- and System.Address.
+ Prep_Buffer : Text_Buffer_Ptr := null;
+ -- A buffer to temporarily stored the result of preprocessing a source.
+ -- It is only allocated if there is at least one source to preprocess.
+
+ Prep_Buffer_Last : Text_Ptr := 0;
+ -- Index of the last significant character in Prep_Buffer
+
+ Initial_Size_Of_Prep_Buffer : constant := 10_000;
+ -- Size of Prep_Buffer when it is first allocated
+
+ -- When a file is to be preprocessed and the options to list symbols
+ -- has been selected (switch -s), Prep.List_Symbols is called with a
+ -- "foreword", a single line indicationg what source the symbols apply to.
+ -- The following two constant String are the start and the end of this
+ -- foreword.
+
+ Foreword_Start : constant String :=
+ "Preprocessing Symbols for source """;
+
+ Foreword_End : constant String := """";
-----------------
-- Subprograms --
-----------------
+ procedure Put_Char_In_Prep_Buffer (C : Character);
+ -- Add one character in Prep_Buffer, extending Prep_Buffer if need be.
+ -- Used to initialize the preprocessor.
+
+ procedure New_EOL_In_Prep_Buffer;
+ -- Add an LF to Prep_Buffer.
+ -- Used to initialize the preprocessor.
+
function Load_File
(N : File_Name_Type;
- T : File_Type)
+ T : Osint.File_Type)
return Source_File_Index;
- -- Load a source file or a configuration pragma file.
+ -- Load a source file, a configuration pragmas file or a definition file
+ -- Coding also allows preprocessing file, but not a library file ???
-------------------------------
-- Adjust_Instantiation_Sloc --
@@ -89,9 +119,10 @@ package body Sinput.L is
---------------------------------
procedure Create_Instantiation_Source
- (Inst_Node : Entity_Id;
- Template_Id : Entity_Id;
- A : out Sloc_Adjustment)
+ (Inst_Node : Entity_Id;
+ Template_Id : Entity_Id;
+ Inlined_Body : Boolean;
+ A : out Sloc_Adjustment)
is
Dnod : constant Node_Id := Declaration_Node (Template_Id);
Xold : Source_File_Index;
@@ -106,6 +137,7 @@ package body Sinput.L is
Xnew := Source_File.Last;
Source_File.Table (Xnew) := Source_File.Table (Xold);
+ Source_File.Table (Xnew).Inlined_Body := Inlined_Body;
Source_File.Table (Xnew).Instantiation := Sloc (Inst_Node);
Source_File.Table (Xnew).Template := Xold;
@@ -115,9 +147,9 @@ package body Sinput.L is
Source_File.Table (Xnew).Source_First :=
Source_File.Table (Xnew - 1).Source_Last + 1;
-
A.Adjust := Source_File.Table (Xnew).Source_First - A.Lo;
Source_File.Table (Xnew).Source_Last := A.Hi + A.Adjust;
+ Set_Source_File_Index_Table (Xnew);
Source_File.Table (Xnew).Sloc_Adjust :=
Source_File.Table (Xold).Sloc_Adjust - A.Adjust;
@@ -220,7 +252,6 @@ package body Sinput.L is
To_Source_Buffer_Ptr
(Source_File.Table (Xold).Source_Text (-A.Adjust)'Address);
end;
-
end Create_Instantiation_Source;
----------------------
@@ -235,19 +266,33 @@ package body Sinput.L is
return Load_File (N, Osint.Config);
end Load_Config_File;
+ --------------------------
+ -- Load_Definition_File --
+ --------------------------
+
+ function Load_Definition_File
+ (N : File_Name_Type)
+ return Source_File_Index
+ is
+ begin
+ return Load_File (N, Osint.Definition);
+ end Load_Definition_File;
+
---------------
-- Load_File --
---------------
function Load_File
(N : File_Name_Type;
- T : File_Type)
+ T : Osint.File_Type)
return Source_File_Index
is
- Src : Source_Buffer_Ptr;
- X : Source_File_Index;
- Lo : Source_Ptr;
- Hi : Source_Ptr;
+ Src : Source_Buffer_Ptr;
+ X : Source_File_Index;
+ Lo : Source_Ptr;
+ Hi : Source_Ptr;
+
+ Preprocessing_Needed : Boolean := False;
begin
for J in 1 .. Source_File.Last loop
@@ -258,6 +303,17 @@ package body Sinput.L is
-- Here we must build a new entry in the file table
+ -- But first, we must check if a source needs to be preprocessed,
+ -- because we may have to load and parse a definition file, and we want
+ -- to do that before we load the source, so that the buffer of the
+ -- source will be the last created, and we will be able to replace it
+ -- and modify Hi without stepping on another buffer.
+
+ if T = Osint.Source then
+ Prepare_To_Preprocess
+ (Source => N, Preprocessing_Needed => Preprocessing_Needed);
+ end if;
+
Source_File.Increment_Last;
X := Source_File.Last;
@@ -267,7 +323,7 @@ package body Sinput.L is
Lo := Source_File.Table (X - 1).Source_Last + 1;
end if;
- Read_Source_File (N, Lo, Hi, Src, T);
+ Osint.Read_Source_File (N, Lo, Hi, Src, T);
if Src = null then
Source_File.Decrement_Last;
@@ -328,15 +384,36 @@ package body Sinput.L is
end if;
declare
- S : Source_File_Record renames Source_File.Table (X);
+ S : Source_File_Record renames Source_File.Table (X);
+ File_Type : Type_Of_File;
begin
- S := (Debug_Source_Name => Full_Source_Name,
+ case T is
+ when Osint.Source =>
+ File_Type := Sinput.Src;
+
+ when Osint.Library =>
+ raise Program_Error;
+
+ when Osint.Config =>
+ File_Type := Sinput.Config;
+
+ when Osint.Definition =>
+ File_Type := Def;
+
+ when Osint.Preprocessing_Data =>
+ File_Type := Preproc;
+ end case;
+
+ S := (Debug_Source_Name => N,
File_Name => N,
+ File_Type => File_Type,
First_Mapped_Line => No_Line_Number,
- Full_File_Name => Full_Source_Name,
- Full_Ref_Name => Full_Source_Name,
+ Full_Debug_Name => Osint.Full_Source_Name,
+ Full_File_Name => Osint.Full_Source_Name,
+ Full_Ref_Name => Osint.Full_Source_Name,
Identifier_Casing => Unknown,
+ Inlined_Body => False,
Instantiation => No_Location,
Keyword_Casing => Unknown,
Last_Source_Line => 1,
@@ -352,16 +429,155 @@ package body Sinput.L is
Source_Last => Hi,
Source_Text => Src,
Template => No_Source_File,
- Time_Stamp => Current_Source_File_Stamp);
+ Time_Stamp => Osint.Current_Source_File_Stamp);
Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
S.Lines_Table (1) := Lo;
end;
+ -- Preprocess the source if it needs to be preprocessed
+
+ if Preprocessing_Needed then
+ if Opt.List_Preprocessing_Symbols then
+ Get_Name_String (N);
+
+ declare
+ Foreword : String (1 .. Foreword_Start'Length +
+ Name_Len + Foreword_End'Length);
+
+ begin
+ Foreword (1 .. Foreword_Start'Length) := Foreword_Start;
+ Foreword (Foreword_Start'Length + 1 ..
+ Foreword_Start'Length + Name_Len) :=
+ Name_Buffer (1 .. Name_Len);
+ Foreword (Foreword'Last - Foreword_End'Length + 1 ..
+ Foreword'Last) := Foreword_End;
+ Prep.List_Symbols (Foreword);
+ end;
+ end if;
+
+ declare
+ T : constant Nat := Total_Errors_Detected;
+ -- Used to check if there were errors during preprocessing
+
+ begin
+ -- If this is the first time we preprocess a source, allocate
+ -- the preprocessing buffer.
+
+ if Prep_Buffer = null then
+ Prep_Buffer :=
+ new Text_Buffer (1 .. Initial_Size_Of_Prep_Buffer);
+ end if;
+
+ -- Make sure the preprocessing buffer is empty
+
+ Prep_Buffer_Last := 0;
+
+ -- Initialize the preprocessor
+
+ Prep.Initialize
+ (Error_Msg => Errout.Error_Msg'Access,
+ Scan => Scn.Scanner.Scan'Access,
+ Set_Ignore_Errors => Errout.Set_Ignore_Errors'Access,
+ Put_Char => Put_Char_In_Prep_Buffer'Access,
+ New_EOL => New_EOL_In_Prep_Buffer'Access);
+
+ -- Initialize the scanner and set its behavior for
+ -- preprocessing, then preprocess.
+
+ Scn.Scanner.Initialize_Scanner (No_Unit, X);
+
+ Scn.Scanner.Set_Special_Character ('#');
+ Scn.Scanner.Set_Special_Character ('$');
+ Scn.Scanner.Set_End_Of_Line_As_Token (True);
+
+ Preprocess;
+
+ -- Reset the scanner to its standard behavior
+
+ Scn.Scanner.Reset_Special_Characters;
+ Scn.Scanner.Set_End_Of_Line_As_Token (False);
+
+ -- If there were errors during preprocessing, record an
+ -- error at the start of the file, and do not change the
+ -- source buffer.
+
+ if T /= Total_Errors_Detected then
+ Errout.Error_Msg
+ ("file could not be successfully preprocessed", Lo);
+ return No_Source_File;
+
+ else
+ -- Set the new value of Hi
+
+ Hi := Lo + Source_Ptr (Prep_Buffer_Last);
+
+ -- Create the new source buffer
+
+ declare
+ subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
+ -- Physical buffer allocated
+
+ type Actual_Source_Ptr is access Actual_Source_Buffer;
+ -- This is the pointer type for the physical buffer
+ -- allocated.
+
+ Actual_Ptr : constant Actual_Source_Ptr :=
+ new Actual_Source_Buffer;
+ -- And this is the actual physical buffer
+
+ begin
+ Actual_Ptr (Lo .. Hi - 1) :=
+ Prep_Buffer (1 .. Prep_Buffer_Last);
+ Actual_Ptr (Hi) := EOF;
+
+ -- Now we need to work out the proper virtual origin
+ -- pointer to return. This is exactly
+ -- Actual_Ptr (0)'Address, but we have to be careful to
+ -- suppress checks to compute this address.
+
+ declare
+ pragma Suppress (All_Checks);
+
+ function To_Source_Buffer_Ptr is new
+ Unchecked_Conversion (Address, Source_Buffer_Ptr);
+
+ begin
+ Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
+
+ -- Record in the table the new source buffer and the
+ -- new value of Hi.
+
+ Source_File.Table (X).Source_Text := Src;
+ Source_File.Table (X).Source_Last := Hi;
+
+ -- Reset Last_Line to 1, because the lines do not
+ -- have neccessarily the same starts and lengths.
+
+ Source_File.Table (X).Last_Source_Line := 1;
+ end;
+ end;
+ end if;
+ end;
+ end if;
+
+ Set_Source_File_Index_Table (X);
return X;
end if;
end Load_File;
+ ----------------------------------
+ -- Load_Preprocessing_Data_File --
+ ----------------------------------
+
+ function Load_Preprocessing_Data_File
+ (N : File_Name_Type)
+ return Source_File_Index
+ is
+ begin
+ return Load_File (N, Osint.Preprocessing_Data);
+ end Load_Preprocessing_Data_File;
+
----------------------
-- Load_Source_File --
----------------------
@@ -375,6 +591,39 @@ package body Sinput.L is
end Load_Source_File;
----------------------------
+ -- New_EOL_In_Prep_Buffer --
+ ----------------------------
+
+ procedure New_EOL_In_Prep_Buffer is
+ begin
+ Put_Char_In_Prep_Buffer (ASCII.LF);
+ end New_EOL_In_Prep_Buffer;
+
+ -----------------------------
+ -- Put_Char_In_Prep_Buffer --
+ -----------------------------
+
+ procedure Put_Char_In_Prep_Buffer (C : Character) is
+ begin
+ -- If preprocessing buffer is not large enough, double it
+
+ if Prep_Buffer_Last = Prep_Buffer'Last then
+ declare
+ New_Prep_Buffer : constant Text_Buffer_Ptr :=
+ new Text_Buffer (1 .. 2 * Prep_Buffer_Last);
+
+ begin
+ New_Prep_Buffer (Prep_Buffer'Range) := Prep_Buffer.all;
+ Free (Prep_Buffer);
+ Prep_Buffer := New_Prep_Buffer;
+ end;
+ end if;
+
+ Prep_Buffer_Last := Prep_Buffer_Last + 1;
+ Prep_Buffer (Prep_Buffer_Last) := C;
+ end Put_Char_In_Prep_Buffer;
+
+ ----------------------------
-- Source_File_Is_Subunit --
----------------------------
diff --git a/gcc/ada/sinput-l.ads b/gcc/ada/sinput-l.ads
index 9297530e5bc..a7f5e00c9f0 100644
--- a/gcc/ada/sinput-l.ads
+++ b/gcc/ada/sinput-l.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -51,6 +51,17 @@ package Sinput.L is
function Load_Config_File (N : File_Name_Type) return Source_File_Index;
-- Similar to Load_Source_File, except that the file name is always
-- interpreted in the context of the current working directory.
+ -- The file is never preprocessed.
+
+ function Load_Definition_File
+ (N : File_Name_Type)
+ return Source_File_Index;
+ -- Needs comments ???
+
+ function Load_Preprocessing_Data_File
+ (N : File_Name_Type)
+ return Source_File_Index;
+ -- Similar to Load_Source_File, except that the file is never preprocessed.
procedure Complete_Source_File_Entry;
-- Called on completing the parsing of a source file. This call completes
@@ -73,14 +84,19 @@ package Sinput.L is
-- calls to Adjust_Instantiation_Sloc.
procedure Create_Instantiation_Source
- (Inst_Node : Entity_Id;
- Template_Id : Entity_Id;
- A : out Sloc_Adjustment);
+ (Inst_Node : Entity_Id;
+ Template_Id : Entity_Id;
+ Inlined_Body : Boolean;
+ A : out Sloc_Adjustment);
-- This procedure creates the source table entry for an instantiation.
-- Inst_Node is the instantiation node, and Template_Id is the defining
-- identifier of the generic declaration or body unit as appropriate.
-- A is set to an adjustment factor to be used in subsequent calls to
- -- Adjust_Instantiation_Sloc.
+ -- Adjust_Instantiation_Sloc. The instantiation mechnaism is also used
+ -- for inlined function and procedure calls. The parameter Inlined_Body
+ -- is set to True in such cases, and False for a generic instantiation.
+ -- This is used for generating error messages that distinguish these
+ -- two cases, otherwise the two cases are handled identically.
procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment);
-- The instantiation tree is created by copying the tree of the generic
diff --git a/gcc/ada/sinput-p.adb b/gcc/ada/sinput-p.adb
index d0985c4eaae..5edc13bf9ae 100644
--- a/gcc/ada/sinput-p.adb
+++ b/gcc/ada/sinput-p.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -24,12 +24,9 @@
-- --
------------------------------------------------------------------------------
-with Ada.Unchecked_Conversion;
-
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Namet; use Namet;
-with Opt; use Opt;
-with System; use System;
+with Prj; use Prj;
+with Prj.Err;
+with Sinput.C;
package body Sinput.P is
@@ -43,162 +40,16 @@ package body Sinput.P is
-----------------------
function Load_Project_File (Path : String) return Source_File_Index is
- Src : Source_Buffer_Ptr;
X : Source_File_Index;
- Lo : Source_Ptr;
- Hi : Source_Ptr;
-
- Source_File_FD : File_Descriptor;
- -- The file descriptor for the current source file. A negative value
- -- indicates failure to open the specified source file.
-
- Len : Integer;
- -- Length of file. Assume no more than 2 gigabytes of source!
-
- Actual_Len : Integer;
-
- Path_Id : Name_Id;
- File_Id : Name_Id;
begin
- if Path = "" then
- return No_Source_File;
- end if;
-
- Source_File.Increment_Last;
- X := Source_File.Last;
+ X := Sinput.C.Load_File (Path);
if First then
Main_Source_File := X;
First := False;
end if;
- if X = Source_File.First then
- Lo := First_Source_Ptr;
- else
- Lo := Source_File.Table (X - 1).Source_Last + 1;
- end if;
-
- Name_Len := Path'Length;
- Name_Buffer (1 .. Name_Len) := Path;
- Path_Id := Name_Find;
- Name_Buffer (Name_Len + 1) := ASCII.NUL;
-
- -- Open the source FD, note that we open in binary mode, because as
- -- documented in the spec, the caller is expected to handle either
- -- DOS or Unix mode files, and there is no point in wasting time on
- -- text translation when it is not required.
-
- Source_File_FD := Open_Read (Name_Buffer'Address, Binary);
-
- if Source_File_FD = Invalid_FD then
- Source_File.Decrement_Last;
- return No_Source_File;
-
- end if;
-
- Len := Integer (File_Length (Source_File_FD));
-
- -- Set Hi so that length is one more than the physical length,
- -- allowing for the extra EOF character at the end of the buffer
-
- Hi := Lo + Source_Ptr (Len);
-
- -- Do the actual read operation
-
- declare
- subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi);
- -- Physical buffer allocated
-
- type Actual_Source_Ptr is access Actual_Source_Buffer;
- -- This is the pointer type for the physical buffer allocated
-
- Actual_Ptr : Actual_Source_Ptr := new Actual_Source_Buffer;
- -- And this is the actual physical buffer
-
- begin
- -- Allocate source buffer, allowing extra character at end for EOF
-
- -- Some systems (e.g. VMS) have file types that require one
- -- read per line, so read until we get the Len bytes or until
- -- there are no more characters.
-
- Hi := Lo;
- loop
- Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len);
- Hi := Hi + Source_Ptr (Actual_Len);
- exit when Actual_Len = Len or Actual_Len <= 0;
- end loop;
-
- Actual_Ptr (Hi) := EOF;
-
- -- Now we need to work out the proper virtual origin pointer to
- -- return. This is exactly Actual_Ptr (0)'Address, but we have
- -- to be careful to suppress checks to compute this address.
-
- declare
- pragma Suppress (All_Checks);
-
- function To_Source_Buffer_Ptr is new
- Ada.Unchecked_Conversion (Address, Source_Buffer_Ptr);
-
- begin
- Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address);
- end;
- end;
-
- -- Read is complete, get time stamp and close file and we are done
-
- Close (Source_File_FD);
-
- -- Get the file name, without path information
-
- declare
- Index : Positive := Path'Last;
-
- begin
- while Index > Path'First loop
- exit when Path (Index - 1) = '/';
- exit when Path (Index - 1) = Directory_Separator;
- Index := Index - 1;
- end loop;
-
- Name_Len := Path'Last - Index + 1;
- Name_Buffer (1 .. Name_Len) := Path (Index .. Path'Last);
- File_Id := Name_Find;
- end;
-
- declare
- S : Source_File_Record renames Source_File.Table (X);
-
- begin
- S := (Debug_Source_Name => Path_Id,
- File_Name => File_Id,
- First_Mapped_Line => No_Line_Number,
- Full_File_Name => Path_Id,
- Full_Ref_Name => Path_Id,
- Identifier_Casing => Unknown,
- Instantiation => No_Location,
- Keyword_Casing => Unknown,
- Last_Source_Line => 1,
- License => Unknown,
- Lines_Table => null,
- Lines_Table_Max => 1,
- Logical_Lines_Table => null,
- Num_SRef_Pragmas => 0,
- Reference_Name => File_Id,
- Sloc_Adjust => 0,
- Source_Checksum => 0,
- Source_First => Lo,
- Source_Last => Hi,
- Source_Text => Src,
- Template => No_Source_File,
- Time_Stamp => Empty_Time_Stamp);
-
- Alloc_Line_Tables (S, Opt.Table_Factor * Alloc.Lines_Initial);
- S.Lines_Table (1) := Lo;
- end;
-
return X;
end Load_Project_File;
@@ -228,4 +79,28 @@ package body Sinput.P is
Saved_State.Current_Source_File := Current_Source_File;
end Save_Project_Scan_State;
+ ----------------------------
+ -- Source_File_Is_Subunit --
+ ----------------------------
+
+ function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
+ begin
+ Prj.Err.Scanner.Initialize_Scanner (No_Unit, X);
+
+ -- We scan past junk to the first interesting compilation unit
+ -- token, to see if it is SEPARATE. We ignore WITH keywords during
+ -- this and also PRIVATE. The reason for ignoring PRIVATE is that
+ -- it handles some error situations, and also it is possible that
+ -- a PRIVATE WITH feature might be approved some time in the future.
+
+ while Token = Tok_With
+ or else Token = Tok_Private
+ or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
+ loop
+ Scan;
+ end loop;
+
+ return Token = Tok_Separate;
+ end Source_File_Is_Subunit;
+
end Sinput.P;
diff --git a/gcc/ada/sinput-p.ads b/gcc/ada/sinput-p.ads
index 1cc19b378b8..0ebf8f646c7 100644
--- a/gcc/ada/sinput-p.ads
+++ b/gcc/ada/sinput-p.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -37,6 +37,15 @@ package Sinput.P is
-- Load into memory the source of a project source file.
-- Initialize the Scans state.
+ function Source_File_Is_Subunit (X : Source_File_Index) return Boolean;
+ -- This function determines if a source file represents a subunit. It
+ -- works by scanning for the first compilation unit token, and returning
+ -- True if it is the token SEPARATE. It will return False otherwise,
+ -- meaning that the file cannot possibly be a legal subunit. This
+ -- function does NOT do a complete parse of the file, or build a
+ -- tree. It is used in gnatmake to decide if a body without a spec
+ -- in a project file needs to be compiled or not.
+
type Saved_Project_Scan_State is limited private;
-- Used to save project scan state in following two routines
diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb
index ec9659eb7c8..25b74a8c694 100644
--- a/gcc/ada/sinput.adb
+++ b/gcc/ada/sinput.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -376,7 +376,9 @@ package body Sinput is
return Source_Cache_Index;
else
- for J in 1 .. Source_File.Last loop
+ for J in Source_File_Index_Table (Int (S) / Chunk_Size)
+ .. Source_File.Last
+ loop
if S in Source_File.Table (J).Source_First ..
Source_File.Table (J).Source_Last
then
@@ -401,6 +403,12 @@ package body Sinput is
procedure Initialize is
begin
+ Source_Cache_First := 1;
+ Source_Cache_Last := 0;
+ Source_Cache_Index := No_Source_File;
+ Source_gnat_adc := No_Source_File;
+ First_Time_Around := True;
+
Source_File.Init;
end Initialize;
@@ -573,13 +581,14 @@ package body Sinput is
begin
if File_Name /= No_Name then
- SFR.Full_Ref_Name := File_Name;
+ SFR.Reference_Name := Stripped_File_Name;
+ SFR.Full_Ref_Name := File_Name;
if not Debug_Generated_Code then
- SFR.Debug_Source_Name := File_Name;
+ SFR.Debug_Source_Name := Stripped_File_Name;
+ SFR.Full_Debug_Name := File_Name;
end if;
- SFR.Reference_Name := Stripped_File_Name;
SFR.Num_SRef_Pragmas := SFR.Num_SRef_Pragmas + 1;
end if;
@@ -604,6 +613,27 @@ package body Sinput is
end loop;
end Register_Source_Ref_Pragma;
+ ---------------------------------
+ -- Set_Source_File_Index_Table --
+ ---------------------------------
+
+ procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is
+ Ind : Int;
+ SP : Source_Ptr;
+ SL : constant Source_Ptr := Source_File.Table (Xnew).Source_Last;
+
+ begin
+ SP := (Source_File.Table (Xnew).Source_First + Chunk_Size - 1)
+ / Chunk_Size * Chunk_Size;
+ Ind := Int (SP) / Chunk_Size;
+
+ while SP <= SL loop
+ Source_File_Index_Table (Ind) := Xnew;
+ SP := SP + Chunk_Size;
+ Ind := Ind + 1;
+ end loop;
+ end Set_Source_File_Index_Table;
+
---------------------------
-- Skip_Line_Terminators --
---------------------------
@@ -864,6 +894,8 @@ package body Sinput is
end;
end if;
end;
+
+ Set_Source_File_Index_Table (J);
end loop;
end Tree_Read;
@@ -1006,11 +1038,21 @@ package body Sinput is
return Source_File.Table (S).File_Name;
end File_Name;
+ function File_Type (S : SFI) return Type_Of_File is
+ begin
+ return Source_File.Table (S).File_Type;
+ end File_Type;
+
function First_Mapped_Line (S : SFI) return Logical_Line_Number is
begin
return Source_File.Table (S).First_Mapped_Line;
end First_Mapped_Line;
+ function Full_Debug_Name (S : SFI) return File_Name_Type is
+ begin
+ return Source_File.Table (S).Full_Debug_Name;
+ end Full_Debug_Name;
+
function Full_File_Name (S : SFI) return File_Name_Type is
begin
return Source_File.Table (S).Full_File_Name;
@@ -1026,6 +1068,11 @@ package body Sinput is
return Source_File.Table (S).Identifier_Casing;
end Identifier_Casing;
+ function Inlined_Body (S : SFI) return Boolean is
+ begin
+ return Source_File.Table (S).Inlined_Body;
+ end Inlined_Body;
+
function Instantiation (S : SFI) return Source_Ptr is
begin
return Source_File.Table (S).Instantiation;
diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads
index 1bf1af33019..fb085cd7008 100644
--- a/gcc/ada/sinput.ads
+++ b/gcc/ada/sinput.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -47,6 +47,21 @@ with Types; use Types;
package Sinput is
+ type Type_Of_File is (
+ -- Indicates type of file being read
+
+ Src,
+ -- Normal Ada source file
+
+ Config,
+ -- Configuration pragma file
+
+ Def,
+ -- Preprocessing definition file
+
+ Preproc);
+ -- Source file with preprocessing commands to be preprocessed
+
----------------------------
-- Source License Control --
----------------------------
@@ -106,8 +121,8 @@ package Sinput is
-- The source file table has an entry for each source file read in for
-- this run of the compiler. This table is (default) initialized when
-- the compiler is loaded, and simply accumulates entries as compilation
- -- proceeds and the Sinput.L.Load_Source_File procedure is called to load
- -- required source files.
+ -- proceeds and various routines in Sinput and its child packages are
+ -- called to load required source files.
-- Virtual entries are also created for generic templates when they are
-- instantiated, as described in a separate section later on.
@@ -120,34 +135,44 @@ package Sinput is
-- The entries in the table are accessed using a Source_File_Index that
-- ranges from 1 to Last_Source_File. Each entry has the following fields
- -- Note that entry 1 is always for system.ads (see Targparm for details
- -- of why we always read this source file first), and we have defined a
- -- constant Types.System_Source_File_Index as 1 to reflect this fact.
+ -- Note: fields marked read-only are set by Sinput or one of its child
+ -- packages when a source file table entry is created, and cannot be
+ -- subsqently modified, or alternatively are set only by very special
+ -- circumstances, documented in the comments.
- -- File_Name : File_Name_Type
- -- Name of the source file (simple name with no directory information).
- -- Set by Sinput.L.Load_Source_File and cannot be subequently changed.
+ -- File_Name : File_Name_Type (read-only)
+ -- Name of the source file (simple name with no directory information)
- -- Full_File_Name : File_Name_Type
+ -- Full_File_Name : File_Name_Type (read-only)
-- Full file name (full name with directory info), used for generation
- -- of error messages, etc. Set by Sinput.L.Load_Source_File and cannot
- -- be subsequently changed.
+ -- of error messages, etc.
+
+ -- File_Type : Type_Of_File (read-only)
+ -- Indicates type of file (source file, configuration pragmas file,
+ -- preprocessor definition file, preprocessor input file).
- -- Reference_Name : File_Name_Type
+ -- Reference_Name : File_Name_Type (read-only)
-- Name to be used for source file references in error messages where
-- only the simple name of the file is required. Identical to File_Name
-- unless pragma Source_Reference is used to change it. Only processing
-- for the Source_Reference pragma circuit may set this field.
- -- Full_Ref_Name : File_Name_Type
+ -- Full_Ref_Name : File_Name_Type (read-only)
-- Name to be used for source file references in error messages where
-- the full name of the file is required. Identical to Full_File_Name
-- unless pragma Source_Reference is used to change it. Only processing
-- for the Source_Reference pragma may set this field.
- -- Debug_Source_Name : File_Name_Type
+ -- Debug_Source_Name : File_Name_Type (read-only)
-- Name to be used for source file references in debugging information
-- where only the simple name of the file is required. Identical to
+ -- Reference_Name unless the -gnatD (debug source file) switch is used.
+ -- Only processing in Sprint that generates this file is permitted to
+ -- set this field.
+
+ -- Full_Debug_Name : File_Name_Type (read-only)
+ -- Name to be used for source file references in debugging information
+ -- where the full name of the file is required. This is identical to
-- Full_Ref_Name unless the -gnatD (debug source file) switch is used.
-- Only processing in Sprint that generates this file is permitted to
-- set this field.
@@ -163,28 +188,23 @@ package Sinput is
-- file that is not a Source_Reference pragma. If no source reference
-- pragmas are used, then the value is set to No_Line_Number.
- -- Source_Text : Source_Buffer_Ptr
+ -- Source_Text : Source_Buffer_Ptr (read-only)
-- Text of source file. Note that every source file has a distinct set
-- of non-overlapping logical bounds, so it is possible to determine
-- which file is referenced from a given subscript (Source_Ptr) value.
- -- Set by Sinput.L.Load_Source_File and cannot be subsequently changed.
- -- Source_First : Source_Ptr;
+ -- Source_First : Source_Ptr; (read-only)
-- Subscript of first character in Source_Text. Note that this cannot
-- be obtained as Source_Text'First, because we use virtual origin
- -- addressing. Set by Sinput.L procedures when the entry is first
- -- created and never subsequently changed.
+ -- addressing.
- -- Source_Last : Source_Ptr;
+ -- Source_Last : Source_Ptr; (read-only)
-- Subscript of last character in Source_Text. Note that this cannot
-- be obtained as Source_Text'Last, because we use virtual origin
- -- addressing, so this value is always Source_Ptr'Last. Set by
- -- Sinput.L procedures when the entry is first created and never
- -- subsequently changed.
+ -- addressing, so this value is always Source_Ptr'Last.
- -- Time_Stamp : Time_Stamp_Type;
- -- Time stamp of the source file. Set by Sinput.L.Load_Source_File,
- -- and cannot be subsequently changed.
+ -- Time_Stamp : Time_Stamp_Type; (read-only)
+ -- Time stamp of the source file
-- Source_Checksum : Word;
-- Computed checksum for contents of source file. See separate section
@@ -214,23 +234,36 @@ package Sinput is
-- of a normal non-instantiation entry. See section below for details.
-- This field is read-only for clients.
- -- Template : Source_File_Index;
+ -- Inlined_Body : Boolean;
+ -- This can only be set True if Instantiation has a value other than
+ -- No_Location. If true it indicates that the instantiation is actually
+ -- an instance of an inlined body.
+
+ -- Template : Source_File_Index; (read-only)
-- Source file index of the source file containing the template if this
-- is a generic instantiation. Set to No_Source_File for the normal case
- -- of a non-instantiation entry. See Sinput-L for details. This field is
- -- read-only for clients.
+ -- of a non-instantiation entry. See Sinput-L for details.
-- The source file table is accessed by clients using the following
-- subprogram interface:
subtype SFI is Source_File_Index;
+ System_Source_File_Index : SFI;
+ -- The file system.ads is always read by the compiler to determine the
+ -- settings of the target parameters in the private part of System. This
+ -- variable records the source file index of system.ads. Typically this
+ -- will be 1 since system.ads is read first.
+
function Debug_Source_Name (S : SFI) return File_Name_Type;
function File_Name (S : SFI) return File_Name_Type;
+ function File_Type (S : SFI) return Type_Of_File;
function First_Mapped_Line (S : SFI) return Logical_Line_Number;
+ function Full_Debug_Name (S : SFI) return File_Name_Type;
function Full_File_Name (S : SFI) return File_Name_Type;
function Full_Ref_Name (S : SFI) return File_Name_Type;
function Identifier_Casing (S : SFI) return Casing_Type;
+ function Inlined_Body (S : SFI) return Boolean;
function Instantiation (S : SFI) return Source_Ptr;
function Keyword_Casing (S : SFI) return Casing_Type;
function Last_Source_Line (S : SFI) return Physical_Line_Number;
@@ -263,6 +296,48 @@ package Sinput is
Main_Source_File : Source_File_Index;
-- This is set to the source file index of the main unit
+ -----------------------------
+ -- Source_File_Index_Table --
+ -----------------------------
+
+ -- The Get_Source_File_Index function is called very frequently. Earlier
+ -- versions cached a single entry, but then reverted to a serial search,
+ -- and this proved to be a significant source of inefficiency. To get
+ -- around this, we use the following directly indexed array. The space
+ -- of possible input values is a value of type Source_Ptr which is simply
+ -- an Int value. The values in this space are allocated sequentially as
+ -- new units are loaded.
+
+ -- The following table has an entry for each 4K range of possible
+ -- Source_Ptr values. The value in the table is the lowest value
+ -- Source_File_Index whose Source_Ptr range contains value in the
+ -- range.
+
+ -- For example, the entry with index 4 in this table represents Source_Ptr
+ -- values in the range 4*4096 .. 5*4096-1. The Source_File_Index value
+ -- stored would be the lowest numbered source file with at least one byte
+ -- in this range.
+
+ -- The algorithm used in Get_Source_File_Index is simply to access this
+ -- table and then do a serial search starting at the given position. This
+ -- will almost always terminate with one or two checks.
+
+ -- Note that this array is pretty large, but in most operating systems
+ -- it will not be allocated in physical memory unless it is actually used.
+
+ Chunk_Power : constant := 12;
+ Chunk_Size : constant := 2 ** Chunk_Power;
+ -- Change comments above if value changed. Note that Chunk_Size must
+ -- be a power of 2 (to allow for efficient access to the table).
+
+ Source_File_Index_Table :
+ array (Int range 0 .. Int'Last / Chunk_Size) of Source_File_Index;
+
+ procedure Set_Source_File_Index_Table (Xnew : Source_File_Index);
+ -- Sets entries in the Source_File_Index_Table for the newly created
+ -- Source_File table entry whose index is Xnew. The Source_First and
+ -- Source_Last fields of this entry must be set before the call.
+
-----------------------
-- Checksum Handling --
-----------------------
@@ -556,10 +631,13 @@ private
type Source_File_Record is record
File_Name : File_Name_Type;
+ File_Type : Type_Of_File;
Reference_Name : File_Name_Type;
Debug_Source_Name : File_Name_Type;
+ Full_Debug_Name : File_Name_Type;
Full_File_Name : File_Name_Type;
Full_Ref_Name : File_Name_Type;
+ Inlined_Body : Boolean;
License : License_Type;
Num_SRef_Pragmas : Nat;
First_Mapped_Line : Logical_Line_Number;
diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb
index 4af08092924..944fe9c397c 100644
--- a/gcc/ada/snames.adb
+++ b/gcc/ada/snames.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- --
@@ -62,10 +62,8 @@ package body Snames is
"off#" &
"space#" &
"time#" &
- "_init_proc#" &
- "_size#" &
+ "_alignment#" &
"_abort_signal#" &
- "_address_resolver#" &
"_assign#" &
"_chain#" &
"_clean#" &
@@ -80,6 +78,7 @@ package body Snames is
"_object#" &
"_priority#" &
"_service#" &
+ "_size#" &
"_tags#" &
"_task#" &
"_task_id#" &
@@ -91,17 +90,6 @@ package body Snames is
"finalize#" &
"next#" &
"prev#" &
- "_deep_adjust#" &
- "_equality#" &
- "_deep_finalize#" &
- "_deep_initialize#" &
- "_input#" &
- "_output#" &
- "_ras_access#" &
- "_ras_dereference#" &
- "_read#" &
- "_rep_to_pos#" &
- "_write#" &
"allocate#" &
"deallocate#" &
"dereference#" &
@@ -162,36 +150,45 @@ package body Snames is
"ada_83#" &
"ada_95#" &
"c_pass_by_copy#" &
+ "compile_time_warning#" &
"component_alignment#" &
"convention_identifier#" &
"discard_names#" &
"elaboration_checks#" &
"eliminate#" &
+ "explicit_overriding#" &
"extend_system#" &
"extensions_allowed#" &
"external_name_casing#" &
"float_representation#" &
"initialize_scalars#" &
+ "interrupt_state#" &
"license#" &
"locking_policy#" &
"long_float#" &
"no_run_time#" &
"normalize_scalars#" &
"polling#" &
+ "persistent_data#" &
+ "persistent_object#" &
"propagate_exceptions#" &
"queuing_policy#" &
"ravenscar#" &
"restricted_run_time#" &
"restrictions#" &
+ "restriction_warnings#" &
"reviewable#" &
"source_file_name#" &
+ "source_file_name_project#" &
"style_checks#" &
"suppress#" &
+ "suppress_exception_locations#" &
"task_dispatching_policy#" &
+ "universal_data#" &
"unsuppress#" &
"use_vads_size#" &
- "warnings#" &
"validity_checks#" &
+ "warnings#" &
"abort_defer#" &
"all_calls_remote#" &
"annotate#" &
@@ -218,6 +215,7 @@ package body Snames is
"export_function#" &
"export_object#" &
"export_procedure#" &
+ "export_value#" &
"export_valued_procedure#" &
"external#" &
"finalize_storage_only#" &
@@ -238,6 +236,7 @@ package body Snames is
"interrupt_priority#" &
"java_constructor#" &
"java_interface#" &
+ "keep_names#" &
"link_with#" &
"linker_alias#" &
"linker_options#" &
@@ -248,7 +247,10 @@ package body Snames is
"main_storage#" &
"memory_size#" &
"no_return#" &
+ "obsolescent#" &
"optimize#" &
+ "optional_overriding#" &
+ "overriding#" &
"pack#" &
"page#" &
"passive#" &
@@ -276,7 +278,6 @@ package body Snames is
"title#" &
"unchecked_union#" &
"unimplemented_unit#" &
- "universal_data#" &
"unreferenced#" &
"unreserve_all_interrupts#" &
"volatile#" &
@@ -333,6 +334,7 @@ package body Snames is
"restricted#" &
"result_mechanism#" &
"result_type#" &
+ "runtime#" &
"sb#" &
"section#" &
"semaphore#" &
@@ -351,6 +353,7 @@ package body Snames is
"unknown#" &
"unrestricted#" &
"uppercase#" &
+ "user#" &
"vax_float#" &
"vms#" &
"working_storage#" &
@@ -418,6 +421,7 @@ package body Snames is
"object_size#" &
"partition_id#" &
"passed_by_reference#" &
+ "pool_address#" &
"pos#" &
"position#" &
"range#" &
@@ -436,12 +440,14 @@ package body Snames is
"storage_size#" &
"storage_unit#" &
"tag#" &
+ "target_name#" &
"terminated#" &
"to_address#" &
"type_class#" &
"uet_address#" &
"unbiased_rounding#" &
"unchecked_access#" &
+ "unconstrained_array#" &
"universal_literal_string#" &
"unrestricted_access#" &
"vads_size#" &
@@ -575,6 +581,7 @@ package body Snames is
"source_location#" &
"unchecked_conversion#" &
"unchecked_deallocation#" &
+ "to_pointer#" &
"abstract#" &
"aliased#" &
"protected#" &
@@ -583,13 +590,17 @@ package body Snames is
"tagged#" &
"raise_exception#" &
"binder#" &
+ "body_suffix#" &
"builder#" &
"compiler#" &
"cross_reference#" &
"default_switches#" &
"exec_dir#" &
+ "executable#" &
+ "executable_suffix#" &
"extends#" &
"finder#" &
+ "global_configuration_pragmas#" &
"gnatls#" &
"gnatstub#" &
"implementation#" &
@@ -597,22 +608,33 @@ package body Snames is
"implementation_suffix#" &
"languages#" &
"library_dir#" &
- "library_elaboration#" &
+ "library_auto_init#" &
+ "library_gcc#" &
+ "library_interface#" &
"library_kind#" &
"library_name#" &
+ "library_options#" &
+ "library_src_dir#" &
+ "library_symbol_file#" &
"library_version#" &
"linker#" &
+ "local_configuration_pragmas#" &
+ "locally_removed_files#" &
"naming#" &
"object_dir#" &
+ "pretty_printer#" &
"project#" &
"separate_suffix#" &
"source_dirs#" &
"source_files#" &
"source_list_file#" &
+ "spec#" &
+ "spec_suffix#" &
"specification#" &
"specification_exceptions#" &
"specification_suffix#" &
"switches#" &
+ "unaligned_valid#" &
"#";
---------------------
@@ -638,7 +660,6 @@ package body Snames is
-- xxxE dispatch table pointer type for tagged type xxx (Exp_Ch3)
-- xxxE parameters for accept body for entry xxx (Exp_Ch9)
-- xxxFn n'th primitive of a tagged type (named xxx) (Exp_Ch3)
- -- xxxI initialization procedure for type xxx (Exp_Ch3)
-- xxxJ tag table type index for tagged type xxx (Exp_Ch3)
-- xxxM master Id value for access type xxx (Exp_Ch3)
-- xxxP tag table pointer type for tagged type xxx (Exp_Ch3)
@@ -653,6 +674,21 @@ package body Snames is
-- xxxY dispatch table type for tagged type xxx (Exp_Ch3)
-- xxxZ size variable for task xxx (Exp_Ch9)
+ -- TSS names
+
+ -- xxxDA deep adjust routine for type xxx (Exp_TSS)
+ -- xxxDF deep finalize routine for type xxx (Exp_TSS)
+ -- xxxDI deep initialize routine for type xxx (Exp_TSS)
+ -- xxxEQ composite equality routine for record type xxx (Exp_TSS)
+ -- xxxIP initialization procedure for type xxx (Exp_TSS)
+ -- xxxRA RAs type access routine for type xxx (Exp_TSS)
+ -- xxxRD RAs type dereference routine for type xxx (Exp_TSS)
+ -- xxxRP Rep to Pos conversion for enumeration type xxx (Exp_TSS)
+ -- xxxSI stream input attribute subprogram for type xxx (Exp_TSS)
+ -- xxxSO stream output attribute subprogram for type xxx (Exp_TSS)
+ -- xxxSR stream read attribute subprogram for type xxx (Exp_TSS)
+ -- xxxSW stream write attribute subprogram for type xxx (Exp_TSS)
+
-- Implicit type names
-- TxxxT type of literal table for enumeration type xxx (Sem_Ch3)
@@ -695,6 +731,9 @@ package body Snames is
when Name_Stdcall => return Convention_Stdcall;
when Name_Stubbed => return Convention_Stubbed;
+ -- If no direct match, then we must have a convention
+ -- identifier pragma that has specified this name.
+
when others =>
for J in 1 .. Convention_Identifiers.Last loop
if N = Convention_Identifiers.Table (J).Name then
@@ -727,6 +766,8 @@ package body Snames is
return Pragma_Storage_Size;
elsif N = Name_Storage_Unit then
return Pragma_Storage_Unit;
+ elsif N not in First_Pragma_Name .. Last_Pragma_Name then
+ return Unknown_Pragma;
else
return Pragma_Id'Val (N - First_Pragma_Name);
end if;
@@ -827,11 +868,15 @@ package body Snames is
function Is_Convention_Name (N : Name_Id) return Boolean is
begin
+ -- Check if this is one of the standard conventions
+
if N in First_Convention_Name .. Last_Convention_Name
or else N = Name_C
then
return True;
+ -- Otherwise check if it is in convention identifier table
+
else
for J in 1 .. Convention_Identifiers.Last loop
if N = Convention_Identifiers.Table (J).Name then
diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads
index 0c3a8cb3557..3d1705e584c 100644
--- a/gcc/ada/snames.ads
+++ b/gcc/ada/snames.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -140,149 +140,133 @@ package Snames is
Name_Off : constant Name_Id := N + 002;
Name_Space : constant Name_Id := N + 003;
Name_Time : constant Name_Id := N + 004;
- Name_uInit_Proc : constant Name_Id := N + 005;
- Name_uSize : constant Name_Id := N + 006;
-- Some special names used by the expander. Note that the lower case u's
-- at the start of these names get translated to extra underscores. These
-- names are only referenced internally by expander generated code.
- Name_uAbort_Signal : constant Name_Id := N + 007;
- Name_uAddress_Resolver : constant Name_Id := N + 008;
- Name_uAssign : constant Name_Id := N + 009;
- Name_uChain : constant Name_Id := N + 010;
- Name_uClean : constant Name_Id := N + 011;
- Name_uController : constant Name_Id := N + 012;
- Name_uEntry_Bodies : constant Name_Id := N + 013;
- Name_uExpunge : constant Name_Id := N + 014;
- Name_uFinal_List : constant Name_Id := N + 015;
- Name_uIdepth : constant Name_Id := N + 016;
- Name_uInit : constant Name_Id := N + 017;
- Name_uLocal_Final_List : constant Name_Id := N + 018;
- Name_uMaster : constant Name_Id := N + 019;
- Name_uObject : constant Name_Id := N + 020;
- Name_uPriority : constant Name_Id := N + 021;
- Name_uService : constant Name_Id := N + 022;
- Name_uTags : constant Name_Id := N + 023;
- Name_uTask : constant Name_Id := N + 024;
- Name_uTask_Id : constant Name_Id := N + 025;
- Name_uTask_Info : constant Name_Id := N + 026;
- Name_uTask_Name : constant Name_Id := N + 027;
- Name_uTrace_Sp : constant Name_Id := N + 028;
+ Name_uAlignment : constant Name_Id := N + 005;
+ Name_uAbort_Signal : constant Name_Id := N + 006;
+ Name_uAssign : constant Name_Id := N + 007;
+ Name_uChain : constant Name_Id := N + 008;
+ Name_uClean : constant Name_Id := N + 009;
+ Name_uController : constant Name_Id := N + 010;
+ Name_uEntry_Bodies : constant Name_Id := N + 011;
+ Name_uExpunge : constant Name_Id := N + 012;
+ Name_uFinal_List : constant Name_Id := N + 013;
+ Name_uIdepth : constant Name_Id := N + 014;
+ Name_uInit : constant Name_Id := N + 015;
+ Name_uLocal_Final_List : constant Name_Id := N + 016;
+ Name_uMaster : constant Name_Id := N + 017;
+ Name_uObject : constant Name_Id := N + 018;
+ Name_uPriority : constant Name_Id := N + 019;
+ Name_uService : constant Name_Id := N + 020;
+ Name_uSize : constant Name_Id := N + 021;
+ Name_uTags : constant Name_Id := N + 022;
+ Name_uTask : constant Name_Id := N + 023;
+ Name_uTask_Id : constant Name_Id := N + 024;
+ Name_uTask_Info : constant Name_Id := N + 025;
+ Name_uTask_Name : constant Name_Id := N + 026;
+ Name_uTrace_Sp : constant Name_Id := N + 027;
-- Names of routines in Ada.Finalization, needed by expander
- Name_Initialize : constant Name_Id := N + 029;
- Name_Adjust : constant Name_Id := N + 030;
- Name_Finalize : constant Name_Id := N + 031;
+ Name_Initialize : constant Name_Id := N + 028;
+ Name_Adjust : constant Name_Id := N + 029;
+ Name_Finalize : constant Name_Id := N + 030;
-- Names of fields declared in System.Finalization_Implementation,
-- needed by the expander when generating code for finalization.
- Name_Next : constant Name_Id := N + 032;
- Name_Prev : constant Name_Id := N + 033;
-
- -- Names of TSS routines (see Exp_TSS); Name_uInit_Proc above is also
- -- one of these.
-
- Name_uDeep_Adjust : constant Name_Id := N + 034;
- Name_uEquality : constant Name_Id := N + 035;
- Name_uDeep_Finalize : constant Name_Id := N + 036;
- Name_uDeep_Initialize : constant Name_Id := N + 037;
- Name_uInput : constant Name_Id := N + 038;
- Name_uOutput : constant Name_Id := N + 039;
- Name_uRAS_Access : constant Name_Id := N + 040;
- Name_uRAS_Dereference : constant Name_Id := N + 041;
- Name_uRead : constant Name_Id := N + 042;
- Name_uRep_To_Pos : constant Name_Id := N + 043;
- Name_uWrite : constant Name_Id := N + 044;
+ Name_Next : constant Name_Id := N + 031;
+ Name_Prev : constant Name_Id := N + 032;
-- Names of allocation routines, also needed by expander
- Name_Allocate : constant Name_Id := N + 045;
- Name_Deallocate : constant Name_Id := N + 046;
- Name_Dereference : constant Name_Id := N + 047;
+ Name_Allocate : constant Name_Id := N + 033;
+ Name_Deallocate : constant Name_Id := N + 034;
+ Name_Dereference : constant Name_Id := N + 035;
-- Names of Text_IO generic subpackages (see Rtsfind.Text_IO_Kludge)
- First_Text_IO_Package : constant Name_Id := N + 048;
- Name_Decimal_IO : constant Name_Id := N + 048;
- Name_Enumeration_IO : constant Name_Id := N + 049;
- Name_Fixed_IO : constant Name_Id := N + 050;
- Name_Float_IO : constant Name_Id := N + 051;
- Name_Integer_IO : constant Name_Id := N + 052;
- Name_Modular_IO : constant Name_Id := N + 053;
- Last_Text_IO_Package : constant Name_Id := N + 053;
+ First_Text_IO_Package : constant Name_Id := N + 036;
+ Name_Decimal_IO : constant Name_Id := N + 036;
+ Name_Enumeration_IO : constant Name_Id := N + 037;
+ Name_Fixed_IO : constant Name_Id := N + 038;
+ Name_Float_IO : constant Name_Id := N + 039;
+ Name_Integer_IO : constant Name_Id := N + 040;
+ Name_Modular_IO : constant Name_Id := N + 041;
+ Last_Text_IO_Package : constant Name_Id := N + 041;
subtype Text_IO_Package_Name is Name_Id
range First_Text_IO_Package .. Last_Text_IO_Package;
-- Names of files in library for Ada.Text_IO and Ada.Wide_Text_IO
- Name_a_textio : constant Name_Id := N + 054;
- Name_a_witeio : constant Name_Id := N + 055;
+ Name_a_textio : constant Name_Id := N + 042;
+ Name_a_witeio : constant Name_Id := N + 043;
-- Some miscellaneous names used for error detection/recovery
- Name_Const : constant Name_Id := N + 056;
- Name_Error : constant Name_Id := N + 057;
- Name_Go : constant Name_Id := N + 058;
- Name_Put : constant Name_Id := N + 059;
- Name_Put_Line : constant Name_Id := N + 060;
- Name_To : constant Name_Id := N + 061;
+ Name_Const : constant Name_Id := N + 044;
+ Name_Error : constant Name_Id := N + 045;
+ Name_Go : constant Name_Id := N + 046;
+ Name_Put : constant Name_Id := N + 047;
+ Name_Put_Line : constant Name_Id := N + 048;
+ Name_To : constant Name_Id := N + 049;
-- Names for packages that are treated specially by the compiler
- Name_Finalization : constant Name_Id := N + 062;
- Name_Finalization_Root : constant Name_Id := N + 063;
- Name_Interfaces : constant Name_Id := N + 064;
- Name_Standard : constant Name_Id := N + 065;
- Name_System : constant Name_Id := N + 066;
- Name_Text_IO : constant Name_Id := N + 067;
- Name_Wide_Text_IO : constant Name_Id := N + 068;
+ Name_Finalization : constant Name_Id := N + 050;
+ Name_Finalization_Root : constant Name_Id := N + 051;
+ Name_Interfaces : constant Name_Id := N + 052;
+ Name_Standard : constant Name_Id := N + 053;
+ Name_System : constant Name_Id := N + 054;
+ Name_Text_IO : constant Name_Id := N + 055;
+ Name_Wide_Text_IO : constant Name_Id := N + 056;
-- Names of identifiers used in expanding distribution stubs
- Name_Addr : constant Name_Id := N + 069;
- Name_Async : constant Name_Id := N + 070;
- Name_Get_Active_Partition_ID : constant Name_Id := N + 071;
- Name_Get_RCI_Package_Receiver : constant Name_Id := N + 072;
- Name_Origin : constant Name_Id := N + 073;
- Name_Params : constant Name_Id := N + 074;
- Name_Partition : constant Name_Id := N + 075;
- Name_Partition_Interface : constant Name_Id := N + 076;
- Name_Ras : constant Name_Id := N + 077;
- Name_RCI_Name : constant Name_Id := N + 078;
- Name_Receiver : constant Name_Id := N + 079;
- Name_Result : constant Name_Id := N + 080;
- Name_Rpc : constant Name_Id := N + 081;
- Name_Subp_Id : constant Name_Id := N + 082;
+ Name_Addr : constant Name_Id := N + 057;
+ Name_Async : constant Name_Id := N + 058;
+ Name_Get_Active_Partition_ID : constant Name_Id := N + 059;
+ Name_Get_RCI_Package_Receiver : constant Name_Id := N + 060;
+ Name_Origin : constant Name_Id := N + 061;
+ Name_Params : constant Name_Id := N + 062;
+ Name_Partition : constant Name_Id := N + 063;
+ Name_Partition_Interface : constant Name_Id := N + 064;
+ Name_Ras : constant Name_Id := N + 065;
+ Name_RCI_Name : constant Name_Id := N + 066;
+ Name_Receiver : constant Name_Id := N + 067;
+ Name_Result : constant Name_Id := N + 068;
+ Name_Rpc : constant Name_Id := N + 069;
+ Name_Subp_Id : constant Name_Id := N + 070;
-- Operator Symbol entries. The actual names have an upper case O at
-- the start in place of the Op_ prefix (e.g. the actual name that
-- corresponds to Name_Op_Abs is "Oabs".
- First_Operator_Name : constant Name_Id := N + 083;
- Name_Op_Abs : constant Name_Id := N + 083; -- "abs"
- Name_Op_And : constant Name_Id := N + 084; -- "and"
- Name_Op_Mod : constant Name_Id := N + 085; -- "mod"
- Name_Op_Not : constant Name_Id := N + 086; -- "not"
- Name_Op_Or : constant Name_Id := N + 087; -- "or"
- Name_Op_Rem : constant Name_Id := N + 088; -- "rem"
- Name_Op_Xor : constant Name_Id := N + 089; -- "xor"
- Name_Op_Eq : constant Name_Id := N + 090; -- "="
- Name_Op_Ne : constant Name_Id := N + 091; -- "/="
- Name_Op_Lt : constant Name_Id := N + 092; -- "<"
- Name_Op_Le : constant Name_Id := N + 093; -- "<="
- Name_Op_Gt : constant Name_Id := N + 094; -- ">"
- Name_Op_Ge : constant Name_Id := N + 095; -- ">="
- Name_Op_Add : constant Name_Id := N + 096; -- "+"
- Name_Op_Subtract : constant Name_Id := N + 097; -- "-"
- Name_Op_Concat : constant Name_Id := N + 098; -- "&"
- Name_Op_Multiply : constant Name_Id := N + 099; -- "*"
- Name_Op_Divide : constant Name_Id := N + 100; -- "/"
- Name_Op_Expon : constant Name_Id := N + 101; -- "**"
- Last_Operator_Name : constant Name_Id := N + 101;
+ First_Operator_Name : constant Name_Id := N + 071;
+ Name_Op_Abs : constant Name_Id := N + 071; -- "abs"
+ Name_Op_And : constant Name_Id := N + 072; -- "and"
+ Name_Op_Mod : constant Name_Id := N + 073; -- "mod"
+ Name_Op_Not : constant Name_Id := N + 074; -- "not"
+ Name_Op_Or : constant Name_Id := N + 075; -- "or"
+ Name_Op_Rem : constant Name_Id := N + 076; -- "rem"
+ Name_Op_Xor : constant Name_Id := N + 077; -- "xor"
+ Name_Op_Eq : constant Name_Id := N + 078; -- "="
+ Name_Op_Ne : constant Name_Id := N + 079; -- "/="
+ Name_Op_Lt : constant Name_Id := N + 080; -- "<"
+ Name_Op_Le : constant Name_Id := N + 081; -- "<="
+ Name_Op_Gt : constant Name_Id := N + 082; -- ">"
+ Name_Op_Ge : constant Name_Id := N + 083; -- ">="
+ Name_Op_Add : constant Name_Id := N + 084; -- "+"
+ Name_Op_Subtract : constant Name_Id := N + 085; -- "-"
+ Name_Op_Concat : constant Name_Id := N + 086; -- "&"
+ Name_Op_Multiply : constant Name_Id := N + 087; -- "*"
+ Name_Op_Divide : constant Name_Id := N + 088; -- "/"
+ Name_Op_Expon : constant Name_Id := N + 089; -- "**"
+ Last_Operator_Name : constant Name_Id := N + 089;
-- Names for all pragmas recognized by GNAT. The entries with the comment
-- "Ada 83" are pragmas that are defined in Ada 83, but not in Ada 95.
@@ -302,50 +286,59 @@ package Snames is
-- only in GNAT for the AAMP. They are ignored in other versions with
-- appropriate warnings.
- First_Pragma_Name : constant Name_Id := N + 102;
+ First_Pragma_Name : constant Name_Id := N + 090;
-- Configuration pragmas are grouped at start
- Name_Ada_83 : constant Name_Id := N + 102; -- GNAT
- Name_Ada_95 : constant Name_Id := N + 103; -- GNAT
- Name_C_Pass_By_Copy : constant Name_Id := N + 104; -- GNAT
- Name_Component_Alignment : constant Name_Id := N + 105; -- GNAT
- Name_Convention_Identifier : constant Name_Id := N + 106; -- GNAT
- Name_Discard_Names : constant Name_Id := N + 107;
- Name_Elaboration_Checks : constant Name_Id := N + 108; -- GNAT
- Name_Eliminate : constant Name_Id := N + 109; -- GNAT
- Name_Extend_System : constant Name_Id := N + 110; -- GNAT
- Name_Extensions_Allowed : constant Name_Id := N + 111; -- GNAT
- Name_External_Name_Casing : constant Name_Id := N + 112; -- GNAT
- Name_Float_Representation : constant Name_Id := N + 113; -- GNAT
- Name_Initialize_Scalars : constant Name_Id := N + 114; -- GNAT
- Name_License : constant Name_Id := N + 115; -- GNAT
- Name_Locking_Policy : constant Name_Id := N + 116;
- Name_Long_Float : constant Name_Id := N + 117; -- VMS
- Name_No_Run_Time : constant Name_Id := N + 118; -- GNAT
- Name_Normalize_Scalars : constant Name_Id := N + 119;
- Name_Polling : constant Name_Id := N + 120; -- GNAT
- Name_Propagate_Exceptions : constant Name_Id := N + 121; -- GNAT
- Name_Queuing_Policy : constant Name_Id := N + 122;
- Name_Ravenscar : constant Name_Id := N + 123;
- Name_Restricted_Run_Time : constant Name_Id := N + 124;
- Name_Restrictions : constant Name_Id := N + 125;
- Name_Reviewable : constant Name_Id := N + 126;
- Name_Source_File_Name : constant Name_Id := N + 127; -- GNAT
- Name_Style_Checks : constant Name_Id := N + 128; -- GNAT
- Name_Suppress : constant Name_Id := N + 129;
- Name_Task_Dispatching_Policy : constant Name_Id := N + 130;
- Name_Unsuppress : constant Name_Id := N + 131; -- GNAT
- Name_Use_VADS_Size : constant Name_Id := N + 132; -- GNAT
- Name_Warnings : constant Name_Id := N + 133; -- GNAT
- Name_Validity_Checks : constant Name_Id := N + 134; -- GNAT
- Last_Configuration_Pragma_Name : constant Name_Id := N + 134;
+ Name_Ada_83 : constant Name_Id := N + 090; -- GNAT
+ Name_Ada_95 : constant Name_Id := N + 091; -- GNAT
+ Name_C_Pass_By_Copy : constant Name_Id := N + 092; -- GNAT
+ Name_Compile_Time_Warning : constant Name_Id := N + 093; -- GNAT
+ Name_Component_Alignment : constant Name_Id := N + 094; -- GNAT
+ Name_Convention_Identifier : constant Name_Id := N + 095; -- GNAT
+ Name_Discard_Names : constant Name_Id := N + 096;
+ Name_Elaboration_Checks : constant Name_Id := N + 097; -- GNAT
+ Name_Eliminate : constant Name_Id := N + 098; -- GNAT
+ Name_Explicit_Overriding : constant Name_Id := N + 099;
+ Name_Extend_System : constant Name_Id := N + 100; -- GNAT
+ Name_Extensions_Allowed : constant Name_Id := N + 101; -- GNAT
+ Name_External_Name_Casing : constant Name_Id := N + 102; -- GNAT
+ Name_Float_Representation : constant Name_Id := N + 103; -- GNAT
+ Name_Initialize_Scalars : constant Name_Id := N + 104; -- GNAT
+ Name_Interrupt_State : constant Name_Id := N + 105; -- GNAT
+ Name_License : constant Name_Id := N + 106; -- GNAT
+ Name_Locking_Policy : constant Name_Id := N + 107;
+ Name_Long_Float : constant Name_Id := N + 108; -- VMS
+ Name_No_Run_Time : constant Name_Id := N + 109; -- GNAT
+ Name_Normalize_Scalars : constant Name_Id := N + 110;
+ Name_Polling : constant Name_Id := N + 111; -- GNAT
+ Name_Persistent_Data : constant Name_Id := N + 112; -- GNAT
+ Name_Persistent_Object : constant Name_Id := N + 113; -- GNAT
+ Name_Propagate_Exceptions : constant Name_Id := N + 114; -- GNAT
+ Name_Queuing_Policy : constant Name_Id := N + 115;
+ Name_Ravenscar : constant Name_Id := N + 116;
+ Name_Restricted_Run_Time : constant Name_Id := N + 117;
+ Name_Restrictions : constant Name_Id := N + 118;
+ Name_Restriction_Warnings : constant Name_Id := N + 119; -- GNAT
+ Name_Reviewable : constant Name_Id := N + 120;
+ Name_Source_File_Name : constant Name_Id := N + 121; -- GNAT
+ Name_Source_File_Name_Project : constant Name_Id := N + 122; -- GNAT
+ Name_Style_Checks : constant Name_Id := N + 123; -- GNAT
+ Name_Suppress : constant Name_Id := N + 124;
+ Name_Suppress_Exception_Locations : constant Name_Id := N + 125; -- GNAT
+ Name_Task_Dispatching_Policy : constant Name_Id := N + 126;
+ Name_Universal_Data : constant Name_Id := N + 127; -- AAMP
+ Name_Unsuppress : constant Name_Id := N + 128; -- GNAT
+ Name_Use_VADS_Size : constant Name_Id := N + 129; -- GNAT
+ Name_Validity_Checks : constant Name_Id := N + 130; -- GNAT
+ Name_Warnings : constant Name_Id := N + 131; -- GNAT
+ Last_Configuration_Pragma_Name : constant Name_Id := N + 131;
-- Remaining pragma names
- Name_Abort_Defer : constant Name_Id := N + 135; -- GNAT
- Name_All_Calls_Remote : constant Name_Id := N + 136;
- Name_Annotate : constant Name_Id := N + 137; -- GNAT
+ Name_Abort_Defer : constant Name_Id := N + 132; -- GNAT
+ Name_All_Calls_Remote : constant Name_Id := N + 133;
+ Name_Annotate : constant Name_Id := N + 134; -- GNAT
-- Note: AST_Entry is not in this list because its name matches the
-- name of the corresponding attribute. However, it is included in the
@@ -353,73 +346,78 @@ package Snames is
-- and Check_Pragma_Id correctly recognize and process Name_AST_Entry.
-- AST_Entry is a VMS specific pragma.
- Name_Assert : constant Name_Id := N + 138; -- GNAT
- Name_Asynchronous : constant Name_Id := N + 139;
- Name_Atomic : constant Name_Id := N + 140;
- Name_Atomic_Components : constant Name_Id := N + 141;
- Name_Attach_Handler : constant Name_Id := N + 142;
- Name_Comment : constant Name_Id := N + 143; -- GNAT
- Name_Common_Object : constant Name_Id := N + 144; -- GNAT
- Name_Complex_Representation : constant Name_Id := N + 145; -- GNAT
- Name_Controlled : constant Name_Id := N + 146;
- Name_Convention : constant Name_Id := N + 147;
- Name_CPP_Class : constant Name_Id := N + 148; -- GNAT
- Name_CPP_Constructor : constant Name_Id := N + 149; -- GNAT
- Name_CPP_Virtual : constant Name_Id := N + 150; -- GNAT
- Name_CPP_Vtable : constant Name_Id := N + 151; -- GNAT
- Name_Debug : constant Name_Id := N + 152; -- GNAT
- Name_Elaborate : constant Name_Id := N + 153; -- Ada 83
- Name_Elaborate_All : constant Name_Id := N + 154;
- Name_Elaborate_Body : constant Name_Id := N + 155;
- Name_Export : constant Name_Id := N + 156;
- Name_Export_Exception : constant Name_Id := N + 157; -- VMS
- Name_Export_Function : constant Name_Id := N + 158; -- GNAT
- Name_Export_Object : constant Name_Id := N + 159; -- GNAT
- Name_Export_Procedure : constant Name_Id := N + 160; -- GNAT
- Name_Export_Valued_Procedure : constant Name_Id := N + 161; -- GNAT
- Name_External : constant Name_Id := N + 162; -- GNAT
- Name_Finalize_Storage_Only : constant Name_Id := N + 163; -- GNAT
- Name_Ident : constant Name_Id := N + 164; -- VMS
- Name_Import : constant Name_Id := N + 165;
- Name_Import_Exception : constant Name_Id := N + 166; -- VMS
- Name_Import_Function : constant Name_Id := N + 167; -- GNAT
- Name_Import_Object : constant Name_Id := N + 168; -- GNAT
- Name_Import_Procedure : constant Name_Id := N + 169; -- GNAT
- Name_Import_Valued_Procedure : constant Name_Id := N + 170; -- GNAT
- Name_Inline : constant Name_Id := N + 171;
- Name_Inline_Always : constant Name_Id := N + 172; -- GNAT
- Name_Inline_Generic : constant Name_Id := N + 173; -- GNAT
- Name_Inspection_Point : constant Name_Id := N + 174;
- Name_Interface : constant Name_Id := N + 175; -- Ada 83
- Name_Interface_Name : constant Name_Id := N + 176; -- GNAT
- Name_Interrupt_Handler : constant Name_Id := N + 177;
- Name_Interrupt_Priority : constant Name_Id := N + 178;
- Name_Java_Constructor : constant Name_Id := N + 179; -- GNAT
- Name_Java_Interface : constant Name_Id := N + 180; -- GNAT
- Name_Link_With : constant Name_Id := N + 181; -- GNAT
- Name_Linker_Alias : constant Name_Id := N + 182; -- GNAT
- Name_Linker_Options : constant Name_Id := N + 183;
- Name_Linker_Section : constant Name_Id := N + 184; -- GNAT
- Name_List : constant Name_Id := N + 185;
- Name_Machine_Attribute : constant Name_Id := N + 186; -- GNAT
- Name_Main : constant Name_Id := N + 187; -- GNAT
- Name_Main_Storage : constant Name_Id := N + 188; -- GNAT
- Name_Memory_Size : constant Name_Id := N + 189; -- Ada 83
- Name_No_Return : constant Name_Id := N + 190; -- GNAT
+ Name_Assert : constant Name_Id := N + 135; -- GNAT
+ Name_Asynchronous : constant Name_Id := N + 136;
+ Name_Atomic : constant Name_Id := N + 137;
+ Name_Atomic_Components : constant Name_Id := N + 138;
+ Name_Attach_Handler : constant Name_Id := N + 139;
+ Name_Comment : constant Name_Id := N + 140; -- GNAT
+ Name_Common_Object : constant Name_Id := N + 141; -- GNAT
+ Name_Complex_Representation : constant Name_Id := N + 142; -- GNAT
+ Name_Controlled : constant Name_Id := N + 143;
+ Name_Convention : constant Name_Id := N + 144;
+ Name_CPP_Class : constant Name_Id := N + 145; -- GNAT
+ Name_CPP_Constructor : constant Name_Id := N + 146; -- GNAT
+ Name_CPP_Virtual : constant Name_Id := N + 147; -- GNAT
+ Name_CPP_Vtable : constant Name_Id := N + 148; -- GNAT
+ Name_Debug : constant Name_Id := N + 149; -- GNAT
+ Name_Elaborate : constant Name_Id := N + 150; -- Ada 83
+ Name_Elaborate_All : constant Name_Id := N + 151;
+ Name_Elaborate_Body : constant Name_Id := N + 152;
+ Name_Export : constant Name_Id := N + 153;
+ Name_Export_Exception : constant Name_Id := N + 154; -- VMS
+ Name_Export_Function : constant Name_Id := N + 155; -- GNAT
+ Name_Export_Object : constant Name_Id := N + 156; -- GNAT
+ Name_Export_Procedure : constant Name_Id := N + 157; -- GNAT
+ Name_Export_Value : constant Name_Id := N + 158; -- GNAT
+ Name_Export_Valued_Procedure : constant Name_Id := N + 159; -- GNAT
+ Name_External : constant Name_Id := N + 160; -- GNAT
+ Name_Finalize_Storage_Only : constant Name_Id := N + 161; -- GNAT
+ Name_Ident : constant Name_Id := N + 162; -- VMS
+ Name_Import : constant Name_Id := N + 163;
+ Name_Import_Exception : constant Name_Id := N + 164; -- VMS
+ Name_Import_Function : constant Name_Id := N + 165; -- GNAT
+ Name_Import_Object : constant Name_Id := N + 166; -- GNAT
+ Name_Import_Procedure : constant Name_Id := N + 167; -- GNAT
+ Name_Import_Valued_Procedure : constant Name_Id := N + 168; -- GNAT
+ Name_Inline : constant Name_Id := N + 169;
+ Name_Inline_Always : constant Name_Id := N + 170; -- GNAT
+ Name_Inline_Generic : constant Name_Id := N + 171; -- GNAT
+ Name_Inspection_Point : constant Name_Id := N + 172;
+ Name_Interface : constant Name_Id := N + 173; -- Ada 83
+ Name_Interface_Name : constant Name_Id := N + 174; -- GNAT
+ Name_Interrupt_Handler : constant Name_Id := N + 175;
+ Name_Interrupt_Priority : constant Name_Id := N + 176;
+ Name_Java_Constructor : constant Name_Id := N + 177; -- GNAT
+ Name_Java_Interface : constant Name_Id := N + 178; -- GNAT
+ Name_Keep_Names : constant Name_Id := N + 179; -- GNAT
+ Name_Link_With : constant Name_Id := N + 180; -- GNAT
+ Name_Linker_Alias : constant Name_Id := N + 181; -- GNAT
+ Name_Linker_Options : constant Name_Id := N + 182;
+ Name_Linker_Section : constant Name_Id := N + 183; -- GNAT
+ Name_List : constant Name_Id := N + 184;
+ Name_Machine_Attribute : constant Name_Id := N + 185; -- GNAT
+ Name_Main : constant Name_Id := N + 186; -- GNAT
+ Name_Main_Storage : constant Name_Id := N + 187; -- GNAT
+ Name_Memory_Size : constant Name_Id := N + 188; -- Ada 83
+ Name_No_Return : constant Name_Id := N + 189; -- GNAT
+ Name_Obsolescent : constant Name_Id := N + 190; -- GNAT
Name_Optimize : constant Name_Id := N + 191;
- Name_Pack : constant Name_Id := N + 192;
- Name_Page : constant Name_Id := N + 193;
- Name_Passive : constant Name_Id := N + 194; -- GNAT
- Name_Preelaborate : constant Name_Id := N + 195;
- Name_Priority : constant Name_Id := N + 196;
- Name_Psect_Object : constant Name_Id := N + 197; -- VMS
- Name_Pure : constant Name_Id := N + 198;
- Name_Pure_Function : constant Name_Id := N + 199; -- GNAT
- Name_Remote_Call_Interface : constant Name_Id := N + 200;
- Name_Remote_Types : constant Name_Id := N + 201;
- Name_Share_Generic : constant Name_Id := N + 202; -- GNAT
- Name_Shared : constant Name_Id := N + 203; -- Ada 83
- Name_Shared_Passive : constant Name_Id := N + 204;
+ Name_Optional_Overriding : constant Name_Id := N + 192;
+ Name_Overriding : constant Name_Id := N + 193;
+ Name_Pack : constant Name_Id := N + 194;
+ Name_Page : constant Name_Id := N + 195;
+ Name_Passive : constant Name_Id := N + 196; -- GNAT
+ Name_Preelaborate : constant Name_Id := N + 197;
+ Name_Priority : constant Name_Id := N + 198;
+ Name_Psect_Object : constant Name_Id := N + 199; -- VMS
+ Name_Pure : constant Name_Id := N + 200;
+ Name_Pure_Function : constant Name_Id := N + 201; -- GNAT
+ Name_Remote_Call_Interface : constant Name_Id := N + 202;
+ Name_Remote_Types : constant Name_Id := N + 203;
+ Name_Share_Generic : constant Name_Id := N + 204; -- GNAT
+ Name_Shared : constant Name_Id := N + 205; -- Ada 83
+ Name_Shared_Passive : constant Name_Id := N + 206;
-- Note: Storage_Size is not in this list because its name matches the
-- name of the corresponding attribute. However, it is included in the
@@ -429,27 +427,26 @@ package Snames is
-- Note: Storage_Unit is also omitted from the list because of a clash
-- with an attribute name, and is treated similarly.
- Name_Source_Reference : constant Name_Id := N + 205; -- GNAT
- Name_Stream_Convert : constant Name_Id := N + 206; -- GNAT
- Name_Subtitle : constant Name_Id := N + 207; -- GNAT
- Name_Suppress_All : constant Name_Id := N + 208; -- GNAT
- Name_Suppress_Debug_Info : constant Name_Id := N + 209; -- GNAT
- Name_Suppress_Initialization : constant Name_Id := N + 210; -- GNAT
- Name_System_Name : constant Name_Id := N + 211; -- Ada 83
- Name_Task_Info : constant Name_Id := N + 212; -- GNAT
- Name_Task_Name : constant Name_Id := N + 213; -- GNAT
- Name_Task_Storage : constant Name_Id := N + 214; -- VMS
- Name_Time_Slice : constant Name_Id := N + 215; -- GNAT
- Name_Title : constant Name_Id := N + 216; -- GNAT
- Name_Unchecked_Union : constant Name_Id := N + 217; -- GNAT
- Name_Unimplemented_Unit : constant Name_Id := N + 218; -- GNAT
- Name_Universal_Data : constant Name_Id := N + 219; -- AAMP
- Name_Unreferenced : constant Name_Id := N + 220; -- GNAT
- Name_Unreserve_All_Interrupts : constant Name_Id := N + 221; -- GNAT
- Name_Volatile : constant Name_Id := N + 222;
- Name_Volatile_Components : constant Name_Id := N + 223;
- Name_Weak_External : constant Name_Id := N + 224; -- GNAT
- Last_Pragma_Name : constant Name_Id := N + 224;
+ Name_Source_Reference : constant Name_Id := N + 207; -- GNAT
+ Name_Stream_Convert : constant Name_Id := N + 208; -- GNAT
+ Name_Subtitle : constant Name_Id := N + 209; -- GNAT
+ Name_Suppress_All : constant Name_Id := N + 210; -- GNAT
+ Name_Suppress_Debug_Info : constant Name_Id := N + 211; -- GNAT
+ Name_Suppress_Initialization : constant Name_Id := N + 212; -- GNAT
+ Name_System_Name : constant Name_Id := N + 213; -- Ada 83
+ Name_Task_Info : constant Name_Id := N + 214; -- GNAT
+ Name_Task_Name : constant Name_Id := N + 215; -- GNAT
+ Name_Task_Storage : constant Name_Id := N + 216; -- VMS
+ Name_Time_Slice : constant Name_Id := N + 217; -- GNAT
+ Name_Title : constant Name_Id := N + 218; -- GNAT
+ Name_Unchecked_Union : constant Name_Id := N + 219; -- GNAT
+ Name_Unimplemented_Unit : constant Name_Id := N + 220; -- GNAT
+ Name_Unreferenced : constant Name_Id := N + 221; -- GNAT
+ Name_Unreserve_All_Interrupts : constant Name_Id := N + 222; -- GNAT
+ Name_Volatile : constant Name_Id := N + 223;
+ Name_Volatile_Components : constant Name_Id := N + 224;
+ Name_Weak_External : constant Name_Id := N + 225; -- GNAT
+ Last_Pragma_Name : constant Name_Id := N + 225;
-- Language convention names for pragma Convention/Export/Import/Interface
-- Note that Name_C is not included in this list, since it was already
@@ -460,93 +457,95 @@ package Snames is
-- Entry and Protected, this is because these conventions cannot be
-- specified by a pragma.
- First_Convention_Name : constant Name_Id := N + 225;
- Name_Ada : constant Name_Id := N + 225;
- Name_Assembler : constant Name_Id := N + 226;
- Name_COBOL : constant Name_Id := N + 227;
- Name_CPP : constant Name_Id := N + 228;
- Name_Fortran : constant Name_Id := N + 229;
- Name_Intrinsic : constant Name_Id := N + 230;
- Name_Java : constant Name_Id := N + 231;
- Name_Stdcall : constant Name_Id := N + 232;
- Name_Stubbed : constant Name_Id := N + 233;
- Last_Convention_Name : constant Name_Id := N + 233;
+ First_Convention_Name : constant Name_Id := N + 226;
+ Name_Ada : constant Name_Id := N + 226;
+ Name_Assembler : constant Name_Id := N + 227;
+ Name_COBOL : constant Name_Id := N + 228;
+ Name_CPP : constant Name_Id := N + 229;
+ Name_Fortran : constant Name_Id := N + 230;
+ Name_Intrinsic : constant Name_Id := N + 231;
+ Name_Java : constant Name_Id := N + 232;
+ Name_Stdcall : constant Name_Id := N + 233;
+ Name_Stubbed : constant Name_Id := N + 234;
+ Last_Convention_Name : constant Name_Id := N + 234;
-- The following names are preset as synonyms for Assembler
- Name_Asm : constant Name_Id := N + 234;
- Name_Assembly : constant Name_Id := N + 235;
+ Name_Asm : constant Name_Id := N + 235;
+ Name_Assembly : constant Name_Id := N + 236;
-- The following names are preset as synonyms for C
- Name_Default : constant Name_Id := N + 236;
+ Name_Default : constant Name_Id := N + 237;
-- Name_Exernal (previously defined as pragma)
-- The following names are present as synonyms for Stdcall
- Name_DLL : constant Name_Id := N + 237;
- Name_Win32 : constant Name_Id := N + 238;
+ Name_DLL : constant Name_Id := N + 238;
+ Name_Win32 : constant Name_Id := N + 239;
-- Other special names used in processing pragma arguments
- Name_As_Is : constant Name_Id := N + 239;
- Name_Body_File_Name : constant Name_Id := N + 240;
- Name_Casing : constant Name_Id := N + 241;
- Name_Code : constant Name_Id := N + 242;
- Name_Component : constant Name_Id := N + 243;
- Name_Component_Size_4 : constant Name_Id := N + 244;
- Name_Copy : constant Name_Id := N + 245;
- Name_D_Float : constant Name_Id := N + 246;
- Name_Descriptor : constant Name_Id := N + 247;
- Name_Dot_Replacement : constant Name_Id := N + 248;
- Name_Dynamic : constant Name_Id := N + 249;
- Name_Entity : constant Name_Id := N + 250;
- Name_External_Name : constant Name_Id := N + 251;
- Name_First_Optional_Parameter : constant Name_Id := N + 252;
- Name_Form : constant Name_Id := N + 253;
- Name_G_Float : constant Name_Id := N + 254;
- Name_Gcc : constant Name_Id := N + 255;
- Name_Gnat : constant Name_Id := N + 256;
- Name_GPL : constant Name_Id := N + 257;
- Name_IEEE_Float : constant Name_Id := N + 258;
- Name_Homonym_Number : constant Name_Id := N + 259;
- Name_Internal : constant Name_Id := N + 260;
- Name_Link_Name : constant Name_Id := N + 261;
- Name_Lowercase : constant Name_Id := N + 262;
- Name_Max_Size : constant Name_Id := N + 263;
- Name_Mechanism : constant Name_Id := N + 264;
- Name_Mixedcase : constant Name_Id := N + 265;
- Name_Modified_GPL : constant Name_Id := N + 266;
- Name_Name : constant Name_Id := N + 267;
- Name_NCA : constant Name_Id := N + 268;
- Name_No : constant Name_Id := N + 269;
- Name_On : constant Name_Id := N + 270;
- Name_Parameter_Types : constant Name_Id := N + 271;
- Name_Reference : constant Name_Id := N + 272;
- Name_Restricted : constant Name_Id := N + 273;
- Name_Result_Mechanism : constant Name_Id := N + 274;
- Name_Result_Type : constant Name_Id := N + 275;
- Name_SB : constant Name_Id := N + 276;
- Name_Section : constant Name_Id := N + 277;
- Name_Semaphore : constant Name_Id := N + 278;
- Name_Spec_File_Name : constant Name_Id := N + 279;
- Name_Static : constant Name_Id := N + 280;
- Name_Stack_Size : constant Name_Id := N + 281;
- Name_Subunit_File_Name : constant Name_Id := N + 282;
- Name_Task_Stack_Size_Default : constant Name_Id := N + 283;
- Name_Task_Type : constant Name_Id := N + 284;
- Name_Time_Slicing_Enabled : constant Name_Id := N + 285;
- Name_Top_Guard : constant Name_Id := N + 286;
- Name_UBA : constant Name_Id := N + 287;
- Name_UBS : constant Name_Id := N + 288;
- Name_UBSB : constant Name_Id := N + 289;
- Name_Unit_Name : constant Name_Id := N + 290;
- Name_Unknown : constant Name_Id := N + 291;
- Name_Unrestricted : constant Name_Id := N + 292;
- Name_Uppercase : constant Name_Id := N + 293;
- Name_VAX_Float : constant Name_Id := N + 294;
- Name_VMS : constant Name_Id := N + 295;
- Name_Working_Storage : constant Name_Id := N + 296;
+ Name_As_Is : constant Name_Id := N + 240;
+ Name_Body_File_Name : constant Name_Id := N + 241;
+ Name_Casing : constant Name_Id := N + 242;
+ Name_Code : constant Name_Id := N + 243;
+ Name_Component : constant Name_Id := N + 244;
+ Name_Component_Size_4 : constant Name_Id := N + 245;
+ Name_Copy : constant Name_Id := N + 246;
+ Name_D_Float : constant Name_Id := N + 247;
+ Name_Descriptor : constant Name_Id := N + 248;
+ Name_Dot_Replacement : constant Name_Id := N + 249;
+ Name_Dynamic : constant Name_Id := N + 250;
+ Name_Entity : constant Name_Id := N + 251;
+ Name_External_Name : constant Name_Id := N + 252;
+ Name_First_Optional_Parameter : constant Name_Id := N + 253;
+ Name_Form : constant Name_Id := N + 254;
+ Name_G_Float : constant Name_Id := N + 255;
+ Name_Gcc : constant Name_Id := N + 256;
+ Name_Gnat : constant Name_Id := N + 257;
+ Name_GPL : constant Name_Id := N + 258;
+ Name_IEEE_Float : constant Name_Id := N + 259;
+ Name_Homonym_Number : constant Name_Id := N + 260;
+ Name_Internal : constant Name_Id := N + 261;
+ Name_Link_Name : constant Name_Id := N + 262;
+ Name_Lowercase : constant Name_Id := N + 263;
+ Name_Max_Size : constant Name_Id := N + 264;
+ Name_Mechanism : constant Name_Id := N + 265;
+ Name_Mixedcase : constant Name_Id := N + 266;
+ Name_Modified_GPL : constant Name_Id := N + 267;
+ Name_Name : constant Name_Id := N + 268;
+ Name_NCA : constant Name_Id := N + 269;
+ Name_No : constant Name_Id := N + 270;
+ Name_On : constant Name_Id := N + 271;
+ Name_Parameter_Types : constant Name_Id := N + 272;
+ Name_Reference : constant Name_Id := N + 273;
+ Name_Restricted : constant Name_Id := N + 274;
+ Name_Result_Mechanism : constant Name_Id := N + 275;
+ Name_Result_Type : constant Name_Id := N + 276;
+ Name_Runtime : constant Name_Id := N + 277;
+ Name_SB : constant Name_Id := N + 278;
+ Name_Section : constant Name_Id := N + 279;
+ Name_Semaphore : constant Name_Id := N + 280;
+ Name_Spec_File_Name : constant Name_Id := N + 281;
+ Name_Static : constant Name_Id := N + 282;
+ Name_Stack_Size : constant Name_Id := N + 283;
+ Name_Subunit_File_Name : constant Name_Id := N + 284;
+ Name_Task_Stack_Size_Default : constant Name_Id := N + 285;
+ Name_Task_Type : constant Name_Id := N + 286;
+ Name_Time_Slicing_Enabled : constant Name_Id := N + 287;
+ Name_Top_Guard : constant Name_Id := N + 288;
+ Name_UBA : constant Name_Id := N + 289;
+ Name_UBS : constant Name_Id := N + 290;
+ Name_UBSB : constant Name_Id := N + 291;
+ Name_Unit_Name : constant Name_Id := N + 292;
+ Name_Unknown : constant Name_Id := N + 293;
+ Name_Unrestricted : constant Name_Id := N + 294;
+ Name_Uppercase : constant Name_Id := N + 295;
+ Name_User : constant Name_Id := N + 296;
+ Name_VAX_Float : constant Name_Id := N + 297;
+ Name_VMS : constant Name_Id := N + 298;
+ Name_Working_Storage : constant Name_Id := N + 299;
-- Names of recognized attributes. The entries with the comment "Ada 83"
-- are attributes that are defined in Ada 83, but not in Ada 95. These
@@ -560,155 +559,158 @@ package Snames is
-- The entries marked VMS are recognized only in OpenVMS implementations
-- of GNAT, and are treated as illegal in all other contexts.
- First_Attribute_Name : constant Name_Id := N + 297;
- Name_Abort_Signal : constant Name_Id := N + 297; -- GNAT
- Name_Access : constant Name_Id := N + 298;
- Name_Address : constant Name_Id := N + 299;
- Name_Address_Size : constant Name_Id := N + 300; -- GNAT
- Name_Aft : constant Name_Id := N + 301;
- Name_Alignment : constant Name_Id := N + 302;
- Name_Asm_Input : constant Name_Id := N + 303; -- GNAT
- Name_Asm_Output : constant Name_Id := N + 304; -- GNAT
- Name_AST_Entry : constant Name_Id := N + 305; -- VMS
- Name_Bit : constant Name_Id := N + 306; -- GNAT
- Name_Bit_Order : constant Name_Id := N + 307;
- Name_Bit_Position : constant Name_Id := N + 308; -- GNAT
- Name_Body_Version : constant Name_Id := N + 309;
- Name_Callable : constant Name_Id := N + 310;
- Name_Caller : constant Name_Id := N + 311;
- Name_Code_Address : constant Name_Id := N + 312; -- GNAT
- Name_Component_Size : constant Name_Id := N + 313;
- Name_Compose : constant Name_Id := N + 314;
- Name_Constrained : constant Name_Id := N + 315;
- Name_Count : constant Name_Id := N + 316;
- Name_Default_Bit_Order : constant Name_Id := N + 317; -- GNAT
- Name_Definite : constant Name_Id := N + 318;
- Name_Delta : constant Name_Id := N + 319;
- Name_Denorm : constant Name_Id := N + 320;
- Name_Digits : constant Name_Id := N + 321;
- Name_Elaborated : constant Name_Id := N + 322; -- GNAT
- Name_Emax : constant Name_Id := N + 323; -- Ada 83
- Name_Enum_Rep : constant Name_Id := N + 324; -- GNAT
- Name_Epsilon : constant Name_Id := N + 325; -- Ada 83
- Name_Exponent : constant Name_Id := N + 326;
- Name_External_Tag : constant Name_Id := N + 327;
- Name_First : constant Name_Id := N + 328;
- Name_First_Bit : constant Name_Id := N + 329;
- Name_Fixed_Value : constant Name_Id := N + 330; -- GNAT
- Name_Fore : constant Name_Id := N + 331;
- Name_Has_Discriminants : constant Name_Id := N + 332; -- GNAT
- Name_Identity : constant Name_Id := N + 333;
- Name_Img : constant Name_Id := N + 334; -- GNAT
- Name_Integer_Value : constant Name_Id := N + 335; -- GNAT
- Name_Large : constant Name_Id := N + 336; -- Ada 83
- Name_Last : constant Name_Id := N + 337;
- Name_Last_Bit : constant Name_Id := N + 338;
- Name_Leading_Part : constant Name_Id := N + 339;
- Name_Length : constant Name_Id := N + 340;
- Name_Machine_Emax : constant Name_Id := N + 341;
- Name_Machine_Emin : constant Name_Id := N + 342;
- Name_Machine_Mantissa : constant Name_Id := N + 343;
- Name_Machine_Overflows : constant Name_Id := N + 344;
- Name_Machine_Radix : constant Name_Id := N + 345;
- Name_Machine_Rounds : constant Name_Id := N + 346;
- Name_Machine_Size : constant Name_Id := N + 347; -- GNAT
- Name_Mantissa : constant Name_Id := N + 348; -- Ada 83
- Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 349;
- Name_Maximum_Alignment : constant Name_Id := N + 350; -- GNAT
- Name_Mechanism_Code : constant Name_Id := N + 351; -- GNAT
- Name_Model_Emin : constant Name_Id := N + 352;
- Name_Model_Epsilon : constant Name_Id := N + 353;
- Name_Model_Mantissa : constant Name_Id := N + 354;
- Name_Model_Small : constant Name_Id := N + 355;
- Name_Modulus : constant Name_Id := N + 356;
- Name_Null_Parameter : constant Name_Id := N + 357; -- GNAT
- Name_Object_Size : constant Name_Id := N + 358; -- GNAT
- Name_Partition_ID : constant Name_Id := N + 359;
- Name_Passed_By_Reference : constant Name_Id := N + 360; -- GNAT
- Name_Pos : constant Name_Id := N + 361;
- Name_Position : constant Name_Id := N + 362;
- Name_Range : constant Name_Id := N + 363;
- Name_Range_Length : constant Name_Id := N + 364; -- GNAT
- Name_Round : constant Name_Id := N + 365;
- Name_Safe_Emax : constant Name_Id := N + 366; -- Ada 83
- Name_Safe_First : constant Name_Id := N + 367;
- Name_Safe_Large : constant Name_Id := N + 368; -- Ada 83
- Name_Safe_Last : constant Name_Id := N + 369;
- Name_Safe_Small : constant Name_Id := N + 370; -- Ada 83
- Name_Scale : constant Name_Id := N + 371;
- Name_Scaling : constant Name_Id := N + 372;
- Name_Signed_Zeros : constant Name_Id := N + 373;
- Name_Size : constant Name_Id := N + 374;
- Name_Small : constant Name_Id := N + 375;
- Name_Storage_Size : constant Name_Id := N + 376;
- Name_Storage_Unit : constant Name_Id := N + 377; -- GNAT
- Name_Tag : constant Name_Id := N + 378;
- Name_Terminated : constant Name_Id := N + 379;
- Name_To_Address : constant Name_Id := N + 380; -- GNAT
- Name_Type_Class : constant Name_Id := N + 381; -- GNAT
- Name_UET_Address : constant Name_Id := N + 382; -- GNAT
- Name_Unbiased_Rounding : constant Name_Id := N + 383;
- Name_Unchecked_Access : constant Name_Id := N + 384;
- Name_Universal_Literal_String : constant Name_Id := N + 385; -- GNAT
- Name_Unrestricted_Access : constant Name_Id := N + 386; -- GNAT
- Name_VADS_Size : constant Name_Id := N + 387; -- GNAT
- Name_Val : constant Name_Id := N + 388;
- Name_Valid : constant Name_Id := N + 389;
- Name_Value_Size : constant Name_Id := N + 390; -- GNAT
- Name_Version : constant Name_Id := N + 391;
- Name_Wchar_T_Size : constant Name_Id := N + 392; -- GNAT
- Name_Wide_Width : constant Name_Id := N + 393;
- Name_Width : constant Name_Id := N + 394;
- Name_Word_Size : constant Name_Id := N + 395; -- GNAT
+ First_Attribute_Name : constant Name_Id := N + 300;
+ Name_Abort_Signal : constant Name_Id := N + 300; -- GNAT
+ Name_Access : constant Name_Id := N + 301;
+ Name_Address : constant Name_Id := N + 302;
+ Name_Address_Size : constant Name_Id := N + 303; -- GNAT
+ Name_Aft : constant Name_Id := N + 304;
+ Name_Alignment : constant Name_Id := N + 305;
+ Name_Asm_Input : constant Name_Id := N + 306; -- GNAT
+ Name_Asm_Output : constant Name_Id := N + 307; -- GNAT
+ Name_AST_Entry : constant Name_Id := N + 308; -- VMS
+ Name_Bit : constant Name_Id := N + 309; -- GNAT
+ Name_Bit_Order : constant Name_Id := N + 310;
+ Name_Bit_Position : constant Name_Id := N + 311; -- GNAT
+ Name_Body_Version : constant Name_Id := N + 312;
+ Name_Callable : constant Name_Id := N + 313;
+ Name_Caller : constant Name_Id := N + 314;
+ Name_Code_Address : constant Name_Id := N + 315; -- GNAT
+ Name_Component_Size : constant Name_Id := N + 316;
+ Name_Compose : constant Name_Id := N + 317;
+ Name_Constrained : constant Name_Id := N + 318;
+ Name_Count : constant Name_Id := N + 319;
+ Name_Default_Bit_Order : constant Name_Id := N + 320; -- GNAT
+ Name_Definite : constant Name_Id := N + 321;
+ Name_Delta : constant Name_Id := N + 322;
+ Name_Denorm : constant Name_Id := N + 323;
+ Name_Digits : constant Name_Id := N + 324;
+ Name_Elaborated : constant Name_Id := N + 325; -- GNAT
+ Name_Emax : constant Name_Id := N + 326; -- Ada 83
+ Name_Enum_Rep : constant Name_Id := N + 327; -- GNAT
+ Name_Epsilon : constant Name_Id := N + 328; -- Ada 83
+ Name_Exponent : constant Name_Id := N + 329;
+ Name_External_Tag : constant Name_Id := N + 330;
+ Name_First : constant Name_Id := N + 331;
+ Name_First_Bit : constant Name_Id := N + 332;
+ Name_Fixed_Value : constant Name_Id := N + 333; -- GNAT
+ Name_Fore : constant Name_Id := N + 334;
+ Name_Has_Discriminants : constant Name_Id := N + 335; -- GNAT
+ Name_Identity : constant Name_Id := N + 336;
+ Name_Img : constant Name_Id := N + 337; -- GNAT
+ Name_Integer_Value : constant Name_Id := N + 338; -- GNAT
+ Name_Large : constant Name_Id := N + 339; -- Ada 83
+ Name_Last : constant Name_Id := N + 340;
+ Name_Last_Bit : constant Name_Id := N + 341;
+ Name_Leading_Part : constant Name_Id := N + 342;
+ Name_Length : constant Name_Id := N + 343;
+ Name_Machine_Emax : constant Name_Id := N + 344;
+ Name_Machine_Emin : constant Name_Id := N + 345;
+ Name_Machine_Mantissa : constant Name_Id := N + 346;
+ Name_Machine_Overflows : constant Name_Id := N + 347;
+ Name_Machine_Radix : constant Name_Id := N + 348;
+ Name_Machine_Rounds : constant Name_Id := N + 349;
+ Name_Machine_Size : constant Name_Id := N + 350; -- GNAT
+ Name_Mantissa : constant Name_Id := N + 351; -- Ada 83
+ Name_Max_Size_In_Storage_Elements : constant Name_Id := N + 352;
+ Name_Maximum_Alignment : constant Name_Id := N + 353; -- GNAT
+ Name_Mechanism_Code : constant Name_Id := N + 354; -- GNAT
+ Name_Model_Emin : constant Name_Id := N + 355;
+ Name_Model_Epsilon : constant Name_Id := N + 356;
+ Name_Model_Mantissa : constant Name_Id := N + 357;
+ Name_Model_Small : constant Name_Id := N + 358;
+ Name_Modulus : constant Name_Id := N + 359;
+ Name_Null_Parameter : constant Name_Id := N + 360; -- GNAT
+ Name_Object_Size : constant Name_Id := N + 361; -- GNAT
+ Name_Partition_ID : constant Name_Id := N + 362;
+ Name_Passed_By_Reference : constant Name_Id := N + 363; -- GNAT
+ Name_Pool_Address : constant Name_Id := N + 364;
+ Name_Pos : constant Name_Id := N + 365;
+ Name_Position : constant Name_Id := N + 366;
+ Name_Range : constant Name_Id := N + 367;
+ Name_Range_Length : constant Name_Id := N + 368; -- GNAT
+ Name_Round : constant Name_Id := N + 369;
+ Name_Safe_Emax : constant Name_Id := N + 370; -- Ada 83
+ Name_Safe_First : constant Name_Id := N + 371;
+ Name_Safe_Large : constant Name_Id := N + 372; -- Ada 83
+ Name_Safe_Last : constant Name_Id := N + 373;
+ Name_Safe_Small : constant Name_Id := N + 374; -- Ada 83
+ Name_Scale : constant Name_Id := N + 375;
+ Name_Scaling : constant Name_Id := N + 376;
+ Name_Signed_Zeros : constant Name_Id := N + 377;
+ Name_Size : constant Name_Id := N + 378;
+ Name_Small : constant Name_Id := N + 379;
+ Name_Storage_Size : constant Name_Id := N + 380;
+ Name_Storage_Unit : constant Name_Id := N + 381; -- GNAT
+ Name_Tag : constant Name_Id := N + 382;
+ Name_Target_Name : constant Name_Id := N + 383; -- GNAT
+ Name_Terminated : constant Name_Id := N + 384;
+ Name_To_Address : constant Name_Id := N + 385; -- GNAT
+ Name_Type_Class : constant Name_Id := N + 386; -- GNAT
+ Name_UET_Address : constant Name_Id := N + 387; -- GNAT
+ Name_Unbiased_Rounding : constant Name_Id := N + 388;
+ Name_Unchecked_Access : constant Name_Id := N + 389;
+ Name_Unconstrained_Array : constant Name_Id := N + 390;
+ Name_Universal_Literal_String : constant Name_Id := N + 391; -- GNAT
+ Name_Unrestricted_Access : constant Name_Id := N + 392; -- GNAT
+ Name_VADS_Size : constant Name_Id := N + 393; -- GNAT
+ Name_Val : constant Name_Id := N + 394;
+ Name_Valid : constant Name_Id := N + 395;
+ Name_Value_Size : constant Name_Id := N + 396; -- GNAT
+ Name_Version : constant Name_Id := N + 397;
+ Name_Wchar_T_Size : constant Name_Id := N + 398; -- GNAT
+ Name_Wide_Width : constant Name_Id := N + 399;
+ Name_Width : constant Name_Id := N + 400;
+ Name_Word_Size : constant Name_Id := N + 401; -- GNAT
-- Attributes that designate attributes returning renamable functions,
-- i.e. functions that return other than a universal value.
- First_Renamable_Function_Attribute : constant Name_Id := N + 396;
- Name_Adjacent : constant Name_Id := N + 396;
- Name_Ceiling : constant Name_Id := N + 397;
- Name_Copy_Sign : constant Name_Id := N + 398;
- Name_Floor : constant Name_Id := N + 399;
- Name_Fraction : constant Name_Id := N + 400;
- Name_Image : constant Name_Id := N + 401;
- Name_Input : constant Name_Id := N + 402;
- Name_Machine : constant Name_Id := N + 403;
- Name_Max : constant Name_Id := N + 404;
- Name_Min : constant Name_Id := N + 405;
- Name_Model : constant Name_Id := N + 406;
- Name_Pred : constant Name_Id := N + 407;
- Name_Remainder : constant Name_Id := N + 408;
- Name_Rounding : constant Name_Id := N + 409;
- Name_Succ : constant Name_Id := N + 410;
- Name_Truncation : constant Name_Id := N + 411;
- Name_Value : constant Name_Id := N + 412;
- Name_Wide_Image : constant Name_Id := N + 413;
- Name_Wide_Value : constant Name_Id := N + 414;
- Last_Renamable_Function_Attribute : constant Name_Id := N + 414;
+ First_Renamable_Function_Attribute : constant Name_Id := N + 402;
+ Name_Adjacent : constant Name_Id := N + 402;
+ Name_Ceiling : constant Name_Id := N + 403;
+ Name_Copy_Sign : constant Name_Id := N + 404;
+ Name_Floor : constant Name_Id := N + 405;
+ Name_Fraction : constant Name_Id := N + 406;
+ Name_Image : constant Name_Id := N + 407;
+ Name_Input : constant Name_Id := N + 408;
+ Name_Machine : constant Name_Id := N + 409;
+ Name_Max : constant Name_Id := N + 410;
+ Name_Min : constant Name_Id := N + 411;
+ Name_Model : constant Name_Id := N + 412;
+ Name_Pred : constant Name_Id := N + 413;
+ Name_Remainder : constant Name_Id := N + 414;
+ Name_Rounding : constant Name_Id := N + 415;
+ Name_Succ : constant Name_Id := N + 416;
+ Name_Truncation : constant Name_Id := N + 417;
+ Name_Value : constant Name_Id := N + 418;
+ Name_Wide_Image : constant Name_Id := N + 419;
+ Name_Wide_Value : constant Name_Id := N + 420;
+ Last_Renamable_Function_Attribute : constant Name_Id := N + 420;
-- Attributes that designate procedures
- First_Procedure_Attribute : constant Name_Id := N + 415;
- Name_Output : constant Name_Id := N + 415;
- Name_Read : constant Name_Id := N + 416;
- Name_Write : constant Name_Id := N + 417;
- Last_Procedure_Attribute : constant Name_Id := N + 417;
+ First_Procedure_Attribute : constant Name_Id := N + 421;
+ Name_Output : constant Name_Id := N + 421;
+ Name_Read : constant Name_Id := N + 422;
+ Name_Write : constant Name_Id := N + 423;
+ Last_Procedure_Attribute : constant Name_Id := N + 423;
-- Remaining attributes are ones that return entities
- First_Entity_Attribute_Name : constant Name_Id := N + 418;
- Name_Elab_Body : constant Name_Id := N + 418; -- GNAT
- Name_Elab_Spec : constant Name_Id := N + 419; -- GNAT
- Name_Storage_Pool : constant Name_Id := N + 420;
+ First_Entity_Attribute_Name : constant Name_Id := N + 424;
+ Name_Elab_Body : constant Name_Id := N + 424; -- GNAT
+ Name_Elab_Spec : constant Name_Id := N + 425; -- GNAT
+ Name_Storage_Pool : constant Name_Id := N + 426;
-- These attributes are the ones that return types
- First_Type_Attribute_Name : constant Name_Id := N + 421;
- Name_Base : constant Name_Id := N + 421;
- Name_Class : constant Name_Id := N + 422;
- Last_Type_Attribute_Name : constant Name_Id := N + 422;
- Last_Entity_Attribute_Name : constant Name_Id := N + 422;
- Last_Attribute_Name : constant Name_Id := N + 422;
+ First_Type_Attribute_Name : constant Name_Id := N + 427;
+ Name_Base : constant Name_Id := N + 427;
+ Name_Class : constant Name_Id := N + 428;
+ Last_Type_Attribute_Name : constant Name_Id := N + 428;
+ Last_Entity_Attribute_Name : constant Name_Id := N + 428;
+ Last_Attribute_Name : constant Name_Id := N + 428;
-- Names of recognized locking policy identifiers
@@ -716,10 +718,10 @@ package Snames is
-- name (e.g. C for Ceiling_Locking). If new policy names are added,
-- the first character must be distinct.
- First_Locking_Policy_Name : constant Name_Id := N + 423;
- Name_Ceiling_Locking : constant Name_Id := N + 423;
- Name_Inheritance_Locking : constant Name_Id := N + 424;
- Last_Locking_Policy_Name : constant Name_Id := N + 424;
+ First_Locking_Policy_Name : constant Name_Id := N + 429;
+ Name_Ceiling_Locking : constant Name_Id := N + 429;
+ Name_Inheritance_Locking : constant Name_Id := N + 430;
+ Last_Locking_Policy_Name : constant Name_Id := N + 430;
-- Names of recognized queuing policy identifiers.
@@ -727,10 +729,10 @@ package Snames is
-- name (e.g. F for FIFO_Queuing). If new policy names are added,
-- the first character must be distinct.
- First_Queuing_Policy_Name : constant Name_Id := N + 425;
- Name_FIFO_Queuing : constant Name_Id := N + 425;
- Name_Priority_Queuing : constant Name_Id := N + 426;
- Last_Queuing_Policy_Name : constant Name_Id := N + 426;
+ First_Queuing_Policy_Name : constant Name_Id := N + 431;
+ Name_FIFO_Queuing : constant Name_Id := N + 431;
+ Name_Priority_Queuing : constant Name_Id := N + 432;
+ Last_Queuing_Policy_Name : constant Name_Id := N + 432;
-- Names of recognized task dispatching policy identifiers
@@ -738,172 +740,191 @@ package Snames is
-- name (e.g. F for FIFO_WIthinn_Priorities). If new policy names
-- are added, the first character must be distinct.
- First_Task_Dispatching_Policy_Name : constant Name_Id := N + 427;
- Name_Fifo_Within_Priorities : constant Name_Id := N + 427;
- Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 427;
+ First_Task_Dispatching_Policy_Name : constant Name_Id := N + 433;
+ Name_Fifo_Within_Priorities : constant Name_Id := N + 433;
+ Last_Task_Dispatching_Policy_Name : constant Name_Id := N + 433;
-- Names of recognized checks for pragma Suppress
- First_Check_Name : constant Name_Id := N + 428;
- Name_Access_Check : constant Name_Id := N + 428;
- Name_Accessibility_Check : constant Name_Id := N + 429;
- Name_Discriminant_Check : constant Name_Id := N + 430;
- Name_Division_Check : constant Name_Id := N + 431;
- Name_Elaboration_Check : constant Name_Id := N + 432;
- Name_Index_Check : constant Name_Id := N + 433;
- Name_Length_Check : constant Name_Id := N + 434;
- Name_Overflow_Check : constant Name_Id := N + 435;
- Name_Range_Check : constant Name_Id := N + 436;
- Name_Storage_Check : constant Name_Id := N + 437;
- Name_Tag_Check : constant Name_Id := N + 438;
- Name_All_Checks : constant Name_Id := N + 439;
- Last_Check_Name : constant Name_Id := N + 439;
+ First_Check_Name : constant Name_Id := N + 434;
+ Name_Access_Check : constant Name_Id := N + 434;
+ Name_Accessibility_Check : constant Name_Id := N + 435;
+ Name_Discriminant_Check : constant Name_Id := N + 436;
+ Name_Division_Check : constant Name_Id := N + 437;
+ Name_Elaboration_Check : constant Name_Id := N + 438;
+ Name_Index_Check : constant Name_Id := N + 439;
+ Name_Length_Check : constant Name_Id := N + 440;
+ Name_Overflow_Check : constant Name_Id := N + 441;
+ Name_Range_Check : constant Name_Id := N + 442;
+ Name_Storage_Check : constant Name_Id := N + 443;
+ Name_Tag_Check : constant Name_Id := N + 444;
+ Name_All_Checks : constant Name_Id := N + 445;
+ Last_Check_Name : constant Name_Id := N + 445;
-- Names corresponding to reserved keywords, excluding those already
-- declared in the attribute list (Access, Delta, Digits, Range).
- Name_Abort : constant Name_Id := N + 440;
- Name_Abs : constant Name_Id := N + 441;
- Name_Accept : constant Name_Id := N + 442;
- Name_And : constant Name_Id := N + 443;
- Name_All : constant Name_Id := N + 444;
- Name_Array : constant Name_Id := N + 445;
- Name_At : constant Name_Id := N + 446;
- Name_Begin : constant Name_Id := N + 447;
- Name_Body : constant Name_Id := N + 448;
- Name_Case : constant Name_Id := N + 449;
- Name_Constant : constant Name_Id := N + 450;
- Name_Declare : constant Name_Id := N + 451;
- Name_Delay : constant Name_Id := N + 452;
- Name_Do : constant Name_Id := N + 453;
- Name_Else : constant Name_Id := N + 454;
- Name_Elsif : constant Name_Id := N + 455;
- Name_End : constant Name_Id := N + 456;
- Name_Entry : constant Name_Id := N + 457;
- Name_Exception : constant Name_Id := N + 458;
- Name_Exit : constant Name_Id := N + 459;
- Name_For : constant Name_Id := N + 460;
- Name_Function : constant Name_Id := N + 461;
- Name_Generic : constant Name_Id := N + 462;
- Name_Goto : constant Name_Id := N + 463;
- Name_If : constant Name_Id := N + 464;
- Name_In : constant Name_Id := N + 465;
- Name_Is : constant Name_Id := N + 466;
- Name_Limited : constant Name_Id := N + 467;
- Name_Loop : constant Name_Id := N + 468;
- Name_Mod : constant Name_Id := N + 469;
- Name_New : constant Name_Id := N + 470;
- Name_Not : constant Name_Id := N + 471;
- Name_Null : constant Name_Id := N + 472;
- Name_Of : constant Name_Id := N + 473;
- Name_Or : constant Name_Id := N + 474;
- Name_Others : constant Name_Id := N + 475;
- Name_Out : constant Name_Id := N + 476;
- Name_Package : constant Name_Id := N + 477;
- Name_Pragma : constant Name_Id := N + 478;
- Name_Private : constant Name_Id := N + 479;
- Name_Procedure : constant Name_Id := N + 480;
- Name_Raise : constant Name_Id := N + 481;
- Name_Record : constant Name_Id := N + 482;
- Name_Rem : constant Name_Id := N + 483;
- Name_Renames : constant Name_Id := N + 484;
- Name_Return : constant Name_Id := N + 485;
- Name_Reverse : constant Name_Id := N + 486;
- Name_Select : constant Name_Id := N + 487;
- Name_Separate : constant Name_Id := N + 488;
- Name_Subtype : constant Name_Id := N + 489;
- Name_Task : constant Name_Id := N + 490;
- Name_Terminate : constant Name_Id := N + 491;
- Name_Then : constant Name_Id := N + 492;
- Name_Type : constant Name_Id := N + 493;
- Name_Use : constant Name_Id := N + 494;
- Name_When : constant Name_Id := N + 495;
- Name_While : constant Name_Id := N + 496;
- Name_With : constant Name_Id := N + 497;
- Name_Xor : constant Name_Id := N + 498;
+ Name_Abort : constant Name_Id := N + 446;
+ Name_Abs : constant Name_Id := N + 447;
+ Name_Accept : constant Name_Id := N + 448;
+ Name_And : constant Name_Id := N + 449;
+ Name_All : constant Name_Id := N + 450;
+ Name_Array : constant Name_Id := N + 451;
+ Name_At : constant Name_Id := N + 452;
+ Name_Begin : constant Name_Id := N + 453;
+ Name_Body : constant Name_Id := N + 454;
+ Name_Case : constant Name_Id := N + 455;
+ Name_Constant : constant Name_Id := N + 456;
+ Name_Declare : constant Name_Id := N + 457;
+ Name_Delay : constant Name_Id := N + 458;
+ Name_Do : constant Name_Id := N + 459;
+ Name_Else : constant Name_Id := N + 460;
+ Name_Elsif : constant Name_Id := N + 461;
+ Name_End : constant Name_Id := N + 462;
+ Name_Entry : constant Name_Id := N + 463;
+ Name_Exception : constant Name_Id := N + 464;
+ Name_Exit : constant Name_Id := N + 465;
+ Name_For : constant Name_Id := N + 466;
+ Name_Function : constant Name_Id := N + 467;
+ Name_Generic : constant Name_Id := N + 468;
+ Name_Goto : constant Name_Id := N + 469;
+ Name_If : constant Name_Id := N + 470;
+ Name_In : constant Name_Id := N + 471;
+ Name_Is : constant Name_Id := N + 472;
+ Name_Limited : constant Name_Id := N + 473;
+ Name_Loop : constant Name_Id := N + 474;
+ Name_Mod : constant Name_Id := N + 475;
+ Name_New : constant Name_Id := N + 476;
+ Name_Not : constant Name_Id := N + 477;
+ Name_Null : constant Name_Id := N + 478;
+ Name_Of : constant Name_Id := N + 479;
+ Name_Or : constant Name_Id := N + 480;
+ Name_Others : constant Name_Id := N + 481;
+ Name_Out : constant Name_Id := N + 482;
+ Name_Package : constant Name_Id := N + 483;
+ Name_Pragma : constant Name_Id := N + 484;
+ Name_Private : constant Name_Id := N + 485;
+ Name_Procedure : constant Name_Id := N + 486;
+ Name_Raise : constant Name_Id := N + 487;
+ Name_Record : constant Name_Id := N + 488;
+ Name_Rem : constant Name_Id := N + 489;
+ Name_Renames : constant Name_Id := N + 490;
+ Name_Return : constant Name_Id := N + 491;
+ Name_Reverse : constant Name_Id := N + 492;
+ Name_Select : constant Name_Id := N + 493;
+ Name_Separate : constant Name_Id := N + 494;
+ Name_Subtype : constant Name_Id := N + 495;
+ Name_Task : constant Name_Id := N + 496;
+ Name_Terminate : constant Name_Id := N + 497;
+ Name_Then : constant Name_Id := N + 498;
+ Name_Type : constant Name_Id := N + 499;
+ Name_Use : constant Name_Id := N + 500;
+ Name_When : constant Name_Id := N + 501;
+ Name_While : constant Name_Id := N + 502;
+ Name_With : constant Name_Id := N + 503;
+ Name_Xor : constant Name_Id := N + 504;
-- Names of intrinsic subprograms
-- Note: Asm is missing from this list, since Asm is a legitimate
- -- convention name.
-
- First_Intrinsic_Name : constant Name_Id := N + 499;
- Name_Divide : constant Name_Id := N + 499;
- Name_Enclosing_Entity : constant Name_Id := N + 500;
- Name_Exception_Information : constant Name_Id := N + 501;
- Name_Exception_Message : constant Name_Id := N + 502;
- Name_Exception_Name : constant Name_Id := N + 503;
- Name_File : constant Name_Id := N + 504;
- Name_Import_Address : constant Name_Id := N + 505;
- Name_Import_Largest_Value : constant Name_Id := N + 506;
- Name_Import_Value : constant Name_Id := N + 507;
- Name_Is_Negative : constant Name_Id := N + 508;
- Name_Line : constant Name_Id := N + 509;
- Name_Rotate_Left : constant Name_Id := N + 510;
- Name_Rotate_Right : constant Name_Id := N + 511;
- Name_Shift_Left : constant Name_Id := N + 512;
- Name_Shift_Right : constant Name_Id := N + 513;
- Name_Shift_Right_Arithmetic : constant Name_Id := N + 514;
- Name_Source_Location : constant Name_Id := N + 515;
- Name_Unchecked_Conversion : constant Name_Id := N + 516;
- Name_Unchecked_Deallocation : constant Name_Id := N + 517;
- Last_Intrinsic_Name : constant Name_Id := N + 517;
+ -- convention name. So is To_Adress, which is a GNAT attribute.
+
+ First_Intrinsic_Name : constant Name_Id := N + 505;
+ Name_Divide : constant Name_Id := N + 505;
+ Name_Enclosing_Entity : constant Name_Id := N + 506;
+ Name_Exception_Information : constant Name_Id := N + 507;
+ Name_Exception_Message : constant Name_Id := N + 508;
+ Name_Exception_Name : constant Name_Id := N + 509;
+ Name_File : constant Name_Id := N + 510;
+ Name_Import_Address : constant Name_Id := N + 511;
+ Name_Import_Largest_Value : constant Name_Id := N + 512;
+ Name_Import_Value : constant Name_Id := N + 513;
+ Name_Is_Negative : constant Name_Id := N + 514;
+ Name_Line : constant Name_Id := N + 515;
+ Name_Rotate_Left : constant Name_Id := N + 516;
+ Name_Rotate_Right : constant Name_Id := N + 517;
+ Name_Shift_Left : constant Name_Id := N + 518;
+ Name_Shift_Right : constant Name_Id := N + 519;
+ Name_Shift_Right_Arithmetic : constant Name_Id := N + 520;
+ Name_Source_Location : constant Name_Id := N + 521;
+ Name_Unchecked_Conversion : constant Name_Id := N + 522;
+ Name_Unchecked_Deallocation : constant Name_Id := N + 523;
+ Name_To_Pointer : constant Name_Id := N + 524;
+ Last_Intrinsic_Name : constant Name_Id := N + 524;
-- Reserved words used only in Ada 95
- First_95_Reserved_Word : constant Name_Id := N + 518;
- Name_Abstract : constant Name_Id := N + 518;
- Name_Aliased : constant Name_Id := N + 519;
- Name_Protected : constant Name_Id := N + 520;
- Name_Until : constant Name_Id := N + 521;
- Name_Requeue : constant Name_Id := N + 522;
- Name_Tagged : constant Name_Id := N + 523;
- Last_95_Reserved_Word : constant Name_Id := N + 523;
+ First_95_Reserved_Word : constant Name_Id := N + 525;
+ Name_Abstract : constant Name_Id := N + 525;
+ Name_Aliased : constant Name_Id := N + 526;
+ Name_Protected : constant Name_Id := N + 527;
+ Name_Until : constant Name_Id := N + 528;
+ Name_Requeue : constant Name_Id := N + 529;
+ Name_Tagged : constant Name_Id := N + 530;
+ Last_95_Reserved_Word : constant Name_Id := N + 530;
subtype Ada_95_Reserved_Words is
Name_Id range First_95_Reserved_Word .. Last_95_Reserved_Word;
-- Miscellaneous names used in semantic checking
- Name_Raise_Exception : constant Name_Id := N + 524;
+ Name_Raise_Exception : constant Name_Id := N + 531;
-- Additional reserved words in GNAT Project Files
-- Note that Name_External is already previously declared
- Name_Binder : constant Name_Id := N + 525;
- Name_Builder : constant Name_Id := N + 526;
- Name_Compiler : constant Name_Id := N + 527;
- Name_Cross_Reference : constant Name_Id := N + 528;
- Name_Default_Switches : constant Name_Id := N + 529;
- Name_Exec_Dir : constant Name_Id := N + 530;
- Name_Extends : constant Name_Id := N + 531;
- Name_Finder : constant Name_Id := N + 532;
- Name_Gnatls : constant Name_Id := N + 533;
- Name_Gnatstub : constant Name_Id := N + 534;
- Name_Implementation : constant Name_Id := N + 535;
- Name_Implementation_Exceptions : constant Name_Id := N + 536;
- Name_Implementation_Suffix : constant Name_Id := N + 537;
- Name_Languages : constant Name_Id := N + 538;
- Name_Library_Dir : constant Name_Id := N + 539;
- Name_Library_Elaboration : constant Name_Id := N + 540;
- Name_Library_Kind : constant Name_Id := N + 541;
- Name_Library_Name : constant Name_Id := N + 542;
- Name_Library_Version : constant Name_Id := N + 543;
- Name_Linker : constant Name_Id := N + 544;
- Name_Naming : constant Name_Id := N + 545;
- Name_Object_Dir : constant Name_Id := N + 546;
- Name_Project : constant Name_Id := N + 547;
- Name_Separate_Suffix : constant Name_Id := N + 548;
- Name_Source_Dirs : constant Name_Id := N + 549;
- Name_Source_Files : constant Name_Id := N + 550;
- Name_Source_List_File : constant Name_Id := N + 551;
- Name_Specification : constant Name_Id := N + 552;
- Name_Specification_Exceptions : constant Name_Id := N + 553;
- Name_Specification_Suffix : constant Name_Id := N + 554;
- Name_Switches : constant Name_Id := N + 555;
+ Name_Binder : constant Name_Id := N + 532;
+ Name_Body_Suffix : constant Name_Id := N + 533;
+ Name_Builder : constant Name_Id := N + 534;
+ Name_Compiler : constant Name_Id := N + 535;
+ Name_Cross_Reference : constant Name_Id := N + 536;
+ Name_Default_Switches : constant Name_Id := N + 537;
+ Name_Exec_Dir : constant Name_Id := N + 538;
+ Name_Executable : constant Name_Id := N + 539;
+ Name_Executable_Suffix : constant Name_Id := N + 540;
+ Name_Extends : constant Name_Id := N + 541;
+ Name_Finder : constant Name_Id := N + 542;
+ Name_Global_Configuration_Pragmas : constant Name_Id := N + 543;
+ Name_Gnatls : constant Name_Id := N + 544;
+ Name_Gnatstub : constant Name_Id := N + 545;
+ Name_Implementation : constant Name_Id := N + 546;
+ Name_Implementation_Exceptions : constant Name_Id := N + 547;
+ Name_Implementation_Suffix : constant Name_Id := N + 548;
+ Name_Languages : constant Name_Id := N + 549;
+ Name_Library_Dir : constant Name_Id := N + 550;
+ Name_Library_Auto_Init : constant Name_Id := N + 551;
+ Name_Library_GCC : constant Name_Id := N + 552;
+ Name_Library_Interface : constant Name_Id := N + 553;
+ Name_Library_Kind : constant Name_Id := N + 554;
+ Name_Library_Name : constant Name_Id := N + 555;
+ Name_Library_Options : constant Name_Id := N + 556;
+ Name_Library_Src_Dir : constant Name_Id := N + 557;
+ Name_Library_Symbol_File : constant Name_Id := N + 558;
+ Name_Library_Version : constant Name_Id := N + 559;
+ Name_Linker : constant Name_Id := N + 560;
+ Name_Local_Configuration_Pragmas : constant Name_Id := N + 561;
+ Name_Locally_Removed_Files : constant Name_Id := N + 562;
+ Name_Naming : constant Name_Id := N + 563;
+ Name_Object_Dir : constant Name_Id := N + 564;
+ Name_Pretty_Printer : constant Name_Id := N + 565;
+ Name_Project : constant Name_Id := N + 566;
+ Name_Separate_Suffix : constant Name_Id := N + 567;
+ Name_Source_Dirs : constant Name_Id := N + 568;
+ Name_Source_Files : constant Name_Id := N + 569;
+ Name_Source_List_File : constant Name_Id := N + 570;
+ Name_Spec : constant Name_Id := N + 571;
+ Name_Spec_Suffix : constant Name_Id := N + 572;
+ Name_Specification : constant Name_Id := N + 573;
+ Name_Specification_Exceptions : constant Name_Id := N + 574;
+ Name_Specification_Suffix : constant Name_Id := N + 575;
+ Name_Switches : constant Name_Id := N + 576;
+ -- Other miscellaneous names used in front end
+
+ Name_Unaligned_Valid : constant Name_Id := N + 577;
+
-- Mark last defined name for consistency check in Snames body
- Last_Predefined_Name : constant Name_Id := N + 555;
+ Last_Predefined_Name : constant Name_Id := N + 577;
subtype Any_Operator_Name is Name_Id range
First_Operator_Name .. Last_Operator_Name;
@@ -977,6 +998,7 @@ package Snames is
Attribute_Object_Size,
Attribute_Partition_ID,
Attribute_Passed_By_Reference,
+ Attribute_Pool_Address,
Attribute_Pos,
Attribute_Position,
Attribute_Range,
@@ -995,12 +1017,14 @@ package Snames is
Attribute_Storage_Size,
Attribute_Storage_Unit,
Attribute_Tag,
+ Attribute_Target_Name,
Attribute_Terminated,
Attribute_To_Address,
Attribute_Type_Class,
Attribute_UET_Address,
Attribute_Unbiased_Rounding,
Attribute_Unchecked_Access,
+ Attribute_Unconstrained_Array,
Attribute_Universal_Literal_String,
Attribute_Unrestricted_Access,
Attribute_VADS_Size,
@@ -1052,24 +1076,6 @@ package Snames is
Attribute_Base,
Attribute_Class);
- -------------------------------
- -- Check Name ID Definitions --
- -------------------------------
-
- type Check_Id is (
- Access_Check,
- Accessibility_Check,
- Discriminant_Check,
- Division_Check,
- Elaboration_Check,
- Index_Check,
- Length_Check,
- Overflow_Check,
- Range_Check,
- Storage_Check,
- Tag_Check,
- All_Checks);
-
------------------------------------
-- Convention Name ID Definitions --
------------------------------------
@@ -1124,36 +1130,45 @@ package Snames is
Pragma_Ada_83,
Pragma_Ada_95,
Pragma_C_Pass_By_Copy,
+ Pragma_Compile_Time_Warning,
Pragma_Component_Alignment,
Pragma_Convention_Identifier,
Pragma_Discard_Names,
Pragma_Elaboration_Checks,
Pragma_Eliminate,
+ Pragma_Explicit_Overriding,
Pragma_Extend_System,
Pragma_Extensions_Allowed,
Pragma_External_Name_Casing,
Pragma_Float_Representation,
Pragma_Initialize_Scalars,
+ Pragma_Interrupt_State,
Pragma_License,
Pragma_Locking_Policy,
Pragma_Long_Float,
Pragma_No_Run_Time,
Pragma_Normalize_Scalars,
Pragma_Polling,
+ Pragma_Persistent_Data,
+ Pragma_Persistent_Object,
Pragma_Propagate_Exceptions,
Pragma_Queuing_Policy,
Pragma_Ravenscar,
Pragma_Restricted_Run_Time,
Pragma_Restrictions,
+ Pragma_Restriction_Warnings,
Pragma_Reviewable,
Pragma_Source_File_Name,
+ Pragma_Source_File_Name_Project,
Pragma_Style_Checks,
Pragma_Suppress,
+ Pragma_Suppress_Exception_Locations,
Pragma_Task_Dispatching_Policy,
+ Pragma_Universal_Data,
Pragma_Unsuppress,
Pragma_Use_VADS_Size,
- Pragma_Warnings,
Pragma_Validity_Checks,
+ Pragma_Warnings,
-- Remaining (non-configuration) pragmas
@@ -1183,6 +1198,7 @@ package Snames is
Pragma_Export_Function,
Pragma_Export_Object,
Pragma_Export_Procedure,
+ Pragma_Export_Value,
Pragma_Export_Valued_Procedure,
Pragma_External,
Pragma_Finalize_Storage_Only,
@@ -1203,6 +1219,7 @@ package Snames is
Pragma_Interrupt_Priority,
Pragma_Java_Constructor,
Pragma_Java_Interface,
+ Pragma_Keep_Names,
Pragma_Link_With,
Pragma_Linker_Alias,
Pragma_Linker_Options,
@@ -1213,7 +1230,10 @@ package Snames is
Pragma_Main_Storage,
Pragma_Memory_Size,
Pragma_No_Return,
+ Pragma_Obsolescent,
Pragma_Optimize,
+ Pragma_Optional_Overriding,
+ Pragma_Overriding,
Pragma_Pack,
Pragma_Page,
Pragma_Passive,
@@ -1241,7 +1261,6 @@ package Snames is
Pragma_Title,
Pragma_Unchecked_Union,
Pragma_Unimplemented_Unit,
- Pragma_Universal_Data,
Pragma_Unreferenced,
Pragma_Unreserve_All_Interrupts,
Pragma_Volatile,
@@ -1254,7 +1273,11 @@ package Snames is
Pragma_AST_Entry,
Pragma_Storage_Size,
- Pragma_Storage_Unit);
+ Pragma_Storage_Unit,
+
+ -- The value to represent an unknown or unrecognized pragma
+
+ Unknown_Pragma);
-----------------------------------
-- Queuing Policy ID definitions --
@@ -1306,8 +1329,11 @@ package Snames is
-- as required by pragma Suppress.
function Is_Convention_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of one of the recognized language
- -- conventions, as required by pragma Convention, Import, Export, Interface
+ -- Test to see if the name N is the name of one of the recognized
+ -- language conventions, as required by pragma Convention, Import,
+ -- Export, Interface. Returns True if so. Also returns True for a
+ -- name that has been specified by a Convention_Identifier pragma.
+ -- If neither case holds, returns False.
function Is_Locking_Policy_Name (N : Name_Id) return Boolean;
-- Test to see if the name N is the name of a recognized locking policy
@@ -1325,8 +1351,8 @@ package Snames is
-- Test to see if the name N is the name of a recognized queuing policy
function Is_Task_Dispatching_Policy_Name (N : Name_Id) return Boolean;
- -- Test to see if the name N is the name of a recognized
- -- task dispatching policy
+ -- Test to see if the name N is the name of a recognized task
+ -- dispatching policy.
function Get_Attribute_Id (N : Name_Id) return Attribute_Id;
-- Returns Id of attribute corresponding to given name. It is an error to
@@ -1346,10 +1372,10 @@ package Snames is
-- to call this function with a name that is not the name of a check.
function Get_Pragma_Id (N : Name_Id) return Pragma_Id;
- -- Returns Id of pragma corresponding to given name. It is an error to
- -- call this function with a name that is not the name of a pragma. Note
- -- that the function also works correctly for names of pragmas that are
- -- not in the main list of pragma Names (AST_Entry, Storage_Size, and
+ -- Returns Id of pragma corresponding to given name. Returns Unknown_Pragma
+ -- if N is not a name of a known (Ada defined or GNAT-specific) pragma.
+ -- Note that the function also works correctly for names of pragmas that
+ -- are not in the main list of pragma Names (AST_Entry, Storage_Size, and
-- Storage_Unit (e.g. Name_Storage_Size returns Pragma_Storage_Size).
function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id;
@@ -1375,7 +1401,6 @@ private
pragma Inline (Is_Entity_Attribute_Name);
pragma Inline (Is_Type_Attribute_Name);
pragma Inline (Is_Check_Name);
- pragma Inline (Is_Convention_Name);
pragma Inline (Is_Locking_Policy_Name);
pragma Inline (Is_Operator_Symbol_Name);
pragma Inline (Is_Queuing_Policy_Name);
diff --git a/gcc/ada/snames.h b/gcc/ada/snames.h
index 594b14ebe50..b71c60b8998 100644
--- a/gcc/ada/snames.h
+++ b/gcc/ada/snames.h
@@ -6,8 +6,7 @@
* *
* C Header File *
* *
- * *
- * 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- *
@@ -33,10 +32,8 @@
#define Name_uParent (First_Name_Id + 256 + 0)
#define Name_uTag (First_Name_Id + 256 + 1)
#define Name_Off (First_Name_Id + 256 + 2)
-#define Name_Space (First_Name_Id + 256 + 3)
+#define Name_Space (First_Name_Id + 256 + 3)
#define Name_Time (First_Name_Id + 256 + 4)
-#define Name_uInit_Proc (First_Name_Id + 256 + 5)
-#define Name_uSize (First_Name_Id + 256 + 6)
/* Define the function to return one of the numeric values below. Note
that it actually returns a char since an enumeration value of less
@@ -44,9 +41,9 @@
field value. */
#define Get_Attribute_Id snames__get_attribute_id
-extern char Get_Attribute_Id PARAMS ((int));
+extern unsigned char Get_Attribute_Id (int);
-/* Define the numeric values for the attributes. */
+/* Define the numeric values for attributes. */
#define Attr_Abort_Signal 0
#define Attr_Access 1
@@ -112,77 +109,80 @@ extern char Get_Attribute_Id PARAMS ((int));
#define Attr_Object_Size 61
#define Attr_Partition_ID 62
#define Attr_Passed_By_Reference 63
-#define Attr_Pos 64
-#define Attr_Position 65
-#define Attr_Range 66
-#define Attr_Range_Length 67
-#define Attr_Round 68
-#define Attr_Safe_Emax 69
-#define Attr_Safe_First 70
-#define Attr_Safe_Large 71
-#define Attr_Safe_Last 72
-#define Attr_Safe_Small 73
-#define Attr_Scale 74
-#define Attr_Scaling 75
-#define Attr_Signed_Zeros 76
-#define Attr_Size 77
-#define Attr_Small 78
-#define Attr_Storage_Size 79
-#define Attr_Storage_Unit 80
-#define Attr_Tag 81
-#define Attr_Terminated 82
-#define Attr_To_Address 83
-#define Attr_Type_Class 84
-#define Attr_UET_Address 85
-#define Attr_Unbiased_Rounding 86
-#define Attr_Unchecked_Access 87
-#define Attr_Universal_Literal_String 88
-#define Attr_Unrestricted_Access 89
-#define Attr_VADS_Size 90
-#define Attr_Val 91
-#define Attr_Valid 92
-#define Attr_Value_Size 93
-#define Attr_Version 94
-#define Attr_Wide_Character_Size 95
-#define Attr_Wide_Width 96
-#define Attr_Width 97
-#define Attr_Word_Size 98
+#define Attr_Pool_Address 64
+#define Attr_Pos 65
+#define Attr_Position 66
+#define Attr_Range 67
+#define Attr_Range_Length 68
+#define Attr_Round 69
+#define Attr_Safe_Emax 70
+#define Attr_Safe_First 71
+#define Attr_Safe_Large 72
+#define Attr_Safe_Last 73
+#define Attr_Safe_Small 74
+#define Attr_Scale 75
+#define Attr_Scaling 76
+#define Attr_Signed_Zeros 77
+#define Attr_Size 78
+#define Attr_Small 79
+#define Attr_Storage_Size 80
+#define Attr_Storage_Unit 81
+#define Attr_Tag 82
+#define Attr_Target_Name 83
+#define Attr_Terminated 84
+#define Attr_To_Address 85
+#define Attr_Type_Class 86
+#define Attr_UET_Address 87
+#define Attr_Unbiased_Rounding 88
+#define Attr_Unchecked_Access 89
+#define Attr_Unconstrained_Array 90
+#define Attr_Universal_Literal_String 91
+#define Attr_Unrestricted_Access 92
+#define Attr_VADS_Size 93
+#define Attr_Val 94
+#define Attr_Valid 95
+#define Attr_Value_Size 96
+#define Attr_Version 97
+#define Attr_Wide_Character_Size 98
+#define Attr_Wide_Width 99
+#define Attr_Width 100
-#define Attr_Adjacent 99
-#define Attr_Ceiling 100
-#define Attr_Copy_Sign 101
-#define Attr_Floor 102
-#define Attr_Fraction 103
-#define Attr_Image 104
-#define Attr_Input 105
-#define Attr_Machine 106
-#define Attr_Max 107
-#define Attr_Min 108
-#define Attr_Model 109
-#define Attr_Pred 110
-#define Attr_Remainder 111
-#define Attr_Rounding 112
-#define Attr_Succ 113
-#define Attr_Truncation 114
-#define Attr_Value 115
-#define Attr_Wide_Image 116
-#define Attr_Wide_Value 117
+#define Attr_Word_Size 101
+#define Attr_Adjacent 102
+#define Attr_Ceiling 103
+#define Attr_Copy_Sign 104
+#define Attr_Floor 105
+#define Attr_Fraction 106
+#define Attr_Image 107
+#define Attr_Input 108
+#define Attr_Machine 109
+#define Attr_Max 110
+#define Attr_Min 111
+#define Attr_Model 112
+#define Attr_Pred 113
+#define Attr_Remainder 114
+#define Attr_Rounding 115
+#define Attr_Succ 116
+#define Attr_Truncation 117
+#define Attr_Value 118
+#define Attr_Wide_Image 119
+#define Attr_Wide_Value 120
-#define Attr_Output 118
-#define Attr_Read 119
-#define Attr_Write 120
+#define Attr_Output 121
+#define Attr_Read 122
+#define Attr_Write 123
-#define Attr_Elab_Body 121
-#define Attr_Elab_Spec 122
-#define Attr_Storage_Pool 123
+#define Attr_Elab_Body 124
+#define Attr_Elab_Spec 125
+#define Attr_Storage_Pool 126
-#define Attr_Base 124
-#define Attr_Class 125
+#define Attr_Base 127
+#define Attr_Class 128
/* Define the function to check if a Name_Id value is a valid pragma */
#define Is_Pragma_Name snames__is_pragma_name
-extern Boolean Is_Pragma_Name PARAMS ((Name_Id));
+extern Boolean Is_Pragma_Name (Name_Id);
/* Define the function to return one of the numeric values below. Note
that it actually returns a char since an enumeration value of less
@@ -190,144 +190,157 @@ extern Boolean Is_Pragma_Name PARAMS ((Name_Id));
field value. */
#define Get_Pragma_Id snames__get_pragma_id
-extern char Get_Pragma_Id PARAMS ((int));
+extern unsigned char Get_Pragma_Id (int);
/* Define the numeric values for the pragmas. */
/* Configuration pragmas first */
-#define Pragma_Ada_83 0
-#define Pragma_Ada_95 1
-#define Pragma_C_Pass_By_Copy 2
-#define Pragma_Component_Alignment 3
-#define Pragma_Convention_Identifier 4
-#define Pragma_Discard_Names 5
-#define Pragma_Elaboration_Checking 6
-#define Pragma_Eliminate 7
-#define Pragma_Extend_System 8
-#define Pragma_Extensions_Allowed 9
-#define Pragma_External_Name_Casing 10
-#define Pragma_Float_Representation 11
-#define Pragma_Initialize 12
-#define Pragma_License 13
-#define Pragma_Locking_Policy 14
-#define Pragma_Long_Float 15
-#define Pragma_No_Run_Time 16
-#define Pragma_Normalize_Scalars 17
-#define Pragma_Polling 18
-#define Pragma_Propagate_Exceptions 19
-#define Pragma_Queuing_Policy 20
-#define Pragma_Ravenscar 21
-#define Pragma_Restricted_Run_Time 22
-#define Pragma_Restrictions 23
-#define Pragma_Reviewable 24
-#define Pragma_Source_File_Name 25
-#define Pragma_Style_Checks 26
-#define Pragma_Suppress 27
-#define Pragma_Task_Dispatching_Policy 28
-#define Pragma_Unsuppress 29
-#define Pragma_Use_VADS_Size 30
-#define Pragma_Validity_Checks 31
-#define Pragma_Warnings 32
+#define Pragma_Ada_83 0
+#define Pragma_Ada_95 1
+#define Pragma_C_Pass_By_Copy 2
+#define Pragma_Compile_Time_Warning 3
+#define Pragma_Component_Alignment 4
+#define Pragma_Convention_Identifier 5
+#define Pragma_Discard_Names 6
+#define Pragma_Elaboration_Checking 7
+#define Pragma_Eliminate 8
+#define Pragma_Explicit_Overriding 9
+#define Pragma_Extend_System 10
+#define Pragma_Extensions_Allowed 11
+#define Pragma_External_Name_Casing 12
+#define Pragma_Float_Representation 13
+#define Pragma_Initialize_Scalars 14
+#define Pragma_Interrupt_State 15
+#define Pragma_License 16
+#define Pragma_Locking_Policy 17
+#define Pragma_Long_Float 18
+#define Pragma_No_Run_Time 19
+#define Pragma_Normalize_Scalars 20
+#define Pragma_Polling 21
+#define Pragma_Persistent_Data 22
+#define Pragma_Persistent_Object 23
+#define Pragma_Propagate_Exceptions 24
+#define Pragma_Queuing_Policy 25
+#define Pragma_Ravenscar 26
+#define Pragma_Restricted_Run_Time 27
+#define Pragma_Restrictions 28
+#define Pragma_Restriction_Warnings 29
+#define Pragma_Reviewable 30
+#define Pragma_Source_File_Name 31
+#define Pragma_Source_File_Name_Project 32
+#define Pragma_Style_Checks 33
+#define Pragma_Suppress 34
+#define Pragma_Suppress_Exception_Locations 35
+#define Pragma_Task_Dispatching_Policy 36
+#define Pragma_Universal_Data 37
+#define Pragma_Unsuppress 38
+#define Pragma_Use_VADS_Size 39
+#define Pragma_Validity_Checks 40
+#define Pragma_Warnings 41
/* Remaining pragmas */
-#define Pragma_Abort_Defer 33
-#define Pragma_All_Calls_Remote 34
-#define Pragma_Annotate 35
-#define Pragma_Assert 36
-#define Pragma_Asynchronous 37
-#define Pragma_Atomic 38
-#define Pragma_Atomic_Components 39
-#define Pragma_Attach_Handler 40
-#define Pragma_Comment 41
-#define Pragma_Common_Object 42
-#define Pragma_Complex_Representation 43
-#define Pragma_Controlled 44
-#define Pragma_Convention 45
-#define Pragma_CPP_Class 46
-#define Pragma_CPP_Constructor 47
-#define Pragma_CPP_Virtual 48
-#define Pragma_CPP_Vtable 49
-#define Pragma_Debug 50
-#define Pragma_Elaborate 51
-#define Pragma_Elaborate_All 52
-#define Pragma_Elaborate_Body 53
-#define Pragma_Export 54
-#define Pragma_Export_Exception 55
-#define Pragma_Export_Function 56
-#define Pragma_Export_Object 57
-#define Pragma_Export_Procedure 58
-#define Pragma_Export_Valued_Procedure 59
-#define Pragma_External 60
-#define Pragma_Finalize_Storage_Only 61
-#define Pragma_Ident 62
-#define Pragma_Import 63
-#define Pragma_Import_Exception 64
-#define Pragma_Import_Function 65
-#define Pragma_Import_Object 66
-#define Pragma_Import_Procedure 67
-#define Pragma_Import_Valued_Procedure 68
-#define Pragma_Inline 69
-#define Pragma_Inline_Always 70
-#define Pragma_Inline_Generic 71
-#define Pragma_Inspection_Point 72
-#define Pragma_Interface 73
-#define Pragma_Interface_Name 74
-#define Pragma_Interrupt_Handler 75
-#define Pragma_Interrupt_Priority 76
-#define Pragma_Java_Constructor 77
-#define Pragma_Java_Interface 78
-#define Pragma_Link_With 79
-#define Pragma_Linker_Alias 80
-#define Pragma_Linker_Options 81
-#define Pragma_Linker_Section 82
-#define Pragma_List 83
-#define Pragma_Machine_Attribute 84
-#define Pragma_Main 85
-#define Pragma_Main_Storage 86
-#define Pragma_Memory_Size 87
-#define Pragma_No_Return 88
-#define Pragma_Optimize 89
-#define Pragma_Pack 90
-#define Pragma_Page 91
-#define Pragma_Passive 92
-#define Pragma_Preelaborate 93
-#define Pragma_Priority 94
-#define Pragma_Psect_Object 95
-#define Pragma_Pure 96
-#define Pragma_Pure_Function 97
-#define Pragma_Remote_Call_Interface 98
-#define Pragma_Remote_Types 99
-#define Pragma_Share_Generic 100
-#define Pragma_Shared 101
-#define Pragma_Shared_Passive 102
-#define Pragma_Source_Reference 103
-#define Pragma_Stream_Convert 104
-#define Pragma_Subtitle 105
-#define Pragma_Suppress_All 106
-#define Pragma_Suppress_Debug_Info 107
-#define Pragma_Suppress_Initialization 108
-#define Pragma_System_Name 109
-#define Pragma_Task_Info 110
-#define Pragma_Task_Name 111
-#define Pragma_Task_Storage 112
-#define Pragma_Time_Slice 113
-#define Pragma_Title 114
-#define Pragma_Unchecked_Union 115
-#define Pragma_Unimplemented_Unit 116
-#define Pragma_Universal_Data 117
-#define Pragma_Unreferenced 118
-#define Pragma_Unreserve_All_Interrupts 119
-#define Pragma_Volatile 120
-#define Pragma_Volatile_Components 121
-#define Pragma_Weak_External 122
+#define Pragma_Abort_Defer 42
+#define Pragma_All_Calls_Remote 43
+#define Pragma_Annotate 44
+#define Pragma_Assert 45
+#define Pragma_Asynchronous 46
+#define Pragma_Atomic 47
+#define Pragma_Atomic_Components 48
+#define Pragma_Attach_Handler 49
+#define Pragma_Comment 50
+#define Pragma_Common_Object 51
+#define Pragma_Complex_Representation 52
+#define Pragma_Controlled 53
+#define Pragma_Convention 54
+#define Pragma_CPP_Class 55
+#define Pragma_CPP_Constructor 56
+#define Pragma_CPP_Virtual 57
+#define Pragma_CPP_Vtable 58
+#define Pragma_Debug 59
+#define Pragma_Elaborate 60
+#define Pragma_Elaborate_All 61
+#define Pragma_Elaborate_Body 62
+#define Pragma_Export 63
+#define Pragma_Export_Exception 64
+#define Pragma_Export_Function 65
+#define Pragma_Export_Object 66
+#define Pragma_Export_Procedure 67
+#define Pragma_Export_Value 68
+#define Pragma_Export_Valued_Procedure 69
+#define Pragma_External 70
+#define Pragma_Finalize_Storage_Only 71
+#define Pragma_Ident 72
+#define Pragma_Import 73
+#define Pragma_Import_Exception 74
+#define Pragma_Import_Function 75
+#define Pragma_Import_Object 76
+#define Pragma_Import_Procedure 77
+#define Pragma_Import_Valued_Procedure 78
+#define Pragma_Inline 79
+#define Pragma_Inline_Always 80
+#define Pragma_Inline_Generic 81
+#define Pragma_Inspection_Point 82
+#define Pragma_Interface 83
+#define Pragma_Interface_Name 84
+#define Pragma_Interrupt_Handler 85
+#define Pragma_Interrupt_Priority 86
+#define Pragma_Java_Constructor 87
+#define Pragma_Java_Interface 88
+#define Pragma_Keep_Names 89
+#define Pragma_Link_With 90
+#define Pragma_Linker_Alias 91
+#define Pragma_Linker_Options 92
+#define Pragma_Linker_Section 93
+#define Pragma_List 94
+#define Pragma_Machine_Attribute 95
+#define Pragma_Main 96
+#define Pragma_Main_Storage 97
+#define Pragma_Memory_Size 98
+#define Pragma_No_Return 99
+#define Pragma_Obsolescent 100
+#define Pragma_Optimize 101
+#define Pragma_Optional_Overriding 102
+#define Pragma_Overriding 103
+#define Pragma_Pack 104
+#define Pragma_Page 105
+#define Pragma_Passive 106
+#define Pragma_Preelaborate 107
+#define Pragma_Priority 108
+#define Pragma_Psect_Object 109
+#define Pragma_Pure 110
+#define Pragma_Pure_Function 111
+#define Pragma_Remote_Call_Interface 112
+#define Pragma_Remote_Types 113
+#define Pragma_Share_Generic 114
+#define Pragma_Shared 115
+#define Pragma_Shared_Passive 116
+#define Pragma_Source_Reference 117
+#define Pragma_Stream_Convert 118
+#define Pragma_Subtitle 119
+#define Pragma_Suppress_All 120
+#define Pragma_Suppress_Debug_Info 121
+#define Pragma_Suppress_Initialization 122
+#define Pragma_System_Name 123
+#define Pragma_Task_Info 124
+#define Pragma_Task_Name 125
+#define Pragma_Task_Storage 126
+#define Pragma_Time_Slice 127
+#define Pragma_Title 128
+#define Pragma_Unchecked_Union 129
+#define Pragma_Unimplemented_Unit 130
+#define Pragma_Unreferenced 131
+#define Pragma_Unreserve_All_Interrupts 132
+#define Pragma_Volatile 133
+#define Pragma_Volatile_Components 134
+#define Pragma_Weak_External 135
/* The following are deliberately out of alphabetical order, see Snames */
-#define Pragma_AST_Entry 123
-#define Pragma_Storage_Size 124
-#define Pragma_Storage_Unit 125
+#define Pragma_AST_Entry 136
+#define Pragma_Storage_Size 137
+#define Pragma_Storage_Unit 138
/* Define the numeric values for the conventions. */
@@ -343,3 +356,5 @@ extern char Get_Pragma_Id PARAMS ((int));
#define Convention_Java 9
#define Convention_Stdcall 10
#define Convention_Stubbed 11
+
+/* End of snames.h (C version of Snames package spec) */
diff --git a/gcc/ada/socket.c b/gcc/ada/socket.c
new file mode 100644
index 00000000000..f660975fcba
--- /dev/null
+++ b/gcc/ada/socket.c
@@ -0,0 +1,181 @@
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * S O C K E T *
+ * *
+ * C Implementation File *
+ * *
+ * Copyright (C) 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- *
+ * ware Foundation; either version 2, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * As a special exception, if you link this file with other files to *
+ * produce an executable, this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not however invalidate any other reasons why the executable *
+ * file might be covered by the GNU Public License. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * Extensive contributions were provided by Ada Core Technologies Inc. *
+ * *
+ ****************************************************************************/
+
+/* This file provides a portable binding to the fd set functions */
+
+#ifdef __vxworks
+#include "vxWorks.h"
+#endif
+
+#ifdef IN_RTS
+#include "tconfig.h"
+#include "tsystem.h"
+
+#if defined (WINNT)
+#define FD_SETSIZE 1024
+#include <windows.h>
+
+#ifdef __MINGW32__
+#include "mingw32.h"
+#if STD_MINGW
+#include <winsock.h>
+#else
+#include <windows32/sockets.h>
+#endif
+#endif
+#endif
+
+#if defined (VMS)
+#define FD_SETSIZE 4096
+#include <sys/time.h>
+#endif
+
+#else
+#include "config.h"
+#include "system.h"
+#endif
+
+#include "raise.h"
+
+extern void __gnat_free_socket_set PARAMS ((fd_set *));
+extern void __gnat_last_socket_in_set PARAMS ((fd_set *, int *));
+extern void __gnat_get_socket_from_set PARAMS ((fd_set *, int *, int *));
+extern void __gnat_insert_socket_in_set PARAMS ((fd_set *, int));
+extern int __gnat_is_socket_in_set PARAMS ((fd_set *, int));
+extern fd_set *__gnat_new_socket_set PARAMS ((fd_set *));
+extern void __gnat_remove_socket_from_set PARAMS ((fd_set *, int));
+
+/* Free socket set. */
+
+void
+__gnat_free_socket_set (set)
+ fd_set *set;
+{
+ __gnat_free (set);
+}
+
+/* Find the largest socket in the socket set SET. This is needed for
+ `select'. LAST is the maximum value for the largest socket. This hint is
+ used to avoid scanning very large socket sets. On return, LAST is the
+ actual largest socket in the socket set. */
+
+void
+__gnat_last_socket_in_set (set, last)
+ fd_set *set;
+ int *last;
+{
+ int s;
+ int l;
+ l = -1;
+
+#ifdef WINNT
+ /* More efficient method for NT. */
+ for (s = 0; s < set->fd_count; s++)
+ if ((int) set->fd_array[s] > l)
+ l = set->fd_array[s];
+
+#else
+
+ for (s = *last; s != -1; s--)
+ if (FD_ISSET (s, set))
+ {
+ l = s;
+ break;
+ }
+#endif
+
+ *last = l;
+}
+
+/* Get last socket and remove it from the socket set SET. LAST is the
+ maximum value of the largest socket. This hint is used to avoid scanning
+ very large socket sets. On return, LAST is set to the actual largest
+ socket in the socket set. */
+
+void
+__gnat_get_socket_from_set (set, last, socket)
+ fd_set *set;
+ int *last;
+ int *socket;
+{
+ *socket = *last;
+ FD_CLR (*socket, set);
+ __gnat_last_socket_in_set (set, last);
+}
+
+/* Insert SOCKET in the socket set SET. */
+
+void
+__gnat_insert_socket_in_set (set, socket)
+ fd_set *set;
+ int socket;
+{
+ FD_SET (socket, set);
+}
+
+/* Check whether a given SOCKET is in the socket set SET. */
+
+int
+__gnat_is_socket_in_set (set, socket)
+ fd_set *set;
+ int socket;
+{
+ return FD_ISSET (socket, set);
+}
+
+/* Allocate a new socket set and set it as empty. */
+
+fd_set *
+__gnat_new_socket_set (set)
+ fd_set *set;
+{
+ fd_set *new;
+
+ new = (fd_set *) __gnat_malloc (sizeof (fd_set));
+
+ if (set)
+ memcpy (new, set, sizeof (fd_set));
+ else
+ FD_ZERO (new);
+
+ return new;
+}
+
+/* Remove SOCKET from the socket set SET. */
+
+void
+__gnat_remove_socket_from_set (set, socket)
+ fd_set *set;
+ int socket;
+{
+ FD_CLR (socket, set);
+}
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index 4d1b4a4ac0b..0cb991802e4 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -186,7 +186,7 @@ package body Sprint is
-- Write Condition and Reason codes of Raise_xxx_Error node
procedure Write_Discr_Specs (N : Node_Id);
- -- Output discriminant specification for node, which is any of the type
+ -- Ouput discriminant specification for node, which is any of the type
-- declarations that can have discriminants.
procedure Write_Ekind (E : Entity_Id);
@@ -1232,9 +1232,14 @@ package body Sprint is
Write_Char (';');
+ when N_Expanded_Name =>
+ Sprint_Node (Prefix (Node));
+ Write_Char_Sloc ('.');
+ Sprint_Node (Selector_Name (Node));
+
when N_Explicit_Dereference =>
Sprint_Node (Prefix (Node));
- Write_Char ('.');
+ Write_Char_Sloc ('.');
Write_Str_Sloc ("all");
when N_Extension_Aggregate =>
@@ -1653,49 +1658,28 @@ package body Sprint is
end if;
when N_Object_Declaration =>
+ Set_Debug_Sloc;
- -- Put extra blank line before and after if this is a handler
- -- record or a subprogram descriptor.
-
- declare
- Typ : constant Entity_Id := Etype (Defining_Identifier (Node));
- Exc : constant Boolean :=
- Is_RTE (Typ, RE_Handler_Record)
- or else
- Is_RTE (Typ, RE_Subprogram_Descriptor);
+ if Write_Indent_Identifiers (Node) then
+ Write_Str (" : ");
- begin
- if Exc then
- Write_Indent;
+ if Aliased_Present (Node) then
+ Write_Str_With_Col_Check ("aliased ");
end if;
- Set_Debug_Sloc;
-
- if Write_Indent_Identifiers (Node) then
- Write_Str (" : ");
-
- if Aliased_Present (Node) then
- Write_Str_With_Col_Check ("aliased ");
- end if;
-
- if Constant_Present (Node) then
- Write_Str_With_Col_Check ("constant ");
- end if;
-
- Sprint_Node (Object_Definition (Node));
+ if Constant_Present (Node) then
+ Write_Str_With_Col_Check ("constant ");
+ end if;
- if Present (Expression (Node)) then
- Write_Str (" := ");
- Sprint_Node (Expression (Node));
- end if;
+ Sprint_Node (Object_Definition (Node));
- Write_Char (';');
+ if Present (Expression (Node)) then
+ Write_Str (" := ");
+ Sprint_Node (Expression (Node));
end if;
- if Exc then
- Write_Indent;
- end if;
- end;
+ Write_Char (';');
+ end if;
when N_Object_Renaming_Declaration =>
Write_Indent;
@@ -2243,7 +2227,7 @@ package body Sprint is
Write_Char (';');
- when N_Selected_Component | N_Expanded_Name =>
+ when N_Selected_Component =>
Sprint_Node (Prefix (Node));
Write_Char_Sloc ('.');
Sprint_Node (Selector_Name (Node));
diff --git a/gcc/ada/stringt.adb b/gcc/ada/stringt.adb
index 9b2bb57e32f..5f6fd969cba 100644
--- a/gcc/ada/stringt.adb
+++ b/gcc/ada/stringt.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -358,8 +358,12 @@ package body Stringt is
procedure Write_Hex_Byte (J : Natural);
-- Write single hex digit
+ --------------------
+ -- Write_Hex_Byte --
+ --------------------
+
procedure Write_Hex_Byte (J : Natural) is
- Hexd : String := "0123456789abcdef";
+ Hexd : constant String := "0123456789abcdef";
begin
Write_Char (Hexd (J / 16 + 1));
diff --git a/gcc/ada/stringt.ads b/gcc/ada/stringt.ads
index ca68c259347..8453ab5697a 100644
--- a/gcc/ada/stringt.ads
+++ b/gcc/ada/stringt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -99,6 +99,7 @@ package Stringt is
-- Returns length of previously stored string
function Get_String_Char (Id : String_Id; Index : Int) return Char_Code;
+ pragma Inline (Get_String_Char);
-- Obtains the specified character from a stored string. The lower bound
-- of stored strings is always 1, so the range is 1 .. String_Length (Id).
diff --git a/gcc/ada/stringt.h b/gcc/ada/stringt.h
index 88bdc9b8a4a..68b02bdaebc 100644
--- a/gcc/ada/stringt.h
+++ b/gcc/ada/stringt.h
@@ -6,7 +6,6 @@
* *
* C Header File *
* *
- * *
* Copyright (C) 1992-2001 Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
diff --git a/gcc/ada/style.ads b/gcc/ada/style.ads
index 7d59b557997..c86f704e253 100644
--- a/gcc/ada/style.ads
+++ b/gcc/ada/style.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,125 +29,176 @@
-- a separate package so that they can more easily be customized. Calls
-- to these subprograms are only made if Opt.Style_Check is set True.
+with Errout;
+with Styleg;
+with Styleg.C;
with Types; use Types;
package Style is
- procedure Body_With_No_Spec (N : Node_Id);
+ package Style_Inst is new Styleg
+ (Errout.Error_Msg,
+ Errout.Error_Msg_S,
+ Errout.Error_Msg_SC,
+ Errout.Error_Msg_SP);
+ -- Instantiation of Styleg for all subprograms that do not depend directly
+ -- depend on the GNAT tree.
+
+ package Style_C_Inst is new Style_Inst.C
+ (Errout.Error_Msg_N);
+ -- Instantiation of Styleg.C for the subprograms that depend directly
+ -- on the GNAT tree.
+
+ -- All subroutines below are renames of subroutines in the two
+ -- instantiations above.
+
+ procedure Body_With_No_Spec (N : Node_Id)
+ renames Style_C_Inst.Body_With_No_Spec;
-- Called where N is a subprogram body node for a subprogram body
-- for which no spec was given, i.e. a body acting as its own spec.
- procedure Check_Abs_Not;
+ procedure Check_Abs_Not
+ renames Style_Inst.Check_Abs_Not;
-- Called after scanning an ABS or NOT operator to check spacing
- procedure Check_Arrow;
+ procedure Check_Apostrophe
+ renames Style_Inst.Check_Apostrophe;
+ -- Called after scanning an apostrophe to check spacing
+
+ procedure Check_Arrow
+ renames Style_Inst.Check_Arrow;
-- Called after scanning out an arrow to check spacing
- procedure Check_Attribute_Name (Reserved : Boolean);
- -- The current token is an attribute designator. Check that it is
- -- capitalized in an appropriate manner. Reserved is set if the
- -- attribute designator is a reserved word (access, digits, delta
- -- or range) to allow differing rules for the two cases.
+ procedure Check_Attribute_Name (Reserved : Boolean)
+ renames Style_Inst.Check_Attribute_Name;
+ -- The current token is an attribute designator. Check that it
+ -- is capitalized in an appropriate manner. Reserved is set if
+ -- the attribute designator is a reserved word (access, digits,
+ -- delta or range) to allow differing rules for the two cases.
- procedure Check_Box;
+ procedure Check_Box
+ renames Style_Inst.Check_Box;
-- Called after scanning out a box to check spacing
- procedure Check_Binary_Operator;
+ procedure Check_Binary_Operator
+ renames Style_Inst.Check_Binary_Operator;
-- Called after scanning out a binary operator other than a plus, minus
-- or exponentiation operator. Intended for checking spacing rules.
- procedure Check_Exponentiation_Operator;
+ procedure Check_Exponentiation_Operator
+ renames Style_Inst.Check_Exponentiation_Operator;
-- Called after scanning out an exponentiation operator. Intended for
-- checking spacing rules.
- procedure Check_Colon;
+ procedure Check_Colon
+ renames Style_Inst.Check_Colon;
-- Called after scanning out colon to check spacing
- procedure Check_Colon_Equal;
+ procedure Check_Colon_Equal
+ renames Style_Inst.Check_Colon_Equal;
-- Called after scanning out colon equal to check spacing
- procedure Check_Comma;
+ procedure Check_Comma
+ renames Style_Inst.Check_Comma;
-- Called after scanning out comma to check spacing
- procedure Check_Comment;
+ procedure Check_Comment
+ renames Style_Inst.Check_Comment;
-- Called with Scan_Ptr pointing to the first minus sign of a comment.
-- Intended for checking any specific rules for comment placement/format.
- procedure Check_Dot_Dot;
+ procedure Check_Dot_Dot
+ renames Style_Inst.Check_Dot_Dot;
-- Called after scanning out dot dot to check spacing
- procedure Check_HT;
+ procedure Check_HT
+ renames Style_Inst.Check_HT;
-- Called with Scan_Ptr pointing to a horizontal tab character
procedure Check_Identifier
(Ref : Node_Or_Entity_Id;
- Def : Node_Or_Entity_Id);
+ Def : Node_Or_Entity_Id)
+ renames Style_C_Inst.Check_Identifier;
-- Check style of identifier occurrence. Ref is an N_Identifier node whose
-- spelling is to be checked against the Chars spelling in identifier node
-- Def (which may be either an N_Identifier, or N_Defining_Identifier node)
- procedure Check_Indentation;
+ procedure Check_Indentation
+ renames Style_Inst.Check_Indentation;
-- Called at the start of a new statement or declaration, with Token_Ptr
-- pointing to the first token of the statement or declaration. The check
-- is that the starting column is appropriate to the indentation rules if
-- Token_Ptr is the first token on the line.
- procedure Check_Left_Paren;
+ procedure Check_Left_Paren
+ renames Style_Inst.Check_Left_Paren;
-- Called after scanning out a left parenthesis to check spacing.
- procedure Check_Line_Terminator (Len : Int);
+ procedure Check_Line_Terminator (Len : Int)
+ renames Style_Inst.Check_Line_Terminator;
-- Called with Scan_Ptr pointing to the first line terminator terminating
-- the current line, used to check for appropriate line terminator and
-- to check the line length (Len is the length of the current line).
-- Note that the terminator may be the EOF character.
- procedure Check_Pragma_Name;
+ procedure Check_Pragma_Name
+ renames Style_Inst.Check_Pragma_Name;
-- The current token is a pragma identifier. Check that it is spelled
-- properly (i.e. with an appropriate casing convention).
- procedure Check_Right_Paren;
+ procedure Check_Right_Paren
+ renames Style_Inst.Check_Right_Paren;
-- Called after scanning out a right parenthesis to check spacing.
- procedure Check_Semicolon;
+ procedure Check_Semicolon
+ renames Style_Inst.Check_Semicolon;
-- Called after scanning out a semicolon to check spacing
- procedure Check_Then (If_Loc : Source_Ptr);
+ procedure Check_Then (If_Loc : Source_Ptr)
+ renames Style_Inst.Check_Then;
-- Called to check that THEN and IF keywords are appropriately positioned.
-- The parameters show the first characters of the two keywords. This
-- procedure is called only if THEN appears at the start of a line with
-- Token_Ptr pointing to the THEN keyword.
- procedure Check_Unary_Plus_Or_Minus;
+ procedure Check_Unary_Plus_Or_Minus
+ renames Style_Inst.Check_Unary_Plus_Or_Minus;
-- Called after scanning a unary plus or minus to check spacing
- procedure Check_Vertical_Bar;
+ procedure Check_Vertical_Bar
+ renames Style_Inst.Check_Vertical_Bar;
-- Called after scanning a vertical bar to check spacing
- procedure No_End_Name (Name : Node_Id);
+ procedure No_End_Name (Name : Node_Id)
+ renames Style_Inst.No_End_Name;
-- Called if an END is encountered where a name is allowed but not present.
-- The parameter is the node whose name is the name that is permitted in
-- the END line, and the scan pointer is positioned so that if an error
-- message is to be generated in this situation, it should be generated
-- using Error_Msg_SP.
- procedure No_Exit_Name (Name : Node_Id);
+ procedure No_Exit_Name (Name : Node_Id)
+ renames Style_Inst.No_Exit_Name;
-- Called when exiting a named loop, but a name is not present on the EXIT.
-- The parameter is the node whose name should have followed EXIT, and the
-- scan pointer is positioned so that if an error message is to be
-- generated, it should be generated using Error_Msg_SP.
- procedure Non_Lower_Case_Keyword;
+ procedure Non_Lower_Case_Keyword
+ renames Style_Inst.Non_Lower_Case_Keyword;
-- Called if a reserved keyword is scanned which is not spelled in all
-- lower case letters. On entry Token_Ptr points to the keyword token.
-- This is not used for keywords appearing as attribute designators,
-- where instead Check_Attribute_Name (True) is called.
- function RM_Column_Check return Boolean;
+ function RM_Column_Check return Boolean
+ renames Style_Inst.RM_Column_Check;
pragma Inline (RM_Column_Check);
-- Determines whether style checking is active and the RM column check
-- mode is set requiring checking of RM format layout.
- procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id);
+ procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id)
+ renames Style_C_Inst.Subprogram_Not_In_Alpha_Order;
-- Called if Name is the name of a subprogram body in a package body
-- that is not in alphabetical order.
diff --git a/gcc/ada/styleg-c.adb b/gcc/ada/styleg-c.adb
new file mode 100644
index 00000000000..99e3f09c7b9
--- /dev/null
+++ b/gcc/ada/styleg-c.adb
@@ -0,0 +1,225 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T Y L E G . C --
+-- --
+-- B o d y --
+-- --
+-- 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Atree; use Atree;
+with Casing; use Casing;
+with Csets; use Csets;
+with Einfo; use Einfo;
+with Err_Vars; use Err_Vars;
+with Namet; use Namet;
+with Sinfo; use Sinfo;
+with Sinput; use Sinput;
+with Stand; use Stand;
+with Stylesw; use Stylesw;
+
+package body Styleg.C is
+
+ -----------------------
+ -- Body_With_No_Spec --
+ -----------------------
+
+ -- If the check specs mode (-gnatys) is set, then all subprograms must
+ -- have specs unless they are parameterless procedures that are not child
+ -- units at the library level (i.e. they are possible main programs).
+
+ procedure Body_With_No_Spec (N : Node_Id) is
+ begin
+ if Style_Check_Specs then
+ if Nkind (Parent (N)) = N_Compilation_Unit then
+ declare
+ Spec : constant Node_Id := Specification (N);
+ Defnm : constant Node_Id := Defining_Unit_Name (Spec);
+
+ begin
+ if Nkind (Spec) = N_Procedure_Specification
+ and then Nkind (Defnm) = N_Defining_Identifier
+ and then No (First_Formal (Defnm))
+ then
+ return;
+ end if;
+ end;
+ end if;
+
+ Error_Msg_N ("(style): subprogram body has no previous spec", N);
+ end if;
+ end Body_With_No_Spec;
+
+ ----------------------
+ -- Check_Identifier --
+ ----------------------
+
+ -- In check references mode (-gnatyr), identifier uses must be cased
+ -- the same way as the corresponding identifier declaration.
+
+ procedure Check_Identifier
+ (Ref : Node_Or_Entity_Id;
+ Def : Node_Or_Entity_Id)
+ is
+ Sref : Source_Ptr := Sloc (Ref);
+ Sdef : Source_Ptr := Sloc (Def);
+ Tref : Source_Buffer_Ptr;
+ Tdef : Source_Buffer_Ptr;
+ Nlen : Nat;
+ Cas : Casing_Type;
+
+ begin
+ -- If reference does not come from source, nothing to check
+
+ if not Comes_From_Source (Ref) then
+ return;
+
+ -- If previous error on either node/entity, ignore
+
+ elsif Error_Posted (Ref) or else Error_Posted (Def) then
+ return;
+
+ -- Case of definition comes from source
+
+ elsif Comes_From_Source (Def) then
+
+ -- Check same casing if we are checking references
+
+ if Style_Check_References then
+ Tref := Source_Text (Get_Source_File_Index (Sref));
+ Tdef := Source_Text (Get_Source_File_Index (Sdef));
+
+ -- Ignore operator name case completely. This also catches the
+ -- case of where one is an operator and the other is not. This
+ -- is a phenomenon from rewriting of operators as functions,
+ -- and is to be ignored.
+
+ if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then
+ return;
+
+ else
+ while Tref (Sref) = Tdef (Sdef) loop
+
+ -- If end of identifier, all done
+
+ if not Identifier_Char (Tref (Sref)) then
+ return;
+
+ -- Otherwise loop continues
+
+ else
+ Sref := Sref + 1;
+ Sdef := Sdef + 1;
+ end if;
+ end loop;
+
+ -- Fall through loop when mismatch between identifiers
+ -- If either identifier is not terminated, error.
+
+ if Identifier_Char (Tref (Sref))
+ or else
+ Identifier_Char (Tdef (Sdef))
+ then
+ Error_Msg_Node_1 := Def;
+ Error_Msg_Sloc := Sloc (Def);
+ Error_Msg
+ ("(style) bad casing of & declared#", Sref);
+ return;
+
+ -- Else end of identifiers, and they match
+
+ else
+ return;
+ end if;
+ end if;
+ end if;
+
+ -- Case of definition in package Standard
+
+ elsif Sdef = Standard_Location then
+
+ -- Check case of identifiers in Standard
+
+ if Style_Check_Standard then
+ Tref := Source_Text (Get_Source_File_Index (Sref));
+
+ -- Ignore operators
+
+ if Tref (Sref) = '"' then
+ null;
+
+ -- Otherwise determine required casing of Standard entity
+
+ else
+ -- ASCII entities are in all upper case
+
+ if Entity (Ref) = Standard_ASCII then
+ Cas := All_Upper_Case;
+
+ -- Special names in ASCII are also all upper case
+
+ elsif Entity (Ref) in SE (S_LC_A) .. SE (S_LC_Z)
+ or else
+ Entity (Ref) in SE (S_NUL) .. SE (S_US)
+ or else
+ Entity (Ref) = SE (S_DEL)
+ then
+ Cas := All_Upper_Case;
+
+ -- All other entities are in mixed case
+
+ else
+ Cas := Mixed_Case;
+ end if;
+
+ Nlen := Length_Of_Name (Chars (Ref));
+
+ -- Now check if we have the right casing
+
+ if Determine_Casing
+ (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)) = Cas
+ then
+ null;
+ else
+ Name_Len := Integer (Nlen);
+ Name_Buffer (1 .. Name_Len) :=
+ String (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1));
+ Set_Casing (Cas);
+ Error_Msg_Name_1 := Name_Enter;
+ Error_Msg_N
+ ("(style) bad casing of { declared in Standard", Ref);
+ end if;
+ end if;
+ end if;
+ end if;
+ end Check_Identifier;
+
+ -----------------------------------
+ -- Subprogram_Not_In_Alpha_Order --
+ -----------------------------------
+
+ procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
+ begin
+ if Style_Check_Subprogram_Order then
+ Error_Msg_N
+ ("(style) subprogram body& not in alphabetical order", Name);
+ end if;
+ end Subprogram_Not_In_Alpha_Order;
+end Styleg.C;
diff --git a/gcc/ada/styleg-c.ads b/gcc/ada/styleg-c.ads
new file mode 100644
index 00000000000..6a85ca601f6
--- /dev/null
+++ b/gcc/ada/styleg-c.ads
@@ -0,0 +1,54 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T Y L E G . C --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This generic package, instantiated in package Style, contains routines
+-- used by the compiler for style checking. These routines are in a separate
+-- package because they depend on the GNAT tree (Atree, Sinfo, ...).
+
+with Types; use Types;
+
+generic
+ with procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id);
+ -- Output a message at the Sloc of the given node
+
+package Styleg.C is
+
+ procedure Body_With_No_Spec (N : Node_Id);
+ -- Called where N is a subprogram body node for a subprogram body
+ -- for which no spec was given, i.e. a body acting as its own spec.
+
+ procedure Check_Identifier
+ (Ref : Node_Or_Entity_Id;
+ Def : Node_Or_Entity_Id);
+ -- Check style of identifier occurrence. Ref is an N_Identifier node whose
+ -- spelling is to be checked against the Chars spelling in identifier node
+ -- Def (which may be either an N_Identifier, or N_Defining_Identifier node)
+
+ procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id);
+ -- Called if Name is the name of a subprogram body in a package body
+ -- that is not in alphabetical order.
+
+end Styleg.C;
diff --git a/gcc/ada/style.adb b/gcc/ada/styleg.adb
index a693569bb71..e382daffd78 100644
--- a/gcc/ada/style.adb
+++ b/gcc/ada/styleg.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- S T Y L E --
+-- S T Y L E G --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -28,26 +28,33 @@
-- checking rules. For documentation of these rules, see comments on the
-- individual procedures.
-with Atree; use Atree;
-with Casing; use Casing;
+with Casing; use Casing;
with Csets; use Csets;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Namet; use Namet;
+with Err_Vars; use Err_Vars;
with Opt; use Opt;
-with Scn; use Scn;
with Scans; use Scans;
-with Sinfo; use Sinfo;
with Sinput; use Sinput;
-with Stand; use Stand;
with Stylesw; use Stylesw;
-package body Style is
+package body Styleg is
+
+ use ASCII;
-----------------------
-- Local Subprograms --
-----------------------
+ procedure Check_No_Space_After;
+ -- Checks that there is a non-white space character after the current
+ -- token, or white space followed by a comment, or the end of line.
+ -- Issue error message if not.
+
+ procedure Check_No_Space_Before;
+ -- Check that token is first token on line, or else is not preceded
+ -- by white space. Signal error of space not allowed if not.
+
+ function Determine_Token_Casing return Casing_Type;
+
procedure Error_Space_Not_Allowed (S : Source_Ptr);
-- Posts an error message indicating that a space is not allowed
-- at the given source location.
@@ -56,6 +63,10 @@ package body Style is
-- Posts an error message indicating that a space is required at
-- the given source location.
+ function Is_White_Space (C : Character) return Boolean;
+ pragma Inline (Is_White_Space);
+ -- Returns True for space, HT, VT or FF, False otherwise
+
procedure Require_Following_Space;
pragma Inline (Require_Following_Space);
-- Require token to be followed by white space. Used only if in GNAT
@@ -66,36 +77,6 @@ package body Style is
-- Require token to be preceded by white space. Used only if in GNAT
-- style checking mode.
- -----------------------
- -- Body_With_No_Spec --
- -----------------------
-
- -- If the check specs mode (-gnatys) is set, then all subprograms must
- -- have specs unless they are parameterless procedures that are not child
- -- units at the library level (i.e. they are possible main programs).
-
- procedure Body_With_No_Spec (N : Node_Id) is
- begin
- if Style_Check_Specs then
- if Nkind (Parent (N)) = N_Compilation_Unit then
- declare
- Spec : constant Node_Id := Specification (N);
- Defnm : constant Node_Id := Defining_Unit_Name (Spec);
-
- begin
- if Nkind (Spec) = N_Procedure_Specification
- and then Nkind (Defnm) = N_Defining_Identifier
- and then No (First_Formal (Defnm))
- then
- return;
- end if;
- end;
- end if;
-
- Error_Msg_N ("(style): subprogram body has no previous spec", N);
- end if;
- end Body_With_No_Spec;
-
----------------------
-- Check_Abs_Or_Not --
----------------------
@@ -111,6 +92,19 @@ package body Style is
end if;
end Check_Abs_Not;
+ ----------------------
+ -- Check_Apostrophe --
+ ----------------------
+
+ -- Do not allow space before or after apostrophe
+
+ procedure Check_Apostrophe is
+ begin
+ if Style_Check_Tokens then
+ Check_No_Space_After;
+ end if;
+ end Check_Apostrophe;
+
-----------------
-- Check_Arrow --
-----------------
@@ -215,11 +209,7 @@ package body Style is
procedure Check_Comma is
begin
if Style_Check_Tokens then
- if Token_Ptr > First_Non_Blank_Location
- and then Source (Token_Ptr - 1) = ' '
- then
- Error_Space_Not_Allowed (Token_Ptr - 1);
- end if;
+ Check_No_Space_Before;
if Source (Scan_Ptr) > ' ' then
Error_Space_Required (Scan_Ptr);
@@ -254,11 +244,37 @@ package body Style is
-- range 16#21#..16#2F# or 16#3A#..16#3F#. This allows special
-- comments, such as those generated by gnatprep, or those that
-- appear in the SPARK annotation language to be accepted.
+ --
+ -- Note: for GNAT internal files (-gnatg switch set on for the
+ -- compilation), the only special sequence recognized and allowed
+ -- is --! as generated by gnatprep.
procedure Check_Comment is
S : Source_Ptr;
C : Character;
+ function Is_Box_Comment return Boolean;
+ -- Returns True if the last two characters on the line are -- which
+ -- characterizes a box comment (as for example follows this spec).
+
+ --------------------
+ -- Is_Box_Comment --
+ --------------------
+
+ function Is_Box_Comment return Boolean is
+ S : Source_Ptr;
+
+ begin
+ S := Scan_Ptr + 3;
+ while Source (S) not in Line_Terminator loop
+ S := S + 1;
+ end loop;
+
+ return Source (S - 1) = '-' and then Source (S - 2) = '-';
+ end Is_Box_Comment;
+
+ -- Start of processing for Check_Comment
+
begin
-- Can never have a non-blank character preceding the first minus
@@ -295,45 +311,60 @@ package body Style is
end if;
end if;
- -- Now check form of the comment
+ -- If we are not checking comments, nothing to do
if not Style_Check_Comments then
return;
+ end if;
-- Case of not followed by a blank. Usually wrong, but there are
-- some exceptions that we permit.
- elsif Source (Scan_Ptr + 2) /= ' ' then
+ if Source (Scan_Ptr + 2) /= ' ' then
C := Source (Scan_Ptr + 2);
-- Case of -- all on its own on a line is OK
if C < ' ' then
return;
+ end if;
-- Case of --x, x special character is OK (gnatprep/SPARK/etc.)
+ -- This is not permitted in internal GNAT implementation units
+ -- except for the case of --! as used by gnatprep output.
+
+ if GNAT_Mode then
+ if C = '!' then
+ return;
+ end if;
- elsif Character'Pos (C) in 16#21# .. 16#2F#
+ else
+ if Character'Pos (C) in 16#21# .. 16#2F#
or else
Character'Pos (C) in 16#3A# .. 16#3F#
- then
- return;
-
- -- Otherwise only cases allowed are when the entire line is
- -- made up of minus signs (case of a box comment).
+ then
+ return;
+ end if;
+ end if;
- else
- S := Scan_Ptr + 2;
+ -- The only other case in which we allow a character after
+ -- the -- other than a space is when we have a row of minus
+ -- signs (case of header lines for a box comment for example).
- while Source (S) >= ' ' loop
- if Source (S) /= '-' then
+ S := Scan_Ptr + 2;
+ while Source (S) >= ' ' loop
+ if Source (S) /= '-' then
+ if Is_Box_Comment then
Error_Space_Required (Scan_Ptr + 2);
- return;
+ else
+ Error_Msg ("(style) two spaces required", Scan_Ptr + 2);
end if;
- S := S + 1;
- end loop;
- end if;
+ return;
+ end if;
+
+ S := S + 1;
+ end loop;
-- If we are followed by a blank, then the comment is OK if the
-- character following this blank is another blank or a format
@@ -342,20 +373,12 @@ package body Style is
elsif Source (Scan_Ptr + 3) <= ' ' then
return;
- -- Here is the case where we only have one blank after the two minus
- -- signs, which is an error unless the line ends with two blanks, the
- -- case of a box comment.
-
- else
- S := Scan_Ptr + 3;
-
- while Source (S) not in Line_Terminator loop
- S := S + 1;
- end loop;
+ -- Here is the case where we only have one blank after the two
+ -- minus signs, which is an error unless the line ends with two
+ -- minus signs, the case of a box comment.
- if Source (S - 1) /= '-' or else Source (S - 2) /= '-' then
- Error_Space_Required (Scan_Ptr + 3);
- end if;
+ elsif not Is_Box_Comment then
+ Error_Space_Required (Scan_Ptr + 3);
end if;
end if;
end Check_Comment;
@@ -398,132 +421,6 @@ package body Style is
end if;
end Check_HT;
- ----------------------
- -- Check_Identifier --
- ----------------------
-
- -- In check references mode (-gnatyr), identifier uses must be cased
- -- the same way as the corresponding identifier declaration.
-
- procedure Check_Identifier
- (Ref : Node_Or_Entity_Id;
- Def : Node_Or_Entity_Id)
- is
- Sref : Source_Ptr := Sloc (Ref);
- Sdef : Source_Ptr := Sloc (Def);
- Tref : Source_Buffer_Ptr;
- Tdef : Source_Buffer_Ptr;
- Nlen : Nat;
- Cas : Casing_Type;
-
- begin
- -- If reference does not come from source, nothing to check
-
- if not Comes_From_Source (Ref) then
- return;
-
- -- Case of definition comes from source
-
- elsif Comes_From_Source (Def) then
-
- -- Check same casing if we are checking references
-
- if Style_Check_References then
- Tref := Source_Text (Get_Source_File_Index (Sref));
- Tdef := Source_Text (Get_Source_File_Index (Sdef));
-
- -- Ignore operator name case completely. This also catches the
- -- case of where one is an operator and the other is not. This
- -- is a phenomenon from rewriting of operators as functions,
- -- and is to be ignored.
-
- if Tref (Sref) = '"' or else Tdef (Sdef) = '"' then
- return;
-
- else
- while Tref (Sref) = Tdef (Sdef) loop
-
- -- If end of identifier, all done
-
- if not Identifier_Char (Tref (Sref)) then
- return;
-
- -- Otherwise loop continues
-
- else
- Sref := Sref + 1;
- Sdef := Sdef + 1;
- end if;
- end loop;
-
- -- Fall through loop when mismatch between identifiers
- -- If either identifier is not terminated, error.
-
- if Identifier_Char (Tref (Sref))
- or else
- Identifier_Char (Tdef (Sdef))
- then
- Error_Msg_Node_1 := Def;
- Error_Msg_Sloc := Sloc (Def);
- Error_Msg
- ("(style) bad casing of & declared#", Sref);
- return;
-
- -- Else end of identifiers, and they match
-
- else
- return;
- end if;
- end if;
- end if;
-
- -- Case of definition in package Standard
-
- elsif Sdef = Standard_Location then
-
- -- Check case of identifiers in Standard
-
- if Style_Check_Standard then
- Tref := Source_Text (Get_Source_File_Index (Sref));
-
- -- Ignore operators
-
- if Tref (Sref) = '"' then
- null;
-
- -- Special case of ASCII
-
- else
- if Entity (Ref) = Standard_ASCII then
- Cas := All_Upper_Case;
-
- elsif Entity (Ref) in SE (S_LC_A) .. SE (S_LC_Z)
- or else
- Entity (Ref) in SE (S_NUL) .. SE (S_US)
- or else
- Entity (Ref) = SE (S_DEL)
- then
- Cas := All_Upper_Case;
-
- else
- Cas := Mixed_Case;
- end if;
-
- Nlen := Length_Of_Name (Chars (Ref));
-
- if Determine_Casing
- (Tref (Sref .. Sref + Source_Ptr (Nlen) - 1)) = Cas
- then
- null;
- else
- Error_Msg_N
- ("(style) bad casing for entity in Standard", Ref);
- end if;
- end if;
- end if;
- end if;
- end Check_Identifier;
-
-----------------------
-- Check_Indentation --
-----------------------
@@ -552,8 +449,6 @@ package body Style is
-- may never be followed by a space.
procedure Check_Left_Paren is
- S : Source_Ptr;
-
begin
if Style_Check_Tokens then
if Token_Ptr > Source_First (Current_Source_File)
@@ -562,23 +457,7 @@ package body Style is
Error_Space_Required (Token_Ptr);
end if;
- if Source (Scan_Ptr) = ' ' then
-
- -- Allow one or more spaces if followed by comment
-
- S := Scan_Ptr + 1;
- loop
- if Source (S) = '-' and then Source (S + 1) = '-' then
- return;
- elsif Source (S) /= ' ' then
- exit;
- else
- S := S + 1;
- end if;
- end loop;
-
- Error_Space_Not_Allowed (Scan_Ptr);
- end if;
+ Check_No_Space_After;
end if;
end Check_Left_Paren;
@@ -610,14 +489,25 @@ package body Style is
end if;
end if;
+ -- We are now possibly going to check for trailing spaces and maximum
+ -- line length. There is no point in doing this if the current line is
+ -- empty. It is actually wrong in the case of trailing spaces, because
+ -- we scan backwards for this purpose, so we would end up looking at a
+ -- different line, or even at invalid buffer locations if we have the
+ -- first source line at hand.
+
+ if Len = 0 then
+ return;
+ end if;
+
-- Check trailing space
if Style_Check_Blanks_At_End then
if Scan_Ptr >= First_Non_Blank_Location then
- if Source (Scan_Ptr - 1) = ' ' then
+ if Is_White_Space (Source (Scan_Ptr - 1)) then
S := Scan_Ptr - 1;
- while Source (S - 1) = ' ' loop
+ while Is_White_Space (Source (S - 1)) loop
S := S - 1;
end loop;
@@ -638,6 +528,48 @@ package body Style is
end Check_Line_Terminator;
+ --------------------------
+ -- Check_No_Space_After --
+ --------------------------
+
+ procedure Check_No_Space_After is
+ S : Source_Ptr;
+
+ begin
+ if Is_White_Space (Source (Scan_Ptr)) then
+
+ -- Allow one or more spaces if followed by comment
+
+ S := Scan_Ptr + 1;
+ loop
+ if Source (S) = '-' and then Source (S + 1) = '-' then
+ return;
+
+ elsif Is_White_Space (Source (S)) then
+ S := S + 1;
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ Error_Space_Not_Allowed (Scan_Ptr);
+ end if;
+ end Check_No_Space_After;
+
+ ---------------------------
+ -- Check_No_Space_Before --
+ ---------------------------
+
+ procedure Check_No_Space_Before is
+ begin
+ if Token_Ptr > First_Non_Blank_Location
+ and then Source (Token_Ptr - 1) <= ' '
+ then
+ Error_Space_Not_Allowed (Token_Ptr - 1);
+ end if;
+ end Check_No_Space_Before;
+
-----------------------
-- Check_Pragma_Name --
-----------------------
@@ -665,11 +597,7 @@ package body Style is
procedure Check_Right_Paren is
begin
if Style_Check_Tokens then
- if Token_Ptr > First_Non_Blank_Location
- and then Source (Token_Ptr - 1) = ' '
- then
- Error_Space_Not_Allowed (Token_Ptr - 1);
- end if;
+ Check_No_Space_Before;
end if;
end Check_Right_Paren;
@@ -683,12 +611,9 @@ package body Style is
procedure Check_Semicolon is
begin
if Style_Check_Tokens then
- if Scan_Ptr > Source_First (Current_Source_File)
- and then Source (Token_Ptr - 1) = ' '
- then
- Error_Space_Not_Allowed (Token_Ptr - 1);
+ Check_No_Space_Before;
- elsif Source (Scan_Ptr) > ' ' then
+ if Source (Scan_Ptr) > ' ' then
Error_Space_Required (Scan_Ptr);
end if;
end if;
@@ -724,9 +649,7 @@ package body Style is
procedure Check_Unary_Plus_Or_Minus is
begin
if Style_Check_Tokens then
- if Source (Scan_Ptr) = ' ' then
- Error_Space_Not_Allowed (Scan_Ptr);
- end if;
+ Check_No_Space_After;
end if;
end Check_Unary_Plus_Or_Minus;
@@ -744,6 +667,15 @@ package body Style is
end if;
end Check_Vertical_Bar;
+ ----------------------------
+ -- Determine_Token_Casing --
+ ----------------------------
+
+ function Determine_Token_Casing return Casing_Type is
+ begin
+ return Determine_Casing (Source (Token_Ptr .. Scan_Ptr - 1));
+ end Determine_Token_Casing;
+
-----------------------------
-- Error_Space_Not_Allowed --
-----------------------------
@@ -762,6 +694,15 @@ package body Style is
Error_Msg ("(style) space required", S);
end Error_Space_Required;
+ --------------------
+ -- Is_White_Space --
+ --------------------
+
+ function Is_White_Space (C : Character) return Boolean is
+ begin
+ return C = ' ' or else C = HT;
+ end Is_White_Space;
+
-----------------
-- No_End_Name --
-----------------
@@ -840,15 +781,4 @@ package body Style is
return Style_Check and Style_Check_Layout;
end RM_Column_Check;
- -----------------------------------
- -- Subprogram_Not_In_Alpha_Order --
- -----------------------------------
-
- procedure Subprogram_Not_In_Alpha_Order (Name : Node_Id) is
- begin
- if Style_Check_Subprogram_Order then
- Error_Msg_N
- ("(style) subprogram body& not in alphabetical order", Name);
- end if;
- end Subprogram_Not_In_Alpha_Order;
-end Style;
+end Styleg;
diff --git a/gcc/ada/styleg.ads b/gcc/ada/styleg.ads
new file mode 100644
index 00000000000..7f4e22b8b2d
--- /dev/null
+++ b/gcc/ada/styleg.ads
@@ -0,0 +1,159 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S T Y L E G --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This generic package collects the routines used for style checking, as
+-- activated by the relevant command line option. These are gathered in
+-- a separate package so that they can more easily be customized. Calls
+-- to these subprograms are only made if Opt.Style_Check is set True.
+-- Styleg does not depends on the GNAT tree (Atree, Sinfo, ...).
+
+-- For the compiler, there is also a child package Styleg.C that depends
+-- on the GNAT tree.
+
+with Types; use Types;
+
+generic
+ with procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr);
+ -- Output a message at specified location
+
+ with procedure Error_Msg_S (Msg : String);
+ -- Output a message at current scan pointer location
+
+ with procedure Error_Msg_SC (Msg : String);
+ -- Output a message at the start of the current token
+
+ with procedure Error_Msg_SP (Msg : String);
+ -- Output a message at the start of the previous token
+
+package Styleg is
+
+ procedure Check_Abs_Not;
+ -- Called after scanning an ABS or NOT operator to check spacing
+
+ procedure Check_Apostrophe;
+ -- Called after scanning an apostrophe to check spacing
+
+ procedure Check_Arrow;
+ -- Called after scanning out an arrow to check spacing
+
+ procedure Check_Attribute_Name (Reserved : Boolean);
+ -- The current token is an attribute designator. Check that it
+ -- is capitalized in an appropriate manner. Reserved is set if
+ -- the attribute designator is a reserved word (access, digits,
+ -- delta or range) to allow differing rules for the two cases.
+
+ procedure Check_Box;
+ -- Called after scanning out a box to check spacing
+
+ procedure Check_Binary_Operator;
+ -- Called after scanning out a binary operator other than a plus, minus
+ -- or exponentiation operator. Intended for checking spacing rules.
+
+ procedure Check_Exponentiation_Operator;
+ -- Called after scanning out an exponentiation operator. Intended for
+ -- checking spacing rules.
+
+ procedure Check_Colon;
+ -- Called after scanning out colon to check spacing
+
+ procedure Check_Colon_Equal;
+ -- Called after scanning out colon equal to check spacing
+
+ procedure Check_Comma;
+ -- Called after scanning out comma to check spacing
+
+ procedure Check_Comment;
+ -- Called with Scan_Ptr pointing to the first minus sign of a comment.
+ -- Intended for checking any specific rules for comment placement/format.
+
+ procedure Check_Dot_Dot;
+ -- Called after scanning out dot dot to check spacing
+
+ procedure Check_HT;
+ -- Called with Scan_Ptr pointing to a horizontal tab character
+
+ procedure Check_Indentation;
+ -- Called at the start of a new statement or declaration, with Token_Ptr
+ -- pointing to the first token of the statement or declaration. The check
+ -- is that the starting column is appropriate to the indentation rules if
+ -- Token_Ptr is the first token on the line.
+
+ procedure Check_Left_Paren;
+ -- Called after scanning out a left parenthesis to check spacing.
+
+ procedure Check_Line_Terminator (Len : Int);
+ -- Called with Scan_Ptr pointing to the first line terminator terminating
+ -- the current line, used to check for appropriate line terminator and
+ -- to check the line length (Len is the length of the current line).
+ -- Note that the terminator may be the EOF character.
+
+ procedure Check_Pragma_Name;
+ -- The current token is a pragma identifier. Check that it is spelled
+ -- properly (i.e. with an appropriate casing convention).
+
+ procedure Check_Right_Paren;
+ -- Called after scanning out a right parenthesis to check spacing.
+
+ procedure Check_Semicolon;
+ -- Called after scanning out a semicolon to check spacing
+
+ procedure Check_Then (If_Loc : Source_Ptr);
+ -- Called to check that THEN and IF keywords are appropriately positioned.
+ -- The parameters show the first characters of the two keywords. This
+ -- procedure is called only if THEN appears at the start of a line with
+ -- Token_Ptr pointing to the THEN keyword.
+
+ procedure Check_Unary_Plus_Or_Minus;
+ -- Called after scanning a unary plus or minus to check spacing
+
+ procedure Check_Vertical_Bar;
+ -- Called after scanning a vertical bar to check spacing
+
+ procedure No_End_Name (Name : Node_Id);
+ -- Called if an END is encountered where a name is allowed but not present.
+ -- The parameter is the node whose name is the name that is permitted in
+ -- the END line, and the scan pointer is positioned so that if an error
+ -- message is to be generated in this situation, it should be generated
+ -- using Error_Msg_SP.
+
+ procedure No_Exit_Name (Name : Node_Id);
+ -- Called when exiting a named loop, but a name is not present on the EXIT.
+ -- The parameter is the node whose name should have followed EXIT, and the
+ -- scan pointer is positioned so that if an error message is to be
+ -- generated, it should be generated using Error_Msg_SP.
+
+ procedure Non_Lower_Case_Keyword;
+ -- Called if a reserved keyword is scanned which is not spelled in all
+ -- lower case letters. On entry Token_Ptr points to the keyword token.
+ -- This is not used for keywords appearing as attribute designators,
+ -- where instead Check_Attribute_Name (True) is called.
+
+ function RM_Column_Check return Boolean;
+ pragma Inline (RM_Column_Check);
+ -- Determines whether style checking is active and the RM column check
+ -- mode is set requiring checking of RM format layout.
+
+end Styleg;
diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb
index 1213da8987e..b0b351d4f32 100644
--- a/gcc/ada/stylesw.adb
+++ b/gcc/ada/stylesw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -24,8 +24,7 @@
-- --
------------------------------------------------------------------------------
-with Hostparm; use Hostparm;
-with Opt; use Opt;
+with Opt; use Opt;
package body Stylesw is
@@ -210,14 +209,18 @@ package body Stylesw is
Style_Max_Line_Length :=
Style_Max_Line_Length * 10 +
Character'Pos (Options (J)) - Character'Pos ('0');
+
+ if Style_Max_Line_Length > Int (Column_Number'Last) then
+ OK := False;
+ Err_Col := J;
+ return;
+ end if;
+
J := J + 1;
exit when J > Options'Last
or else Options (J) not in '0' .. '9';
end loop;
- Style_Max_Line_Length :=
- Int'Min (Style_Max_Line_Length, Hostparm.Max_Line_Length);
-
Style_Check_Max_Line_Length := Style_Max_Line_Length /= 0;
when 'o' =>
diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads
index 5a7a62d0e15..862f0262ce5 100644
--- a/gcc/ada/stylesw.ads
+++ b/gcc/ada/stylesw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001, 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- --
@@ -136,10 +136,9 @@ package Stylesw is
-- an attribute name.
Style_Check_Max_Line_Length : Boolean := False;
- -- This can be set True by using the -gnatg or -gnatym switches. If
- -- it is True, it activates checking for a maximum line length of 79
- -- characters (chosen to fit in standard 80 column displays that don't
- -- handle the limiting case of 80 characters cleanly).
+ -- This can be set True by using the -gnatg or -gnatym/M switches.
+ -- If it is True, it activates checking for a maximum line length of
+ -- Style_Max_Line_Length characters.
Style_Check_Pragma_Casing : Boolean := False;
-- This can be set True by using the -gnatg or -gnatyp switches. If
@@ -217,9 +216,9 @@ package Stylesw is
-- is True, then names of subprogram bodies must be in alphabetical
-- order (not taking casing into account).
- Style_Max_Line_Length : Int := 79;
- -- Value used to check maximum line length. Can be reset by a call to
- -- Set_Max_Line_Length. The value here is the default if no such call.
+ Style_Max_Line_Length : Int := 0;
+ -- Value used to check maximum line length. Gets reset as a result of
+ -- use of -gnatym or -gnatyM switches (or by use of -gnatg).
-----------------
-- Subprograms --
diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb
index 08ad2732932..ecc022ee400 100644
--- a/gcc/ada/switch-b.adb
+++ b/gcc/ada/switch-b.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -37,9 +37,9 @@ package body Switch.B is
--------------------------
procedure Scan_Binder_Switches (Switch_Chars : String) is
- Ptr : Integer := Switch_Chars'First;
- Max : Integer := Switch_Chars'Last;
- C : Character := ' ';
+ Max : constant Integer := Switch_Chars'Last;
+ Ptr : Integer := Switch_Chars'First;
+ C : Character := ' ';
begin
-- Skip past the initial character (must be the switch character)
@@ -150,6 +150,12 @@ package body Switch.B is
Ptr := Ptr + 1;
Force_RM_Elaboration_Order := True;
+ -- Processing for F switch
+
+ when 'F' =>
+ Ptr := Ptr + 1;
+ Force_Checking_Of_Elaboration_Flags := True;
+
-- Processing for g switch
when 'g' =>
@@ -281,6 +287,7 @@ package body Switch.B is
Ptr := Ptr + 1;
Time_Slice_Set := True;
Scan_Nat (Switch_Chars, Max, Ptr, Time_Slice_Value);
+ Time_Slice_Value := Time_Slice_Value * 1_000;
-- Processing for v switch
@@ -371,21 +378,36 @@ package body Switch.B is
Opt.RTS_Switch := True;
declare
- Src_Path_Name : String_Ptr := Get_RTS_Search_Dir
- (Switch_Chars (Ptr + 4 .. Switch_Chars'Last), Include);
- Lib_Path_Name : String_Ptr := Get_RTS_Search_Dir
- (Switch_Chars (Ptr + 4 .. Switch_Chars'Last), Objects);
+ Src_Path_Name : constant String_Ptr :=
+ Get_RTS_Search_Dir
+ (Switch_Chars
+ (Ptr + 4 .. Switch_Chars'Last),
+ Include);
+ Lib_Path_Name : constant String_Ptr :=
+ Get_RTS_Search_Dir
+ (Switch_Chars
+ (Ptr + 4 .. Switch_Chars'Last),
+ Objects);
+
begin
if Src_Path_Name /= null and then
Lib_Path_Name /= null
then
- Add_Search_Dirs (Src_Path_Name, Include);
- Add_Search_Dirs (Lib_Path_Name, Objects);
- -- we can exit as there can not be another switch
+ -- Set the RTS_*_Path_Name variables, so that the
+ -- correct directories will be set when
+ -- Osint.Add_Default_Search_Dirs will be called later.
+
+ RTS_Src_Path_Name := Src_Path_Name;
+ RTS_Lib_Path_Name := Lib_Path_Name;
+
+ -- We can exit as there can not be another switch
-- after --RTS
+
exit;
+
elsif Src_Path_Name = null
- and Lib_Path_Name = null then
+ and then Lib_Path_Name = null
+ then
Osint.Fail ("RTS path not valid: missing " &
"adainclude and adalib directories");
elsif Src_Path_Name = null then
@@ -414,7 +436,7 @@ package body Switch.B is
Osint.Fail ("invalid switch: ", (1 => C));
when Bad_Switch_Value =>
- Osint.Fail ("numeric value too big for switch: ", (1 => C));
+ Osint.Fail ("numeric value out of range for switch: ", (1 => C));
when Missing_Switch_Value =>
Osint.Fail ("missing numeric value for switch: ", (1 => C));
diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb
index 4052db70d03..c76c4a1af55 100644
--- a/gcc/ada/switch-c.adb
+++ b/gcc/ada/switch-c.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -24,10 +24,13 @@
-- --
------------------------------------------------------------------------------
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
with Debug; use Debug;
with Lib; use Lib;
with Osint; use Osint;
with Opt; use Opt;
+with Prepcomp; use Prepcomp;
with Types; use Types;
with Validsw; use Validsw;
with Stylesw; use Stylesw;
@@ -36,6 +39,9 @@ with System.WCh_Con; use System.WCh_Con;
package body Switch.C is
+ RTS_Specified : String_Access := null;
+ -- Used to detect multiple use of --RTS= flag
+
-----------------------------
-- Scan_Front_End_Switches --
-----------------------------
@@ -50,6 +56,7 @@ package body Switch.C is
Ptr : Integer := Switch_Chars'First;
Max : constant Integer := Switch_Chars'Last;
C : Character := ' ';
+ Dot : Boolean;
Store_Switch : Boolean := True;
First_Char : Integer := Ptr;
@@ -88,6 +95,7 @@ package body Switch.C is
case Switch_Starts_With_Gnat is
when False =>
+
-- There are only two front-end switches that
-- do not start with -gnat, namely -I and --RTS
@@ -113,49 +121,70 @@ package body Switch.C is
-- Processing of the --RTS switch. --RTS has been modified by
-- gcc and is now of the form -fRTS
- elsif Ptr + 3 <= Max and then
- Switch_Chars (Ptr .. Ptr + 3) = "fRTS"
+
+ elsif Ptr + 3 <= Max
+ and then Switch_Chars (Ptr .. Ptr + 3) = "fRTS"
then
Ptr := Ptr + 1;
- if Ptr + 4 > Max or else Switch_Chars (Ptr + 3) /= '=' then
+ if Ptr + 4 > Max
+ or else Switch_Chars (Ptr + 3) /= '='
+ then
Osint.Fail ("missing path for --RTS");
else
+ -- Check that this is the first time --RTS is specified
+ -- or if it is not the first time, the same path has
+ -- been specified.
+
+ if RTS_Specified = null then
+ RTS_Specified :=
+ new String'(Switch_Chars (Ptr + 4 .. Max));
+
+ elsif
+ RTS_Specified.all /= Switch_Chars (Ptr + 4 .. Max)
+ then
+ Osint.Fail
+ ("--RTS cannot be specified multiple times");
+ end if;
+
+ -- Valid --RTS switch
- -- valid --RTS switch
Opt.No_Stdinc := True;
Opt.RTS_Switch := True;
- declare
- Src_Path_Name : String_Ptr := Get_RTS_Search_Dir
- (Switch_Chars (Ptr + 4 .. Max), Include);
- Lib_Path_Name : String_Ptr := Get_RTS_Search_Dir
- (Switch_Chars (Ptr + 4 .. Max), Objects);
- begin
- if Src_Path_Name /= null and then
- Lib_Path_Name /= null
- then
- Add_Search_Dirs (Src_Path_Name, Include);
- Add_Search_Dirs (Lib_Path_Name, Objects);
- Ptr := Max + 1;
- elsif Src_Path_Name = null
- and Lib_Path_Name = null then
- Osint.Fail ("RTS path not valid: missing " &
- "adainclude and adalib directories");
- elsif Src_Path_Name = null then
- Osint.Fail ("RTS path not valid: missing " &
- "adainclude directory");
- elsif Lib_Path_Name = null then
- Osint.Fail ("RTS path not valid: missing " &
- "adalib directory");
- end if;
- end;
+ RTS_Src_Path_Name := Get_RTS_Search_Dir
+ (Switch_Chars (Ptr + 4 .. Max),
+ Include);
+ RTS_Lib_Path_Name := Get_RTS_Search_Dir
+ (Switch_Chars (Ptr + 4 .. Max),
+ Objects);
+
+ if RTS_Src_Path_Name /= null and then
+ RTS_Lib_Path_Name /= null
+ then
+ Ptr := Max + 1;
+
+ elsif RTS_Src_Path_Name = null and then
+ RTS_Lib_Path_Name = null
+ then
+ Osint.Fail ("RTS path not valid: missing " &
+ "adainclude and adalib directories");
+
+ elsif RTS_Src_Path_Name = null then
+ Osint.Fail ("RTS path not valid: missing " &
+ "adainclude directory");
+
+ elsif RTS_Lib_Path_Name = null then
+ Osint.Fail ("RTS path not valid: missing " &
+ "adalib directory");
+ end if;
end if;
else
raise Bad_Switch;
end if;
when True =>
+
-- Process -gnat* options
case C is
@@ -181,23 +210,19 @@ package body Switch.C is
when 'c' =>
if not First_Switch then
Osint.Fail
- ("-gnatc myust be first if combined with other switches");
+ ("-gnatc must be first if combined with other switches");
end if;
Ptr := Ptr + 1;
Operating_Mode := Check_Semantics;
- -- Processing for C switch
-
- when 'C' =>
- Ptr := Ptr + 1;
- Compress_Debug_Names := True;
-
-- Processing for d switch
when 'd' =>
Store_Switch := False;
Storing (First_Stored) := 'd';
+ Dot := False;
+
-- Note: for the debug switch, the remaining characters in this
-- switch field must all be debug flags, since all valid switch
-- characters are also valid debug characters.
@@ -213,10 +238,23 @@ package body Switch.C is
C in 'a' .. 'z' or else
C in 'A' .. 'Z'
then
- Set_Debug_Flag (C);
- Storing (First_Stored + 1) := C;
- Store_Compilation_Switch
- (Storing (Storing'First .. First_Stored + 1));
+ if Dot then
+ Set_Dotted_Debug_Flag (C);
+ Storing (First_Stored + 1) := '.';
+ Storing (First_Stored + 2) := C;
+ Store_Compilation_Switch
+ (Storing (Storing'First .. First_Stored + 2));
+ Dot := False;
+
+ else
+ Set_Debug_Flag (C);
+ Storing (First_Stored + 1) := C;
+ Store_Compilation_Switch
+ (Storing (Storing'First .. First_Stored + 1));
+ end if;
+
+ elsif C = '.' then
+ Dot := True;
else
raise Bad_Switch;
@@ -249,6 +287,8 @@ package body Switch.C is
-- Processing for e switch
when 'e' =>
+ -- Only -gnateD and -gnatep= are stored
+
Ptr := Ptr + 1;
if Ptr > Max then
@@ -263,21 +303,93 @@ package body Switch.C is
Store_Switch := False;
Ptr := Ptr + 1;
+ -- There may be an equal sign between -gnatec and
+ -- the path name of the config file.
+
+ if Ptr <= Max and then Switch_Chars (Ptr) = '=' then
+ Ptr := Ptr + 1;
+ end if;
+
if Ptr > Max then
raise Bad_Switch;
end if;
- Config_File_Name :=
- new String'(Switch_Chars (Ptr .. Max));
+ declare
+ Config_File_Name : constant String_Access :=
+ new String'
+ (Switch_Chars (Ptr .. Max));
+
+ begin
+ if Config_File_Names = null then
+ Config_File_Names :=
+ new String_List'(1 => Config_File_Name);
+
+ else
+ declare
+ New_Names : constant String_List_Access :=
+ new String_List
+ (1 ..
+ Config_File_Names'Length + 1);
+
+ begin
+ for Index in Config_File_Names'Range loop
+ New_Names (Index) :=
+ Config_File_Names (Index);
+ Config_File_Names (Index) := null;
+ end loop;
+
+ New_Names (New_Names'Last) := Config_File_Name;
+ Free (Config_File_Names);
+ Config_File_Names := New_Names;
+ end;
+ end if;
+ end;
return;
+ -- Symbol definition
+
+ when 'D' =>
+ Store_Switch := False;
+ Ptr := Ptr + 1;
+
+ if Ptr > Max then
+ raise Bad_Switch;
+ end if;
+
+ Add_Symbol_Definition (Switch_Chars (Ptr .. Max));
+
+ -- Store the switch
+
+ Storing (First_Stored .. First_Stored + 1) := "eD";
+ Storing
+ (First_Stored + 2 .. First_Stored + Max - Ptr + 2) :=
+ Switch_Chars (Ptr .. Max);
+ Store_Compilation_Switch (Storing
+ (Storing'First .. First_Stored + Max - Ptr + 2));
+ return;
+
+ -- Full source path for brief error messages
+
+ when 'f' =>
+ Store_Switch := False;
+ Ptr := Ptr + 1;
+ Full_Path_Name_For_Brief_Errors := True;
+ return;
+
-- Mapping file
when 'm' =>
Store_Switch := False;
Ptr := Ptr + 1;
+ -- There may be an equal sign between -gnatem and
+ -- the path name of the mapping file.
+
+ if Ptr <= Max and then Switch_Chars (Ptr) = '=' then
+ Ptr := Ptr + 1;
+ end if;
+
if Ptr > Max then
raise Bad_Switch;
end if;
@@ -286,6 +398,43 @@ package body Switch.C is
new String'(Switch_Chars (Ptr .. Max));
return;
+ -- Preprocessing data file
+
+ when 'p' =>
+ Store_Switch := False;
+ Ptr := Ptr + 1;
+
+ -- There may be an equal sign between -gnatep and
+ -- the path name of the mapping file.
+
+ if Ptr <= Max and then Switch_Chars (Ptr) = '=' then
+ Ptr := Ptr + 1;
+ end if;
+
+ if Ptr > Max then
+ raise Bad_Switch;
+ end if;
+
+ Preprocessing_Data_File :=
+ new String'(Switch_Chars (Ptr .. Max));
+
+ -- Store the switch.
+ -- Because we may store a longer switch (we normalize
+ -- to -gnatep=), use a local variable.
+
+ declare
+ To_Store : String
+ (1 .. Preprocessing_Data_File'Length + 8);
+
+ begin
+ To_Store (1 .. 8) := "-gnatep=";
+ To_Store (9 .. Preprocessing_Data_File'Length + 8) :=
+ Preprocessing_Data_File.all;
+ Store_Compilation_Switch (To_Store);
+ end;
+
+ return;
+
when others =>
raise Bad_Switch;
end case;
@@ -313,11 +462,13 @@ package body Switch.C is
when 'g' =>
Ptr := Ptr + 1;
- GNAT_Mode := True;
- Identifier_Character_Set := 'n';
- Warning_Mode := Treat_As_Error;
- Check_Unreferenced := True;
- Check_Withs := True;
+ GNAT_Mode := True;
+ Identifier_Character_Set := 'n';
+ Warning_Mode := Treat_As_Error;
+ Check_Unreferenced := True;
+ Check_Withs := True;
+ Check_Unreferenced_Formals := True;
+ System_Extend_Unit := Empty;
Set_Default_Style_Check_Options;
@@ -406,12 +557,13 @@ package body Switch.C is
when 'o' =>
Ptr := Ptr + 1;
- Suppress_Options.Overflow_Checks := False;
+ Suppress_Options (Overflow_Check) := False;
Opt.Enable_Overflow_Checks := True;
-- Processing for O switch
when 'O' =>
+ Store_Switch := False;
Ptr := Ptr + 1;
Output_File_Name_Present := True;
@@ -419,20 +571,9 @@ package body Switch.C is
when 'p' =>
Ptr := Ptr + 1;
- Suppress_Options.Access_Checks := True;
- Suppress_Options.Accessibility_Checks := True;
- Suppress_Options.Discriminant_Checks := True;
- Suppress_Options.Division_Checks := True;
- Suppress_Options.Elaboration_Checks := True;
- Suppress_Options.Index_Checks := True;
- Suppress_Options.Length_Checks := True;
- Suppress_Options.Overflow_Checks := True;
- Suppress_Options.Range_Checks := True;
- Suppress_Options.Storage_Checks := True;
- Suppress_Options.Tag_Checks := True;
-
- Validity_Checks_On := False;
- Opt.Suppress_Checks := True;
+ Suppress_Options := (others => True);
+ Validity_Checks_On := False;
+ Opt.Suppress_Checks := True;
Opt.Enable_Overflow_Checks := False;
-- Processing for P switch
@@ -459,38 +600,34 @@ package body Switch.C is
when 'R' =>
Ptr := Ptr + 1;
Back_Annotate_Rep_Info := True;
+ List_Representation_Info := 1;
- if Ptr <= Max
- and then Switch_Chars (Ptr) in '0' .. '9'
- then
+ while Ptr <= Max loop
C := Switch_Chars (Ptr);
- if C in '4' .. '9' then
- raise Bad_Switch;
- else
+ if C in '1' .. '3' then
List_Representation_Info :=
Character'Pos (C) - Character'Pos ('0');
- Ptr := Ptr + 1;
- end if;
- if Ptr <= Max and then Switch_Chars (Ptr) = 's' then
- Ptr := Ptr + 1;
+ elsif Switch_Chars (Ptr) = 's' then
+ List_Representation_Info_To_File := True;
- if List_Representation_Info /= 0 then
- List_Representation_Info_To_File := True;
- end if;
+ elsif Switch_Chars (Ptr) = 'm' then
+ List_Representation_Info_Mechanisms := True;
+
+ else
+ raise Bad_Switch;
end if;
- else
- List_Representation_Info := 1;
- end if;
+ Ptr := Ptr + 1;
+ end loop;
-- Processing for s switch
when 's' =>
if not First_Switch then
Osint.Fail
- ("-gnats myust be first if combined with other switches");
+ ("-gnats must be first if combined with other switches");
end if;
Ptr := Ptr + 1;
@@ -501,6 +638,7 @@ package body Switch.C is
when 't' =>
Ptr := Ptr + 1;
Tree_Output := True;
+ ASIS_Mode := True;
Back_Annotate_Rep_Info := True;
-- Processing for T switch
@@ -575,35 +713,40 @@ package body Switch.C is
C := Switch_Chars (Ptr);
case C is
-
when 'a' =>
- Constant_Condition_Warnings := True;
- Elab_Warnings := True;
Check_Unreferenced := True;
- Check_Withs := True;
Check_Unreferenced_Formals := True;
+ Check_Withs := True;
+ Constant_Condition_Warnings := True;
Implementation_Unit_Warnings := True;
Ineffective_Inline_Warnings := True;
+ Warn_On_Constant := True;
+ Warn_On_Export_Import := True;
+ Warn_On_Modified_Unread := True;
+ Warn_On_No_Value_Assigned := True;
+ Warn_On_Obsolescent_Feature := True;
Warn_On_Redundant_Constructs := True;
+ Warn_On_Unchecked_Conversion := True;
+ Warn_On_Unrecognized_Pragma := True;
when 'A' =>
- Constant_Condition_Warnings := False;
- Elab_Warnings := False;
Check_Unreferenced := False;
- Check_Withs := False;
Check_Unreferenced_Formals := False;
+ Check_Withs := False;
+ Constant_Condition_Warnings := False;
+ Elab_Warnings := False;
Implementation_Unit_Warnings := False;
- Warn_On_Biased_Rounding := False;
+ Ineffective_Inline_Warnings := False;
+ Warn_On_Constant := False;
Warn_On_Dereference := False;
+ Warn_On_Export_Import := False;
Warn_On_Hiding := False;
+ Warn_On_Modified_Unread := False;
+ Warn_On_No_Value_Assigned := False;
+ Warn_On_Obsolescent_Feature := False;
Warn_On_Redundant_Constructs := False;
- Ineffective_Inline_Warnings := False;
-
- when 'b' =>
- Warn_On_Biased_Rounding := True;
-
- when 'B' =>
- Warn_On_Biased_Rounding := False;
+ Warn_On_Unchecked_Conversion := False;
+ Warn_On_Unrecognized_Pragma := False;
when 'c' =>
Constant_Condition_Warnings := True;
@@ -626,6 +769,12 @@ package body Switch.C is
when 'F' =>
Check_Unreferenced_Formals := False;
+ when 'g' =>
+ Warn_On_Unrecognized_Pragma := True;
+
+ when 'G' =>
+ Warn_On_Unrecognized_Pragma := False;
+
when 'h' =>
Warn_On_Hiding := True;
@@ -638,12 +787,33 @@ package body Switch.C is
when 'I' =>
Implementation_Unit_Warnings := False;
+ when 'j' =>
+ Warn_On_Obsolescent_Feature := True;
+
+ when 'J' =>
+ Warn_On_Obsolescent_Feature := False;
+
+ when 'k' =>
+ Warn_On_Constant := True;
+
+ when 'K' =>
+ Warn_On_Constant := False;
+
when 'l' =>
Elab_Warnings := True;
when 'L' =>
Elab_Warnings := False;
+ when 'm' =>
+ Warn_On_Modified_Unread := True;
+
+ when 'M' =>
+ Warn_On_Modified_Unread := False;
+
+ when 'n' =>
+ Warning_Mode := Normal;
+
when 'o' =>
Address_Clause_Overlay_Warnings := True;
@@ -675,6 +845,24 @@ package body Switch.C is
Check_Withs := False;
Check_Unreferenced_Formals := False;
+ when 'v' =>
+ Warn_On_No_Value_Assigned := True;
+
+ when 'V' =>
+ Warn_On_No_Value_Assigned := False;
+
+ when 'x' =>
+ Warn_On_Export_Import := True;
+
+ when 'X' =>
+ Warn_On_Export_Import := False;
+
+ when 'z' =>
+ Warn_On_Unchecked_Conversion := True;
+
+ when 'Z' =>
+ Warn_On_Unchecked_Conversion := False;
+
-- Allow and ignore 'w' so that the old
-- format (e.g. -gnatwuwl) will work.
@@ -787,7 +975,7 @@ package body Switch.C is
when 'z' =>
Ptr := Ptr + 1;
- -- Allowed for compiler, only if this is the only
+ -- Allowed for compiler only if this is the only
-- -z switch, we do not allow multiple occurrences
if Distribution_Stub_Mode = No_Stubs then
@@ -858,7 +1046,7 @@ package body Switch.C is
Osint.Fail ("invalid switch: ", (1 => C));
when Bad_Switch_Value =>
- Osint.Fail ("numeric value too big for switch: ", (1 => C));
+ Osint.Fail ("numeric value out of range for switch: ", (1 => C));
when Missing_Switch_Value =>
Osint.Fail ("missing numeric value for switch: ", (1 => C));
diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb
index b04672b5ffc..ec99f8f20b4 100644
--- a/gcc/ada/switch-m.adb
+++ b/gcc/ada/switch-m.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -37,7 +37,7 @@ package body Switch.M is
Table_Low_Bound => 1,
Table_Initial => 20,
Table_Increment => 100,
- Table_Name => "Switch.C.Normalized_Switches");
+ Table_Name => "Switch.M.Normalized_Switches");
-- This table is used to keep the normalized switches, so that they may be
-- reused for subsequent invocations of Normalize_Compiler_Switches with
-- similar switches.
@@ -62,7 +62,6 @@ package body Switch.M is
Max : constant Integer := Switch_Chars'Last;
C : Character := ' ';
- First_Char : Integer := Ptr;
Storing : String := Switch_Chars;
First_Stored : Positive := Ptr + 1;
Last_Stored : Positive := First_Stored;
@@ -143,7 +142,6 @@ package body Switch.M is
end if;
while Ptr <= Max loop
- First_Char := Ptr;
C := Switch_Chars (Ptr);
-- Processing for a switch
@@ -151,9 +149,21 @@ package body Switch.M is
case Switch_Starts_With_Gnat is
when False =>
- -- All switches that don't start with -gnat stay as is
- Add_Switch_Component (Switch_Chars);
+ -- All switches that don't start with -gnat stay as is,
+ -- except -v and -pg
+
+ if Switch_Chars = "-pg" then
+
+ -- The gcc driver converts -pg to -p, so that is what
+ -- is stored in the ALI file.
+
+ Add_Switch_Component ("-p");
+
+ elsif C /= 'v' then
+ Add_Switch_Component (Switch_Chars);
+ end if;
+
return;
when True =>
@@ -162,7 +172,7 @@ package body Switch.M is
-- One-letter switches
- when 'a' | 'A' | 'b' | 'c' | 'C' | 'D' | 'E' | 'f' |
+ when 'a' | 'A' | 'b' | 'c' | 'D' | 'E' | 'f' |
'F' | 'g' | 'h' | 'H' | 'k' | 'l' | 'L' | 'n' | 'N' |
'o' | 'O' | 'p' | 'P' | 'q' | 'Q' | 'r' | 's' | 't' |
'u' | 'U' | 'v' | 'x' | 'X' | 'Z' =>
@@ -214,8 +224,59 @@ package body Switch.M is
return;
when 'e' =>
- -- None of the -gnate switches (-gnatec and -gnatem)
- -- need to be store in an ALI file.
+
+ -- Only -gnateD and -gnatep= need to be store in an ALI
+ -- file.
+
+ Storing (First_Stored) := 'e';
+ Ptr := Ptr + 1;
+
+ if Ptr > Max
+ or else (Switch_Chars (Ptr) /= 'D'
+ and then Switch_Chars (Ptr) /= 'p')
+ then
+ Last := 0;
+ return;
+ end if;
+
+ if Switch_Chars (Ptr) = 'D' then
+ -- gnateD
+
+ Storing (First_Stored + 1 ..
+ First_Stored + Max - Ptr + 1) :=
+ Switch_Chars (Ptr .. Max);
+ Add_Switch_Component
+ (Storing (Storing'First ..
+ First_Stored + Max - Ptr + 1));
+
+ else
+ -- gnatep=
+
+ Ptr := Ptr + 1;
+
+ if Ptr = Max then
+ Last := 0;
+ return;
+ end if;
+
+ if Switch_Chars (Ptr) = '=' then
+ Ptr := Ptr + 1;
+ end if;
+
+ -- To normalize, always put a '=' after -gnatep.
+ -- Because that could lengthen the switch string,
+ -- declare a local variable.
+
+ declare
+ To_Store : String (1 .. Max - Ptr + 9);
+
+ begin
+ To_Store (1 .. 8) := "-gnatep=";
+ To_Store (9 .. Max - Ptr + 9) :=
+ Switch_Chars (Ptr .. Max);
+ Add_Switch_Component (To_Store);
+ end;
+ end if;
return;
@@ -379,9 +440,9 @@ package body Switch.M is
------------------------
procedure Scan_Make_Switches (Switch_Chars : String) is
- Ptr : Integer := Switch_Chars'First;
- Max : Integer := Switch_Chars'Last;
- C : Character := ' ';
+ Ptr : Integer := Switch_Chars'First;
+ Max : constant Integer := Switch_Chars'Last;
+ C : Character := ' ';
begin
-- Skip past the initial character (must be the switch character)
@@ -405,7 +466,7 @@ package body Switch.M is
-- Loop to scan through switches given in switch string
- while Ptr <= Max loop
+ Check_Switch : begin
C := Switch_Chars (Ptr);
-- Processing for a switch
@@ -420,13 +481,15 @@ package body Switch.M is
when 'b' =>
Ptr := Ptr + 1;
- Bind_Only := True;
+ Bind_Only := True;
+ Make_Steps := True;
-- Processing for c switch
when 'c' =>
Ptr := Ptr + 1;
Compile_Only := True;
+ Make_Steps := True;
-- Processing for C switch
@@ -434,6 +497,18 @@ package body Switch.M is
Ptr := Ptr + 1;
Create_Mapping_File := True;
+ -- Processing for D switch
+
+ when 'D' =>
+ Ptr := Ptr + 1;
+
+ if Object_Directory_Present then
+ Osint.Fail ("duplicate -D switch");
+
+ else
+ Object_Directory_Present := True;
+ end if;
+
-- Processing for d switch
when 'd' =>
@@ -477,6 +552,12 @@ package body Switch.M is
Ptr := Ptr + 1;
Force_Compilations := True;
+ -- Processing for F switch
+
+ when 'F' =>
+ Ptr := Ptr + 1;
+ Full_Path_Name_For_Brief_Errors := True;
+
-- Processing for h switch
when 'h' =>
@@ -511,7 +592,8 @@ package body Switch.M is
when 'l' =>
Ptr := Ptr + 1;
- Link_Only := True;
+ Link_Only := True;
+ Make_Steps := True;
when 'M' =>
Ptr := Ptr + 1;
@@ -540,6 +622,12 @@ package body Switch.M is
Ptr := Ptr + 1;
Quiet_Output := True;
+ -- Processing for R switch
+
+ when 'R' =>
+ Ptr := Ptr + 1;
+ Run_Path_Option := False;
+
-- Processing for s switch
when 's' =>
@@ -569,14 +657,19 @@ package body Switch.M is
raise Bad_Switch;
end case;
- end loop;
+
+ if Ptr <= Max then
+ Osint.Fail ("invalid switch: ", Switch_Chars);
+ end if;
+
+ end Check_Switch;
exception
when Bad_Switch =>
Osint.Fail ("invalid switch: ", (1 => C));
when Bad_Switch_Value =>
- Osint.Fail ("numeric value too big for switch: ", (1 => C));
+ Osint.Fail ("numeric value out of range for switch: ", (1 => C));
when Missing_Switch_Value =>
Osint.Fail ("missing numeric value for switch: ", (1 => C));
diff --git a/gcc/ada/switch.adb b/gcc/ada/switch.adb
index 4601e927e0c..f01e3081080 100644
--- a/gcc/ada/switch.adb
+++ b/gcc/ada/switch.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -92,12 +92,16 @@ package body Switch is
Ptr : in out Integer;
Result : out Pos) is
+ Temp : Nat;
+
begin
- Scan_Nat (Switch_Chars, Max, Ptr, Result);
+ Scan_Nat (Switch_Chars, Max, Ptr, Temp);
- if Result = 0 then
+ if Temp = 0 then
raise Bad_Switch_Value;
end if;
+
+ Result := Temp;
end Scan_Pos;
end Switch;
diff --git a/gcc/ada/switch.ads b/gcc/ada/switch.ads
index 6e5e4c2f102..8dfa2984092 100644
--- a/gcc/ada/switch.ads
+++ b/gcc/ada/switch.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -74,7 +74,7 @@ private
Too_Many_Output_Files : exception;
-- Exception raised if the -o switch is encountered more than once
- Switch_Max_Value : constant := 999;
+ Switch_Max_Value : constant := 999_999;
-- Maximum value permitted in switches that take a value
procedure Scan_Nat
diff --git a/gcc/ada/symbols.adb b/gcc/ada/symbols.adb
new file mode 100644
index 00000000000..2c3e7d0ac08
--- /dev/null
+++ b/gcc/ada/symbols.adb
@@ -0,0 +1,79 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y M B O L S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the default version of this package, used when the creation
+-- of symbol files is not supported.
+
+with Ada.Text_IO; use Ada.Text_IO;
+
+package body Symbols is
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize
+ (Symbol_File : String;
+ Force : Boolean;
+ Quiet : Boolean;
+ Success : out Boolean)
+ is
+ pragma Unreferenced (Symbol_File);
+ pragma Unreferenced (Force);
+ pragma Unreferenced (Quiet);
+ begin
+ Put_Line
+ ("creation of symbol files are not supported on this platform");
+ Success := False;
+ end Initialize;
+
+ -------------
+ -- Process --
+ -------------
+
+ procedure Process
+ (Object_File : String;
+ Success : out Boolean)
+ is
+ pragma Unreferenced (Object_File);
+ begin
+ Success := False;
+ end Process;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize
+ (Quiet : Boolean;
+ Success : out Boolean)
+ is
+ pragma Unreferenced (Quiet);
+ begin
+ Success := False;
+ end Finalize;
+
+end Symbols;
diff --git a/gcc/ada/symbols.ads b/gcc/ada/symbols.ads
new file mode 100644
index 00000000000..9e823eff74c
--- /dev/null
+++ b/gcc/ada/symbols.ads
@@ -0,0 +1,84 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- S Y M B O L S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package allows the creation of symbol files to be used for linking
+-- libraries. The format of symbol files depends on the platform, so there is
+-- several implementations of the body.
+
+with GNAT.Dynamic_Tables;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+package Symbols is
+
+ type Symbol_Kind is (Data, Proc);
+ -- To distinguish between the different kinds of symbols
+
+ type Symbol_Data is record
+ Name : String_Access;
+ Kind : Symbol_Kind := Data;
+ Present : Boolean := True;
+ end record;
+ -- Data (name and kind) for each of the symbols
+
+ package Symbol_Table is new GNAT.Dynamic_Tables
+ (Table_Component_Type => Symbol_Data,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 0,
+ Table_Initial => 100,
+ Table_Increment => 100);
+ -- The symbol tables
+
+ Original_Symbols : Symbol_Table.Instance;
+ -- The symbols, if any, found in the original symbol table
+
+ Complete_Symbols : Symbol_Table.Instance;
+ -- The symbols, if any, found in the objects files
+
+ procedure Initialize
+ (Symbol_File : String;
+ Force : Boolean;
+ Quiet : Boolean;
+ Success : out Boolean);
+ -- Initialize a symbol file. This procedure must be called before
+ -- Processing any object file. Depending on the platforms and the
+ -- circumstances, additional messages may be issued if Quiet is False.
+
+ procedure Process
+ (Object_File : String;
+ Success : out Boolean);
+ -- Get the symbols from an object file. Success is set to True if the
+ -- object file exists and has the expected format.
+
+ procedure Finalize
+ (Quiet : Boolean;
+ Success : out Boolean);
+ -- Finalize the symbol file. This procedure should be called after
+ -- Initialize (once) and Process (one or more times). If Success is
+ -- True, the symbol file is written and closed, ready to be used for
+ -- linking the library. Depending on the platforms and the circumstances,
+ -- additional messages may be issued if Quiet is False.
+
+end Symbols;
diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c
index d40e84d0bec..0b9d2c3b750 100644
--- a/gcc/ada/sysdep.c
+++ b/gcc/ada/sysdep.c
@@ -6,8 +6,7 @@
* *
* C Implementation File *
* *
- * *
- * 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- *
@@ -204,7 +203,7 @@ __gnat_ttyname (filedes)
This problem occurs when using Text_IO.Get_Line after Text_IO.Get_Immediate
for example.
- Calling FlushConsoleInputBuffer just after getch() fix the bug under
+ Calling FlushConsoleInputBuffer just after getch() fix the bug under
95/98. */
static void winflush_init PARAMS ((void));
@@ -219,11 +218,11 @@ static void winflush_nt PARAMS ((void));
static void (*winflush_function) PARAMS ((void)) = winflush_init;
/* This function does the runtime check of the OS version and then sets
- winflush_function to the appropriate function and then call it. */
+ winflush_function to the appropriate function and then call it. */
static void
winflush_init ()
-{
+{
DWORD dwVersion = GetVersion();
if (dwVersion < 0x80000000) /* Windows NT/2000 */
@@ -236,7 +235,7 @@ winflush_init ()
}
static void winflush_95 ()
-{
+{
FlushConsoleInputBuffer (GetStdHandle (STD_INPUT_HANDLE));
}
@@ -294,9 +293,15 @@ __gnat_ttyname (filedes)
#if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \
|| (defined (__osf__) && ! defined (__alpha_vxworks)) || defined (WINNT) \
|| defined (__MACHTEN__) || defined (hpux) || defined (_AIX) \
- || (defined (__svr4__) && defined (i386)) || defined (__Lynx__) \
- || defined (__CYGWIN__)
+ || (defined (__svr4__) && defined (i386)) || defined (__Lynx__)
+
+#ifdef __MINGW32__
+#if OLD_MINGW
#include <termios.h>
+#endif
+#else
+#include <termios.h>
+#endif
#else
#if defined (VMS)
@@ -350,7 +355,7 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting)
{
#if defined (linux) || defined (sun) || defined (sgi) || defined (__EMX__) \
|| (defined (__osf__) && ! defined (__alpha_vxworks)) \
- || defined (__CYGWIN__) || defined (__MACHTEN__) || defined (hpux) \
+ || defined (__CYGWIN32__) || defined (__MACHTEN__) || defined (hpux) \
|| defined (_AIX) || (defined (__svr4__) && defined (i386)) \
|| defined (__Lynx__)
char c;
@@ -498,7 +503,7 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting)
#elif defined (__vxworks)
/* Bit masks of file descriptors to read from. */
struct fd_set readFds;
- /* Timeout before select returns if nothing can be read. */
+ /* Timeout before select returns if nothing can be read. */
struct timeval timeOut;
char c;
int fd = fileno (stream);
@@ -508,14 +513,14 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting)
int status;
int width;
- if (isatty (fd))
+ if (isatty (fd))
{
/* If we do not want to wait, we have to set up fd in RAW mode. This
should be done outside this function as setting fd in RAW mode under
vxWorks flushes the buffer of fd. If the RAW mode was set here, the
buffer would be empty and we would always return that no character
is available */
- if (! waiting)
+ if (! waiting)
{
/* Initialization of timeOut for its use with select. */
timeOut.tv_sec = 0;
@@ -537,19 +542,19 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting)
else
{
nread = read (fd, &c, 1);
- if (nread > 0)
+ if (nread > 0)
*avail = 1, *end_of_file = 0;
/* End Of File. */
- else if (nread == 0)
+ else if (nread == 0)
*avail = 0, *end_of_file = 1;
/* Error. */
- else
+ else
*avail = -1, *end_of_file = -1;
- }
+ }
}
/* We have to wait until we get a character */
- else
+ else
{
*avail = -1;
*end_of_file = -1;
@@ -559,13 +564,13 @@ getc_immediate_common (stream, ch, end_of_file, avail, waiting)
/* Set FD in RAW mode. */
status = ioctl (fd, FIOSETOPTIONS, OPT_RAW);
- if (status != -1)
+ if (status != -1)
{
nread = read (fd, &c, 1);
- if (nread > 0)
+ if (nread > 0)
*avail = 1, *end_of_file = 0;
/* End of file. */
- else if (nread == 0)
+ else if (nread == 0)
*avail = 0, *end_of_file = 1;
/* Else there is an ERROR. */
}
@@ -613,27 +618,27 @@ char *rts_get_lpCommandLine PARAMS ((void));
int rts_get_nShowCmd PARAMS ((void));
char *
-rts_get_hInstance ()
-{
- return GetModuleHandleA (0);
+rts_get_hInstance ()
+{
+ return (char *)GetModuleHandleA (0);
}
char *
-rts_get_hPrevInstance ()
-{
- return 0;
+rts_get_hPrevInstance ()
+{
+ return 0;
}
char *
-rts_get_lpCommandLine ()
-{
- return GetCommandLineA ();
+rts_get_lpCommandLine ()
+{
+ return GetCommandLineA ();
}
-int
-rts_get_nShowCmd ()
-{
- return 1;
+int
+rts_get_nShowCmd ()
+{
+ return 1;
}
#endif /* WINNT */
@@ -670,8 +675,8 @@ extern void (*Unlock_Task) PARAMS ((void));
provide localtime_r, but in the library libc_r which doesn't get included
systematically, so we can't use it. */
-extern void struct tm *__gnat_localtime_r PARAMS ((const time_t *,
- struct tm *));
+extern struct tm *__gnat_localtime_r PARAMS ((const time_t *,
+ struct tm *));
struct tm *
__gnat_localtime_r (timer, tp)
diff --git a/gcc/ada/system.ads b/gcc/ada/system.ads
index 0f001c2fdbd..eca2dc662dd 100644
--- a/gcc/ada/system.ads
+++ b/gcc/ada/system.ads
@@ -5,9 +5,9 @@
-- S Y S T E M --
-- --
-- S p e c --
--- (Compiler Version) --
+-- (Compiler Version) --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -63,7 +63,7 @@ pragma Pure (System);
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
- Tick : constant := 1.0;
+ Tick : constant := 0.01;
-- Storage-related Declarations
@@ -131,21 +131,33 @@ private
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
+ Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
+ Duration_32_Bits : constant Boolean := False;
+ Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
- Long_Shifts_Inlined : constant Boolean := True;
- High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
+ Support_64_Bit_Divides : constant Boolean := True;
+ Support_Aggregates : constant Boolean := True;
+ Support_Composite_Assign : constant Boolean := True;
+ Support_Composite_Compare : constant Boolean := True;
+ Support_Long_Shifts : constant Boolean := True;
+ Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
+ -- Obsolete entries, to be removed eventually (bootstrap issues!)
+
+ High_Integrity_Mode : constant Boolean := False;
+ Long_Shifts_Inlined : constant Boolean := True;
+
end System;
diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb
index 60f185b0d96..30c068f6eae 100644
--- a/gcc/ada/table.adb
+++ b/gcc/ada/table.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,13 +32,16 @@
------------------------------------------------------------------------------
with Debug; use Debug;
-with Opt;
-with Output; use Output;
-pragma Elaborate_All (Output);
-with System; use System;
-with Tree_IO; use Tree_IO;
+with Opt; use Opt;
+with Output; use Output;
+with System; use System;
+with Tree_IO; use Tree_IO;
+
with System.Memory; use System.Memory;
-with System.Address_To_Access_Conversions;
+
+with Unchecked_Conversion;
+
+pragma Elaborate_All (Output);
package body Table is
package body Table is
@@ -63,17 +66,8 @@ package body Table is
-- Return Null_Address if the table length is zero,
-- Table (First)'Address if not.
- package Table_Conversions is
- new System.Address_To_Access_Conversions (Big_Table_Type);
- -- Address and Access conversions for a Table object.
-
- function To_Address (Table : Table_Ptr) return Address;
- pragma Inline (To_Address);
- -- Returns the Address for the Table object.
-
- function To_Pointer (Table : Address) return Table_Ptr;
- pragma Inline (To_Pointer);
- -- Returns the Access pointer for the Table object.
+ function To_Address is new Unchecked_Conversion (Table_Ptr, Address);
+ function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr);
------------
-- Append --
@@ -123,11 +117,12 @@ package body Table is
----------
procedure Init is
- Old_Length : Int := Length;
+ Old_Length : constant Int := Length;
begin
+ Locked := False;
Last_Val := Min - 1;
- Max := Min + (Table_Initial * Opt.Table_Factor) - 1;
+ Max := Min + (Table_Initial * Table_Factor) - 1;
Length := Max - Min + 1;
-- If table is same size as before (happens when table is never
@@ -286,25 +281,6 @@ package body Table is
end if;
end Set_Last;
- ----------------
- -- To_Address --
- ----------------
-
- function To_Address (Table : Table_Ptr) return Address is
- begin
- return Table_Conversions.To_Address
- (Table_Conversions.Object_Pointer (Table));
- end To_Address;
-
- ----------------
- -- To_Pointer --
- ----------------
-
- function To_Pointer (Table : Address) return Table_Ptr is
- begin
- return Table_Ptr (Table_Conversions.To_Pointer (Table));
- end To_Pointer;
-
----------------------------
-- Tree_Get_Table_Address --
----------------------------
diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads
index 7c78a30da42..4fe58edebb0 100644
--- a/gcc/ada/table.ads
+++ b/gcc/ada/table.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -88,10 +88,23 @@ pragma Elaborate_Body (Table);
-- freely (expensive reallocation occurs only at major granularity
-- chunks controlled by the allocation parameters).
- -- Note: we do not make the table components aliased, since this would
+ -- Note: We do not make the table components aliased, since this would
-- restict the use of table for discriminated types. If it is necessary
-- to take the access of a table element, use Unrestricted_Access.
+ -- WARNING: On HPPA, the virtual addressing approach used in this unit
+ -- is incompatible with the indexing instructions on the HPPA. So when
+ -- using this unit, compile your application with -mdisable-indexing.
+
+ -- WARNING: If the table is reallocated, then the address of all its
+ -- components will change. So do not capture the address of an element
+ -- and then use the address later after the table may be reallocated.
+ -- One tricky case of this is passing an element of the table to a
+ -- subprogram by reference where the table gets reallocated during
+ -- the execution of the subprogram. The best rule to follow is never
+ -- to pass a table element as a parameter except for the case of IN
+ -- mode parameters with scalar values.
+
type Table_Type is
array (Table_Index_Type range <>) of Table_Component_Type;
diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb
index 2621dbf2045..6e911fba3cb 100644
--- a/gcc/ada/targparm.adb
+++ b/gcc/ada/targparm.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-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- --
@@ -24,95 +24,175 @@
-- --
------------------------------------------------------------------------------
-with Namet; use Namet;
-with Output; use Output;
-with Sinput; use Sinput;
-with Sinput.L; use Sinput.L;
-with Types; use Types;
+with Csets; use Csets;
+with Namet; use Namet;
+with Opt; use Opt;
+with Osint; use Osint;
+with Output; use Output;
package body Targparm is
+ use ASCII;
+
+ Parameters_Obtained : Boolean := False;
+ -- Set True after first call to Get_Target_Parameters. Used to avoid
+ -- reading system.ads more than once, since it cannot change.
+
+ -- The following array defines a tag name for each entry
type Targparm_Tags is
- (AAM, -- AAMP;
- BDC, -- Backend_Divide_Checks;
- BOC, -- Backend_Overflow_Checks;
- CLA, -- Command_Line_Args;
- DEN, -- Denorm;
- DSP, -- Functions_Return_By_DSP;
- FEL, -- Frontend_Layout;
+ (AAM, -- AAMP
+ BDC, -- Backend_Divide_Checks
+ BOC, -- Backend_Overflow_Checks
+ CLA, -- Command_Line_Args
+ CRT, -- Configurable_Run_Time
+ D32, -- Duration_32_Bits
+ DEN, -- Denorm
+ DSP, -- Functions_Return_By_DSP
+ EXS, -- Exit_Status_Supported
+ FEL, -- Frontend_Layout
FFO, -- Fractional_Fixed_Ops
- HIM, -- High_Integrity_Mode;
- LSI, -- Long_Shifts_Inlined;
- MOV, -- Machine_Overflows;
- MRN, -- Machine_Rounds;
- SCD, -- Stack_Check_Default;
- SCP, -- Stack_Check_Probes;
- SNZ, -- Signed_Zeros;
- UAM, -- Use_Ada_Main_Program_Name;
- VMS, -- OpenVMS;
- ZCD, -- ZCX_By_Default;
- ZCG, -- GCC_ZCX_Support;
- ZCF); -- Front_End_ZCX_Support;
+ MOV, -- Machine_Overflows
+ MRN, -- Machine_Rounds
+ S64, -- Support_64_Bit_Divides
+ SAG, -- Support_Aggregates
+ SCA, -- Support_Composite_Assign
+ SCC, -- Support_Composite_Compare
+ SCD, -- Stack_Check_Default
+ SCP, -- Stack_Check_Probes
+ SLS, -- Support_Long_Shifts
+ SNZ, -- Signed_Zeros
+ SSL, -- Suppress_Standard_Library
+ UAM, -- Use_Ada_Main_Program_Name
+ VMS, -- OpenVMS
+ ZCD, -- ZCX_By_Default
+ ZCG, -- GCC_ZCX_Support
+ ZCF, -- Front_End_ZCX_Support
+
+ -- The following entries are obsolete and can eventually be removed
+
+ HIM, -- High_Integrity_Mode
+ LSI); -- Long_Shifts_Inlined
+
+ subtype Targparm_Tags_OK is Targparm_Tags range AAM .. ZCF;
+ -- Range excluding obsolete entries
Targparm_Flags : array (Targparm_Tags) of Boolean := (others => False);
-- Flag is set True if corresponding parameter is scanned
+ -- The following list of string constants gives the parameter names
+
AAM_Str : aliased constant Source_Buffer := "AAMP";
BDC_Str : aliased constant Source_Buffer := "Backend_Divide_Checks";
BOC_Str : aliased constant Source_Buffer := "Backend_Overflow_Checks";
CLA_Str : aliased constant Source_Buffer := "Command_Line_Args";
+ CRT_Str : aliased constant Source_Buffer := "Configurable_Run_Time";
+ D32_Str : aliased constant Source_Buffer := "Duration_32_Bits";
DEN_Str : aliased constant Source_Buffer := "Denorm";
DSP_Str : aliased constant Source_Buffer := "Functions_Return_By_DSP";
+ EXS_Str : aliased constant Source_Buffer := "Exit_Status_Supported";
FEL_Str : aliased constant Source_Buffer := "Frontend_Layout";
FFO_Str : aliased constant Source_Buffer := "Fractional_Fixed_Ops";
- HIM_Str : aliased constant Source_Buffer := "High_Integrity_Mode";
- LSI_Str : aliased constant Source_Buffer := "Long_Shifts_Inlined";
MOV_Str : aliased constant Source_Buffer := "Machine_Overflows";
MRN_Str : aliased constant Source_Buffer := "Machine_Rounds";
+ S64_Str : aliased constant Source_Buffer := "Support_64_Bit_Divides";
+ SAG_Str : aliased constant Source_Buffer := "Support_Aggregates";
+ SCA_Str : aliased constant Source_Buffer := "Support_Composite_Assign";
+ SCC_Str : aliased constant Source_Buffer := "Support_Composite_Compare";
SCD_Str : aliased constant Source_Buffer := "Stack_Check_Default";
SCP_Str : aliased constant Source_Buffer := "Stack_Check_Probes";
+ SLS_Str : aliased constant Source_Buffer := "Support_Long_Shifts";
SNZ_Str : aliased constant Source_Buffer := "Signed_Zeros";
+ SSL_Str : aliased constant Source_Buffer := "Suppress_Standard_Library";
UAM_Str : aliased constant Source_Buffer := "Use_Ada_Main_Program_Name";
VMS_Str : aliased constant Source_Buffer := "OpenVMS";
ZCD_Str : aliased constant Source_Buffer := "ZCX_By_Default";
ZCG_Str : aliased constant Source_Buffer := "GCC_ZCX_Support";
ZCF_Str : aliased constant Source_Buffer := "Front_End_ZCX_Support";
+ -- Obsolete entries
+
+ HIM_Str : aliased constant Source_Buffer := "High_Integrity_Mode";
+ LSI_Str : aliased constant Source_Buffer := "Long_Shifts_Inlined";
+
+ -- The following defines a set of pointers to the above strings,
+ -- indexed by the tag values.
+
type Buffer_Ptr is access constant Source_Buffer;
- Targparm_Str : array (Targparm_Tags) of Buffer_Ptr :=
+ Targparm_Str : constant array (Targparm_Tags) of Buffer_Ptr :=
(AAM_Str'Access,
BDC_Str'Access,
BOC_Str'Access,
CLA_Str'Access,
+ CRT_Str'Access,
+ D32_Str'Access,
DEN_Str'Access,
DSP_Str'Access,
+ EXS_Str'Access,
FEL_Str'Access,
FFO_Str'Access,
- HIM_Str'Access,
- LSI_Str'Access,
MOV_Str'Access,
MRN_Str'Access,
+ S64_Str'Access,
+ SAG_Str'Access,
+ SCA_Str'Access,
+ SCC_Str'Access,
SCD_Str'Access,
SCP_Str'Access,
+ SLS_Str'Access,
SNZ_Str'Access,
+ SSL_Str'Access,
UAM_Str'Access,
VMS_Str'Access,
ZCD_Str'Access,
ZCG_Str'Access,
- ZCF_Str'Access);
+ ZCF_Str'Access,
+
+ -- Obsolete entries
+
+ HIM_Str'Access,
+ LSI_Str'Access);
---------------------------
-- Get_Target_Parameters --
---------------------------
+ -- Version which reads in system.ads
+
procedure Get_Target_Parameters is
- use ASCII;
+ Text : Source_Buffer_Ptr;
+ Hi : Source_Ptr;
+
+ begin
+ if Parameters_Obtained then
+ return;
+ end if;
- S : Source_File_Index;
- N : Name_Id;
- T : Source_Buffer_Ptr;
+ Name_Buffer (1 .. 10) := "system.ads";
+ Name_Len := 10;
+
+ Read_Source_File (Name_Find, Lo => 0, Hi => Hi, Src => Text);
+
+ if Text = null then
+ Write_Line ("fatal error, run-time library not installed correctly");
+ Write_Line ("cannot locate file system.ads");
+ raise Unrecoverable_Error;
+ end if;
+
+ Targparm.Get_Target_Parameters
+ (System_Text => Text,
+ Source_First => 0,
+ Source_Last => Hi);
+ end Get_Target_Parameters;
+
+ -- Version where caller supplies system.ads text
+
+ procedure Get_Target_Parameters
+ (System_Text : Source_Buffer_Ptr;
+ Source_First : Source_Ptr;
+ Source_Last : Source_Ptr)
+ is
P : Source_Ptr;
- Z : Source_Ptr;
+ V : Uint;
Fatal : Boolean := False;
-- Set True if a fatal error is detected
@@ -121,113 +201,332 @@ package body Targparm is
-- Records boolean from system line
begin
- Name_Buffer (1 .. 10) := "system.ads";
- Name_Len := 10;
- N := Name_Find;
- S := Load_Source_File (N);
+ if Parameters_Obtained then
+ return;
+ else
+ Parameters_Obtained := True;
+ end if;
- if S = No_Source_File then
- Write_Line ("fatal error, run-time library not installed correctly");
- Write_Str ("cannot locate file ");
- Write_Line (Name_Buffer (1 .. Name_Len));
- raise Unrecoverable_Error;
+ P := Source_First;
+ Line_Loop : while System_Text (P .. P + 10) /= "end System;" loop
- -- This must always be the first source file read, and we have defined
- -- a constant Types.System_Source_File_Index as 1 to reflect this.
+ -- Skip comments quickly
- else
- pragma Assert (S = System_Source_File_Index);
- null;
- end if;
+ if System_Text (P) = '-' then
+ goto Line_Loop_Continue;
+
+ -- Test for pragma Restrictions
+
+ elsif System_Text (P .. P + 20) = "pragma Restrictions (" then
+ P := P + 21;
+
+ Rloop : for K in Partition_Restrictions loop
+ declare
+ Rname : constant String := Restriction_Id'Image (K);
+
+ begin
+ for J in Rname'Range loop
+ if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
+ /= Rname (J)
+ then
+ goto Rloop_Continue;
+ end if;
+ end loop;
+
+ if System_Text (P + Rname'Length) = ')' then
+ Restrictions_On_Target (K) := True;
+ goto Line_Loop_Continue;
+ end if;
+ end;
+
+ <<Rloop_Continue>>
+ null;
+ end loop Rloop;
+
+ Ploop : for K in Restriction_Parameter_Id loop
+ declare
+ Rname : constant String :=
+ Restriction_Parameter_Id'Image (K);
+
+ begin
+ for J in Rname'Range loop
+ if Fold_Upper (System_Text (P + Source_Ptr (J - 1)))
+ /= Rname (J)
+ then
+ goto Ploop_Continue;
+ end if;
+ end loop;
+
+ if System_Text (P + Rname'Length .. P + Rname'Length + 3) =
+ " => "
+ then
+ P := P + Rname'Length + 4;
+ V := Uint_0;
+
+ loop
+ if System_Text (P) in '0' .. '9' then
+ V := 10 * V + Character'Pos (System_Text (P)) - 48;
+ elsif System_Text (P) = '_' then
+ null;
+ elsif System_Text (P) = ')' then
+ Restriction_Parameters_On_Target (K) := V;
+ goto Line_Loop_Continue;
+ else
+ goto Ploop_Continue;
+ end if;
+
+ P := P + 1;
+ end loop;
+ end if;
+ end;
+
+ <<Ploop_Continue>>
+ null;
+ end loop Ploop;
+
+ Set_Standard_Error;
+ Write_Line
+ ("fatal error: system.ads is incorrectly formatted");
+ Write_Str ("unrecognized restrictions pragma: ");
+
+ while System_Text (P) /= ')'
+ and then
+ System_Text (P) /= ASCII.LF
+ loop
+ Write_Char (System_Text (P));
+ P := P + 1;
+ end loop;
+
+ Write_Eol;
+ Fatal := True;
+ Set_Standard_Output;
+
+ -- Discard_Names
+
+ elsif System_Text (P .. P + 20) = "pragma Discard_Names;" then
+ P := P + 21;
+ Opt.Global_Discard_Names := True;
+ goto Line_Loop_Continue;
+
+ -- Locking Policy
+
+ elsif System_Text (P .. P + 22) = "pragma Locking_Policy (" then
+ P := P + 23;
+ Opt.Locking_Policy := System_Text (P);
+ Opt.Locking_Policy_Sloc := System_Location;
+ goto Line_Loop_Continue;
+
+ -- Normalize_Scalars
+
+ elsif System_Text (P .. P + 24) = "pragma Normalize_Scalars;" then
+ P := P + 25;
+ Opt.Normalize_Scalars := True;
+ Opt.Init_Or_Norm_Scalars := True;
+ goto Line_Loop_Continue;
- P := Source_First (S);
- Z := Source_Last (S);
- T := Source_Text (S);
+ -- Polling (On)
- while T (P .. P + 10) /= "end System;" loop
+ elsif System_Text (P .. P + 19) = "pragma Polling (On);" then
+ P := P + 20;
+ Opt.Polling_Required := True;
+ goto Line_Loop_Continue;
- for K in Targparm_Tags loop
- if T (P + 3 .. P + 2 + Targparm_Str (K)'Length) =
- Targparm_Str (K).all
+ -- Ignore pragma Pure (System)
+
+ elsif System_Text (P .. P + 20) = "pragma Pure (System);" then
+ P := P + 21;
+ goto Line_Loop_Continue;
+
+ -- Queuing Policy
+
+ elsif System_Text (P .. P + 22) = "pragma Queuing_Policy (" then
+ P := P + 23;
+ Opt.Queuing_Policy := System_Text (P);
+ Opt.Queuing_Policy_Sloc := System_Location;
+ goto Line_Loop_Continue;
+
+ -- Suppress_Exception_Locations
+
+ elsif System_Text (P .. P + 34) =
+ "pragma Suppress_Exception_Locations;"
+ then
+ P := P + 35;
+ Opt.Exception_Locations_Suppressed := True;
+ goto Line_Loop_Continue;
+
+ -- Task_Dispatching Policy
+
+ elsif System_Text (P .. P + 31) =
+ "pragma Task_Dispatching_Policy ("
+ then
+ P := P + 32;
+ Opt.Task_Dispatching_Policy := System_Text (P);
+ Opt.Task_Dispatching_Policy_Sloc := System_Location;
+ goto Line_Loop_Continue;
+
+ -- No other pragmas are permitted
+
+ elsif System_Text (P .. P + 6) = "pragma " then
+ Set_Standard_Error;
+ Write_Line ("unrecognized line in system.ads: ");
+
+ while System_Text (P) /= ')'
+ and then System_Text (P) /= ASCII.LF
+ loop
+ Write_Char (System_Text (P));
+ P := P + 1;
+ end loop;
+
+ Write_Eol;
+ Set_Standard_Output;
+ Fatal := True;
+
+ -- See if we have a Run_Time_Name
+
+ elsif System_Text (P .. P + 38) =
+ " Run_Time_Name : constant String := """
+ then
+ P := P + 39;
+
+ Name_Len := 0;
+ while System_Text (P) in 'A' .. 'Z'
+ or else
+ System_Text (P) in 'a' .. 'z'
+ or else
+ System_Text (P) in '0' .. '9'
+ or else
+ System_Text (P) = ' '
+ or else
+ System_Text (P) = '_'
+ loop
+ Add_Char_To_Name_Buffer (System_Text (P));
+ P := P + 1;
+ end loop;
+
+ if System_Text (P) /= '"'
+ or else System_Text (P + 1) /= ';'
+ or else (System_Text (P + 2) /= ASCII.LF
+ and then
+ System_Text (P + 2) /= ASCII.CR)
then
- P := P + 3 + Targparm_Str (K)'Length;
+ Set_Standard_Error;
+ Write_Line
+ ("incorrectly formatted Run_Time_Name in system.ads");
+ Set_Standard_Output;
+ Fatal := True;
+
+ else
+ Run_Time_Name_On_Target := Name_Enter;
+ end if;
+
+ goto Line_Loop_Continue;
+
+ -- Next See if we have a configuration parameter
+
+ else
+ Config_Param_Loop : for K in Targparm_Tags loop
+ if System_Text (P + 3 .. P + 2 + Targparm_Str (K)'Length) =
+ Targparm_Str (K).all
+ then
+ P := P + 3 + Targparm_Str (K)'Length;
+
- if Targparm_Flags (K) then
- Set_Standard_Error;
- Write_Line
- ("fatal error: system.ads is incorrectly formatted");
- Write_Str ("duplicate line for parameter: ");
+ if Targparm_Flags (K) then
+ Set_Standard_Error;
+ Write_Line
+ ("fatal error: system.ads is incorrectly formatted");
+ Write_Str ("duplicate line for parameter: ");
- for J in Targparm_Str (K)'Range loop
- Write_Char (Targparm_Str (K).all (J));
+ for J in Targparm_Str (K)'Range loop
+ Write_Char (Targparm_Str (K).all (J));
+ end loop;
+
+ Write_Eol;
+ Set_Standard_Output;
+ Fatal := True;
+
+ else
+ Targparm_Flags (K) := True;
+ end if;
+
+ while System_Text (P) /= ':'
+ or else System_Text (P + 1) /= '='
+ loop
+ P := P + 1;
end loop;
- Write_Eol;
- Set_Standard_Output;
- Fatal := True;
+ P := P + 2;
- else
- Targparm_Flags (K) := True;
+ while System_Text (P) = ' ' loop
+ P := P + 1;
+ end loop;
+
+ Result := (System_Text (P) = 'T');
+
+ case K is
+ when AAM => AAMP_On_Target := Result;
+ when BDC => Backend_Divide_Checks_On_Target := Result;
+ when BOC => Backend_Overflow_Checks_On_Target := Result;
+ when CLA => Command_Line_Args_On_Target := Result;
+ when CRT => Configurable_Run_Time_On_Target := Result;
+ when D32 => Duration_32_Bits_On_Target := Result;
+ when DEN => Denorm_On_Target := Result;
+ when DSP => Functions_Return_By_DSP_On_Target := Result;
+ when EXS => Exit_Status_Supported_On_Target := Result;
+ when FEL => Frontend_Layout_On_Target := Result;
+ when FFO => Fractional_Fixed_Ops_On_Target := Result;
+ when MOV => Machine_Overflows_On_Target := Result;
+ when MRN => Machine_Rounds_On_Target := Result;
+ when S64 => Support_64_Bit_Divides_On_Target := Result;
+ when SAG => Support_Aggregates_On_Target := Result;
+ when SCA => Support_Composite_Assign_On_Target := Result;
+ when SCC => Support_Composite_Compare_On_Target := Result;
+ when SCD => Stack_Check_Default_On_Target := Result;
+ when SCP => Stack_Check_Probes_On_Target := Result;
+ when SLS => Support_Long_Shifts_On_Target := Result;
+ when SSL => Suppress_Standard_Library_On_Target := Result;
+ when SNZ => Signed_Zeros_On_Target := Result;
+ when UAM => Use_Ada_Main_Program_Name_On_Target := Result;
+ when VMS => OpenVMS_On_Target := Result;
+ when ZCD => ZCX_By_Default_On_Target := Result;
+ when ZCG => GCC_ZCX_Support_On_Target := Result;
+ when ZCF => Front_End_ZCX_Support_On_Target := Result;
+
+ -- Obsolete entries
+
+ when HIM => null;
+ when LSI => null;
+
+ goto Line_Loop_Continue;
+ end case;
end if;
+ end loop Config_Param_Loop;
+ end if;
- while T (P) /= ':' or else T (P + 1) /= '=' loop
- P := P + 1;
- end loop;
-
- P := P + 2;
-
- while T (P) = ' ' loop
- P := P + 1;
- end loop;
-
- Result := (T (P) = 'T');
-
- case K is
- when AAM => AAMP_On_Target := Result;
- when BDC => Backend_Divide_Checks_On_Target := Result;
- when BOC => Backend_Overflow_Checks_On_Target := Result;
- when CLA => Command_Line_Args_On_Target := Result;
- when DEN => Denorm_On_Target := Result;
- when DSP => Functions_Return_By_DSP_On_Target := Result;
- when FEL => Frontend_Layout_On_Target := Result;
- when FFO => Fractional_Fixed_Ops_On_Target := Result;
- when HIM => High_Integrity_Mode_On_Target := Result;
- when LSI => Long_Shifts_Inlined_On_Target := Result;
- when MOV => Machine_Overflows_On_Target := Result;
- when MRN => Machine_Rounds_On_Target := Result;
- when SCD => Stack_Check_Default_On_Target := Result;
- when SCP => Stack_Check_Probes_On_Target := Result;
- when SNZ => Signed_Zeros_On_Target := Result;
- when UAM => Use_Ada_Main_Program_Name_On_Target := Result;
- when VMS => OpenVMS_On_Target := Result;
- when ZCD => ZCX_By_Default_On_Target := Result;
- when ZCG => GCC_ZCX_Support_On_Target := Result;
- when ZCF => Front_End_ZCX_Support_On_Target := Result;
- end case;
-
- exit;
- end if;
- end loop;
+ -- Here after processing one line of System spec
+
+ <<Line_Loop_Continue>>
- while T (P) /= CR and then T (P) /= LF loop
+ while System_Text (P) /= CR and then System_Text (P) /= LF loop
P := P + 1;
- exit when P >= Z;
+ exit when P >= Source_Last;
end loop;
- while T (P) = CR or else T (P) = LF loop
+ while System_Text (P) = CR or else System_Text (P) = LF loop
P := P + 1;
- exit when P >= Z;
+ exit when P >= Source_Last;
end loop;
- if P >= Z then
+ if P >= Source_Last then
Set_Standard_Error;
Write_Line ("fatal error, system.ads not formatted correctly");
Set_Standard_Output;
- raise Unrecoverable_Error;
end if;
- end loop;
+ end loop Line_Loop;
+
+ -- Check no missing target parameter settings
- for K in Targparm_Tags loop
+ for K in Targparm_Tags_OK loop
if not Targparm_Flags (K) then
Set_Standard_Error;
Write_Line
diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads
index 7aff79d53f3..cf7aa2398ba 100644
--- a/gcc/ada/targparm.ads
+++ b/gcc/ada/targparm.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1999-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- --
@@ -28,13 +28,18 @@
-- System, to indicate parameters relevant to the target environment.
-- Conceptually, these parameters could be obtained using rtsfind, but
--- we do not do this for three reasons:
+-- we do not do this for four reasons:
-- 1. Compiling System for every compilation wastes time
+
-- 2. This compilation impedes debugging by adding extra compile steps
+
-- 3. There are recursion problems coming from compiling System itself
-- or any of its children.
+-- 4. The binder also needs the parameters, and we do not want to have
+-- to drag a lot of front end stuff into the binder.
+
-- For all these reasons, we read in the source of System, and then scan
-- it at the text level to extract the parameter values.
@@ -43,8 +48,109 @@
-- computed and set in the ali file. This partially negates points 1 and 2
-- above although just parsing is quick and does not impact debugging much.
+-- The parameters acquired by this routine from system.ads fall into three
+-- categories:
+
+-- 1. Configuration pragmas, that must appear at the start of the file.
+-- Any such pragmas automatically apply to any unit compiled in the
+-- presence of this system file. Only a limited set of such pragmas
+-- may appear as documented in the corresponding section below,
+
+-- 2. Target parameters. These are boolean constants that are defined
+-- in the private part of the package giving fixed information
+-- about the target architecture, and the capabilities of the
+-- code generator and run-time library.
+
+-- 3. Identification information. This is an optional string constant
+-- that gives the name of the run-time library configuration. This
+-- line may be ommitted for a version of system.ads to be used with
+-- the full Ada 95 run time.
+
+with Rident; use Rident;
+with Types; use Types;
+with Uintp; use Uintp;
+
package Targparm is
+ ---------------------------
+ -- Configuration Pragmas --
+ ---------------------------
+
+ -- The following switches get set if the corresponding configuration
+ -- pragma is scanned from the source of system.ads. No other pragmas
+ -- are permitted to appear at the start of the system.ads source file.
+
+ -- If a pragma Discard_Names appears, then Opt.Global_Discard_Names is
+ -- set to True to indicate that all units must be compiled in this mode.
+
+ -- If a pragma Locking_Policy appears, then Opt.Locking_Policy is set
+ -- to the first character of the policy name, and Opt.Locking_Policy_Sloc
+ -- is set to System_Location.
+
+ -- If a pragma Normalize_Scalars appears, then Opt.Normalize_Scalars
+ -- is set True, as well as Opt.Init_Or_Norm_Scalars.
+
+ -- If a pragma Queuing_Policy appears, then Opt.Queuing_Policy is set
+ -- to the first character of the policy name, and Opt.Queuing_Policy_Sloc
+ -- is set to System_Location.
+
+ -- If a pragma Task_Dispatching_Policy appears, then the flag
+ -- Opt.Task_Dispatching_Policy is set to the first character of the
+ -- policy name, and Opt.Task_Dispatching_Policy_Sloc is set to
+ -- System_Location.
+
+ -- If a pragma Polling (On) appears, then the flag Opt.Polling_Required
+ -- is set to True.
+
+ -- if a pragma Suppress_Exception_Locations appears, then the flag
+ -- Opt.Exception_Locations_Suppressed is set to True.
+
+ -- The only other pragma allowed is a pragma Restrictions that gives the
+ -- simple name of a restriction for which partition consistency is always
+ -- required (see definition of Rident.Partition_Restrictions).
+
+ Restrictions_On_Target :
+ array (Partition_Restrictions) of Boolean := (others => False);
+ -- Element is set True if a pragma Restrictions for the corresponding
+ -- identifier appears in system.ads. Note that only partition restriction
+ -- identifiers are permitted as arguments for pragma Restrictions for
+ -- pragmas appearing at the start of system.ads.
+
+ Restriction_Parameters_On_Target :
+ array (Restriction_Parameter_Id) of Uint := (others => No_Uint);
+ -- Element is set to specified value if a pragma Restrictions for the
+ -- corresponding restriction parameter value is set.
+
+ -------------------
+ -- Run Time Name --
+ -------------------
+
+ -- This parameter should be regarded as read only by all clients of
+ -- of package. The only way they get modified is by calling the
+ -- Get_Target_Parameters routine which reads the values from a provided
+ -- text buffer containing the source of the system package.
+
+ -- The corresponding string constant is placed immediately at the start
+ -- of the private part of system.ads if is present, e.g. in the form:
+
+ -- Run_Time_Name : constant String := "Zero Footprint Run Time";
+
+ -- the corresponding messages will look something like
+
+ -- xxx not supported (Zero Footprint Run Time)
+
+ Run_Time_Name_On_Target : Name_Id := No_Name;
+ -- Set to appropriate names table entry Id value if a Run_Time_Name
+ -- string constant is defined in system.ads. This name is used only
+ -- for the configurable run-time case, and is used to parametrize
+ -- messages that complain about non-supported run-time features.
+ -- The name should contain only letters A-Z, digits 1-9, spaces,
+ -- and underscores.
+
+ -----------------------
+ -- Target Parameters --
+ -----------------------
+
-- The following parameters correspond to the variables defined in the
-- private part of System (without the terminating _On_Target). Note
-- that it is required that all parameters defined here be specified
@@ -52,7 +158,18 @@ package Targparm is
-- All these parameters should be regarded as read only by all clients
-- of the package. The only way they get modified is by calling the
- -- Get_Target_Parameters routine which reads the values from System.
+ -- Get_Target_Parameters routine which reads the values from a provided
+ -- text buffer containing the source of the system package.
+
+ ----------------------------
+ -- Special Target Control --
+ ----------------------------
+
+ -- The great majority of GNAT ports are based on GCC. The switches in
+ -- This section indicate the use of some non-standard target back end.
+
+ AAMP_On_Target : Boolean;
+ -- Set to True if target is AAMP.
-------------------------------
-- Backend Arithmetic Checks --
@@ -78,9 +195,9 @@ package Targparm is
-- Control of Exception Handling --
-----------------------------------
- -- GNAT provides two methods of implementing exceptions:
+ -- GNAT implements three methods of implementing exceptions:
- -- Longjmp/Setjmp (-gnatL)
+ -- Front-End Longjmp/Setjmp Exceptions
-- This approach uses longjmp/setjmp to handle exceptions. It
-- uses less storage, and can often propagate exceptions faster,
@@ -88,7 +205,14 @@ package Targparm is
-- up an exception handler. This approach is available on all
-- targets, and is the default where it is the only approach.
- -- Zero Cost (-gnatZ)
+ -- The generation of the setjmp and longjmp calls is handled by
+ -- the front end of the compiler (this includes gigi in the case
+ -- of the standard GCC back end). It does not use any back end
+ -- suport (such as the GCC3 exception handling mechanism). When
+ -- this approach is used, the compiler generates special exception
+ -- handlers for handling cleanups when an exception is raised.
+
+ -- Front-End Zero Cost Exceptions
-- This approach uses separate exception tables. These use extra
-- storage, and exception propagation can be quite slow, but there
@@ -97,28 +221,193 @@ package Targparm is
-- is only available on some targets, and is the default where it is
-- available.
+ -- The generation of the exception tables is handled by the front
+ -- end of the compiler. It does not use any back end support (such
+ -- as the GCC3 exception handling mechanism). When this approach
+ -- is used, the compiler generates special exception handlers for
+ -- handling cleanups when an exception is raised.
+
+ -- Back-End Zero Cost Exceptions
+
+ -- With this approach, the back end handles the generation and
+ -- handling of exceptions. For example, the GCC3 exception handling
+ -- mechanisms are used in this mode. The front end simply generates
+ -- code for explicit exception handlers, and AT END cleanup handlers
+ -- are simply passed unchanged to the backend for generating cleanups
+ -- both in the exceptional and non-exceptional cases.
+
+ -- As the name implies, this approach generally uses a zero-cost
+ -- mechanism with tables, but the tables are generated by the back
+ -- end. However, since the back-end is entirely responsible for the
+ -- handling of exceptions, another mechanism might be used. In the
+ -- case of GCC3 for instance, it might be the case that the compiler
+ -- is configured for setjmp/longjmp handling, then everything will
+ -- work correctly. However, it is definitely preferred that the
+ -- back end provide zero cost exception handling.
+
+ -- Controlling the selection of methods
+
+ -- The Front-End Longjmp/Setjmp approach is always available in
+ -- all implementations. If it is not the default method, then it
+ -- may be explicitly specified by the use of -gnatL. Note however
+ -- that there is a requirement that all Ada units in a partition
+ -- be compiled with this overriding option if it is not the default.
+
+ -- On some, but not all, implementations of GNAT, one of the two
+ -- ZCX approaches (but not both) is implemented. If this is the
+ -- case, and ZCX is not the default mechanism, then ZCX handling
+ -- (front-end or back-end according to the implementation) may be
+ -- specified by use of the -gnatZ switch. Again, this switch must
+ -- be used to compile all Ada units in a partition. The use of
+ -- the -gnatZ switch will cause termination with a fatal error.
+
+ -- Finally the debug option -gnatdX can be used to force the
+ -- compiler to operate in front-end ZCX exception mode and force
+ -- the front end to generate exception tables. This is only useful
+ -- for debugging purposes for implementations which do not provide
+ -- the possibility of front-end ZCX mode. The resulting object file
+ -- is unusable, but this debug switch may still be useful (e.g. in
+ -- conjunction with -gnatG) for front-end debugging purposes.
+
+ -- Control of Available Methods and Defaults
+
+ -- The following switches specify which of the two ZCX methods
+ -- (if any) is available in an implementation, and which method
+ -- is the default method.
+
ZCX_By_Default_On_Target : Boolean;
- -- Indicates if zero cost exceptions are active by default.
+ -- Indicates if zero cost exceptions are active by default. If this
+ -- variable is False, then the only possible exception method is the
+ -- front-end setjmp/longjmp approach, and this is the default. If
+ -- this variable is True, then one of the following two flags must
+ -- be True, and represents the method to be used by default.
GCC_ZCX_Support_On_Target : Boolean;
- -- Indicates that when ZCX is active the mechanism to be used is the
- -- standard GCC ZCX mechanism (introduced in GCC 3.1)
+ -- Indicates that when ZCX is active, the mechanism to be used is the
+ -- back-end ZCX exception approach. If this variable is set to True,
+ -- then Front_End_ZCX_Support_On_Target must be False.
Front_End_ZCX_Support_On_Target : Boolean;
- -- Indicates that when ZCX is active (and GCC_ZCX_Support is not set)
- -- the mechanism to be used is the GNAT front end specific ZCX mechanism
-
- ---------------------------------------
- -- High_Integrity (No Run Time) Mode --
- ---------------------------------------
-
- -- In High_Integrity mode, there is no system run-time, and the flag
- -- Opt.No_Run_Time is set so that the language is appropriately
- -- restricted to forbid construct that would generate run-time calls.
-
- High_Integrity_Mode_On_Target : Boolean;
- -- Indicates that this build is for a high integrity mode version of
- -- GNAT, so that no run time is permitted.
+ -- Indicates that when ZCX is active, the mechanism to be used is the
+ -- front-end ZCX exception approach. If this variable is set to True,
+ -- then GCC_ZCX_Support_On_Target must be False.
+
+ --------------------------------
+ -- Configurable Run-Time Mode --
+ --------------------------------
+
+ -- In configurable run-time mode, the system run-time may not support
+ -- the full Ada language. The effect of setting this switch is to let
+ -- the compiler know that it is not surprising (i.e. the system is not
+ -- misconfigured) if run-time library units or entities within units are
+ -- not present in the run-time.
+
+ Configurable_Run_Time_On_Target : Boolean;
+ -- Indicates that the system.ads file is for a configurable run-time
+ --
+ -- This has some specific effects as follows
+ --
+ -- The binder generates the gnat_argc/argv/envp variables in the
+ -- binder file instead of being imported from the run-time library.
+ -- If Command_Line_Args_On_Target is set to False, then the
+ -- generation of these variables is suppressed completely.
+ --
+ -- The binder generates the gnat_exit_status variable in the binder
+ -- file instead of being imported from the run-time library. If
+ -- Exit_Status_Supported_On_Target is set to False, then the
+ -- generation of this variable is suppressed entirely.
+ --
+ -- The routine __gnat_break_start is defined within the binder file
+ -- instead of being imported from the run-time library.
+ --
+ -- The variable __gnat_exit_status is generated within the binder file
+ -- instead of being imported from the run-time library.
+ --
+ -- No -Ldir switches are added for the linker step
+ --
+ -- No standard switches are added after user file entries to the
+ -- linker line. All such switches must be explicit. In other words
+ -- the option -nostdlib is implicit with a configurable run-time.
+
+ Suppress_Standard_Library_On_Target : Boolean;
+ -- If this flag is True, then the standard library is not included by
+ -- default in the executable (see unit System.Standard_Library in file
+ -- s-stalib.ads for details of what this includes). This is for example
+ -- set True for the zero foot print case, where these files should not
+ -- be included by default.
+ --
+ -- This flag has some other related effects:
+ --
+ -- The generation of global variables in the bind file is suppressed,
+ -- with the exception of the priority of the environment task, which
+ -- is needed by the Ravenscar run-time.
+ --
+ -- The generation of exception tables is suppressed for front end
+ -- ZCX exception handling (since we assume no exception handling).
+ --
+ -- The calls to __gnat_initialize and __gnat_finalize are omitted
+ --
+ -- All finalization and initialization (controlled types) is omitted
+ --
+ -- The routine __gnat_handler_installed is not imported
+
+ ---------------------
+ -- Duration Format --
+ ---------------------
+
+ -- By default, type Duration is a 64-bit fixed-point type with a delta
+ -- and small of 10**(-9) (i.e. it is a count in nanoseconds. This flag
+ -- allows that standard format to be modified.
+
+ Duration_32_Bits_On_Target : Boolean;
+ -- If True, then Duration is represented in 32 bits and the delta and
+ -- small values are set to 20.0*(10**(-3)) (i.e. it is a count in units
+ -- of 20 milliseconds.
+
+ ------------------------------------
+ -- Back-End Code Generation Flags --
+ ------------------------------------
+
+ -- These flags indicate possible limitations in what the code generator
+ -- can handle. They will all be True for a full run-time, but one or more
+ -- of these may be false for a configurable run-time, and if a feature is
+ -- used at the source level, and the corresponding flag is false, then an
+ -- error message will be issued saying the feature is not supported.
+
+ Support_64_Bit_Divides_On_Target : Boolean;
+ -- If True, the back end supports 64-bit divide operations. If False, then
+ -- the source program may not contain 64-bit divide operations. This is
+ -- specifically useful in the zero foot-print case, where the issue is
+ -- whether there is a hardware divide instruction for 64-bits so that
+ -- no run-time support is required. It should always be set True if the
+ -- necessary run-time support is present.
+
+ Support_Aggregates_On_Target : Boolean;
+ -- In the general case, the use of aggregates may generate calls
+ -- to run-time routines in the C library, including memset, memcpy,
+ -- memmove, and bcopy. This flag is set to True if these routines
+ -- are available. If any of these routines is not available, then
+ -- this flag is False, and the use of aggregates is not permitted.
+
+ Support_Composite_Assign_On_Target : Boolean;
+ -- The assignment of composite objects other than small records and
+ -- arrays whose size is 64-bits or less and is set by an explicit
+ -- size clause may generate calls to memcpy, memmove, and bcopy.
+ -- If versions of all these routines are available, then this flag
+ -- is set to True. If any of these routines is not available, then
+ -- the flag is set False, and composite assignments are not allowed.
+
+ Support_Composite_Compare_On_Target : Boolean;
+ -- If this flag is True, then the back end supports bit-wise comparison
+ -- of composite objects for equality, either generating inline code or
+ -- calling appropriate (and available) run-time routines. If this flag
+ -- is False, then the back end does not provide this support, and the
+ -- front end uses component by component comparison for composites.
+
+ Support_Long_Shifts_On_Target : Boolean;
+ -- If True, the back end supports 64-bit shift operations. If False, then
+ -- the source program may not contain explicit 64-bit shifts. In addition,
+ -- the code generated for packed arrays will avoid the use of long shifts.
-------------------------------
-- Control of Stack Checking --
@@ -164,13 +453,23 @@ package Targparm is
-- For most ports of GNAT, command line arguments are supported. The
-- following flag is set to False for targets that do not support
- -- command line arguments (notably VxWorks).
+ -- command line arguments (VxWorks and AAMP). Note that support of
+ -- command line arguments is not required on such targets (RM A.15(13)).
Command_Line_Args_On_Target : Boolean;
- -- Set False if no command line arguments on target
+ -- Set False if no command line arguments on target. Note that if this
+ -- is False in with Configurable_Run_Time_On_Target set to True, then
+ -- this causes suppression of generation of the argv/argc variables
+ -- used to record command line arguments.
+
+ -- Similarly, most ports support the use of an exit status, but AAMP
+ -- is an exception (as allowed by RM A.15(18-20))
- -- Note: this is prepared for future use, but not yet used, since we
- -- do not yet have a way of propagating Targparm params to the binder
+ Exit_Status_Supported_On_Target : Boolean;
+ -- Set False if returning of an exit status is not supported on target.
+ -- Note that if this False in with Configurable_Run_Time_On_Target
+ -- set to True, then this causes suppression of the gnat_exit_status
+ -- variable used to recod the exit status.
-----------------------
-- Main Program Name --
@@ -186,28 +485,6 @@ package Targparm is
Use_Ada_Main_Program_Name_On_Target : Boolean;
-- Set True to use the Ada main program name as the main name
- -- Note: this is prepared for future use, but not yet used, since we
- -- do not yet have a way of propagating Targparm params to the binder
-
- ----------------------------
- -- Support of Long Shifts --
- ----------------------------
-
- -- In GNORT mode, we cannot call library routines, and in particular
- -- we cannot call routines for long (64-bit) shifts if such routines
- -- are required on the target. This comes up in the context of support
- -- of packed arrays. We can only represent packed arrays whose length
- -- is in the range 33- to 64-bits as modular types if long shifts are
- -- done with inline code.
-
- -- For the default version, for now we set long shifts inlined as True
- -- This may not be quite accurate, but until we get proper separate
- -- System's for each target, it is a safer choice.
-
- Long_Shifts_Inlined_On_Target : Boolean;
- -- Indicates if long (double word) shifts are generated using inlined
- -- code (and thus are permissible in No_Run_Time mode).
-
----------------------------------------------
-- Boolean-Valued Floating-Point Attributes --
----------------------------------------------
@@ -226,9 +503,6 @@ package Targparm is
-- the partition. We probably should add such consistency checks in future,
-- but for now we don't do this.
- AAMP_On_Target : Boolean;
- -- Set to True if target is AAMP.
-
Denorm_On_Target : Boolean;
-- Set to False on targets that do not reliably support denormals.
-- Reliably here means for all settings of the relevant -m flag, so
@@ -313,8 +587,23 @@ package Targparm is
-- Subprograms --
-----------------
+ -- These subprograms are used to initialize the target parameter values
+ -- from the system.ads file. Note that this is only done once, so if more
+ -- than one call is made to either routine, the second and subsequent
+ -- calls are ignored.
+
+ procedure Get_Target_Parameters
+ (System_Text : Source_Buffer_Ptr;
+ Source_First : Source_Ptr;
+ Source_Last : Source_Ptr);
+ -- Called at the start of execution to obtain target parameters from
+ -- the source of package System. The parameters provide the source
+ -- text to be scanned (in System_Text (Source_First .. Source_Last)).
+
procedure Get_Target_Parameters;
- -- Called at the start of execution to read the source of System and
- -- obtain and set the values of the above parameters.
+ -- This version reads in system.ads using Osint. The idea is that the
+ -- caller uses the first version if they have to read system.ads anyway
+ -- (e.g. the compiler) and uses this simpler interface if system.ads is
+ -- not otherwise needed.
end Targparm;
diff --git a/gcc/ada/targtyps.c b/gcc/ada/targtyps.c
index 39a009b0e94..4315c00f023 100644
--- a/gcc/ada/targtyps.c
+++ b/gcc/ada/targtyps.c
@@ -6,8 +6,7 @@
* *
* Body *
* *
- * *
- * Copyright (C) 1992-2001 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- *
diff --git a/gcc/ada/tb-alvms.c b/gcc/ada/tb-alvms.c
new file mode 100644
index 00000000000..fecedd396f0
--- /dev/null
+++ b/gcc/ada/tb-alvms.c
@@ -0,0 +1,263 @@
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * T R A C E B A C K - A l p h a / V M S *
+ * *
+ * C Implementation File *
+ * *
+ * Copyright (C) 2003 Ada Core Technologies, Inc *
+ * *
+ * GNAT is free software; you can redistribute it and/or modify it under *
+ * terms of the GNU General Public License as published by the Free Soft- *
+ * ware Foundation; either version 2, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * As a special exception, if you link this file with other files to *
+ * produce an executable, this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not however invalidate any other reasons why the executable *
+ * file might be covered by the GNU Public License. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * Extensive contributions were provided by Ada Core Technologies Inc. *
+ * *
+ ****************************************************************************/
+
+
+/* Alpha VMS requires a special treatment due to the complexity of the ABI.
+ What is here is along the lines of what the MD_FALLBACK_FRAME_STATE_FOR
+ macro does for frame unwinding during exception propagation. This file is
+ #included within tracebak.c in the appropriate case.
+
+ Most of the contents is directed by the OpenVMS/Alpha Conventions (ABI)
+ document, sections of which we will refer to as ABI-<section_number>. */
+
+#include <pdscdef.h>
+
+/* We still use a number of macros similar to the ones for the generic
+ __gnat_backtrace implementation. */
+#define SKIP_FRAME 1
+#define PC_ADJUST -4
+
+#define STOP_FRAME (frame_state.saved_ra == RA_STOP)
+
+/* Mask for PDSC$V_BASE_FRAME in procedure descriptors, missing from the
+ header file included above. */
+#define PDSC$M_BASE_FRAME (1 << 10)
+
+typedef unsigned long REG;
+
+#define REG_AT(address) (*(REG *)(address))
+
+/* The following structure defines the state maintained during the
+ unwinding process. */
+typedef struct
+{
+ void * pc; /* Address of the call insn involved in the chain. */
+ void * sp; /* Stack Pointer at the time of this call. */
+ void * fp; /* Frame Pointer at the time of this call. */
+
+ /* Values of the registers saved by the functions in the chain,
+ incrementally updated through consecutive calls to the "unwind"
+ function below. */
+ REG saved_regs [32];
+} frame_state_t;
+
+/* Shortcuts for saved_regs of specific interest:
+
+ Frame Pointer is r29,
+ Stack Pointer is r30,
+ Return Address is r26,
+ Procedure Value is r27.
+
+ This is from ABI-3.1.1 [Integer Registers]. */
+
+#define saved_fp saved_regs[29]
+#define saved_sp saved_regs[30]
+#define saved_ra saved_regs[26]
+#define saved_pv saved_regs[27]
+
+/* Special values for saved_ra, used to control the overall unwinding
+ process. */
+#define RA_UNKNOWN ((REG)~0)
+#define RA_STOP ((REG)0)
+
+/**********
+ * unwind *
+ **********/
+
+/* Helper for __gnat_backtrace. Update FS->pc/sp/fp to represent the
+ state computed in FS->saved_regs during the previous call, and update
+ FS->saved_regs in preparation of the next call. */
+
+void
+unwind (frame_state_t * fs)
+{
+ REG frame_base;
+ PDSCDEF * pv;
+
+ /* Don't do anything if requested so. */
+ if (fs->saved_ra == RA_STOP)
+ return;
+
+ /* Retrieve the values of interest computed during the previous
+ call. PC_ADJUST gets us from the return address to the call insn
+ address. */
+ fs->pc = (void *) fs->saved_ra + PC_ADJUST;
+ fs->sp = (void *) fs->saved_sp;
+ fs->fp = (void *) fs->saved_fp;
+
+ /* Unless we are able to determine otherwise, set the frame state's
+ saved return address such that the unwinding process will stop. */
+ fs->saved_ra = RA_STOP;
+
+ /* Now we want to update fs->saved_regs to reflect what the procedure
+ described by pc/fp/sp has done. */
+
+ /* Compute the corresponding "procedure value", following the rules in
+ ABI-3.6.1 [Current Procedure]. Return immediatly if this value mandates
+ us to stop. */
+ if (fs->fp == 0)
+ return;
+
+ if ((REG_AT (fs->fp) & 0x7) == 0)
+ pv = *(PDSCDEF **)fs->fp;
+ else
+ pv = (PDSCDEF *) fs->fp;
+
+ if (pv == 0
+ || pv->pdsc$w_flags & PDSC$M_BASE_FRAME)
+ return;
+
+ /* Use the procedure value to unwind, in a way depending on the kind of
+ procedure at hand. This is based on ABI-3.3 [Procedure Representation]
+ and ABI-3.4 [Procedure Types]. */
+ frame_base
+ = (REG) ((pv->pdsc$w_flags & PDSC$M_BASE_REG_IS_FP) ? fs->fp : fs->sp);
+
+ switch (pv->pdsc$w_flags & 0xf)
+ {
+ case PDSC$K_KIND_FP_STACK:
+ /* Stack Frame Procedure (ABI-3.4.1). Retrieve the necessary registers
+ from the Register Save Area in the frame. */
+ {
+ REG rsa_base = frame_base + pv->pdsc$w_rsa_offset;
+ int i, j;
+
+ fs->saved_ra = REG_AT (rsa_base);
+ fs->saved_pv = REG_AT (frame_base);
+
+ for (i = 0, j = 0; i < 32; i++)
+ if (pv->pdsc$l_ireg_mask & (1 << i))
+ fs->saved_regs[i] = REG_AT (rsa_base + 8 * ++j);
+
+ /* Note that the loop above is guaranteed to set fs->saved_fp, because
+ "The preserved register set must always include R29(FP) since it
+ will always be used." (ABI-3.4.3.4 [Register Save Area for All
+ Stack Frames]).
+
+ Also note that we need to run through all the registers to ensure
+ that unwinding through register procedures (see below) gets the
+ right values out of the saved_regs array. */
+ }
+ break;
+
+ case PDSC$K_KIND_FP_REGISTER:
+ /* Register Procedure (ABI-3.4.4). Retrieve the necessary registers from
+ the registers where they have been saved. */
+ {
+ fs->saved_ra = fs->saved_regs[pv->pdsc$b_save_ra];
+ fs->saved_fp = fs->saved_regs[pv->pdsc$b_save_fp];
+ }
+ break;
+
+ default:
+ /* ??? Are we supposed to ever get here ? Don't think so. */
+ break;
+ }
+
+ /* SP is actually never part of the saved registers area, so we use the
+ corresponding entry in the saved_regs array to manually keep track of
+ it's evolution. */
+ fs->saved_sp = frame_base + pv->pdsc$l_size;
+}
+
+/* Structure representing a traceback entry in the tracebacks array to be
+ filled by __gnat_backtrace below. This should match the declaration of
+ Traceback_Entry in System.Traceback_Entries.
+
+ The use of a structure is motivated by the potential necessity of having
+ several fields to fill for each entry, for instance if later calls to VMS
+ system functions need more than just a mere PC to compute info on a frame
+ (e.g. for non-symbolic->symbolic translation purposes). */
+
+typedef struct {
+ void * pc; /* Address of the call instruction in the chain. */
+ void * sp; /* Stack Pointer value at the point of this call. */
+ void * fp; /* Frame Pointer value at the point of this call. */
+} tb_entry_t;
+
+/********************
+ * __gnat_backtrace *
+ ********************/
+
+int
+__gnat_backtrace (array, size, exclude_min, exclude_max, skip_frames)
+ void **array;
+ int size;
+ void *exclude_min;
+ void *exclude_max;
+ int skip_frames;
+{
+ int cnt;
+
+ tb_entry_t * tbe = (tb_entry_t *)&array [0];
+
+ frame_state_t frame_state;
+
+ /* Setup the frame state before initiating the unwinding sequence. */
+ register REG this_FP __asm__("$29");
+ register REG this_SP __asm__("$30");
+
+ frame_state.saved_fp = this_FP;
+ frame_state.saved_sp = this_SP;
+ frame_state.saved_ra = RA_UNKNOWN;
+
+ unwind (&frame_state);
+
+ /* At this point frame_state describes this very function. Skip the
+ requested number of calls. */
+ for (cnt = 0; cnt < skip_frames; cnt ++)
+ unwind (&frame_state);
+
+ /* Now consider each frame as a potential candidate for insertion inside
+ the provided array. */
+ cnt = 0;
+ while (cnt < size)
+ {
+ if (STOP_FRAME)
+ break;
+
+ if (frame_state.pc < exclude_min
+ || frame_state.pc > exclude_max)
+ {
+ tbe->pc = frame_state.pc;
+ tbe->sp = frame_state.sp;
+ tbe->fp = frame_state.fp;
+
+ cnt ++;
+ tbe ++;
+ }
+
+ unwind (&frame_state);
+ }
+
+ return cnt;
+}
diff --git a/gcc/ada/tb-alvxw.c b/gcc/ada/tb-alvxw.c
new file mode 100644
index 00000000000..0c022aad63b
--- /dev/null
+++ b/gcc/ada/tb-alvxw.c
@@ -0,0 +1,965 @@
+/****************************************************************************
+ * *
+ * GNAT COMPILER COMPONENTS *
+ * *
+ * T R A C E B A C K - A l p h a / V x W o r k s *
+ * *
+ * C Implementation File *
+ * *
+ * Copyright (C) 2000-2003 Ada Core Technologies, Inc *
+ * *
+ * GNAT is free software; you can redistribute it and/or modify it under *
+ * terms of the GNU General Public License as published by the Free Soft- *
+ * ware Foundation; either version 2, or (at your option) any later ver- *
+ * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
+ * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
+ * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
+ * for more details. You should have received a copy of the GNU General *
+ * Public License distributed with GNAT; see file COPYING. If not, write *
+ * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
+ * MA 02111-1307, USA. *
+ * *
+ * As a special exception, if you link this file with other files to *
+ * produce an executable, this file does not by itself cause the resulting *
+ * executable to be covered by the GNU General Public License. This except- *
+ * ion does not however invalidate any other reasons why the executable *
+ * file might be covered by the GNU Public License. *
+ * *
+ * GNAT was originally developed by the GNAT team at New York University. *
+ * Extensive contributions were provided by Ada Core Technologies Inc. *
+ * *
+ ****************************************************************************/
+
+/* Alpha vxWorks requires a special, complex treatment that is extracted
+ from GDB. This file is #included within tracebak.c in the appropriate
+ case. */
+
+#include <stddef.h>
+#include <stdlib.h>
+#include <limits.h>
+#include <string.h>
+
+extern void kerTaskEntry();
+
+/* We still use a number of macros similar to the ones for the generic
+ __gnat_backtrace implementation. */
+#define SKIP_FRAME 1
+#define PC_ADJUST -4
+
+#define STOP_FRAME \
+ (current == NULL \
+ || ((CORE_ADDR) &kerTaskEntry >= PROC_LOW_ADDR (current->proc_desc) \
+ && current->pc >= (CORE_ADDR) &kerTaskEntry))
+
+/* Register numbers of various important registers.
+ Note that most of these values are "real" register numbers,
+ and correspond to the general registers of the machine,
+ and FP_REGNUM is a "phony" register number which is too large
+ to be an actual register number as far as the user is concerned
+ but serves to get the desired value when passed to read_register. */
+
+#define T7_REGNUM 8 /* Return address register for OSF/1 __add* */
+#define GCC_FP_REGNUM 15 /* Used by gcc as frame register */
+#define T9_REGNUM 23 /* Return address register for OSF/1 __div* */
+#define SP_REGNUM 30 /* Contains address of top of stack */
+#define RA_REGNUM 26 /* Contains return address value */
+#define FP0_REGNUM 32 /* Floating point register 0 */
+#define PC_REGNUM 64 /* Contains program counter */
+#define NUM_REGS 66
+
+#define VM_MIN_ADDRESS (CORE_ADDR)0x120000000
+
+#define SIZEOF_FRAME_SAVED_REGS (sizeof (CORE_ADDR) * (NUM_REGS))
+#define INIT_EXTRA_FRAME_INFO(fromleaf, fci) init_extra_frame_info(fci)
+
+#define FRAME_CHAIN(thisframe) (CORE_ADDR) alpha_frame_chain (thisframe)
+
+#define FRAME_CHAIN_VALID(CHAIN, THISFRAME) \
+ ((CHAIN) != 0 \
+ && !inside_entry_file (FRAME_SAVED_PC (THISFRAME)))
+
+#define FRAME_SAVED_PC(FRAME) (alpha_frame_saved_pc (FRAME))
+
+#define FRAME_CHAIN_COMBINE(CHAIN, THISFRAME) (CHAIN)
+
+#define INIT_FRAME_PC(FROMLEAF, PREV)
+
+#define INIT_FRAME_PC_FIRST(FROMLEAF, PREV) \
+ (PREV)->pc = ((FROMLEAF) ? SAVED_PC_AFTER_CALL ((PREV)->next) \
+ : (PREV)->next ? FRAME_SAVED_PC ((PREV)->next) : read_pc ());
+
+#define SAVED_PC_AFTER_CALL(FRAME) alpha_saved_pc_after_call (FRAME)
+
+typedef unsigned long long int bfd_vma;
+
+typedef bfd_vma CORE_ADDR;
+
+typedef struct pdr
+{
+ bfd_vma adr; /* memory address of start of procedure */
+ long isym; /* start of local symbol entries */
+ long iline; /* start of line number entries*/
+ long regmask; /* save register mask */
+ long regoffset; /* save register offset */
+ long iopt; /* start of optimization symbol entries*/
+ long fregmask; /* save floating point register mask */
+ long fregoffset; /* save floating point register offset */
+ long frameoffset; /* frame size */
+ short framereg; /* frame pointer register */
+ short pcreg; /* offset or reg of return pc */
+ long lnLow; /* lowest line in the procedure */
+ long lnHigh; /* highest line in the procedure */
+ bfd_vma cbLineOffset; /* byte offset for this procedure from the fd base */
+ /* These fields are new for 64 bit ECOFF. */
+ unsigned gp_prologue : 8; /* byte size of GP prologue */
+ unsigned gp_used : 1; /* true if the procedure uses GP */
+ unsigned reg_frame : 1; /* true if register frame procedure */
+ unsigned prof : 1; /* true if compiled with -pg */
+ unsigned reserved : 13; /* reserved: must be zero */
+ unsigned localoff : 8; /* offset of local variables from vfp */
+} PDR;
+
+typedef struct alpha_extra_func_info
+{
+ long numargs; /* number of args to procedure (was iopt) */
+ PDR pdr; /* Procedure descriptor record */
+}
+*alpha_extra_func_info_t;
+
+struct frame_info
+{
+ /* Nominal address of the frame described. See comments at FRAME_FP
+ about what this means outside the *FRAME* macros; in the *FRAME*
+ macros, it can mean whatever makes most sense for this machine. */
+ CORE_ADDR frame;
+
+ /* Address at which execution is occurring in this frame. For the
+ innermost frame, it's the current pc. For other frames, it is a
+ pc saved in the next frame. */
+ CORE_ADDR pc;
+
+ /* For each register, address of where it was saved on entry to the
+ frame, or zero if it was not saved on entry to this frame. This
+ includes special registers such as pc and fp saved in special
+ ways in the stack frame. The SP_REGNUM is even more special, the
+ address here is the sp for the next frame, not the address where
+ the sp was saved. Allocated by frame_saved_regs_zalloc () which
+ is called and initialized by FRAME_INIT_SAVED_REGS. */
+ CORE_ADDR *saved_regs; /*NUM_REGS */
+
+ int localoff;
+ int pc_reg;
+ alpha_extra_func_info_t proc_desc;
+
+ /* Pointers to the next and previous frame_info's in the frame cache. */
+ struct frame_info *next, *prev;
+};
+
+struct frame_saved_regs
+{
+ /* For each register R (except the SP), regs[R] is the address at
+ which it was saved on entry to the frame, or zero if it was not
+ saved on entry to this frame. This includes special registers
+ such as pc and fp saved in special ways in the stack frame.
+
+ regs[SP_REGNUM] is different. It holds the actual SP, not the
+ address at which it was saved. */
+
+ CORE_ADDR regs[NUM_REGS];
+};
+
+static CORE_ADDR theRegisters[32];
+
+/* Prototypes for local functions. */
+
+static CORE_ADDR read_next_frame_reg (struct frame_info *, int);
+static CORE_ADDR heuristic_proc_start (CORE_ADDR);
+static int alpha_about_to_return (CORE_ADDR pc);
+static void init_extra_frame_info (struct frame_info *);
+static CORE_ADDR alpha_frame_chain (struct frame_info *);
+static CORE_ADDR alpha_frame_saved_pc (struct frame_info *frame);
+static void *trace_alloc (unsigned int);
+static struct frame_info *create_new_frame (CORE_ADDR, CORE_ADDR);
+
+static alpha_extra_func_info_t
+heuristic_proc_desc (CORE_ADDR, CORE_ADDR, struct frame_info *,
+ struct frame_saved_regs *);
+
+static alpha_extra_func_info_t
+find_proc_desc (CORE_ADDR, struct frame_info *, struct frame_saved_regs *);
+
+/* Heuristic_proc_start may hunt through the text section for a long
+ time across a 2400 baud serial line. Allows the user to limit this
+ search. */
+static unsigned int heuristic_fence_post = 1<<16;
+
+/* Layout of a stack frame on the alpha:
+
+ | |
+ pdr members: | 7th ... nth arg, |
+ | `pushed' by caller. |
+ | |
+----------------|-------------------------------|<-- old_sp == vfp
+ ^ ^ ^ ^ | |
+ | | | | | |
+ | |localoff | Copies of 1st .. 6th |
+ | | | | | argument if necessary. |
+ | | | v | |
+ | | | --- |-------------------------------|<-- FRAME_LOCALS_ADDRESS
+ | | | | |
+ | | | | Locals and temporaries. |
+ | | | | |
+ | | | |-------------------------------|
+ | | | | |
+ |-fregoffset | Saved float registers. |
+ | | | | F9 |
+ | | | | . |
+ | | | | . |
+ | | | | F2 |
+ | | v | |
+ | | -------|-------------------------------|
+ | | | |
+ | | | Saved registers. |
+ | | | S6 |
+ |-regoffset | . |
+ | | | . |
+ | | | S0 |
+ | | | pdr.pcreg |
+ | v | |
+ | ----------|-------------------------------|
+ | | |
+ frameoffset | Argument build area, gets |
+ | | 7th ... nth arg for any |
+ | | called procedure. |
+ v | |
+ -------------|-------------------------------|<-- sp
+ | | */
+
+#define PROC_LOW_ADDR(PROC) ((PROC)->pdr.adr) /* least address */
+#define PROC_HIGH_ADDR(PROC) ((PROC)->pdr.iline) /* upper address bound */
+#define PROC_DUMMY_FRAME(PROC) ((PROC)->pdr.cbLineOffset) /*CALL_DUMMY frame */
+#define PROC_FRAME_OFFSET(PROC) ((PROC)->pdr.frameoffset)
+#define PROC_FRAME_REG(PROC) ((PROC)->pdr.framereg)
+#define PROC_REG_MASK(PROC) ((PROC)->pdr.regmask)
+#define PROC_FREG_MASK(PROC) ((PROC)->pdr.fregmask)
+#define PROC_REG_OFFSET(PROC) ((PROC)->pdr.regoffset)
+#define PROC_FREG_OFFSET(PROC) ((PROC)->pdr.fregoffset)
+#define PROC_PC_REG(PROC) ((PROC)->pdr.pcreg)
+#define PROC_LOCALOFF(PROC) ((PROC)->pdr.localoff)
+
+/* Local storage allocation/deallocation functions. trace_alloc does
+ a malloc, but also chains allocated blocks on trace_alloc_chain, so
+ they may all be freed on exit from __gnat_backtrace. */
+
+struct alloc_chain
+{
+ struct alloc_chain *next;
+ double x[0];
+};
+struct alloc_chain *trace_alloc_chain;
+
+static void *
+trace_alloc (n)
+ unsigned int n;
+{
+ struct alloc_chain * result = malloc (n + sizeof(struct alloc_chain));
+
+ result->next = trace_alloc_chain;
+ trace_alloc_chain = result;
+ return (void*) result->x;
+}
+
+static void
+free_trace_alloc ()
+{
+ while (trace_alloc_chain != 0)
+ {
+ struct alloc_chain *old = trace_alloc_chain;
+
+ trace_alloc_chain = trace_alloc_chain->next;
+ free (old);
+ }
+}
+
+/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0
+ otherwise. */
+
+static int
+read_memory_safe4 (addr, dest)
+ CORE_ADDR addr;
+ unsigned int *dest;
+{
+ *dest = *((unsigned int*) addr);
+ return 0;
+}
+
+/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0
+ otherwise. */
+
+static int
+read_memory_safe8 (addr, dest)
+ CORE_ADDR addr;
+ CORE_ADDR *dest;
+{
+ *dest = *((CORE_ADDR*) addr);
+ return 0;
+}
+
+static CORE_ADDR
+read_register (regno)
+ int regno;
+{
+ if (regno >= 0 && regno < 31)
+ return theRegisters[regno];
+
+ return (CORE_ADDR) 0;
+}
+
+static void
+frame_saved_regs_zalloc (fi)
+ struct frame_info *fi;
+{
+ fi->saved_regs = (CORE_ADDR *) trace_alloc (SIZEOF_FRAME_SAVED_REGS);
+ memset (fi->saved_regs, 0, SIZEOF_FRAME_SAVED_REGS);
+}
+
+static void *
+frame_obstack_alloc (size)
+ unsigned long size;
+{
+ return (void *) trace_alloc (size);
+}
+
+static int
+inside_entry_file (addr)
+ CORE_ADDR addr;
+{
+ if (addr == 0)
+ return 1;
+ else
+ return 0;
+}
+
+static CORE_ADDR
+alpha_saved_pc_after_call (frame)
+ struct frame_info *frame;
+{
+ CORE_ADDR pc = frame->pc;
+ alpha_extra_func_info_t proc_desc;
+ int pcreg;
+
+ proc_desc = find_proc_desc (pc, frame->next, NULL);
+ pcreg = proc_desc ? PROC_PC_REG (proc_desc) : RA_REGNUM;
+
+ return read_register (pcreg);
+}
+
+/* Guaranteed to set frame->saved_regs to some values (it never leaves it
+ NULL). */
+
+static void
+alpha_find_saved_regs (frame)
+ struct frame_info *frame;
+{
+ int ireg;
+ CORE_ADDR reg_position;
+ unsigned long mask;
+ alpha_extra_func_info_t proc_desc;
+ int returnreg;
+
+ frame_saved_regs_zalloc (frame);
+
+ /* If it is the frame for __sigtramp, the saved registers are located in a
+ sigcontext structure somewhere on the stack. __sigtramp passes a pointer
+ to the sigcontext structure on the stack. If the stack layout for
+ __sigtramp changes, or if sigcontext offsets change, we might have to
+ update this code. */
+
+#ifndef SIGFRAME_PC_OFF
+#define SIGFRAME_PC_OFF (2 * 8)
+#define SIGFRAME_REGSAVE_OFF (4 * 8)
+#define SIGFRAME_FPREGSAVE_OFF (SIGFRAME_REGSAVE_OFF + 32 * 8 + 8)
+#endif
+
+ proc_desc = frame->proc_desc;
+ if (proc_desc == NULL)
+ /* I'm not sure how/whether this can happen. Normally when we can't
+ find a proc_desc, we "synthesize" one using heuristic_proc_desc
+ and set the saved_regs right away. */
+ return;
+
+ /* Fill in the offsets for the registers which gen_mask says
+ were saved. */
+
+ reg_position = frame->frame + PROC_REG_OFFSET (proc_desc);
+ mask = PROC_REG_MASK (proc_desc);
+
+ returnreg = PROC_PC_REG (proc_desc);
+
+ /* Note that RA is always saved first, regardless of its actual
+ register number. */
+ if (mask & (1 << returnreg))
+ {
+ frame->saved_regs[returnreg] = reg_position;
+ reg_position += 8;
+ mask &= ~(1 << returnreg); /* Clear bit for RA so we
+ don't save again later. */
+ }
+
+ for (ireg = 0; ireg <= 31; ireg++)
+ if (mask & (1 << ireg))
+ {
+ frame->saved_regs[ireg] = reg_position;
+ reg_position += 8;
+ }
+
+ /* Fill in the offsets for the registers which float_mask says
+ were saved. */
+
+ reg_position = frame->frame + PROC_FREG_OFFSET (proc_desc);
+ mask = PROC_FREG_MASK (proc_desc);
+
+ for (ireg = 0; ireg <= 31; ireg++)
+ if (mask & (1 << ireg))
+ {
+ frame->saved_regs[FP0_REGNUM + ireg] = reg_position;
+ reg_position += 8;
+ }
+
+ frame->saved_regs[PC_REGNUM] = frame->saved_regs[returnreg];
+}
+
+static CORE_ADDR
+read_next_frame_reg (fi, regno)
+ struct frame_info *fi;
+ int regno;
+{
+ CORE_ADDR result;
+ for (; fi; fi = fi->next)
+ {
+ /* We have to get the saved sp from the sigcontext
+ if it is a signal handler frame. */
+ if (regno == SP_REGNUM)
+ return fi->frame;
+ else
+ {
+ if (fi->saved_regs == 0)
+ alpha_find_saved_regs (fi);
+
+ if (fi->saved_regs[regno])
+ {
+ if (read_memory_safe8 (fi->saved_regs[regno], &result) == 0)
+ return result;
+ else
+ return 0;
+ }
+ }
+ }
+
+ return read_register (regno);
+}
+
+static CORE_ADDR
+alpha_frame_saved_pc (frame)
+ struct frame_info *frame;
+{
+ return read_next_frame_reg (frame, frame->pc_reg);
+}
+
+static struct alpha_extra_func_info temp_proc_desc;
+
+/* Nonzero if instruction at PC is a return instruction. "ret
+ $zero,($ra),1" on alpha. */
+
+static int
+alpha_about_to_return (pc)
+ CORE_ADDR pc;
+{
+ int inst;
+
+ read_memory_safe4 (pc, &inst);
+ return inst == 0x6bfa8001;
+}
+
+/* A heuristically computed start address for the subprogram
+ containing address PC. Returns 0 if none detected. */
+
+static CORE_ADDR
+heuristic_proc_start (pc)
+ CORE_ADDR pc;
+{
+ CORE_ADDR start_pc = pc;
+ CORE_ADDR fence = start_pc - heuristic_fence_post;
+
+ if (start_pc == 0)
+ return 0;
+
+ if (heuristic_fence_post == UINT_MAX
+ || fence < VM_MIN_ADDRESS)
+ fence = VM_MIN_ADDRESS;
+
+ /* search back for previous return */
+ for (start_pc -= 4; ; start_pc -= 4)
+ {
+ if (start_pc < fence)
+ return 0;
+ else if (alpha_about_to_return (start_pc))
+ break;
+ }
+
+ start_pc += 4; /* skip return */
+ return start_pc;
+}
+
+static alpha_extra_func_info_t
+heuristic_proc_desc (start_pc, limit_pc, next_frame, saved_regs_p)
+ CORE_ADDR start_pc;
+ CORE_ADDR limit_pc;
+ struct frame_info *next_frame;
+ struct frame_saved_regs *saved_regs_p;
+{
+ CORE_ADDR sp = read_next_frame_reg (next_frame, SP_REGNUM);
+ CORE_ADDR cur_pc;
+ int frame_size;
+ int has_frame_reg = 0;
+ unsigned long reg_mask = 0;
+ int pcreg = -1;
+
+ if (start_pc == 0)
+ return 0;
+
+ memset (&temp_proc_desc, '\0', sizeof (temp_proc_desc));
+ if (saved_regs_p != 0)
+ memset (saved_regs_p, '\0', sizeof (struct frame_saved_regs));
+
+ PROC_LOW_ADDR (&temp_proc_desc) = start_pc;
+
+ if (start_pc + 200 < limit_pc)
+ limit_pc = start_pc + 200;
+
+ frame_size = 0;
+ for (cur_pc = start_pc; cur_pc < limit_pc; cur_pc += 4)
+ {
+ unsigned int word;
+ int status;
+
+ status = read_memory_safe4 (cur_pc, &word);
+ if (status)
+ return 0;
+
+ if ((word & 0xffff0000) == 0x23de0000) /* lda $sp,n($sp) */
+ {
+ if (word & 0x8000)
+ frame_size += (-word) & 0xffff;
+ else
+ /* Exit loop if a positive stack adjustment is found, which
+ usually means that the stack cleanup code in the function
+ epilogue is reached. */
+ break;
+ }
+ else if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */
+ && (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */
+ {
+ int reg = (word & 0x03e00000) >> 21;
+
+ reg_mask |= 1 << reg;
+ if (saved_regs_p != 0)
+ saved_regs_p->regs[reg] = sp + (short) word;
+
+ /* Starting with OSF/1-3.2C, the system libraries are shipped
+ without local symbols, but they still contain procedure
+ descriptors without a symbol reference. GDB is currently
+ unable to find these procedure descriptors and uses
+ heuristic_proc_desc instead.
+ As some low level compiler support routines (__div*, __add*)
+ use a non-standard return address register, we have to
+ add some heuristics to determine the return address register,
+ or stepping over these routines will fail.
+ Usually the return address register is the first register
+ saved on the stack, but assembler optimization might
+ rearrange the register saves.
+ So we recognize only a few registers (t7, t9, ra) within
+ the procedure prologue as valid return address registers.
+ If we encounter a return instruction, we extract the
+ the return address register from it.
+
+ FIXME: Rewriting GDB to access the procedure descriptors,
+ e.g. via the minimal symbol table, might obviate this hack. */
+ if (pcreg == -1
+ && cur_pc < (start_pc + 80)
+ && (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM))
+ pcreg = reg;
+ }
+ else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */
+ pcreg = (word >> 16) & 0x1f;
+ else if (word == 0x47de040f) /* bis sp,sp fp */
+ has_frame_reg = 1;
+ }
+
+ if (pcreg == -1)
+ {
+ /* If we haven't found a valid return address register yet,
+ keep searching in the procedure prologue. */
+ while (cur_pc < (limit_pc + 80) && cur_pc < (start_pc + 80))
+ {
+ unsigned int word;
+
+ if (read_memory_safe4 (cur_pc, &word))
+ break;
+ cur_pc += 4;
+
+ if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */
+ && (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */
+ {
+ int reg = (word & 0x03e00000) >> 21;
+
+ if (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM)
+ {
+ pcreg = reg;
+ break;
+ }
+ }
+ else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */
+ {
+ pcreg = (word >> 16) & 0x1f;
+ break;
+ }
+ }
+ }
+
+ if (has_frame_reg)
+ PROC_FRAME_REG (&temp_proc_desc) = GCC_FP_REGNUM;
+ else
+ PROC_FRAME_REG (&temp_proc_desc) = SP_REGNUM;
+
+ PROC_FRAME_OFFSET (&temp_proc_desc) = frame_size;
+ PROC_REG_MASK (&temp_proc_desc) = reg_mask;
+ PROC_PC_REG (&temp_proc_desc) = (pcreg == -1) ? RA_REGNUM : pcreg;
+ PROC_LOCALOFF (&temp_proc_desc) = 0; /* XXX - bogus */
+
+ return &temp_proc_desc;
+}
+
+static alpha_extra_func_info_t
+find_proc_desc (pc, next_frame, saved_regs)
+ CORE_ADDR pc;
+ struct frame_info *next_frame;
+ struct frame_saved_regs *saved_regs;
+{
+ CORE_ADDR startaddr;
+
+ /* If heuristic_fence_post is non-zero, determine the procedure
+ start address by examining the instructions.
+ This allows us to find the start address of static functions which
+ have no symbolic information, as startaddr would have been set to
+ the preceding global function start address by the
+ find_pc_partial_function call above. */
+ startaddr = heuristic_proc_start (pc);
+
+ return heuristic_proc_desc (startaddr, pc, next_frame, saved_regs);
+}
+
+static CORE_ADDR
+alpha_frame_chain (frame)
+ struct frame_info *frame;
+{
+ alpha_extra_func_info_t proc_desc;
+ CORE_ADDR saved_pc = FRAME_SAVED_PC (frame);
+
+ if (saved_pc == 0 || inside_entry_file (saved_pc))
+ return 0;
+
+ proc_desc = find_proc_desc (saved_pc, frame, NULL);
+ if (!proc_desc)
+ return 0;
+
+ /* If no frame pointer and frame size is zero, we must be at end
+ of stack (or otherwise hosed). If we don't check frame size,
+ we loop forever if we see a zero size frame. */
+ if (PROC_FRAME_REG (proc_desc) == SP_REGNUM
+ && PROC_FRAME_OFFSET (proc_desc) == 0)
+ return 0;
+ else
+ return read_next_frame_reg (frame, PROC_FRAME_REG (proc_desc))
+ + PROC_FRAME_OFFSET (proc_desc);
+}
+
+static void
+init_extra_frame_info (frame)
+ struct frame_info *frame;
+{
+ struct frame_saved_regs temp_saved_regs;
+ alpha_extra_func_info_t proc_desc =
+ find_proc_desc (frame->pc, frame->next, &temp_saved_regs);
+
+ frame->saved_regs = NULL;
+ frame->localoff = 0;
+ frame->pc_reg = RA_REGNUM;
+ frame->proc_desc = proc_desc;
+
+ if (proc_desc)
+ {
+ /* Get the locals offset and the saved pc register from the
+ procedure descriptor, they are valid even if we are in the
+ middle of the prologue. */
+ frame->localoff = PROC_LOCALOFF (proc_desc);
+ frame->pc_reg = PROC_PC_REG (proc_desc);
+
+ /* Fixup frame-pointer - only needed for top frame */
+
+ /* This may not be quite right, if proc has a real frame register.
+ Get the value of the frame relative sp, procedure might have been
+ interrupted by a signal at it's very start. */
+ if (frame->pc == PROC_LOW_ADDR (proc_desc))
+ frame->frame = read_next_frame_reg (frame->next, SP_REGNUM);
+ else
+ frame->frame
+ = (read_next_frame_reg (frame->next, PROC_FRAME_REG (proc_desc))
+ + PROC_FRAME_OFFSET (proc_desc));
+
+ frame->saved_regs
+ = (CORE_ADDR *) frame_obstack_alloc (SIZEOF_FRAME_SAVED_REGS);
+ memcpy
+ (frame->saved_regs, temp_saved_regs.regs, SIZEOF_FRAME_SAVED_REGS);
+ frame->saved_regs[PC_REGNUM] = frame->saved_regs[RA_REGNUM];
+ }
+}
+
+/* Create an arbitrary (i.e. address specified by user) or innermost frame.
+ Always returns a non-NULL value. */
+
+static struct frame_info *
+create_new_frame (addr, pc)
+ CORE_ADDR addr;
+ CORE_ADDR pc;
+{
+ struct frame_info *fi;
+
+ fi = (struct frame_info *)
+ trace_alloc (sizeof (struct frame_info));
+
+ /* Arbitrary frame */
+ fi->next = NULL;
+ fi->prev = NULL;
+ fi->frame = addr;
+ fi->pc = pc;
+
+#ifdef INIT_EXTRA_FRAME_INFO
+ INIT_EXTRA_FRAME_INFO (0, fi);
+#endif
+
+ return fi;
+}
+
+static CORE_ADDR current_pc;
+
+static void
+set_current_pc ()
+{
+ current_pc = (CORE_ADDR) __builtin_return_address (0);
+}
+
+static CORE_ADDR
+read_pc ()
+{
+ return current_pc;
+}
+
+static struct frame_info *
+get_current_frame ()
+{
+ return create_new_frame (0, read_pc ());
+}
+
+/* Return the frame that called FI.
+ If FI is the original frame (it has no caller), return 0. */
+
+static struct frame_info *
+get_prev_frame (next_frame)
+ struct frame_info *next_frame;
+{
+ CORE_ADDR address = 0;
+ struct frame_info *prev;
+ int fromleaf = 0;
+
+ /* If we have the prev one, return it */
+ if (next_frame->prev)
+ return next_frame->prev;
+
+ /* On some machines it is possible to call a function without
+ setting up a stack frame for it. On these machines, we
+ define this macro to take two args; a frameinfo pointer
+ identifying a frame and a variable to set or clear if it is
+ or isn't leafless. */
+
+ /* Two macros defined in tm.h specify the machine-dependent
+ actions to be performed here.
+
+ First, get the frame's chain-pointer. If that is zero, the frame
+ is the outermost frame or a leaf called by the outermost frame.
+ This means that if start calls main without a frame, we'll return
+ 0 (which is fine anyway).
+
+ Nope; there's a problem. This also returns when the current
+ routine is a leaf of main. This is unacceptable. We move
+ this to after the ffi test; I'd rather have backtraces from
+ start go curfluy than have an abort called from main not show
+ main. */
+
+ address = FRAME_CHAIN (next_frame);
+ if (!FRAME_CHAIN_VALID (address, next_frame))
+ return 0;
+ address = FRAME_CHAIN_COMBINE (address, next_frame);
+
+ if (address == 0)
+ return 0;
+
+ prev = (struct frame_info *) trace_alloc (sizeof (struct frame_info));
+
+ prev->saved_regs = NULL;
+ if (next_frame)
+ next_frame->prev = prev;
+
+ prev->next = next_frame;
+ prev->prev = (struct frame_info *) 0;
+ prev->frame = address;
+
+ /* This change should not be needed, FIXME! We should
+ determine whether any targets *need* INIT_FRAME_PC to happen
+ after INIT_EXTRA_FRAME_INFO and come up with a simple way to
+ express what goes on here.
+
+ INIT_EXTRA_FRAME_INFO is called from two places: create_new_frame
+ (where the PC is already set up) and here (where it isn't).
+ INIT_FRAME_PC is only called from here, always after
+ INIT_EXTRA_FRAME_INFO.
+
+ The catch is the MIPS, where INIT_EXTRA_FRAME_INFO requires the PC
+ value (which hasn't been set yet). Some other machines appear to
+ require INIT_EXTRA_FRAME_INFO before they can do INIT_FRAME_PC. Phoo.
+
+ We shouldn't need INIT_FRAME_PC_FIRST to add more complication to
+ an already overcomplicated part of GDB. gnu@cygnus.com, 15Sep92.
+
+ Assuming that some machines need INIT_FRAME_PC after
+ INIT_EXTRA_FRAME_INFO, one possible scheme:
+
+ SETUP_INNERMOST_FRAME()
+ Default version is just create_new_frame (read_fp ()),
+ read_pc ()). Machines with extra frame info would do that (or the
+ local equivalent) and then set the extra fields.
+ INIT_PREV_FRAME(fromleaf, prev)
+ Replace INIT_EXTRA_FRAME_INFO and INIT_FRAME_PC. This should
+ also return a flag saying whether to keep the new frame, or
+ whether to discard it, because on some machines (e.g. mips) it
+ is really awkward to have FRAME_CHAIN_VALID called *before*
+ INIT_EXTRA_FRAME_INFO (there is no good way to get information
+ deduced in FRAME_CHAIN_VALID into the extra fields of the new frame).
+ std_frame_pc(fromleaf, prev)
+ This is the default setting for INIT_PREV_FRAME. It just does what
+ the default INIT_FRAME_PC does. Some machines will call it from
+ INIT_PREV_FRAME (either at the beginning, the end, or in the middle).
+ Some machines won't use it.
+ kingdon@cygnus.com, 13Apr93, 31Jan94, 14Dec94. */
+
+#ifdef INIT_FRAME_PC_FIRST
+ INIT_FRAME_PC_FIRST (fromleaf, prev);
+#endif
+
+#ifdef INIT_EXTRA_FRAME_INFO
+ INIT_EXTRA_FRAME_INFO (fromleaf, prev);
+#endif
+
+ /* This entry is in the frame queue now, which is good since
+ FRAME_SAVED_PC may use that queue to figure out its value
+ (see tm-sparc.h). We want the pc saved in the inferior frame. */
+ INIT_FRAME_PC (fromleaf, prev);
+
+ /* If ->frame and ->pc are unchanged, we are in the process of getting
+ ourselves into an infinite backtrace. Some architectures check this
+ in FRAME_CHAIN or thereabouts, but it seems like there is no reason
+ this can't be an architecture-independent check. */
+ if (next_frame != NULL)
+ {
+ if (prev->frame == next_frame->frame
+ && prev->pc == next_frame->pc)
+ {
+ next_frame->prev = NULL;
+ free (prev);
+ return NULL;
+ }
+ }
+
+ return prev;
+}
+
+#define SAVE(regno,disp) \
+ "stq $" #regno ", " #disp "(%0)\n"
+
+int
+__gnat_backtrace (array, size, exclude_min, exclude_max, skip_frames)
+ void **array;
+ int size;
+ void *exclude_min;
+ void *exclude_max;
+ int skip_frames;
+{
+ struct frame_info* top;
+ struct frame_info* current;
+ int cnt;
+
+ /* This function is not thread safe, protect it */
+ (*Lock_Task) ();
+ asm volatile (
+ SAVE (9,72)
+ SAVE (10,80)
+ SAVE (11,88)
+ SAVE (12,96)
+ SAVE (13,104)
+ SAVE (14,112)
+ SAVE (15,120)
+ SAVE (16,128)
+ SAVE (17,136)
+ SAVE (18,144)
+ SAVE (19,152)
+ SAVE (20,160)
+ SAVE (21,168)
+ SAVE (22,176)
+ SAVE (23,184)
+ SAVE (24,192)
+ SAVE (25,200)
+ SAVE (26,208)
+ SAVE (27,216)
+ SAVE (28,224)
+ SAVE (29,232)
+ SAVE (30,240)
+ : : "r" (&theRegisters));
+
+ trace_alloc_chain = NULL;
+ set_current_pc ();
+
+ top = current = get_current_frame ();
+ cnt = 0;
+
+ for (cnt = 0; cnt < skip_frames; cnt += 1) {
+ current = get_prev_frame (current);
+ }
+
+ cnt = 0;
+ while (cnt < size)
+ {
+ if (STOP_FRAME)
+ break;
+
+ if (current->pc < (CORE_ADDR) exclude_min
+ || current->pc > (CORE_ADDR) exclude_max)
+ array[cnt++] = (void*) (current->pc + PC_ADJUST);
+
+ current = get_prev_frame (current);
+ }
+
+ free_trace_alloc ();
+ (*Unlock_Task) ();
+
+ return cnt;
+}
diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb
index 1548a41cf16..b14ed658df9 100644
--- a/gcc/ada/tbuild.adb
+++ b/gcc/ada/tbuild.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- --
@@ -106,6 +106,28 @@ package body Tbuild is
end if;
end Convert_To;
+ ------------------
+ -- Discard_List --
+ ------------------
+
+ procedure Discard_List (L : List_Id) is
+ pragma Warnings (Off, L);
+
+ begin
+ null;
+ end Discard_List;
+
+ ------------------
+ -- Discard_Node --
+ ------------------
+
+ procedure Discard_Node (N : Node_Or_Entity_Id) is
+ pragma Warnings (Off, N);
+
+ begin
+ null;
+ end Discard_Node;
+
-------------------------------------------
-- Make_Byte_Aligned_Attribute_Reference --
-------------------------------------------
@@ -584,6 +606,12 @@ package body Tbuild is
then
Result := Relocate_Node (Expr);
+ elsif Nkind (Expr) = N_Null then
+
+ -- No need for a conversion
+
+ Result := Relocate_Node (Expr);
+
-- All other cases
else
diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads
index ef321a14940..cca92773c43 100644
--- a/gcc/ada/tbuild.ads
+++ b/gcc/ada/tbuild.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -46,6 +46,20 @@ package Tbuild is
-- Exp. This means that it is safe to replace a node by a Convert_To
-- of itself to some other type.
+ procedure Discard_Node (N : Node_Or_Entity_Id);
+ pragma Inline (Discard_Node);
+ -- This is a dummy procedure that simply returns and does nothing.
+ -- It is used when a function returning a Node_Id value is called
+ -- for its side effect (e.g. a call to Make to construct a node)
+ -- but the Node_Id value is not required.
+
+ procedure Discard_List (L : List_Id);
+ pragma Inline (Discard_List);
+ -- This is a dummy procedure that simply returns and does nothing.
+ -- It is used when a function returning a Node_Id value is called
+ -- for its side effect (e.g. a call to the pareser to parse a list
+ -- of compilation units), but the List_Id value is not required.
+
function Make_Byte_Aligned_Attribute_Reference
(Sloc : Source_Ptr;
Prefix : Node_Id;
@@ -96,7 +110,7 @@ package Tbuild is
Defining_Identifier : Node_Id;
Label_Construct : Node_Id)
return Node_Id;
- -- Used to construct an implicit label declaration node, including setting
+ -- Used to contruct an implicit label declaration node, including setting
-- the proper Label_Construct field (since Label_Construct is a semantic
-- field, the normal call to Make_Implicit_Label_Declaration does not
-- set this field).
diff --git a/gcc/ada/tempdir.adb b/gcc/ada/tempdir.adb
new file mode 100644
index 00000000000..531e3f31e21
--- /dev/null
+++ b/gcc/ada/tempdir.adb
@@ -0,0 +1,123 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- T E M P D I R --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+
+with Namet; use Namet;
+with Opt; use Opt;
+with Output; use Output;
+
+package body Tempdir is
+
+ Tmpdir_Needs_To_Be_Displayed : Boolean := True;
+
+ Tmpdir : constant String := "TMPDIR";
+ No_Dir : aliased String := "";
+ Temp_Dir : String_Access := No_Dir'Access;
+
+ procedure Create_Temp_File
+ (FD : out File_Descriptor;
+ Name : out Name_Id)
+ is
+ File_Name : String_Access;
+ Current_Dir : constant String := Get_Current_Dir;
+
+ function Directory return String;
+ -- Returns Temp_Dir.all if not empty, else return current directory
+
+ ---------------
+ -- Directory --
+ ---------------
+
+ function Directory return String is
+ begin
+ if Temp_Dir'Length /= 0 then
+ return Temp_Dir.all;
+
+ else
+ return Current_Dir;
+ end if;
+ end Directory;
+
+ -- Start of processing Tempdir
+
+ begin
+ if Temp_Dir'Length /= 0 then
+
+ -- In verbose mode, display once the value of TMPDIR, so that
+ -- if temp files cannot be created, it is easier to understand
+ -- where temp files are supposed to be created.
+
+ if Verbose_Mode and then Tmpdir_Needs_To_Be_Displayed then
+ Write_Str ("TMPDIR = """);
+ Write_Str (Temp_Dir.all);
+ Write_Line ("""");
+ Tmpdir_Needs_To_Be_Displayed := False;
+ end if;
+
+ -- Change directory to TMPDIR before creating the temp file,
+ -- then change back immediately to the previous directory.
+
+ Change_Dir (Temp_Dir.all);
+ Create_Temp_File (FD, File_Name);
+ Change_Dir (Current_Dir);
+
+ else
+ Create_Temp_File (FD, File_Name);
+ end if;
+
+ if FD = Invalid_FD then
+ Name := No_Name;
+
+ else
+ declare
+ Path_Name : constant String :=
+ Normalize_Pathname
+ (Directory & Directory_Separator & File_Name.all);
+
+ begin
+ Name_Len := Path_Name'Length;
+ Name_Buffer (1 .. Name_Len) := Path_Name;
+ Name := Name_Find;
+ Free (File_Name);
+ end;
+ end if;
+ end Create_Temp_File;
+
+-- Start of elaboration for package Tempdir
+
+begin
+ declare
+ Dir : String_Access := Getenv (Tmpdir);
+
+ begin
+ if Dir'Length > 0 and then Is_Absolute_Path (Dir.all) then
+ Temp_Dir := new String'(Normalize_Pathname (Dir.all));
+ end if;
+
+ Free (Dir);
+ end;
+end Tempdir;
diff --git a/gcc/ada/tempdir.ads b/gcc/ada/tempdir.ads
new file mode 100644
index 00000000000..2cf89906e7d
--- /dev/null
+++ b/gcc/ada/tempdir.ads
@@ -0,0 +1,47 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- T E M P D I R --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package is used by gnatmake and by the Project Manager to create
+-- temporary files. If environment variable TMPDIR is defined and
+-- designates an absolute path, temporary files are create in this directory.
+-- Otherwise, temporary files are created in the current working directory.
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with Types; use Types;
+
+package Tempdir is
+
+ procedure Create_Temp_File
+ (FD : out File_Descriptor;
+ Name : out Name_Id);
+ -- Create a temporary text file and return its file descriptor and
+ -- its path name as a Name_Id. If environment variable TMPDIR is defined
+ -- and its value is an absolute path, the temp file is created in the
+ -- directory designated by TMPDIR, otherwise, it is created in the current
+ -- directory. If temporary file cannot be created, FD gets the value
+ -- Invalid_FD and Name gets the value No_Name.
+
+end Tempdir;
diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c
index e89a7b42f28..0df46e2fad9 100644
--- a/gcc/ada/tracebak.c
+++ b/gcc/ada/tracebak.c
@@ -6,8 +6,7 @@
* *
* C Implementation File *
* *
- * *
- * Copyright (C) 2000-2001 Ada Core Technologies, Inc. *
+ * Copyright (C) 2000-2003 Ada Core Technologies, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -27,14 +26,13 @@
* file might be covered by the GNU Public License. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
- * It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). *
+ * Extensive contributions were provided by Ada Core Technologies Inc. *
* *
****************************************************************************/
/* This file contains low level support for stack unwinding using GCC intrinsic
functions.
It has been tested on the following configurations:
- HPPA/HP-UX
PowerPC/AiX
PowerPC/VxWorks
Sparc/Solaris
@@ -44,6 +42,7 @@
i386/OS2
i386/LynxOS
Alpha/VxWorks
+ Alpha/VMS
*/
#ifdef __alpha_vxworks
@@ -59,42 +58,140 @@
#include "system.h"
#endif
+extern int __gnat_backtrace PARAMS ((void **, int, void *, void *, int));
+
+/* The point is to provide an implementation of the __gnat_bactrace function
+ above, called by the default implementation of the System.Traceback
+ package.
+
+ We first have a series of target specific implementations, each included
+ from a separate C file for readability purposes.
+
+ Then comes a somewhat generic implementation based on a set of macro and
+ structure definitions which may be tailored on a per target basis. The
+ presence of a definition for one of these macros (PC_ADJUST) controls
+ wether or not the generic implementation is included.
+
+ Finally, there is a default dummy implementation, necessary to make the
+ linker happy on platforms where the feature is not supported, but where the
+ function is still referenced by the default System.Traceback. */
+
#define Lock_Task system__soft_links__lock_task
extern void (*Lock_Task) PARAMS ((void));
#define Unlock_Task system__soft_links__unlock_task
extern void (*Unlock_Task) PARAMS ((void));
-#ifndef CURRENT_STACK_FRAME
-# define CURRENT_STACK_FRAME ({ char __csf; &__csf; })
-#endif
-
-extern int __gnat_backtrace PARAMS ((void **, int, void *, void *));
-
-#if defined (__hppa)
-struct layout
-{
- void *return_address;
- void *pad[4];
- struct layout *next;
-};
+/*-------------------------------------*
+ *-- Target specific implementations --*
+ *-------------------------------------*/
-#define FRAME_LEVEL 1
-#define FRAME_OFFSET -20
-#define SKIP_FRAME 1
-#define PC_ADJUST -4
+#if defined (__alpha_vxworks)
-/* If CURRENT is unaligned, it means that CURRENT is not a valid frame
- pointer and we should stop popping frames. */
+#include "tb-alvxw.c"
-#define STOP_FRAME(CURRENT, TOP_STACK) \
- (((int) (CURRENT) & 0x3) != 0 && (CURRENT)->return_address == 0)
+#elif defined (__ALPHA) && defined (__VMS__)
-/* Current implementation need to be protected against invalid memory
- accesses */
-#define PROTECT_SEGV
+#include "tb-alvms.c"
-#elif defined (_AIX)
+#else
+/* No target specific implementation. */
+
+/*----------------------------------------------------------------*
+ *-- Target specific definitions for the generic implementation --*
+ *----------------------------------------------------------------*/
+
+/* The stack layout is specified by the target ABI. The "generic" scheme is
+ based on the following assumption:
+
+ The stack layout from some frame pointer is such that the information
+ required to compute the backtrace is available at static offsets.
+
+ For a given frame, the information we are interested in is the saved return
+ address (somewhere after the call instruction in the caller) and a pointer
+ to the caller's frame. The former is the base of the call chain information
+ we store in the tracebacks array. The latter allows us to loop over the
+ successive frames in the chain.
+
+ To initiate the process, we retrieve an initial frame pointer using the
+ appropriate GCC builtin (__builtin_frame_address).
+
+ This scheme is unfortunately not applicable on every target because the
+ stack layout is not necessarily regular (static) enough. On targets where
+ this scheme applies, the implementation relies on the following items:
+
+ o struct layout, describing the expected stack data layout relevant to the
+ information we are interested in,
+
+ o FRAME_OFFSET, the offset, from a given frame pointer, at which this
+ layout will be found,
+
+ o FRAME_LEVEL, controls how many frames up we get at to start with,
+ from the initial frame pointer we compute by way of the GCC builtin,
+
+ 0 is most often the appropriate value. 1 may be necessary on targets
+ where return addresses are saved by a function in it's caller's frame
+ (e.g. PPC).
+
+ o PC_ADJUST, to account for the difference between a call point (address
+ of a call instruction), which is what we want in the output array, and
+ the associated return address, which is what we retrieve from the stack.
+
+ o STOP_FRAME, to decide wether we reached the top of the call chain, and
+ thus if the process shall stop.
+
+ :
+ : stack
+ | +----------------+
+ | +-------->| : |
+ | | | (FRAME_OFFSET) |
+ | | | : | (PC_ADJUST)
+ | | layout:| return_address ----------------+
+ | | | .... | |
+ +--------------- next_frame | |
+ | | .... | |
+ | | | |
+ | +----------------+ | +-----+
+ | | : |<- Base fp | | : |
+ | | (FRAME_OFFSET) | (FRAME_LEVEL) | | : |
+ | | : | +---> | [1]
+ | layout:| return_address --------------------> | [0]
+ | | ... | (PC_ADJUST) +-----+
+ +---------- next_frame | traceback[]
+ | ... |
+ | |
+ +----------------+
+
+ o BASE_SKIP,
+
+ Since we inherently deal with return addresses, there is an implicit shift
+ by at least one for the initial point we are able to observe in the chain.
+
+ On some targets (e.g. sparc-solaris), the first return address we can
+ easily get without special code is even our caller's return address, so
+ there is a initial shift of two.
+
+ BASE_SKIP represents this initial shift, which is the minimal "skip_frames"
+ value we support. We could add special code for the skip_frames < BASE_SKIP
+ cases. This is not done currently because there is virtually no situation
+ in which this would be useful.
+
+ Finally, to account for some ABI specificities, a target may (but does
+ not have to) define:
+
+ o FORCE_CALL, to force a call to a dummy function at the very beginning
+ of the computation. See the PPC AIX target for an example where this
+ is useful.
+
+ o FETCH_UP_FRAME, to force an invocation of __builtin_frame_address with a
+ positive argument right after a possibly forced call even if FRAME_LEVEL
+ is 0. See the Sparc Solaris case for an example where this is useful.
+
+ */
+
+/*------------------------------ PPC AIX -------------------------------*/
+
+#if defined (_AIX)
struct layout
{
struct layout *next;
@@ -102,12 +199,24 @@ struct layout
void *return_address;
};
-#define FRAME_LEVEL 1
#define FRAME_OFFSET 0
-#define SKIP_FRAME 2
#define PC_ADJUST -4
#define STOP_FRAME(CURRENT, TOP_STACK) ((void *) (CURRENT) < (TOP_STACK))
+/* The PPC ABI has an interesting specificity: the return address saved by a
+ function is located in it's caller's frame, and the save operation only
+ takes place if the function performs a call.
+
+ To have __gnat_backtrace retrieve it's own return address, we then
+ define ... */
+
+#define FORCE_CALL
+#define FRAME_LEVEL 1
+
+#define BASE_SKIP 1
+
+/*---------------------------- PPC VxWorks------------------------------*/
+
#elif defined (_ARCH_PPC) && defined (__vxworks)
struct layout
{
@@ -115,27 +224,48 @@ struct layout
void *return_address;
};
+#define FORCE_CALL
#define FRAME_LEVEL 1
+/* See the PPC AIX case for an explanation of these values. */
+
#define FRAME_OFFSET 0
-#define SKIP_FRAME 2
-#define PC_ADJUST 0
+#define PC_ADJUST -4
#define STOP_FRAME(CURRENT, TOP_STACK) ((CURRENT)->return_address == 0)
+#define BASE_SKIP 1
+
+/*-------------------------- Sparc Solaris -----------------------------*/
+
#elif defined (sun) && defined (sparc)
+
+/* These definitions are inspired from the Appendix D (Software
+ Considerations) of the SPARC V8 architecture manual. */
+
struct layout
{
struct layout *next;
void *return_address;
};
-#define FRAME_LEVEL 1
-#define FRAME_OFFSET (14*4)
-#define SKIP_FRAME 1
+#define FRAME_LEVEL 0
+#define FRAME_OFFSET (14 * (sizeof (void*)))
#define PC_ADJUST 0
#define STOP_FRAME(CURRENT, TOP_STACK) \
((CURRENT)->return_address == 0|| (CURRENT)->next == 0 \
|| (void *) (CURRENT) < (TOP_STACK))
+/* The sparc register windows need to be flushed before we may access them
+ from the stack. This is achieved by way of builtin_frame_address only
+ when the "count" argument is positive, so force at least one such call. */
+#define FETCH_UP_FRAME_ADDRESS
+
+#define BASE_SKIP 2
+/* From the frame pointer of frame N, we are accessing the flushed register
+ window of frame N-1 (positive offset from fp), in which we retrieve the
+ saved return address. We then end up with our caller's return address. */
+
+/*------------------------------- x86 ----------------------------------*/
+
#elif defined (i386)
struct layout
{
@@ -154,13 +284,14 @@ extern unsigned int _image_base__;
#define FRAME_LEVEL 0
#define FRAME_OFFSET 0
-#define SKIP_FRAME 1
#define PC_ADJUST -2
#define STOP_FRAME(CURRENT, TOP_STACK) \
((unsigned int)(CURRENT)->return_address < LOWEST_ADDR \
|| (CURRENT)->return_address == 0|| (CURRENT)->next == 0 \
|| (void *) (CURRENT) < (TOP_STACK))
+#define BASE_SKIP 1
+
/* On i386 architecture we check that at the call point we really have a call
insn. Possible call instructions are:
@@ -175,91 +306,75 @@ extern unsigned int _image_base__;
#define VALID_STACK_FRAME(ptr) \
(((*((ptr) - 3) & 0xff) == 0xe8) \
- || ((*((ptr) - 4) & 0xff) == 0x9a) \
- || ((*((ptr) - 2) & 0xff) == 0xff) \
- || (((*((ptr) - 1) & 0xff00) == 0xff00) \
- && ((*((ptr) - 1) & 0xf0) == 0xd0)))
+ || ((*((ptr) - 5) & 0xff) == 0x9a) \
+ || ((*((ptr) - 1) & 0xff) == 0xff) \
+ || (((*(ptr) & 0xd0ff) == 0xd0ff)))
-#elif defined (__alpha_vxworks)
-
-#define SKIP_FRAME 1
-#define PC_ADJUST -4
-
-extern void kerTaskEntry();
-
-#define STOP_FRAME \
- (current == NULL \
- || ((CORE_ADDR) &kerTaskEntry >= PROC_LOW_ADDR (current->proc_desc) \
- && current->pc >= (CORE_ADDR) &kerTaskEntry))
#endif
-#if !defined (PC_ADJUST)
-int
-__gnat_backtrace (array, size, exclude_min, exclude_max)
- void **array ATTRIBUTE_UNUSED;
- int size ATTRIBUTE_UNUSED;
- void *exclude_min ATTRIBUTE_UNUSED;
- void *exclude_max ATTRIBUTE_UNUSED;
-{
- return 0;
-}
-
-#elif !defined (__alpha_vxworks)
-
-#ifdef PROTECT_SEGV
-#include <setjmp.h>
-#include <signal.h>
+/*---------------------------------------*
+ *-- The generic implementation per se --*
+ *---------------------------------------*/
-static jmp_buf sigsegv_excp;
+#if defined (PC_ADJUST)
-static void
-segv_handler (ignored)
- int ignored;
-{
- longjmp (sigsegv_excp, 1);
-}
+#ifndef CURRENT_STACK_FRAME
+# define CURRENT_STACK_FRAME ({ char __csf; &__csf; })
#endif
+
#ifndef VALID_STACK_FRAME
#define VALID_STACK_FRAME(ptr) 1
#endif
+#define MAX(x,y) ((x) > (y) ? (x) : (y))
+
+/* Define a dummy function to call if FORCE_CALL is defined. Don't
+ define it otherwise, as this could lead to "defined but not used"
+ warnings. */
+#if defined (FORCE_CALL)
+static void forced_callee () {}
+#endif
+
int
-__gnat_backtrace (array, size, exclude_min, exclude_max)
+__gnat_backtrace (array, size, exclude_min, exclude_max, skip_frames)
void **array;
int size;
void *exclude_min;
void *exclude_max;
+ int skip_frames;
{
struct layout *current;
void *top_frame;
void *top_stack;
int cnt = 0;
-#ifdef PROTECT_SEGV
- struct sigaction this_act, old_act;
+ /* Honor FORCE_CALL when defined. */
+#if defined (FORCE_CALL)
+ forced_callee ();
+#endif
- /* This function is not thread safe if PROTECT_SEGV is defined, so
- protect it */
- (*Lock_Task) ();
+ /* Force a call to builtin_frame_address with a positive argument
+ if required. This is necessary e.g. on sparc to have the register
+ windows flushed before we attempt to access them on the stack. */
+#if defined (FETCH_UP_FRAME_ADDRESS) && (FRAME_LEVEL == 0)
+ __builtin_frame_address (1);
#endif
top_frame = __builtin_frame_address (FRAME_LEVEL);
top_stack = CURRENT_STACK_FRAME;
current = (struct layout *) ((size_t) top_frame + FRAME_OFFSET);
-#ifdef PROTECT_SEGV
- this_act.sa_handler = segv_handler;
- sigemptyset (&this_act.sa_mask);
- this_act.sa_flags = 0;
- sigaction (SIGSEGV, &this_act, &old_act);
+ /* Skip the number of calls we have been requested to skip, accounting for
+ the BASE_SKIP parameter.
- if (setjmp (sigsegv_excp))
- goto Done;
-#endif
+ FRAME_LEVEL is meaningless for the count adjustment. It impacts where we
+ start retrieving data from, but how many frames "up" we start at is in
+ BASE_SKIP by definition. */
- /* We skip the call to this function, it makes no sense to record it. */
- while (cnt < SKIP_FRAME)
+ skip_frames = MAX (0, skip_frames - BASE_SKIP);
+
+ while (cnt < skip_frames)
{
current = (struct layout *) ((size_t) current->next + FRAME_OFFSET);
cnt++;
@@ -268,7 +383,7 @@ __gnat_backtrace (array, size, exclude_min, exclude_max)
cnt = 0;
while (cnt < size)
{
- if (STOP_FRAME (current, top_stack) ||
+ if (STOP_FRAME (current, top_stack) ||
!VALID_STACK_FRAME((char *)(current->return_address + PC_ADJUST)))
break;
@@ -279,931 +394,27 @@ __gnat_backtrace (array, size, exclude_min, exclude_max)
current = (struct layout *) ((size_t) current->next + FRAME_OFFSET);
}
-#ifdef PROTECT_SEGV
- Done:
- sigaction (SIGSEGV, &old_act, NULL);
- (*Unlock_Task) ();
-#endif
return cnt;
}
#else
-/* Alpha vxWorks requires a special, complex treatment that is extracted
- from GDB */
-
-#include <string.h>
-
-/* Register numbers of various important registers.
- Note that most of these values are "real" register numbers,
- and correspond to the general registers of the machine,
- and FP_REGNUM is a "phony" register number which is too large
- to be an actual register number as far as the user is concerned
- but serves to get the desired value when passed to read_register. */
-
-#define T7_REGNUM 8 /* Return address register for OSF/1 __add* */
-#define GCC_FP_REGNUM 15 /* Used by gcc as frame register */
-#define T9_REGNUM 23 /* Return address register for OSF/1 __div* */
-#define SP_REGNUM 30 /* Contains address of top of stack */
-#define RA_REGNUM 26 /* Contains return address value */
-#define FP0_REGNUM 32 /* Floating point register 0 */
-#define PC_REGNUM 64 /* Contains program counter */
-#define NUM_REGS 66
-
-#define VM_MIN_ADDRESS (CORE_ADDR)0x120000000
-
-#define SIZEOF_FRAME_SAVED_REGS (sizeof (CORE_ADDR) * (NUM_REGS))
-#define INIT_EXTRA_FRAME_INFO(fromleaf, fci) init_extra_frame_info(fci)
-
-#define FRAME_CHAIN(thisframe) (CORE_ADDR) alpha_frame_chain (thisframe)
-
-#define FRAME_CHAIN_VALID(CHAIN, THISFRAME) \
- ((CHAIN) != 0 \
- && !inside_entry_file (FRAME_SAVED_PC (THISFRAME)))
-
-#define FRAME_SAVED_PC(FRAME) (alpha_frame_saved_pc (FRAME))
-
-#define FRAME_CHAIN_COMBINE(CHAIN, THISFRAME) (CHAIN)
-
-#define INIT_FRAME_PC(FROMLEAF, PREV)
-
-#define INIT_FRAME_PC_FIRST(FROMLEAF, PREV) \
- (PREV)->pc = ((FROMLEAF) ? SAVED_PC_AFTER_CALL ((PREV)->next) \
- : (PREV)->next ? FRAME_SAVED_PC ((prev)->NEXT) : read_pc ());
-
-#define SAVED_PC_AFTER_CALL(FRAME) alpha_saved_pc_after_call (FRAME)
-
-typedef unsigned long long int bfd_vma;
-
-typedef bfd_vma CORE_ADDR;
-
-typedef struct pdr
-{
- bfd_vma adr; /* memory address of start of procedure */
- long isym; /* start of local symbol entries */
- long iline; /* start of line number entries*/
- long regmask; /* save register mask */
- long regoffset; /* save register offset */
- long iopt; /* start of optimization symbol entries*/
- long fregmask; /* save floating point register mask */
- long fregoffset; /* save floating point register offset */
- long frameoffset; /* frame size */
- short framereg; /* frame pointer register */
- short pcreg; /* offset or reg of return pc */
- long lnLow; /* lowest line in the procedure */
- long lnHigh; /* highest line in the procedure */
- bfd_vma cbLineOffset; /* byte offset for this procedure from the fd base */
- /* These fields are new for 64 bit ECOFF. */
- unsigned gp_prologue : 8; /* byte size of GP prologue */
- unsigned gp_used : 1; /* true if the procedure uses GP */
- unsigned reg_frame : 1; /* true if register frame procedure */
- unsigned prof : 1; /* true if compiled with -pg */
- unsigned reserved : 13; /* reserved: must be zero */
- unsigned localoff : 8; /* offset of local variables from vfp */
-} PDR;
-
-typedef struct alpha_extra_func_info
-{
- long numargs; /* number of args to procedure (was iopt) */
- PDR pdr; /* Procedure descriptor record */
-}
-*alpha_extra_func_info_t;
-
-struct frame_info
-{
- /* Nominal address of the frame described. See comments at FRAME_FP
- about what this means outside the *FRAME* macros; in the *FRAME*
- macros, it can mean whatever makes most sense for this machine. */
- CORE_ADDR frame;
-
- /* Address at which execution is occurring in this frame. For the
- innermost frame, it's the current pc. For other frames, it is a
- pc saved in the next frame. */
- CORE_ADDR pc;
-
- /* For each register, address of where it was saved on entry to the
- frame, or zero if it was not saved on entry to this frame. This
- includes special registers such as pc and fp saved in special
- ways in the stack frame. The SP_REGNUM is even more special, the
- address here is the sp for the next frame, not the address where
- the sp was saved. Allocated by frame_saved_regs_zalloc () which
- is called and initialized by FRAME_INIT_SAVED_REGS. */
- CORE_ADDR *saved_regs; /*NUM_REGS */
-
- int localoff;
- int pc_reg;
- alpha_extra_func_info_t proc_desc;
-
- /* Pointers to the next and previous frame_info's in the frame cache. */
- struct frame_info *next, *prev;
-};
-
-struct frame_saved_regs
-{
- /* For each register R (except the SP), regs[R] is the address at
- which it was saved on entry to the frame, or zero if it was not
- saved on entry to this frame. This includes special registers
- such as pc and fp saved in special ways in the stack frame.
-
- regs[SP_REGNUM] is different. It holds the actual SP, not the
- address at which it was saved. */
-
- CORE_ADDR regs[NUM_REGS];
-};
-
-static CORE_ADDR theRegisters[32];
-
-/* Prototypes for local functions. */
-
-static CORE_ADDR read_next_frame_reg PARAMS ((struct frame_info *, int));
-static CORE_ADDR heuristic_proc_start PARAMS ((CORE_ADDR));
-static int alpha_about_to_return PARAMS ((CORE_ADDR pc));
-static void init_extra_frame_info PARAMS ((struct frame_info *));
-static CORE_ADDR alpha_frame_chain PARAMS ((struct frame_info *));
-static CORE_ADDR alpha_frame_saved_pc PARAMS ((struct frame_info *frame))
-static void *trace_alloc PARAMS ((unsigned int));
-static struct frame_info *create_new_frame PARAMS ((CORE_ADDR, CORE_ADDR));
-
-static alpha_extra_func_info_t
-heuristic_proc_desc PARAMS ((CORE_ADDR, CORE_ADDR, struct frame_info *,
- struct frame_saved_regs *));
-
-static alpha_extra_func_info_t
-find_proc_desc PARAMS ((CORE_ADDR, struct frame_info *,
- struct frame_saved_regs *));
-
-/* Heuristic_proc_start may hunt through the text section for a long
- time across a 2400 baud serial line. Allows the user to limit this
- search. */
-static unsigned int heuristic_fence_post = 1<<16;
-
-/* Layout of a stack frame on the alpha:
-
- | |
- pdr members: | 7th ... nth arg, |
- | `pushed' by caller. |
- | |
-----------------|-------------------------------|<-- old_sp == vfp
- ^ ^ ^ ^ | |
- | | | | | |
- | |localoff | Copies of 1st .. 6th |
- | | | | | argument if necessary. |
- | | | v | |
- | | | --- |-------------------------------|<-- FRAME_LOCALS_ADDRESS
- | | | | |
- | | | | Locals and temporaries. |
- | | | | |
- | | | |-------------------------------|
- | | | | |
- |-fregoffset | Saved float registers. |
- | | | | F9 |
- | | | | . |
- | | | | . |
- | | | | F2 |
- | | v | |
- | | -------|-------------------------------|
- | | | |
- | | | Saved registers. |
- | | | S6 |
- |-regoffset | . |
- | | | . |
- | | | S0 |
- | | | pdr.pcreg |
- | v | |
- | ----------|-------------------------------|
- | | |
- frameoffset | Argument build area, gets |
- | | 7th ... nth arg for any |
- | | called procedure. |
- v | |
- -------------|-------------------------------|<-- sp
- | | */
-
-#define PROC_LOW_ADDR(PROC) ((PROC)->pdr.adr) /* least address */
-#define PROC_HIGH_ADDR(PROC) ((PROC)->pdr.iline) /* upper address bound */
-#define PROC_DUMMY_FRAME(PROC) ((PROC)->pdr.cbLineOffset) /*CALL_DUMMY frame */
-#define PROC_FRAME_OFFSET(PROC) ((PROC)->pdr.frameoffset)
-#define PROC_FRAME_REG(PROC) ((PROC)->pdr.framereg)
-#define PROC_REG_MASK(PROC) ((PROC)->pdr.regmask)
-#define PROC_FREG_MASK(PROC) ((PROC)->pdr.fregmask)
-#define PROC_REG_OFFSET(PROC) ((PROC)->pdr.regoffset)
-#define PROC_FREG_OFFSET(PROC) ((PROC)->pdr.fregoffset)
-#define PROC_PC_REG(PROC) ((PROC)->pdr.pcreg)
-#define PROC_LOCALOFF(PROC) ((PROC)->pdr.localoff)
-
-/* Local storage allocation/deallocation functions. trace_alloc does
- a malloc, but also chains allocated blocks on trace_alloc_chain, so
- they may all be freed on exit from __gnat_backtrace. */
-
-struct alloc_chain
-{
- struct alloc_chain *next;
- double x[0];
-};
-struct alloc_chain *trace_alloc_chain;
-
-static void *
-trace_alloc (n)
- unsigned int n;
-{
- struct alloc_chain * result = malloc (n + sizeof(struct alloc_chain));
-
- result->next = trace_alloc_chain;
- trace_alloc_chain = result;
- return (void*) result->x;
-}
-
-static void
-free_trace_alloc ()
-{
- while (trace_alloc_chain != 0)
- {
- struct alloc_chain *old = trace_alloc_chain;
-
- trace_alloc_chain = trace_alloc_chain->next;
- free (old);
- }
-}
-
-/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0
- otherwise. */
-
-static int
-read_memory_safe4 (addr, dest)
- CORE_ADDR addr;
- unsigned int *dest;
-{
- *dest = *((unsigned int*) addr);
- return 0;
-}
+/* No target specific implementation and PC_ADJUST not defined. */
-/* Read value at ADDR into *DEST, returning 0 if this is valid, != 0
- otherwise. */
+/*------------------------------*
+ *-- The dummy implementation --*
+ *------------------------------*/
-static int
-read_memory_safe8 (addr, dest)
- CORE_ADDR addr;
- CORE_ADDR *dest;
+int
+__gnat_backtrace (array, size, exclude_min, exclude_max, skip_frames)
+ void **array ATTRIBUTE_UNUSED;
+ int size ATTRIBUTE_UNUSED;
+ void *exclude_min ATTRIBUTE_UNUSED;
+ void *exclude_max ATTRIBUTE_UNUSED;
+ int skip_frames ATTRIBUTE_UNUSED;
{
- *dest = *((CORE_ADDR*) addr);
return 0;
}
-static CORE_ADDR
-read_register (regno)
- int regno;
-{
- if (regno >= 0 && regno < 31)
- return theRegisters[regno];
-
- return (CORE_ADDR) 0;
-}
-
-static void
-frame_saved_regs_zalloc (fi)
- struct frame_info *fi;
-{
- fi->saved_regs = (CORE_ADDR *) trace_alloc (SIZEOF_FRAME_SAVED_REGS);
- memset (fi->saved_regs, 0, SIZEOF_FRAME_SAVED_REGS);
-}
-
-static void *
-frame_obstack_alloc (size)
- unsigned long size;
-{
- return (void *) trace_alloc (size);
-}
-
-static int
-inside_entry_file (addr)
- CORE_ADDR addr;
-{
- if (addr == 0)
- return 1;
- else
- return 0;
-}
-
-static CORE_ADDR
-alpha_saved_pc_after_call (frame)
- struct frame_info *frame;
-{
- CORE_ADDR pc = frame->pc;
- alpha_extra_func_info_t proc_desc;
- int pcreg;
-
- proc_desc = find_proc_desc (pc, frame->next, NULL);
- pcreg = proc_desc ? PROC_PC_REG (proc_desc) : RA_REGNUM;
-
- return read_register (pcreg);
-}
-
-/* Guaranteed to set frame->saved_regs to some values (it never leaves it
- NULL). */
-
-static void
-alpha_find_saved_regs (frame)
- struct frame_info *frame;
-{
- int ireg;
- CORE_ADDR reg_position;
- unsigned long mask;
- alpha_extra_func_info_t proc_desc;
- int returnreg;
-
- frame_saved_regs_zalloc (frame);
-
- /* If it is the frame for __sigtramp, the saved registers are located in a
- sigcontext structure somewhere on the stack. __sigtramp passes a pointer
- to the sigcontext structure on the stack. If the stack layout for
- __sigtramp changes, or if sigcontext offsets change, we might have to
- update this code. */
-
-#ifndef SIGFRAME_PC_OFF
-#define SIGFRAME_PC_OFF (2 * 8)
-#define SIGFRAME_REGSAVE_OFF (4 * 8)
-#define SIGFRAME_FPREGSAVE_OFF (SIGFRAME_REGSAVE_OFF + 32 * 8 + 8)
-#endif
-
- proc_desc = frame->proc_desc;
- if (proc_desc == NULL)
- /* I'm not sure how/whether this can happen. Normally when we can't
- find a proc_desc, we "synthesize" one using heuristic_proc_desc
- and set the saved_regs right away. */
- return;
-
- /* Fill in the offsets for the registers which gen_mask says
- were saved. */
-
- reg_position = frame->frame + PROC_REG_OFFSET (proc_desc);
- mask = PROC_REG_MASK (proc_desc);
-
- returnreg = PROC_PC_REG (proc_desc);
-
- /* Note that RA is always saved first, regardless of its actual
- register number. */
- if (mask & (1 << returnreg))
- {
- frame->saved_regs[returnreg] = reg_position;
- reg_position += 8;
- mask &= ~(1 << returnreg); /* Clear bit for RA so we
- don't save again later. */
- }
-
- for (ireg = 0; ireg <= 31; ireg++)
- if (mask & (1 << ireg))
- {
- frame->saved_regs[ireg] = reg_position;
- reg_position += 8;
- }
-
- /* Fill in the offsets for the registers which float_mask says
- were saved. */
-
- reg_position = frame->frame + PROC_FREG_OFFSET (proc_desc);
- mask = PROC_FREG_MASK (proc_desc);
-
- for (ireg = 0; ireg <= 31; ireg++)
- if (mask & (1 << ireg))
- {
- frame->saved_regs[FP0_REGNUM + ireg] = reg_position;
- reg_position += 8;
- }
-
- frame->saved_regs[PC_REGNUM] = frame->saved_regs[returnreg];
-}
-
-static CORE_ADDR
-read_next_frame_reg (fi, regno)
- struct frame_info *fi;
- int regno;
-{
- CORE_ADDR result;
- for (; fi; fi = fi->next)
- {
- /* We have to get the saved sp from the sigcontext
- if it is a signal handler frame. */
- if (regno == SP_REGNUM)
- return fi->frame;
- else
- {
- if (fi->saved_regs == 0)
- alpha_find_saved_regs (fi);
-
- if (fi->saved_regs[regno])
- {
- if (read_memory_safe8 (fi->saved_regs[regno], &result) == 0)
- return result;
- else
- return 0;
- }
- }
- }
-
- return read_register (regno);
-}
-
-static CORE_ADDR
-alpha_frame_saved_pc (frame)
- struct frame_info *frame;
-{
- return read_next_frame_reg (frame, frame->pc_reg);
-}
-
-static struct alpha_extra_func_info temp_proc_desc;
-
-/* Nonzero if instruction at PC is a return instruction. "ret
- $zero,($ra),1" on alpha. */
-
-static int
-alpha_about_to_return (pc)
- CORE_ADDR pc;
-{
- int inst;
-
- read_memory_safe4 (pc, &inst);
- return inst == 0x6bfa8001;
-}
-
-/* A heuristically computed start address for the subprogram
- containing address PC. Returns 0 if none detected. */
-
-static CORE_ADDR
-heuristic_proc_start (pc)
- CORE_ADDR pc;
-{
- CORE_ADDR start_pc = pc;
- CORE_ADDR fence = start_pc - heuristic_fence_post;
-
- if (start_pc == 0)
- return 0;
-
- if (heuristic_fence_post == UINT_MAX
- || fence < VM_MIN_ADDRESS)
- fence = VM_MIN_ADDRESS;
-
- /* search back for previous return */
- for (start_pc -= 4; ; start_pc -= 4)
- {
- if (start_pc < fence)
- return 0;
- else if (alpha_about_to_return (start_pc))
- break;
- }
-
- start_pc += 4; /* skip return */
- return start_pc;
-}
-
-static alpha_extra_func_info_t
-heuristic_proc_desc (start_pc, limit_pc, next_frame, saved_regs_p)
- CORE_ADDR start_pc;
- CORE_ADDR limit_pc;
- struct frame_info *next_frame;
- struct frame_saved_regs *saved_regs_p;
-{
- CORE_ADDR sp = read_next_frame_reg (next_frame, SP_REGNUM);
- CORE_ADDR cur_pc;
- int frame_size;
- int has_frame_reg = 0;
- unsigned long reg_mask = 0;
- int pcreg = -1;
-
- if (start_pc == 0)
- return 0;
-
- memset (&temp_proc_desc, '\0', sizeof (temp_proc_desc));
- if (saved_regs_p != 0)
- memset (saved_regs_p, '\0', sizeof (struct frame_saved_regs));
-
- PROC_LOW_ADDR (&temp_proc_desc) = start_pc;
-
- if (start_pc + 200 < limit_pc)
- limit_pc = start_pc + 200;
-
- frame_size = 0;
- for (cur_pc = start_pc; cur_pc < limit_pc; cur_pc += 4)
- {
- unsigned int word;
- int status;
-
- status = read_memory_safe4 (cur_pc, &word);
- if (status)
- return 0;
-
- if ((word & 0xffff0000) == 0x23de0000) /* lda $sp,n($sp) */
- {
- if (word & 0x8000)
- frame_size += (-word) & 0xffff;
- else
- /* Exit loop if a positive stack adjustment is found, which
- usually means that the stack cleanup code in the function
- epilogue is reached. */
- break;
- }
- else if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */
- && (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */
- {
- int reg = (word & 0x03e00000) >> 21;
-
- reg_mask |= 1 << reg;
- if (saved_regs_p != 0)
- saved_regs_p->regs[reg] = sp + (short) word;
-
- /* Starting with OSF/1-3.2C, the system libraries are shipped
- without local symbols, but they still contain procedure
- descriptors without a symbol reference. GDB is currently
- unable to find these procedure descriptors and uses
- heuristic_proc_desc instead.
- As some low level compiler support routines (__div*, __add*)
- use a non-standard return address register, we have to
- add some heuristics to determine the return address register,
- or stepping over these routines will fail.
- Usually the return address register is the first register
- saved on the stack, but assembler optimization might
- rearrange the register saves.
- So we recognize only a few registers (t7, t9, ra) within
- the procedure prologue as valid return address registers.
- If we encounter a return instruction, we extract the
- the return address register from it.
-
- FIXME: Rewriting GDB to access the procedure descriptors,
- e.g. via the minimal symbol table, might obviate this hack. */
- if (pcreg == -1
- && cur_pc < (start_pc + 80)
- && (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM))
- pcreg = reg;
- }
- else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */
- pcreg = (word >> 16) & 0x1f;
- else if (word == 0x47de040f) /* bis sp,sp fp */
- has_frame_reg = 1;
- }
-
- if (pcreg == -1)
- {
- /* If we haven't found a valid return address register yet,
- keep searching in the procedure prologue. */
- while (cur_pc < (limit_pc + 80) && cur_pc < (start_pc + 80))
- {
- unsigned int word;
-
- if (read_memory_safe4 (cur_pc, &word))
- break;
- cur_pc += 4;
-
- if ((word & 0xfc1f0000) == 0xb41e0000 /* stq reg,n($sp) */
- && (word & 0xffff0000) != 0xb7fe0000) /* reg != $zero */
- {
- int reg = (word & 0x03e00000) >> 21;
-
- if (reg == T7_REGNUM || reg == T9_REGNUM || reg == RA_REGNUM)
- {
- pcreg = reg;
- break;
- }
- }
- else if ((word & 0xffe0ffff) == 0x6be08001) /* ret zero,reg,1 */
- {
- pcreg = (word >> 16) & 0x1f;
- break;
- }
- }
- }
-
- if (has_frame_reg)
- PROC_FRAME_REG (&temp_proc_desc) = GCC_FP_REGNUM;
- else
- PROC_FRAME_REG (&temp_proc_desc) = SP_REGNUM;
-
- PROC_FRAME_OFFSET (&temp_proc_desc) = frame_size;
- PROC_REG_MASK (&temp_proc_desc) = reg_mask;
- PROC_PC_REG (&temp_proc_desc) = (pcreg == -1) ? RA_REGNUM : pcreg;
- PROC_LOCALOFF (&temp_proc_desc) = 0; /* XXX - bogus */
-
- return &temp_proc_desc;
-}
-
-static alpha_extra_func_info_t
-find_proc_desc (pc, next_frame, saved_regs)
- CORE_ADDR pc;
- struct frame_info *next_frame;
- struct frame_saved_regs *saved_regs;
-{
- CORE_ADDR startaddr;
-
- /* If heuristic_fence_post is non-zero, determine the procedure
- start address by examining the instructions.
- This allows us to find the start address of static functions which
- have no symbolic information, as startaddr would have been set to
- the preceding global function start address by the
- find_pc_partial_function call above. */
- startaddr = heuristic_proc_start (pc);
-
- return heuristic_proc_desc (startaddr, pc, next_frame, saved_regs);
-}
-
-static CORE_ADDR
-alpha_frame_chain (frame)
- struct frame_info *frame;
-{
- alpha_extra_func_info_t proc_desc;
- CORE_ADDR saved_pc = FRAME_SAVED_PC (frame);
-
- if (saved_pc == 0 || inside_entry_file (saved_pc))
- return 0;
-
- proc_desc = find_proc_desc (saved_pc, frame, NULL);
- if (!proc_desc)
- return 0;
-
- /* If no frame pointer and frame size is zero, we must be at end
- of stack (or otherwise hosed). If we don't check frame size,
- we loop forever if we see a zero size frame. */
- if (PROC_FRAME_REG (proc_desc) == SP_REGNUM
- && PROC_FRAME_OFFSET (proc_desc) == 0)
- return 0;
- else
- return read_next_frame_reg (frame, PROC_FRAME_REG (proc_desc))
- + PROC_FRAME_OFFSET (proc_desc);
-}
-
-static void
-init_extra_frame_info (frame)
- struct frame_info *frame;
-{
- struct frame_saved_regs temp_saved_regs;
- alpha_extra_func_info_t proc_desc =
- find_proc_desc (frame->pc, frame->next, &temp_saved_regs);
-
- frame->saved_regs = NULL;
- frame->localoff = 0;
- frame->pc_reg = RA_REGNUM;
- frame->proc_desc = proc_desc;
-
- if (proc_desc)
- {
- /* Get the locals offset and the saved pc register from the
- procedure descriptor, they are valid even if we are in the
- middle of the prologue. */
- frame->localoff = PROC_LOCALOFF (proc_desc);
- frame->pc_reg = PROC_PC_REG (proc_desc);
-
- /* Fixup frame-pointer - only needed for top frame */
-
- /* This may not be quite right, if proc has a real frame register.
- Get the value of the frame relative sp, procedure might have been
- interrupted by a signal at it's very start. */
- if (frame->pc == PROC_LOW_ADDR (proc_desc))
- frame->frame = read_next_frame_reg (frame->next, SP_REGNUM);
- else
- frame->frame
- = (read_next_frame_reg (frame->next, PROC_FRAME_REG (proc_desc))
- + PROC_FRAME_OFFSET (proc_desc));
-
- frame->saved_regs
- = (CORE_ADDR *) frame_obstack_alloc (SIZEOF_FRAME_SAVED_REGS);
- memcpy
- (frame->saved_regs, temp_saved_regs.regs, SIZEOF_FRAME_SAVED_REGS);
- frame->saved_regs[PC_REGNUM] = frame->saved_regs[RA_REGNUM];
- }
-}
-
-/* Create an arbitrary (i.e. address specified by user) or innermost frame.
- Always returns a non-NULL value. */
-
-static struct frame_info *
-create_new_frame (addr, pc)
- CORE_ADDR addr;
- CORE_ADDR pc;
-{
- struct frame_info *fi;
-
- fi = (struct frame_info *)
- trace_alloc (sizeof (struct frame_info));
-
- /* Arbitrary frame */
- fi->next = NULL;
- fi->prev = NULL;
- fi->frame = addr;
- fi->pc = pc;
-
-#ifdef INIT_EXTRA_FRAME_INFO
- INIT_EXTRA_FRAME_INFO (0, fi);
-#endif
-
- return fi;
-}
-
-static CORE_ADDR current_pc;
-
-static void
-set_current_pc ()
-{
- current_pc = (CORE_ADDR) __builtin_return_address (0);
-}
-
-static CORE_ADDR
-read_pc ()
-{
- return current_pc;
-}
-
-static struct frame_info *
-get_current_frame ()
-{
- return create_new_frame (0, read_pc ());
-}
-
-/* Return the frame that called FI.
- If FI is the original frame (it has no caller), return 0. */
-
-static struct frame_info *
-get_prev_frame (next_frame)
- struct frame_info *next_frame;
-{
- CORE_ADDR address = 0;
- struct frame_info *prev;
- int fromleaf = 0;
-
- /* If we have the prev one, return it */
- if (next_frame->prev)
- return next_frame->prev;
-
- /* On some machines it is possible to call a function without
- setting up a stack frame for it. On these machines, we
- define this macro to take two args; a frameinfo pointer
- identifying a frame and a variable to set or clear if it is
- or isn't leafless. */
-
- /* Two macros defined in tm.h specify the machine-dependent
- actions to be performed here.
-
- First, get the frame's chain-pointer. If that is zero, the frame
- is the outermost frame or a leaf called by the outermost frame.
- This means that if start calls main without a frame, we'll return
- 0 (which is fine anyway).
-
- Nope; there's a problem. This also returns when the current
- routine is a leaf of main. This is unacceptable. We move
- this to after the ffi test; I'd rather have backtraces from
- start go curfluy than have an abort called from main not show
- main. */
-
- address = FRAME_CHAIN (next_frame);
- if (!FRAME_CHAIN_VALID (address, next_frame))
- return 0;
- address = FRAME_CHAIN_COMBINE (address, next_frame);
-
- if (address == 0)
- return 0;
-
- prev = (struct frame_info *) trace_alloc (sizeof (struct frame_info));
-
- prev->saved_regs = NULL;
- if (next_frame)
- next_frame->prev = prev;
-
- prev->next = next_frame;
- prev->prev = (struct frame_info *) 0;
- prev->frame = address;
-
- /* This change should not be needed, FIXME! We should
- determine whether any targets *need* INIT_FRAME_PC to happen
- after INIT_EXTRA_FRAME_INFO and come up with a simple way to
- express what goes on here.
-
- INIT_EXTRA_FRAME_INFO is called from two places: create_new_frame
- (where the PC is already set up) and here (where it isn't).
- INIT_FRAME_PC is only called from here, always after
- INIT_EXTRA_FRAME_INFO.
-
- The catch is the MIPS, where INIT_EXTRA_FRAME_INFO requires the PC
- value (which hasn't been set yet). Some other machines appear to
- require INIT_EXTRA_FRAME_INFO before they can do INIT_FRAME_PC. Phoo.
-
- We shouldn't need INIT_FRAME_PC_FIRST to add more complication to
- an already overcomplicated part of GDB. gnu@cygnus.com, 15Sep92.
-
- Assuming that some machines need INIT_FRAME_PC after
- INIT_EXTRA_FRAME_INFO, one possible scheme:
-
- SETUP_INNERMOST_FRAME()
- Default version is just create_new_frame (read_fp ()),
- read_pc ()). Machines with extra frame info would do that (or the
- local equivalent) and then set the extra fields.
- INIT_PREV_FRAME(fromleaf, prev)
- Replace INIT_EXTRA_FRAME_INFO and INIT_FRAME_PC. This should
- also return a flag saying whether to keep the new frame, or
- whether to discard it, because on some machines (e.g. mips) it
- is really awkward to have FRAME_CHAIN_VALID called *before*
- INIT_EXTRA_FRAME_INFO (there is no good way to get information
- deduced in FRAME_CHAIN_VALID into the extra fields of the new frame).
- std_frame_pc(fromleaf, prev)
- This is the default setting for INIT_PREV_FRAME. It just does what
- the default INIT_FRAME_PC does. Some machines will call it from
- INIT_PREV_FRAME (either at the beginning, the end, or in the middle).
- Some machines won't use it.
- kingdon@cygnus.com, 13Apr93, 31Jan94, 14Dec94. */
-
-#ifdef INIT_FRAME_PC_FIRST
- INIT_FRAME_PC_FIRST (fromleaf, prev);
-#endif
-
-#ifdef INIT_EXTRA_FRAME_INFO
- INIT_EXTRA_FRAME_INFO (fromleaf, prev);
#endif
- /* This entry is in the frame queue now, which is good since
- FRAME_SAVED_PC may use that queue to figure out its value
- (see tm-sparc.h). We want the pc saved in the inferior frame. */
- INIT_FRAME_PC (fromleaf, prev);
-
- /* If ->frame and ->pc are unchanged, we are in the process of getting
- ourselves into an infinite backtrace. Some architectures check this
- in FRAME_CHAIN or thereabouts, but it seems like there is no reason
- this can't be an architecture-independent check. */
- if (next_frame != NULL)
- {
- if (prev->frame == next_frame->frame
- && prev->pc == next_frame->pc)
- {
- next_frame->prev = NULL;
- free (prev);
- return NULL;
- }
- }
-
- return prev;
-}
-
-#define SAVE(regno,disp) \
- "stq $" #regno ", " #disp "(%0)\n"
-
-int
-__gnat_backtrace (array, size, exclude_min, exclude_max)
- void **array;
- int size;
- void *exclude_min;
- void *exclude_max;
-{
- struct frame_info* top;
- struct frame_info* current;
- int cnt;
-
- /* This function is not thread safe, protect it */
- (*Lock_Task) ();
- asm volatile (
- SAVE (9,72)
- SAVE (10,80)
- SAVE (11,88)
- SAVE (12,96)
- SAVE (13,104)
- SAVE (14,112)
- SAVE (15,120)
- SAVE (16,128)
- SAVE (17,136)
- SAVE (18,144)
- SAVE (19,152)
- SAVE (20,160)
- SAVE (21,168)
- SAVE (22,176)
- SAVE (23,184)
- SAVE (24,192)
- SAVE (25,200)
- SAVE (26,208)
- SAVE (27,216)
- SAVE (28,224)
- SAVE (29,232)
- SAVE (30,240)
- : : "r" (&theRegisters));
-
- trace_alloc_chain = NULL;
- set_current_pc ();
-
- top = current = get_current_frame ();
- cnt = 0;
-
- /* We skip the call to this function, it makes no sense to record it. */
- for (cnt = 0; cnt < SKIP_FRAME; cnt += 1) {
- current = get_prev_frame (current);
- }
-
- cnt = 0;
- while (cnt < size)
- {
- if (STOP_FRAME)
- break;
-
- if (current->pc < (CORE_ADDR) exclude_min
- || current->pc > (CORE_ADDR) exclude_max)
- array[cnt++] = (void*) (current->pc + PC_ADJUST);
-
- current = get_prev_frame (current);
- }
-
- free_trace_alloc ();
- (*Unlock_Task) ();
-
- return cnt;
-}
#endif
diff --git a/gcc/ada/trans.c b/gcc/ada/trans.c
index 2d0e9ffd54f..3df165cc2a9 100644
--- a/gcc/ada/trans.c
+++ b/gcc/ada/trans.c
@@ -6,7 +6,6 @@
* *
* C Implementation File *
* *
- * *
* Copyright (C) 1992-2003, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
@@ -110,8 +109,6 @@ static void process_freeze_entity PARAMS((Node_Id));
static void process_inlined_subprograms PARAMS((Node_Id));
static void process_decls PARAMS((List_Id, List_Id, Node_Id,
int, int));
-static tree emit_access_check PARAMS((tree));
-static tree emit_discriminant_check PARAMS((tree, Node_Id));
static tree emit_range_check PARAMS((tree, Node_Id));
static tree emit_index_check PARAMS((tree, tree, tree, tree));
static tree emit_check PARAMS((tree, tree, int));
@@ -171,8 +168,16 @@ gigi (gnat_root, max_gnat_node, number_name, nodes_ptr, next_node_ptr,
type_annotate_only = (gigi_operating_mode == 1);
+ /* If we are just annotating types, give VOID_TYPE zero sizes to avoid
+ errors. */
+ if (type_annotate_only)
+ {
+ TYPE_SIZE (void_type_node) = bitsize_zero_node;
+ TYPE_SIZE_UNIT (void_type_node) = size_zero_node;
+ }
+
/* See if we should discard file names in exception messages. */
- discard_file_names = (Global_Discard_Names || Debug_Flag_NN);
+ discard_file_names = Debug_Flag_NN;
if (Nkind (gnat_root) != N_Compilation_Unit)
gigi_abort (301);
@@ -183,9 +188,10 @@ gigi (gnat_root, max_gnat_node, number_name, nodes_ptr, next_node_ptr,
init_gnat_to_gnu ();
init_dummy_type ();
init_code_table ();
+ gnat_compute_largest_alignment ();
/* Enable GNAT stack checking method if needed */
- if (!Stack_Check_Probes_On_Target)
+ if (!Stack_Check_Probes_On_Target)
set_stack_check_libfunc (gen_rtx (SYMBOL_REF, Pmode, "_gnat_stack_check"));
/* Save the type we made for integer as the type for Standard.Integer.
@@ -345,10 +351,11 @@ tree_transform (gnat_node)
Entity, something is wrong with the entity map, probably in
generic instantiation. However, this does not apply to
types. Since we sometime have strange Ekind's, just do
- this test for objects. Also, if the Etype of the Entity
- is private, the Etype of the N_Identifier is allowed to be the
- full type and also we consider a packed array type to be the
- same as the original type. Finally, if the types are Itypes,
+ this test for objects. Also, if the Etype of the Entity is
+ private, the Etype of the N_Identifier is allowed to be the full
+ type and also we consider a packed array type to be the same as
+ the original type. Similarly, a class-wide type is equivalent
+ to a subtype of itself. Finally, if the types are Itypes,
one may be a copy of the other, which is also legal. */
gnat_temp = (Nkind (gnat_node) == N_Defining_Identifier
@@ -358,6 +365,7 @@ tree_transform (gnat_node)
if (Etype (gnat_node) != gnat_temp_type
&& ! (Is_Packed (gnat_temp_type)
&& Etype (gnat_node) == Packed_Array_Type (gnat_temp_type))
+ && ! (Is_Class_Wide_Type (Etype (gnat_node)))
&& ! (IN (Ekind (gnat_temp_type), Private_Kind)
&& Present (Full_View (gnat_temp_type))
&& ((Etype (gnat_node) == Full_View (gnat_temp_type))
@@ -531,10 +539,10 @@ tree_transform (gnat_node)
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result = UI_To_gnu (Corresponding_Integer_Value (gnat_node),
gnu_result_type);
- if (TREE_CONSTANT_OVERFLOW (gnu_result)
- )
+ if (TREE_CONSTANT_OVERFLOW (gnu_result))
gigi_abort (305);
}
+
/* We should never see a Vax_Float type literal, since the front end
is supposed to transform these using appropriate conversions */
else if (Vax_Float (Underlying_Type (Etype (gnat_node))))
@@ -729,8 +737,8 @@ tree_transform (gnat_node)
|| Is_Concurrent_Type (Etype (gnat_temp))))
break;
- if (Present (Expression (gnat_node))
- && ! (Nkind (gnat_node) == N_Object_Declaration
+ if (Present (Expression (gnat_node))
+ && ! (Nkind (gnat_node) == N_Object_Declaration
&& No_Initialization (gnat_node))
&& (! type_annotate_only
|| Compile_Time_Known_Value (Expression (gnat_node))))
@@ -789,10 +797,10 @@ tree_transform (gnat_node)
gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
break;
- case N_Subprogram_Renaming_Declaration:
- case N_Package_Renaming_Declaration:
case N_Exception_Renaming_Declaration:
case N_Number_Declaration:
+ case N_Package_Renaming_Declaration:
+ case N_Subprogram_Renaming_Declaration:
/* These are fully handled in the front end. */
break;
@@ -803,11 +811,6 @@ tree_transform (gnat_node)
case N_Explicit_Dereference:
gnu_result = gnat_to_gnu (Prefix (gnat_node));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
-
- /* Emit access check if necessary */
- if (Do_Access_Check (gnat_node))
- gnu_result = emit_access_check (gnu_result);
-
gnu_result = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_result);
break;
@@ -819,10 +822,6 @@ tree_transform (gnat_node)
int i;
Node_Id *gnat_expr_array;
- /* Emit access check if necessary */
- if (Do_Access_Check (gnat_node))
- gnu_array_object = emit_access_check (gnu_array_object);
-
gnu_array_object = maybe_implicit_deref (gnu_array_object);
gnu_array_object = maybe_unconstrained_array (gnu_array_object);
@@ -830,7 +829,7 @@ tree_transform (gnat_node)
if (TREE_CODE (TREE_TYPE (gnu_array_object)) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (gnu_array_object)))
gnu_array_object
- = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
+ = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_array_object))),
gnu_array_object);
gnu_result = gnu_array_object;
@@ -889,16 +888,12 @@ tree_transform (gnat_node)
gnu_result = gnat_to_gnu (Prefix (gnat_node));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
- /* Emit access check if necessary */
- if (Do_Access_Check (gnat_node))
- gnu_result = emit_access_check (gnu_result);
-
/* Do any implicit dereferences of the prefix and do any needed
range check. */
gnu_result = maybe_implicit_deref (gnu_result);
gnu_result = maybe_unconstrained_array (gnu_result);
gnu_type = TREE_TYPE (gnu_result);
- if (Do_Range_Check (gnat_range_node))
+ if (Do_Range_Check (gnat_range_node))
{
/* Get the bounds of the slice. */
tree gnu_index_type
@@ -960,15 +955,12 @@ tree_transform (gnat_node)
while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
|| IN (Ekind (gnat_pref_type), Access_Kind))
{
- if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
+ if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
gnat_pref_type = Underlying_Type (gnat_pref_type);
else if (IN (Ekind (gnat_pref_type), Access_Kind))
gnat_pref_type = Designated_Type (gnat_pref_type);
}
- if (Do_Access_Check (gnat_node))
- gnu_prefix = emit_access_check (gnu_prefix);
-
gnu_prefix = maybe_implicit_deref (gnu_prefix);
/* For discriminant references in tagged types always substitute the
@@ -979,7 +971,7 @@ tree_transform (gnat_node)
gnat_field = Corresponding_Discriminant (gnat_field);
/* For discriminant references of untagged types always substitute the
- corresponding girder discriminant. */
+ corresponding stored discriminant. */
else if (Present (Corresponding_Discriminant (gnat_field)))
gnat_field = Original_Record_Component (gnat_field);
@@ -1004,9 +996,6 @@ tree_transform (gnat_node)
: Etype (Prefix (gnat_node))))
gnu_prefix = gnat_stabilize_reference (gnu_prefix, 0);
- /* Emit discriminant check if necessary. */
- if (Do_Discriminant_Check (gnat_node))
- gnu_prefix = emit_discriminant_check (gnu_prefix, gnat_node);
gnu_result
= build_component_ref (gnu_prefix, NULL_TREE, gnu_field);
}
@@ -1139,6 +1128,43 @@ tree_transform (gnat_node)
break;
+ case Attr_Pool_Address:
+ {
+ tree gnu_obj_type;
+ tree gnu_ptr = gnu_prefix;
+
+ gnu_result_type = get_unpadded_type (Etype (gnat_node));
+
+ /* If this is an unconstrained array, we know the object must
+ have been allocated with the template in front of the object.
+ So compute the template address.*/
+
+ if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_ptr)))
+ gnu_ptr
+ = convert (build_pointer_type
+ (TYPE_OBJECT_RECORD_TYPE
+ (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (gnu_ptr)))),
+ gnu_ptr);
+
+ gnu_obj_type = TREE_TYPE (TREE_TYPE (gnu_ptr));
+ if (TREE_CODE (gnu_obj_type) == RECORD_TYPE
+ && TYPE_CONTAINS_TEMPLATE_P (gnu_obj_type))
+ {
+ tree gnu_char_ptr_type = build_pointer_type (char_type_node);
+ tree gnu_pos = byte_position (TYPE_FIELDS (gnu_obj_type));
+ tree gnu_byte_offset
+ = convert (gnu_char_ptr_type,
+ size_diffop (size_zero_node, gnu_pos));
+
+ gnu_ptr = convert (gnu_char_ptr_type, gnu_ptr);
+ gnu_ptr = build_binary_op (MINUS_EXPR, gnu_char_ptr_type,
+ gnu_ptr, gnu_byte_offset);
+ }
+
+ gnu_result = convert (gnu_result_type, gnu_ptr);
+ }
+ break;
+
case Attr_Size:
case Attr_Object_Size:
case Attr_Value_Size:
@@ -1191,7 +1217,7 @@ tree_transform (gnat_node)
&& TREE_CODE (gnu_expr) == COMPONENT_REF)
{
gnu_result = rm_size (gnu_type);
- if (! (contains_placeholder_p
+ if (! (CONTAINS_PLACEHOLDER_P
(DECL_SIZE (TREE_OPERAND (gnu_expr, 1)))))
gnu_result
= size_binop (MAX_EXPR, gnu_result,
@@ -1210,12 +1236,11 @@ tree_transform (gnat_node)
size for a type and by qualifying the size with
the object for 'Size of an object. */
- if (TREE_CODE (gnu_result) != INTEGER_CST
- && contains_placeholder_p (gnu_result))
+ if (CONTAINS_PLACEHOLDER_P (gnu_result))
{
if (TREE_CODE (gnu_prefix) != TYPE_DECL)
gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
- gnu_result, gnu_prefix);
+ gnu_result, gnu_expr);
else
gnu_result = max_size (gnu_result, 1);
}
@@ -1227,13 +1252,6 @@ tree_transform (gnat_node)
gnu_result = size_binop (MINUS_EXPR, gnu_result,
DECL_SIZE (TYPE_FIELDS (gnu_type)));
- /* If the type contains a template, subtract the size of the
- template. */
- if (TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
- gnu_result = size_binop (MINUS_EXPR, gnu_result,
- DECL_SIZE (TYPE_FIELDS (gnu_type)));
-
gnu_result_type = get_unpadded_type (Etype (gnat_node));
/* Always perform division using unsigned arithmetic as the
@@ -1306,10 +1324,6 @@ tree_transform (gnat_node)
? UI_To_Int (Intval (First (Expressions (gnat_node))))
: 1);
- /* Emit access check if necessary */
- if (Do_Access_Check (gnat_node))
- gnu_prefix = emit_access_check (gnu_prefix);
-
/* Make sure any implicit dereference gets done. */
gnu_prefix = maybe_implicit_deref (gnu_prefix);
gnu_prefix = maybe_unconstrained_array (gnu_prefix);
@@ -1355,7 +1369,7 @@ tree_transform (gnat_node)
(MAX_EXPR, gnu_compute_type,
build_binary_op
(PLUS_EXPR, gnu_compute_type,
- build_binary_op
+ build_binary_op
(MINUS_EXPR, gnu_compute_type,
convert (gnu_compute_type,
TYPE_MAX_VALUE
@@ -1370,8 +1384,7 @@ tree_transform (gnat_node)
/* If this has a PLACEHOLDER_EXPR, qualify it by the object
we are handling. Note that these attributes could not
have been used on an unconstrained array type. */
- if (TREE_CODE (gnu_result) != INTEGER_CST
- && contains_placeholder_p (gnu_result))
+ if (CONTAINS_PLACEHOLDER_P (gnu_result))
gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
gnu_result, gnu_prefix);
@@ -1476,8 +1489,7 @@ tree_transform (gnat_node)
/* If this has a PLACEHOLDER_EXPR, qualify it by the object
we are handling. */
- if (TREE_CODE (gnu_result) != INTEGER_CST
- && contains_placeholder_p (gnu_result))
+ if (CONTAINS_PLACEHOLDER_P (gnu_result))
gnu_result = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_result),
gnu_result, gnu_prefix);
@@ -1560,8 +1572,10 @@ tree_transform (gnat_node)
if (code == Default)
code = ((present_gnu_tree (gnat_obj)
&& (DECL_BY_REF_P (get_gnu_tree (gnat_obj))
- || (DECL_BY_COMPONENT_PTR_P
- (get_gnu_tree (gnat_obj)))))
+ || ((TREE_CODE (get_gnu_tree (gnat_obj))
+ == PARM_DECL)
+ && (DECL_BY_COMPONENT_PTR_P
+ (get_gnu_tree (gnat_obj))))))
? By_Reference : By_Copy);
gnu_result = convert (gnu_result_type, size_int (- code));
}
@@ -1583,8 +1597,7 @@ tree_transform (gnat_node)
the prefix is just an entity name. However, if an access check
is needed, we must do it. See second example in AARM 11.6(5.e). */
if (prefix_unused && TREE_SIDE_EFFECTS (gnu_prefix)
- && (! Is_Entity_Name (Prefix (gnat_node))
- || Do_Access_Check (gnat_node)))
+ && ! Is_Entity_Name (Prefix (gnat_node)))
gnu_result = fold (build (COMPOUND_EXPR, TREE_TYPE (gnu_result),
gnu_prefix, gnu_result));
}
@@ -1696,7 +1709,8 @@ tree_transform (gnat_node)
size_int (align / BITS_PER_UNIT), oalign / BITS_PER_UNIT);
}
- gnu_result = unchecked_convert (gnu_result_type, gnu_result);
+ gnu_result = unchecked_convert (gnu_result_type, gnu_result,
+ No_Truncation (gnat_node));
break;
case N_In:
@@ -1762,16 +1776,30 @@ tree_transform (gnat_node)
case N_And_Then: case N_Or_Else:
{
+ /* Some processing below (e.g. clear_last_expr) requires access to
+ status fields now maintained in the current function context, so
+ we'll setup a dummy one if needed. We cannot use global_binding_p,
+ since it might be true due to force_global and making a dummy
+ context would kill the current function context. */
+ bool make_dummy_context = (cfun == 0);
enum tree_code code = gnu_codes[Nkind (gnat_node)];
tree gnu_rhs_side;
+ if (make_dummy_context)
+ init_dummy_function_start ();
+
/* The elaboration of the RHS may generate code. If so,
we need to make sure it gets executed after the LHS. */
gnu_lhs = gnat_to_gnu (Left_Opnd (gnat_node));
clear_last_expr ();
- gnu_rhs_side = expand_start_stmt_expr (/*has_scope=*/1);
+
+ gnu_rhs_side = expand_start_stmt_expr (1 /*has_scope*/);
gnu_rhs = gnat_to_gnu (Right_Opnd (gnat_node));
expand_end_stmt_expr (gnu_rhs_side);
+
+ if (make_dummy_context)
+ expand_dummy_function_end ();
+
gnu_result_type = get_unpadded_type (Etype (gnat_node));
if (RTL_EXPR_SEQUENCE (gnu_rhs_side) != 0)
@@ -1833,7 +1861,7 @@ tree_transform (gnat_node)
/* If the result type is a private type, its full view may be a
numeric subtype. The representation we need is that of its base
type, given that it is the result of an arithmetic operation. */
- else if (Is_Private_Type (Etype (gnat_node)))
+ else if (Is_Private_Type (Etype (gnat_node)))
gnu_type = gnu_result_type
= get_unpadded_type (Base_Type (Full_View (Etype (gnat_node))));
@@ -1887,7 +1915,7 @@ tree_transform (gnat_node)
&& ! Shift_Count_OK (gnat_node))
gnu_result
= build_cond_expr
- (gnu_type,
+ (gnu_type,
build_binary_op (GE_EXPR, integer_type_node,
gnu_rhs,
convert (TREE_TYPE (gnu_rhs),
@@ -1934,7 +1962,7 @@ tree_transform (gnat_node)
case N_Op_Minus: case N_Op_Abs:
gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
- if (Ekind (Etype (gnat_node)) != E_Private_Type)
+ if (Ekind (Etype (gnat_node)) != E_Private_Type)
gnu_result_type = get_unpadded_type (Etype (gnat_node));
else
gnu_result_type = get_unpadded_type (Base_Type
@@ -1990,7 +2018,7 @@ tree_transform (gnat_node)
gnu_result_type = get_unpadded_type (Etype (gnat_node));
return build_allocator (gnu_type, gnu_init, gnu_result_type,
Procedure_To_Call (gnat_node),
- Storage_Pool (gnat_node));
+ Storage_Pool (gnat_node), gnat_node);
}
break;
@@ -2109,6 +2137,23 @@ tree_transform (gnat_node)
gnu_expr = gnat_to_gnu (Expression (gnat_node));
gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
+ /* The range of values in a case statement is determined by the
+ rules in RM 5.4(7-9). In almost all cases, this range is
+ represented by the Etype of the expression. One exception arises
+ in the case of a simple name that is parenthesized. This still
+ has the Etype of the name, but since it is not a name, para 7
+ does not apply, and we need to go to the base type. This is the
+ only case where parenthesization affects the dynamic semantics
+ (i.e. the range of possible values at runtime that is covered by
+ the others alternative.
+
+ Another exception is if the subtype of the expression is
+ non-static. In that case, we also have to use the base type. */
+ if (Paren_Count (Expression (gnat_node)) != 0
+ || !Is_OK_Static_Subtype (Underlying_Type
+ (Etype (Expression (gnat_node)))))
+ gnu_expr = convert (get_base_type (TREE_TYPE (gnu_expr)), gnu_expr);
+
set_lineno (gnat_node, 1);
expand_start_case (1, gnu_expr, TREE_TYPE (gnu_expr), "case");
@@ -2206,7 +2251,7 @@ tree_transform (gnat_node)
/* Communicate to GCC that we are done with the current WHEN,
i.e. insert a "break" statement. */
expand_exit_something ();
- expand_end_bindings (getdecls (), kept_level_p (), 0);
+ expand_end_bindings (getdecls (), kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
}
@@ -2345,7 +2390,7 @@ tree_transform (gnat_node)
gnat_statement = Next (gnat_statement))
gnat_to_code (gnat_statement);
- expand_end_bindings (getdecls (), kept_level_p (), 0);
+ expand_end_bindings (getdecls (), kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
gnu_block_stack = TREE_CHAIN (gnu_block_stack);
@@ -2371,7 +2416,7 @@ tree_transform (gnat_node)
/* Close the nesting level that sourround the loop that was used to
declare the loop index variable. */
set_lineno (gnat_node, 1);
- expand_end_bindings (getdecls (), 1, 0);
+ expand_end_bindings (getdecls (), 1, -1);
poplevel (1, 1, 0);
}
@@ -2389,7 +2434,7 @@ tree_transform (gnat_node)
expand_start_bindings (0);
process_decls (Declarations (gnat_node), Empty, Empty, 1, 1);
gnat_to_code (Handled_Statement_Sequence (gnat_node));
- expand_end_bindings (getdecls (), kept_level_p (), 0);
+ expand_end_bindings (getdecls (), kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
gnu_block_stack = TREE_CHAIN (gnu_block_stack);
if (Present (Identifier (gnat_node)))
@@ -2465,13 +2510,15 @@ tree_transform (gnat_node)
type is self-referential since we want to allocate the fixed
size in that case. */
if (TREE_CODE (gnu_ret_val) == COMPONENT_REF
+ && (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0)))
+ == RECORD_TYPE)
&& (TYPE_IS_PADDING_P
(TREE_TYPE (TREE_OPERAND (gnu_ret_val, 0))))
- && contains_placeholder_p
- (TYPE_SIZE (TREE_TYPE (gnu_ret_val))))
+ && (CONTAINS_PLACEHOLDER_P
+ (TYPE_SIZE (TREE_TYPE (gnu_ret_val)))))
gnu_ret_val = TREE_OPERAND (gnu_ret_val, 0);
- if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
+ if (TYPE_RETURNS_BY_REF_P (gnu_subprog_type)
|| By_Ref (gnat_node))
gnu_ret_val = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_ret_val);
@@ -2481,19 +2528,20 @@ tree_transform (gnat_node)
/* We have two cases: either the function returns with
depressed stack or not. If not, we allocate on the
- secondary stack. If so, we allocate in the stack frame.
+ secondary stack. If so, we allocate in the stack frame.
if no copy is needed, the front end will set By_Ref,
which we handle in the case above. */
if (TYPE_RETURNS_STACK_DEPRESSED (gnu_subprog_type))
gnu_ret_val
= build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
- TREE_TYPE (gnu_subprog_type), 0, -1);
+ TREE_TYPE (gnu_subprog_type), 0, -1,
+ gnat_node);
else
gnu_ret_val
= build_allocator (TREE_TYPE (gnu_ret_val), gnu_ret_val,
TREE_TYPE (gnu_subprog_type),
Procedure_To_Call (gnat_node),
- Storage_Pool (gnat_node));
+ Storage_Pool (gnat_node), gnat_node);
}
}
@@ -2577,7 +2625,7 @@ tree_transform (gnat_node)
tree gnu_subprog_type;
tree gnu_cico_list;
- /* If this is a generic object or if it has been eliminated,
+ /* If this is a generic object or if it has been eliminated,
ignore it. */
if (Ekind (gnat_subprog_id) == E_Generic_Procedure
@@ -2587,9 +2635,9 @@ tree_transform (gnat_node)
/* If debug information is suppressed for the subprogram,
turn debug mode off for the duration of processing. */
- if (Debug_Info_Off (gnat_subprog_id))
+ if (!Needs_Debug_Info (gnat_subprog_id))
{
- write_symbols = NO_DEBUG;
+ write_symbols = NO_DEBUG;
debug_hooks = &do_nothing_debug_hooks;
}
@@ -2601,20 +2649,29 @@ tree_transform (gnat_node)
a freeze node, so this test is safe, though it does disable
some otherwise-useful error checking. */
gnu_subprog_decl
- = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
+ = gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE,
Acts_As_Spec (gnat_node)
&& ! present_gnu_tree (gnat_subprog_id));
gnu_subprog_type = TREE_TYPE (gnu_subprog_decl);
/* Set the line number in the decl to correspond to that of
- the body so that the line number notes are written
+ the body so that the line number notes are written
correctly. */
set_lineno (gnat_node, 0);
DECL_SOURCE_LOCATION (gnu_subprog_decl) = input_location;
begin_subprog_body (gnu_subprog_decl);
- set_lineno (gnat_node, 1);
+
+ /* There used to be a second call to set_lineno here, with
+ write_note_p set, but begin_subprog_body actually already emits the
+ note we want (via init_function_start).
+
+ Emitting a second note here was necessary for -ftest-coverage with
+ GCC 2.8.1, as the first one was skipped by branch_prob. This is no
+ longer the case with GCC 3.x, so emitting a second note here would
+ result in having the first line of the subprogram counted twice by
+ gcov. */
pushlevel (0);
gnu_block_stack = tree_cons (NULL_TREE, NULL_TREE, gnu_block_stack);
@@ -2630,7 +2687,7 @@ tree_transform (gnat_node)
if (gnu_cico_list != 0)
{
gnu_return_label_stack
- = tree_cons (NULL_TREE,
+ = tree_cons (NULL_TREE,
build_decl (LABEL_DECL, NULL_TREE, NULL_TREE),
gnu_return_label_stack);
pushlevel (0);
@@ -2672,7 +2729,7 @@ tree_transform (gnat_node)
will be present and any OUT parameters will be handled there. */
gnat_to_code (Handled_Statement_Sequence (gnat_node));
- expand_end_bindings (getdecls (), kept_level_p (), 0);
+ expand_end_bindings (getdecls (), kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
gnu_block_stack = TREE_CHAIN (gnu_block_stack);
@@ -2680,7 +2737,7 @@ tree_transform (gnat_node)
{
tree gnu_retval;
- expand_end_bindings (NULL_TREE, kept_level_p (), 0);
+ expand_end_bindings (NULL_TREE, kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
expand_label (TREE_VALUE (gnu_return_label_stack));
@@ -2744,21 +2801,21 @@ tree_transform (gnat_node)
tree gnu_after_list = NULL_TREE;
tree gnu_subprog_call;
- switch (Nkind (Name (gnat_node)))
+ switch (Nkind (Name (gnat_node)))
{
case N_Identifier:
case N_Operator_Symbol:
case N_Expanded_Name:
case N_Attribute_Reference:
if (Is_Eliminated (Entity (Name (gnat_node))))
- post_error_ne ("cannot call eliminated subprogram &!",
+ post_error_ne ("cannot call eliminated subprogram &!",
gnat_node, Entity (Name (gnat_node)));
}
if (TREE_CODE (gnu_subprog_type) != FUNCTION_TYPE)
gigi_abort (317);
- /* If we are calling a stubbed function, make this into a
+ /* If we are calling a stubbed function, make this into a
raise of Program_Error. Elaborate all our args first. */
if (TREE_CODE (gnu_subprog_node) == FUNCTION_DECL
@@ -2797,7 +2854,8 @@ tree_transform (gnat_node)
/* Create the list of the actual parameters as GCC expects it, namely
a chain of TREE_LIST nodes in which the TREE_VALUE field of each
node is a parameter-expression and the TREE_PURPOSE field is
- null. Skip OUT parameters that are not passed by reference. */
+ null. Skip OUT parameters that are not passed by reference and
+ don't need to be copied in. */
for (gnat_actual = First_Actual (gnat_node);
Present (gnat_actual);
@@ -2805,18 +2863,24 @@ tree_transform (gnat_node)
gnat_actual = Next_Actual (gnat_actual))
{
tree gnu_formal_type = gnat_to_gnu_type (Etype (gnat_formal));
+ /* We treat a conversion between aggregate types as if it
+ is an unchecked conversion. */
+ int unchecked_convert_p
+ = (Nkind (gnat_actual) == N_Unchecked_Type_Conversion
+ || (Nkind (gnat_actual) == N_Type_Conversion
+ && Is_Composite_Type (Underlying_Type
+ (Etype (gnat_formal)))));
Node_Id gnat_name
- = ((Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
- ? Expression (gnat_actual) : gnat_actual);
+ = unchecked_convert_p ? Expression (gnat_actual) : gnat_actual;
tree gnu_name = gnat_to_gnu (gnat_name);
tree gnu_name_type = gnat_to_gnu_type (Etype (gnat_name));
tree gnu_actual;
/* If it's possible we may need to use this expression twice,
- make sure than any side-effects are handled via SAVE_EXPRs.
- Likewise if we need to force side-effects before the call.
+ make sure than any side-effects are handled via SAVE_EXPRs.
+ Likewise if we need to force side-effects before the call.
??? This is more conservative than we need since we don't
- need to do this for pass-by-ref with no conversion.
+ need to do this for pass-by-ref with no conversion.
If we are passing a non-addressable Out or In Out parameter by
reference, pass the address of a copy and set up to copy back
out after the call. */
@@ -2827,17 +2891,23 @@ tree_transform (gnat_node)
if (! addressable_p (gnu_name)
&& present_gnu_tree (gnat_formal)
&& (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
- || DECL_BY_COMPONENT_PTR_P (get_gnu_tree (gnat_formal))
- || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal))))
+ || (TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
+ && (DECL_BY_COMPONENT_PTR_P
+ (get_gnu_tree (gnat_formal))
+ || DECL_BY_DESCRIPTOR_P
+ (get_gnu_tree (gnat_formal))))))
{
tree gnu_copy = gnu_name;
+ tree gnu_temp;
- /* Remove any unpadding on the actual and make a copy.
+ /* Remove any unpadding on the actual and make a copy.
But if the actual is a left-justified modular type,
first convert to it. */
if (TREE_CODE (gnu_name) == COMPONENT_REF
- && (TYPE_IS_PADDING_P
- (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))))
+ && ((TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_name, 0)))
+ == RECORD_TYPE)
+ && (TYPE_IS_PADDING_P
+ (TREE_TYPE (TREE_OPERAND (gnu_name, 0))))))
gnu_name = gnu_copy = TREE_OPERAND (gnu_name, 0);
else if (TREE_CODE (gnu_name_type) == RECORD_TYPE
&& (TYPE_LEFT_JUSTIFIED_MODULAR_P
@@ -2846,6 +2916,16 @@ tree_transform (gnat_node)
gnu_actual = save_expr (gnu_name);
+ /* Since we're going to take the address of the SAVE_EXPR,
+ we don't want it to be marked as unchanging.
+ So set TREE_ADDRESSABLE. */
+ gnu_temp = skip_simple_arithmetic (gnu_actual);
+ if (TREE_CODE (gnu_temp) == SAVE_EXPR)
+ {
+ TREE_ADDRESSABLE (gnu_temp) = 1;
+ TREE_READONLY (gnu_temp) = 0;
+ }
+
/* Set up to move the copy back to the original. */
gnu_after_list = tree_cons (gnu_copy, gnu_actual,
gnu_after_list);
@@ -2865,18 +2945,21 @@ tree_transform (gnat_node)
gnu_actual);
if (Ekind (gnat_formal) != E_Out_Parameter
- && Nkind (gnat_actual) != N_Unchecked_Type_Conversion
+ && ! unchecked_convert_p
&& Do_Range_Check (gnat_actual))
gnu_actual = emit_range_check (gnu_actual, Etype (gnat_formal));
/* Do any needed conversions. We need only check for
unchecked conversion since normal conversions will be handled
by just converting to the formal type. */
- if (Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
+ if (unchecked_convert_p)
{
gnu_actual
= unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
- gnu_actual);
+ gnu_actual,
+ (Nkind (gnat_actual)
+ == N_Unchecked_Type_Conversion)
+ && No_Truncation (gnat_actual));
/* One we've done the unchecked conversion, we still
must ensure that the object is in range of the formal's
@@ -2886,18 +2969,20 @@ tree_transform (gnat_node)
gnu_actual = emit_range_check (gnu_actual,
Etype (gnat_formal));
}
- else
+ else if (TREE_CODE (gnu_actual) != SAVE_EXPR)
/* We may have suppressed a conversion to the Etype of the
actual since the parent is a procedure call. So add the
conversion here. */
gnu_actual = convert (gnat_to_gnu_type (Etype (gnat_actual)),
gnu_actual);
- gnu_actual = convert (gnu_formal_type, gnu_actual);
+ if (TREE_CODE (gnu_actual) != SAVE_EXPR)
+ gnu_actual = convert (gnu_formal_type, gnu_actual);
- /* If we have not saved a GCC object for the formal, it means
- it is an OUT parameter not passed by reference. Otherwise,
- look at the PARM_DECL to see if it is passed by reference. */
+ /* If we have not saved a GCC object for the formal, it means it
+ is an OUT parameter not passed by reference and that does not
+ need to be copied in. Otherwise, look at the PARM_DECL to see
+ if it is passed by reference. */
if (present_gnu_tree (gnat_formal)
&& TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
&& DECL_BY_REF_P (get_gnu_tree (gnat_formal)))
@@ -2909,7 +2994,8 @@ tree_transform (gnat_node)
/* If we have a padded type, be sure we've removed the
padding. */
if (TREE_CODE (TREE_TYPE (gnu_actual)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual)))
+ && TYPE_IS_PADDING_P (TREE_TYPE (gnu_actual))
+ && TREE_CODE (gnu_actual) != SAVE_EXPR)
gnu_actual
= convert (get_unpadded_type (Etype (gnat_actual)),
gnu_actual);
@@ -2940,7 +3026,7 @@ tree_transform (gnat_node)
/* Take the address of the object and convert to the
proper pointer type. We'd like to actually compute
- the address of the beginning of the array using
+ the address of the beginning of the array using
an ADDR_EXPR of an ARRAY_REF, but there's a possibility
that the ARRAY_REF might return a constant and we'd
be getting the wrong address. Neither approach is
@@ -2985,14 +3071,14 @@ tree_transform (gnat_node)
else if (TREE_CODE (gnu_actual) == INDIRECT_REF
&& TREE_PRIVATE (gnu_actual)
&& host_integerp (gnu_actual_size, 1)
- && 0 >= compare_tree_int (gnu_actual_size,
+ && 0 >= compare_tree_int (gnu_actual_size,
BITS_PER_WORD))
gnu_actual
= unchecked_convert
(DECL_ARG_TYPE (get_gnu_tree (gnat_formal)),
convert (gnat_type_for_size
(tree_low_cst (gnu_actual_size, 1), 1),
- integer_zero_node));
+ integer_zero_node), 0);
else
gnu_actual
= convert (TYPE_MAIN_VARIANT
@@ -3066,9 +3152,12 @@ tree_transform (gnat_node)
if (! (present_gnu_tree (gnat_formal)
&& TREE_CODE (get_gnu_tree (gnat_formal)) == PARM_DECL
&& (DECL_BY_REF_P (get_gnu_tree (gnat_formal))
- || (DECL_BY_COMPONENT_PTR_P
- (get_gnu_tree (gnat_formal)))
- || DECL_BY_DESCRIPTOR_P (get_gnu_tree (gnat_formal))))
+ || ((TREE_CODE (get_gnu_tree (gnat_formal))
+ == PARM_DECL)
+ && ((DECL_BY_COMPONENT_PTR_P
+ (get_gnu_tree (gnat_formal))
+ || (DECL_BY_DESCRIPTOR_P
+ (get_gnu_tree (gnat_formal))))))))
&& Ekind (gnat_formal) != E_In_Parameter)
{
/* Get the value to assign to this OUT or IN OUT
@@ -3107,7 +3196,8 @@ tree_transform (gnat_node)
else if (unchecked_conversion)
gnu_result
- = unchecked_convert (TREE_TYPE (gnu_actual), gnu_result);
+ = unchecked_convert (TREE_TYPE (gnu_actual), gnu_result,
+ No_Truncation (gnat_actual));
else
{
if (Do_Range_Check (gnat_actual))
@@ -3300,207 +3390,198 @@ tree_transform (gnat_node)
SJLJ case, it seems cleaner to reorder things for the SJLJ case and
generalize the condition to make it not ZCX specific. */
- /* Tell the back-end we are starting a new exception region if
- necessary. */
+ /* If there is an At_End procedure attached to this node, and the eh
+ mechanism is GNAT oriented (SJLJ or ZCX with front end tables), we
+ must have at least a corresponding At_End handler, unless the
+ No_Exception_Handlers restriction is set. */
if (! type_annotate_only
- && Exception_Mechanism == GCC_ZCX
- && Present (Exception_Handlers (gnat_node)))
- expand_eh_region_start ();
-
- /* If there are exception handlers, start a new binding level that
- we can exit (since each exception handler will do so). Then
- declare a variable to save the old __gnat_jmpbuf value and a
- variable for our jmpbuf. Call setjmp and handle each of the
- possible exceptions if it returns one. */
+ && Exception_Mechanism != GCC_ZCX
+ && Present (At_End_Proc (gnat_node))
+ && ! Present (Exception_Handlers (gnat_node))
+ && ! No_Exception_Handlers_Set())
+ gigi_abort (335);
- if (! type_annotate_only && Present (Exception_Handlers (gnat_node)))
- {
- tree gnu_jmpsave_decl = 0;
- tree gnu_jmpbuf_decl = 0;
- tree gnu_cleanup_call = 0;
- tree gnu_cleanup_decl;
-
- pushlevel (0);
- expand_start_bindings (1);
-
- if (Exception_Mechanism == Setjmp_Longjmp)
- {
- gnu_jmpsave_decl
- = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
- jmpbuf_ptr_type,
- build_call_0_expr (get_jmpbuf_decl),
- 0, 0, 0, 0, 0);
-
- gnu_jmpbuf_decl = create_var_decl (get_identifier ("JMP_BUF"),
- NULL_TREE, jmpbuf_type,
- NULL_TREE, 0, 0, 0, 0,
- 0);
- TREE_VALUE (gnu_block_stack) = gnu_jmpbuf_decl;
- }
+ {
+ /* Need a binding level that we can exit for this sequence if there is
+ at least one exception handler for this block (since each handler
+ needs an identified exit point) or there is an At_End procedure
+ attached to this node (in order to have an attachment point for a
+ GCC cleanup). */
+ bool exitable_binding_for_block
+ = (! type_annotate_only
+ && (Present (Exception_Handlers (gnat_node))
+ || Present (At_End_Proc (gnat_node))));
+
+ /* Make a binding level that we can exit if we need one. */
+ if (exitable_binding_for_block)
+ {
+ pushlevel (0);
+ expand_start_bindings (1);
+ }
- /* See if we are to call a function when exiting this block. */
- if (Present (At_End_Proc (gnat_node)))
- {
- gnu_cleanup_call
- = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node)));
+ /* If we are to call a function when exiting this block, expand a GCC
+ cleanup to take care. We have made a binding level for this cleanup
+ above. */
+ if (Present (At_End_Proc (gnat_node)))
+ {
+ tree gnu_cleanup_call
+ = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node)));
- gnu_cleanup_decl
- = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE,
- integer_type_node, NULL_TREE, 0, 0, 0, 0,
- 0);
+ tree gnu_cleanup_decl
+ = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE,
+ integer_type_node, NULL_TREE, 0, 0, 0, 0,
+ 0);
- expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call);
- }
+ expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call);
+ }
- if (Exception_Mechanism == Setjmp_Longjmp)
- {
- /* When we exit this block, restore the saved value. */
- expand_decl_cleanup (gnu_jmpsave_decl,
- build_call_1_expr (set_jmpbuf_decl,
- gnu_jmpsave_decl));
-
- /* Call setjmp and handle exceptions if it returns one. */
- set_lineno (gnat_node, 1);
- expand_start_cond
- (build_call_1_expr (setjmp_decl,
- build_unary_op (ADDR_EXPR, NULL_TREE,
- gnu_jmpbuf_decl)),
- 0);
-
- /* Restore our incoming longjmp value before we do anything. */
- expand_expr_stmt (build_call_1_expr (set_jmpbuf_decl,
- gnu_jmpsave_decl));
-
- pushlevel (0);
- expand_start_bindings (0);
-
- gnu_except_ptr_stack
- = tree_cons (NULL_TREE,
- create_var_decl
- (get_identifier ("EXCEPT_PTR"), NULL_TREE,
- build_pointer_type (except_type_node),
- build_call_0_expr (get_excptr_decl),
- 0, 0, 0, 0, 0),
- gnu_except_ptr_stack);
-
- /* Generate code for each exception handler. The code at
- N_Exception_Handler below does the real work. Note that
- we ignore the dummy exception handler for the identifier
- case, this is used only by the front end */
- if (Present (Exception_Handlers (gnat_node)))
- for (gnat_temp
- = First_Non_Pragma (Exception_Handlers (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next_Non_Pragma (gnat_temp))
- gnat_to_code (gnat_temp);
-
- /* If none of the exception handlers did anything, re-raise
- but do not defer abortion. */
- set_lineno (gnat_node, 1);
- expand_expr_stmt
- (build_call_1_expr (raise_nodefer_decl,
- TREE_VALUE (gnu_except_ptr_stack)));
+ /* Now we generate the code for this block, with a different layout
+ for GNAT SJLJ and for GCC or front end ZCX. The handlers come first
+ in the GNAT SJLJ case, while they come after the handled sequence
+ in the other cases. */
- gnu_except_ptr_stack = TREE_CHAIN (gnu_except_ptr_stack);
- expand_end_bindings (getdecls (), kept_level_p (), 0);
- poplevel (kept_level_p (), 1, 0);
+ /* First deal with possible handlers for the GNAT SJLJ scheme. */
+ if (! type_annotate_only
+ && Exception_Mechanism == Setjmp_Longjmp
+ && Present (Exception_Handlers (gnat_node)))
+ {
+ /* We already have a fresh binding level at hand. Declare a
+ variable to save the old __gnat_jmpbuf value and a variable for
+ our jmpbuf. Call setjmp and handle each of the possible
+ exceptions if it returns one. */
+
+ tree gnu_jmpsave_decl
+ = create_var_decl (get_identifier ("JMPBUF_SAVE"), NULL_TREE,
+ jmpbuf_ptr_type,
+ build_call_0_expr (get_jmpbuf_decl),
+ 0, 0, 0, 0, 0);
+
+ tree gnu_jmpbuf_decl
+ = create_var_decl (get_identifier ("JMP_BUF"),
+ NULL_TREE, jmpbuf_type,
+ NULL_TREE, 0, 0, 0, 0,
+ 0);
+
+ TREE_VALUE (gnu_block_stack) = gnu_jmpbuf_decl;
+
+ /* When we exit this block, restore the saved value. */
+ expand_decl_cleanup (gnu_jmpsave_decl,
+ build_call_1_expr (set_jmpbuf_decl,
+ gnu_jmpsave_decl));
+
+ /* Call setjmp and handle exceptions if it returns one. */
+ set_lineno (gnat_node, 1);
+ expand_start_cond
+ (build_call_1_expr (setjmp_decl,
+ build_unary_op (ADDR_EXPR, NULL_TREE,
+ gnu_jmpbuf_decl)),
+ 0);
+
+ /* Restore our incoming longjmp value before we do anything. */
+ expand_expr_stmt
+ (build_call_1_expr (set_jmpbuf_decl, gnu_jmpsave_decl));
+
+ /* Make a binding level for the exception handling declarations
+ and code. Don't assign it an exit label, since this is the
+ outer block we want to exit at the end of each handler. */
+ pushlevel (0);
+ expand_start_bindings (0);
- /* End the "if" on setjmp. Note that we have arranged things so
- control never returns here. */
- expand_end_cond ();
+ gnu_except_ptr_stack
+ = tree_cons (NULL_TREE,
+ create_var_decl
+ (get_identifier ("EXCEPT_PTR"), NULL_TREE,
+ build_pointer_type (except_type_node),
+ build_call_0_expr (get_excptr_decl),
+ 0, 0, 0, 0, 0),
+ gnu_except_ptr_stack);
+
+ /* Generate code for each handler. The N_Exception_Handler case
+ below does the real work. We ignore the dummy exception handler
+ for the identifier case, as this is used only by the front
+ end. */
+ for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
+ Present (gnat_temp);
+ gnat_temp = Next_Non_Pragma (gnat_temp))
+ gnat_to_code (gnat_temp);
- /* This is now immediately before the body proper. Set
- our jmp_buf as the current buffer. */
- expand_expr_stmt
- (build_call_1_expr (set_jmpbuf_decl,
- build_unary_op (ADDR_EXPR, NULL_TREE,
- gnu_jmpbuf_decl)));
- }
- }
+ /* If none of the exception handlers did anything, re-raise
+ but do not defer abortion. */
+ set_lineno (gnat_node, 1);
+ expand_expr_stmt
+ (build_call_1_expr (raise_nodefer_decl,
+ TREE_VALUE (gnu_except_ptr_stack)));
- /* If there are no exception handlers, we must not have an at end
- cleanup identifier, since the cleanup identifier should always
- generate a corresponding exception handler, except in the case
- of the No_Exception_Handlers restriction, where the front-end
- does not generate exception handlers. */
- else if (! type_annotate_only && Present (At_End_Proc (gnat_node)))
- {
- if (No_Exception_Handlers_Set ())
- {
- tree gnu_cleanup_call = 0;
- tree gnu_cleanup_decl;
+ gnu_except_ptr_stack = TREE_CHAIN (gnu_except_ptr_stack);
- gnu_cleanup_call
- = build_call_0_expr (gnat_to_gnu (At_End_Proc (gnat_node)));
+ /* End the binding level dedicated to the exception handlers. */
+ expand_end_bindings (getdecls (), kept_level_p (), -1);
+ poplevel (kept_level_p (), 1, 0);
- gnu_cleanup_decl
- = create_var_decl (get_identifier ("CLEANUP"), NULL_TREE,
- integer_type_node, NULL_TREE, 0, 0, 0, 0,
- 0);
+ /* End the "if" on setjmp. Note that we have arranged things so
+ control never returns here. */
+ expand_end_cond ();
- expand_decl_cleanup (gnu_cleanup_decl, gnu_cleanup_call);
- }
- else
- gigi_abort (335);
- }
+ /* This is now immediately before the body proper. Set our jmp_buf
+ as the current buffer. */
+ expand_expr_stmt
+ (build_call_1_expr (set_jmpbuf_decl,
+ build_unary_op (ADDR_EXPR, NULL_TREE,
+ gnu_jmpbuf_decl)));
+ }
- /* Generate code and declarations for the prefix of this block,
- if any. */
- if (Present (First_Real_Statement (gnat_node)))
- process_decls (Statements (gnat_node), Empty,
- First_Real_Statement (gnat_node), 1, 1);
-
- /* Generate code for each statement in the block. */
- for (gnat_temp = (Present (First_Real_Statement (gnat_node))
- ? First_Real_Statement (gnat_node)
- : First (Statements (gnat_node)));
- Present (gnat_temp); gnat_temp = Next (gnat_temp))
- gnat_to_code (gnat_temp);
+ /* Now comes the processing for the sequence body. */
+
+ /* If we use the back-end eh support, tell the back-end we are
+ starting a new exception region. */
+ if (! type_annotate_only
+ && Exception_Mechanism == GCC_ZCX
+ && Present (Exception_Handlers (gnat_node)))
+ expand_eh_region_start ();
+
+ /* Generate code and declarations for the prefix of this block,
+ if any. */
+ if (Present (First_Real_Statement (gnat_node)))
+ process_decls (Statements (gnat_node), Empty,
+ First_Real_Statement (gnat_node), 1, 1);
+
+ /* Generate code for each statement in the block. */
+ for (gnat_temp = (Present (First_Real_Statement (gnat_node))
+ ? First_Real_Statement (gnat_node)
+ : First (Statements (gnat_node)));
+ Present (gnat_temp);
+ gnat_temp = Next (gnat_temp))
+ gnat_to_code (gnat_temp);
- /* Tell the back-end we are ending the new exception region and
- starting the associated handlers. */
- if (! type_annotate_only
- && Exception_Mechanism == GCC_ZCX
- && Present (Exception_Handlers (gnat_node)))
- expand_start_all_catch ();
-
- /* For zero-cost exceptions, exit the block and then compile
- the handlers. */
- if (! type_annotate_only
- && Exception_Mechanism == GCC_ZCX
- && Present (Exception_Handlers (gnat_node)))
- {
+ /* Exit the binding level we made, if any. */
+ if (exitable_binding_for_block)
expand_exit_something ();
- for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next_Non_Pragma (gnat_temp))
- gnat_to_code (gnat_temp);
- }
- /* We don't support Front_End_ZCX in GNAT 5.0, but we don't want to
- crash if -gnatdX is specified. */
- if (! type_annotate_only
- && Exception_Mechanism == Front_End_ZCX
- && Present (Exception_Handlers (gnat_node)))
- {
- for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
- Present (gnat_temp);
- gnat_temp = Next_Non_Pragma (gnat_temp))
- gnat_to_code (gnat_temp);
- }
+ /* Compile the handlers for front end ZCX or back-end supported
+ exceptions. */
+ if (! type_annotate_only
+ && Exception_Mechanism != Setjmp_Longjmp
+ && Present (Exception_Handlers (gnat_node)))
+ {
+ if (Exception_Mechanism == GCC_ZCX)
+ expand_start_all_catch ();
- /* Tell the backend when we are done with the handlers. */
- if (! type_annotate_only
- && Exception_Mechanism == GCC_ZCX
- && Present (Exception_Handlers (gnat_node)))
- expand_end_all_catch ();
+ for (gnat_temp = First_Non_Pragma (Exception_Handlers (gnat_node));
+ Present (gnat_temp);
+ gnat_temp = Next_Non_Pragma (gnat_temp))
+ gnat_to_code (gnat_temp);
- /* If we have handlers, close the block we made. */
- if (! type_annotate_only && Present (Exception_Handlers (gnat_node)))
- {
- expand_end_bindings (getdecls (), kept_level_p (), 0);
- poplevel (kept_level_p (), 1, 0);
- }
+ if (Exception_Mechanism == GCC_ZCX)
+ expand_end_all_catch ();
+ }
+
+ /* Close the binding level we made, if any. */
+ if (exitable_binding_for_block)
+ {
+ expand_end_bindings (getdecls (), kept_level_p (), -1);
+ poplevel (kept_level_p (), 1, 0);
+ }
+ }
break;
@@ -3540,11 +3621,17 @@ tree_transform (gnat_node)
else if (Nkind (gnat_temp) == N_Identifier
|| Nkind (gnat_temp) == N_Expanded_Name)
{
+ Entity_Id gnat_ex_id = Entity (gnat_temp);
+
+ /* Exception may be a renaming. Recover original exception
+ which is the one elaborated and registered. */
+ if (Present (Renamed_Object (gnat_ex_id)))
+ gnat_ex_id = Renamed_Object (gnat_ex_id);
+
/* ??? Note that we have to use gnat_to_gnu_entity here
since the type of the exception will be wrong in the
VMS case and that's exactly what this test is for. */
- gnu_expr
- = gnat_to_gnu_entity (Entity (gnat_temp), NULL_TREE, 0);
+ gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
/* If this was a VMS exception, check import_code
against the value of the exception. */
@@ -3560,11 +3647,11 @@ tree_transform (gnat_node)
gnu_expr);
else
this_choice
- = build_binary_op
+ = build_binary_op
(EQ_EXPR, integer_type_node,
TREE_VALUE (gnu_except_ptr_stack),
convert
- (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
+ (TREE_TYPE (TREE_VALUE (gnu_except_ptr_stack)),
build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr)));
/* If this is the distinguished exception "Non_Ada_Error"
@@ -3621,64 +3708,107 @@ tree_transform (gnat_node)
Care should be taken to ensure that the control flow impact of
such clauses is rendered in some way. lang_eh_type_covers is
- doing the trick currently.
-
- ??? Should investigate the possible usage of the end_cleanup
- interface in this context. */
+ doing the trick currently. */
tree gnu_expr, gnu_etype;
tree gnu_etypes_list = NULL_TREE;
for (gnat_temp = First (Exception_Choices (gnat_node));
gnat_temp; gnat_temp = Next (gnat_temp))
- {
+ {
if (Nkind (gnat_temp) == N_Others_Choice)
gnu_etype
= All_Others (gnat_temp) ? integer_one_node
- : integer_zero_node;
+ : integer_zero_node;
else if (Nkind (gnat_temp) == N_Identifier
|| Nkind (gnat_temp) == N_Expanded_Name)
{
- gnu_expr = gnat_to_gnu_entity (Entity (gnat_temp),
- NULL_TREE, 0);
- gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
+ Entity_Id gnat_ex_id = Entity (gnat_temp);
+
+ /* Exception may be a renaming. Recover original exception
+ which is the one elaborated and registered. */
+ if (Present (Renamed_Object (gnat_ex_id)))
+ gnat_ex_id = Renamed_Object (gnat_ex_id);
+
+ gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
+
+ gnu_etype
+ = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
}
else
gigi_abort (337);
- gnu_etypes_list
- = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
-
/* The GCC interface expects NULL to be passed for catch all
- handlers, so the approach below is quite tempting :
-
- if (gnu_etype == integer_zero_node)
- gnu_etypes_list = NULL;
-
- It would not work, however, because GCC's notion
- of "catch all" is stronger than our notion of "others".
+ handlers, so it would be quite tempting to set gnu_etypes_list
+ to NULL if gnu_etype is integer_zero_node. It would not work,
+ however, because GCC's notion of "catch all" is stronger than
+ our notion of "others". Until we correctly use the cleanup
+ interface as well, the doing tht would prevent the "all
+ others" handlers from beeing seen, because nothing can be
+ caught beyond a catch all from GCC's point of view. */
+ gnu_etypes_list
+ = tree_cons (NULL_TREE, gnu_etype, gnu_etypes_list);
- Until we correctly use the cleanup interface as well, the
- two lines above will prevent the "all others" handlers from
- beeing seen, because nothing can be caught beyond a catch
- all from GCC's point of view. */
}
expand_start_catch (gnu_etypes_list);
+
+ pushlevel (0);
+ expand_start_bindings (0);
+
+ {
+ /* Expand a call to the begin_handler hook at the beginning of the
+ handler, and arrange for a call to the end_handler hook to
+ occur on every possible exit path.
+
+ The hooks expect a pointer to the low level occurrence. This
+ is required for our stack management scheme because a raise
+ inside the handler pushes a new occurrence on top of the
+ stack, which means that this top does not necessarily match
+ the occurrence this handler was dealing with.
+
+ The EXC_PTR_EXPR object references the exception occurrence
+ beeing propagated. Upon handler entry, this is the exception
+ for which the handler is triggered. This might not be the case
+ upon handler exit, however, as we might have a new occurrence
+ propagated by the handler's body, and the end_handler hook
+ called as a cleanup in this context.
+
+ We use a local variable to retrieve the incoming value at
+ handler entry time, and reuse it to feed the end_handler
+ hook's argument at exit time. */
+ tree gnu_current_exc_ptr
+ = build (EXC_PTR_EXPR, ptr_type_node);
+ tree gnu_incoming_exc_ptr
+ = create_var_decl (get_identifier ("EXPTR"), NULL_TREE,
+ ptr_type_node, gnu_current_exc_ptr,
+ 0, 0, 0, 0, 0);
+
+ expand_expr_stmt
+ (build_call_1_expr (begin_handler_decl, gnu_incoming_exc_ptr));
+ expand_decl_cleanup
+ (0, build_call_1_expr (end_handler_decl, gnu_incoming_exc_ptr));
+ }
}
for (gnat_temp = First (Statements (gnat_node));
gnat_temp; gnat_temp = Next (gnat_temp))
gnat_to_code (gnat_temp);
- /* At the end of the handler, exit the block. We made this block
- in N_Handled_Sequence_Of_Statements. */
- expand_exit_something ();
-
- /* Tell the back end that we're done with the current handler. */
if (Exception_Mechanism == GCC_ZCX)
- expand_end_catch ();
- else if (Exception_Mechanism == Setjmp_Longjmp)
+ {
+ /* Tell the back end that we're done with the current handler. */
+ expand_end_bindings (getdecls (), kept_level_p (), -1);
+ poplevel (kept_level_p (), 1, 0);
+
+ expand_end_catch ();
+ }
+ else
+ /* At the end of the handler, exit the block. We made this block in
+ N_Handled_Sequence_Of_Statements. */
+ expand_exit_something ();
+
+ if (Exception_Mechanism == Setjmp_Longjmp)
expand_end_cond ();
break;
@@ -3742,7 +3872,7 @@ tree_transform (gnat_node)
tree gnu_constr = build_tree_list (NULL_TREE, gnat_to_gnu
(Asm_Input_Constraint ()));
- gnu_input_list
+ gnu_input_list
= tree_cons (gnu_constr, gnu_value, gnu_input_list);
Next_Asm_Input ();
}
@@ -3764,7 +3894,7 @@ tree_transform (gnat_node)
Clobber_Setup (gnat_node);
while ((clobber = Clobber_Get_Next ()) != 0)
gnu_clobber_list
- = tree_cons (NULL_TREE,
+ = tree_cons (NULL_TREE,
build_string (strlen (clobber) + 1, clobber),
gnu_clobber_list);
@@ -3845,7 +3975,7 @@ tree_transform (gnat_node)
expand_expr_stmt
(build_call_alloc_dealloc (gnu_ptr, gnu_obj_size, align,
Procedure_To_Call (gnat_node),
- Storage_Pool (gnat_node)));
+ Storage_Pool (gnat_node), gnat_node));
}
break;
@@ -3859,7 +3989,7 @@ tree_transform (gnat_node)
gnu_result_type = get_unpadded_type (Etype (gnat_node));
gnu_result = build_call_raise (UI_To_Int (Reason (gnat_node)));
- /* If the type is VOID, this is a statement, so we need to
+ /* If the type is VOID, this is a statement, so we need to
generate the code for the call. Handle a Condition, if there
is one. */
if (TREE_CODE (gnu_result_type) == VOID_TYPE)
@@ -3910,8 +4040,7 @@ tree_transform (gnat_node)
once. Note we must do this before any conversions. */
if (TREE_SIDE_EFFECTS (gnu_result)
&& (TREE_CODE (gnu_result_type) == UNCONSTRAINED_ARRAY_TYPE
- || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
- && contains_placeholder_p (TYPE_SIZE (gnu_result_type)))))
+ || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))))
gnu_result = gnat_stabilize_reference (gnu_result, 0);
/* Now convert the result to the proper type. If the type is void or if
@@ -3952,10 +4081,8 @@ tree_transform (gnat_node)
&& (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
!= INTEGER_CST))
|| (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
- && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
- != INTEGER_CST)
- && ! (contains_placeholder_p (TYPE_SIZE (gnu_result_type)))
- && (contains_placeholder_p
+ && ! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
+ && (CONTAINS_PLACEHOLDER_P
(TYPE_SIZE (TREE_TYPE (gnu_result))))))
&& ! (TREE_CODE (gnu_result_type) == RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_result_type))))
@@ -3966,7 +4093,7 @@ tree_transform (gnat_node)
we want to avoid copying too much data. */
if (TREE_CODE (TREE_TYPE (gnu_result)) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (gnu_result))
- && contains_placeholder_p (TYPE_SIZE
+ && CONTAINS_PLACEHOLDER_P (TYPE_SIZE
(TREE_TYPE (TYPE_FIELDS
(TREE_TYPE (gnu_result))))))
gnu_result = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_result))),
@@ -3979,7 +4106,7 @@ tree_transform (gnat_node)
|| (TYPE_SIZE (gnu_result_type) != 0
&& TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
&& TREE_CODE (gnu_result) != INDIRECT_REF
- && contains_placeholder_p (TYPE_SIZE (gnu_result_type)))
+ && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type)))
|| ((TYPE_NAME (gnu_result_type)
== TYPE_NAME (TREE_TYPE (gnu_result)))
&& TREE_CODE (gnu_result_type) == RECORD_TYPE
@@ -4023,7 +4150,7 @@ tree_transform (gnat_node)
packages are elaborated on demand, and if clients have different usage
patterns, the normal case, then the order and selection of entities
will differ. In most cases however, it seems that linkers do not know
- how to eliminate duplicate debugging information, even if it is
+ how to eliminate duplicate debugging information, even if it is
identical, so the use of this routine would increase the total amount
of debugging information in the final executable.
@@ -4036,7 +4163,12 @@ elaborate_all_entities (gnat_node)
{
Entity_Id gnat_with_clause, gnat_entity;
- save_gnu_tree (gnat_node, integer_zero_node, 1);
+ /* Process each unit only once. As we trace the context of all relevant
+ units transitively, including generic bodies, we may encounter the
+ same generic unit repeatedly */
+
+ if (!present_gnu_tree (gnat_node))
+ save_gnu_tree (gnat_node, integer_zero_node, 1);
/* Save entities in all context units. A body may have an implicit_with
on its own spec, if the context includes a child unit, so don't save
@@ -4052,22 +4184,38 @@ elaborate_all_entities (gnat_node)
elaborate_all_entities (Library_Unit (gnat_with_clause));
if (Ekind (Entity (Name (gnat_with_clause))) == E_Package)
- for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
- Present (gnat_entity);
- gnat_entity = Next_Entity (gnat_entity))
- if (Is_Public (gnat_entity)
- && Convention (gnat_entity) != Convention_Intrinsic
- && Ekind (gnat_entity) != E_Package
- && Ekind (gnat_entity) != E_Package_Body
- && Ekind (gnat_entity) != E_Operator
- && ! (IN (Ekind (gnat_entity), Type_Kind)
- && ! Is_Frozen (gnat_entity))
- && ! ((Ekind (gnat_entity) == E_Procedure
- || Ekind (gnat_entity) == E_Function)
- && Is_Intrinsic_Subprogram (gnat_entity))
- && ! IN (Ekind (gnat_entity), Named_Kind)
- && ! IN (Ekind (gnat_entity), Generic_Unit_Kind))
- gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
+ {
+ for (gnat_entity = First_Entity (Entity (Name (gnat_with_clause)));
+ Present (gnat_entity);
+ gnat_entity = Next_Entity (gnat_entity))
+ if (Is_Public (gnat_entity)
+ && Convention (gnat_entity) != Convention_Intrinsic
+ && Ekind (gnat_entity) != E_Package
+ && Ekind (gnat_entity) != E_Package_Body
+ && Ekind (gnat_entity) != E_Operator
+ && ! (IN (Ekind (gnat_entity), Type_Kind)
+ && ! Is_Frozen (gnat_entity))
+ && ! ((Ekind (gnat_entity) == E_Procedure
+ || Ekind (gnat_entity) == E_Function)
+ && Is_Intrinsic_Subprogram (gnat_entity))
+ && ! IN (Ekind (gnat_entity), Named_Kind)
+ && ! IN (Ekind (gnat_entity), Generic_Unit_Kind))
+ gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
+ }
+ else if (Ekind (Entity (Name (gnat_with_clause))) == E_Generic_Package)
+ {
+ Node_Id gnat_body
+ = Corresponding_Body (Unit (Library_Unit (gnat_with_clause)));
+
+ /* Retrieve compilation unit node of generic body. */
+ while (Present (gnat_body)
+ && Nkind (gnat_body) != N_Compilation_Unit)
+ gnat_body = Parent (gnat_body);
+
+ /* If body is available, elaborate its context. */
+ if (Present (gnat_body))
+ elaborate_all_entities (gnat_body);
+ }
}
if (Nkind (Unit (gnat_node)) == N_Package_Body && type_annotate_only)
@@ -4285,12 +4433,8 @@ process_decls (gnat_decls, gnat_decls2, gnat_end_list, pass1p, pass2p)
record_code_position
(Proper_Body (Unit (Library_Unit (gnat_decl))));
- /* We defer most subprogram bodies to the second pass.
- However, Init_Proc subprograms cannot be defered, but luckily
- don't need to be. */
- else if ((Nkind (gnat_decl) == N_Subprogram_Body
- && (Chars (Defining_Entity (gnat_decl))
- != Name_uInit_Proc)))
+ /* We defer most subprogram bodies to the second pass. */
+ else if (Nkind (gnat_decl) == N_Subprogram_Body)
{
if (Acts_As_Spec (gnat_decl))
{
@@ -4334,9 +4478,7 @@ process_decls (gnat_decls, gnat_decls2, gnat_end_list, pass1p, pass2p)
for (gnat_decl = First (gnat_decl_array[i]);
gnat_decl != gnat_end_list; gnat_decl = Next (gnat_decl))
{
- if ((Nkind (gnat_decl) == N_Subprogram_Body
- && (Chars (Defining_Entity (gnat_decl))
- != Name_uInit_Proc))
+ if (Nkind (gnat_decl) == N_Subprogram_Body
|| Nkind (gnat_decl) == N_Subprogram_Body_Stub
|| Nkind (gnat_decl) == N_Task_Body_Stub
|| Nkind (gnat_decl) == N_Protected_Body_Stub)
@@ -4354,129 +4496,6 @@ process_decls (gnat_decls, gnat_decls2, gnat_end_list, pass1p, pass2p)
}
}
-/* Emits an access check. GNU_EXPR is the expression that needs to be
- checked against the NULL pointer. */
-
-static tree
-emit_access_check (gnu_expr)
- tree gnu_expr;
-{
- tree gnu_check_expr;
-
- /* Checked expressions must be evaluated only once. */
- gnu_check_expr = gnu_expr = protect_multiple_eval (gnu_expr);
-
- /* Technically, we check a fat pointer against two words of zero. However,
- that's wasteful and really doesn't protect against null accesses. It
- makes more sense to check oly the array pointer. */
- if (TYPE_FAT_POINTER_P (TREE_TYPE (gnu_expr)))
- gnu_check_expr
- = build_component_ref (gnu_expr, get_identifier ("P_ARRAY"), NULL_TREE);
-
- if (! POINTER_TYPE_P (TREE_TYPE (gnu_check_expr)))
- gigi_abort (322);
-
- return emit_check (build_binary_op (EQ_EXPR, integer_type_node,
- gnu_check_expr,
- convert (TREE_TYPE (gnu_check_expr),
- integer_zero_node)),
- gnu_expr,
- CE_Access_Check_Failed);
-}
-
-/* Emits a discriminant check. GNU_EXPR is the expression to be checked and
- GNAT_NODE a N_Selected_Component node. */
-
-static tree
-emit_discriminant_check (gnu_expr, gnat_node)
- tree gnu_expr;
- Node_Id gnat_node;
-{
- Entity_Id orig_comp
- = Original_Record_Component (Entity (Selector_Name (gnat_node)));
- Entity_Id gnat_discr_fct = Discriminant_Checking_Func (orig_comp);
- tree gnu_discr_fct;
- Entity_Id gnat_discr;
- tree gnu_actual_list = NULL_TREE;
- tree gnu_cond;
- Entity_Id gnat_pref_type;
- tree gnu_pref_type;
-
- if (Is_Tagged_Type (Scope (orig_comp)))
- gnat_pref_type = Scope (orig_comp);
- else
- {
- gnat_pref_type = Etype (Prefix (gnat_node));
-
- /* For an untagged derived type, use the discriminants of the parent,
- which have been renamed in the derivation, possibly by a one-to-many
- constraint. */
- if (Is_Derived_Type (gnat_pref_type)
- && (Number_Discriminants (gnat_pref_type)
- != Number_Discriminants (Etype (Base_Type (gnat_pref_type)))))
- gnat_pref_type = Etype (Base_Type (gnat_pref_type));
- }
-
- if (! Present (gnat_discr_fct))
- return gnu_expr;
-
- gnu_discr_fct = gnat_to_gnu (gnat_discr_fct);
-
- /* Checked expressions must be evaluated only once. */
- gnu_expr = protect_multiple_eval (gnu_expr);
-
- /* Create the list of the actual parameters as GCC expects it.
- This list is the list of the discriminant fields of the
- record expression to be discriminant checked. For documentation
- on what is the GCC format for this list see under the
- N_Function_Call case */
-
- while (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind)
- || IN (Ekind (gnat_pref_type), Access_Kind))
- {
- if (IN (Ekind (gnat_pref_type), Incomplete_Or_Private_Kind))
- gnat_pref_type = Underlying_Type (gnat_pref_type);
- else if (IN (Ekind (gnat_pref_type), Access_Kind))
- gnat_pref_type = Designated_Type (gnat_pref_type);
- }
-
- gnu_pref_type
- = TREE_TYPE (gnat_to_gnu_entity (gnat_pref_type, NULL_TREE, 0));
-
- for (gnat_discr = First_Discriminant (gnat_pref_type);
- Present (gnat_discr); gnat_discr = Next_Discriminant (gnat_discr))
- {
- Entity_Id gnat_real_discr
- = ((Present (Corresponding_Discriminant (gnat_discr))
- && Present (Parent_Subtype (gnat_pref_type)))
- ? Corresponding_Discriminant (gnat_discr) : gnat_discr);
- tree gnu_discr = gnat_to_gnu_entity (gnat_real_discr, NULL_TREE, 0);
-
- gnu_actual_list
- = chainon (gnu_actual_list,
- build_tree_list (NULL_TREE,
- build_component_ref
- (convert (gnu_pref_type, gnu_expr),
- NULL_TREE, gnu_discr)));
- }
-
- gnu_cond = build (CALL_EXPR,
- TREE_TYPE (TREE_TYPE (gnu_discr_fct)),
- build_unary_op (ADDR_EXPR, NULL_TREE, gnu_discr_fct),
- gnu_actual_list,
- NULL_TREE);
- TREE_SIDE_EFFECTS (gnu_cond) = 1;
-
- return
- build_unary_op
- (INDIRECT_REF, NULL_TREE,
- emit_check (gnu_cond,
- build_unary_op (ADDR_EXPR,
- build_reference_type (TREE_TYPE (gnu_expr)),
- gnu_expr),
- CE_Discriminant_Check_Failed));
-}
-
/* Emit code for a range check. GNU_EXPR is the expression to be checked,
GNAT_RANGE_TYPE the gnat type or subtype containing the bounds against
which we have to check. */
@@ -4551,11 +4570,11 @@ emit_index_check (gnu_array_object, gnu_expr, gnu_low, gnu_high)
/* If GNU_LOW or GNU_HIGH are a PLACEHOLDER_EXPR, qualify them by
the object we are handling. */
- if (TREE_CODE (gnu_low) != INTEGER_CST && contains_placeholder_p (gnu_low))
+ if (CONTAINS_PLACEHOLDER_P (gnu_low))
gnu_low = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_low),
gnu_low, gnu_array_object);
- if (TREE_CODE (gnu_high) != INTEGER_CST && contains_placeholder_p (gnu_high))
+ if (CONTAINS_PLACEHOLDER_P (gnu_high))
gnu_high = build (WITH_RECORD_EXPR, TREE_TYPE (gnu_high),
gnu_high, gnu_array_object);
@@ -4649,7 +4668,7 @@ convert_with_check (gnat_type, gnu_expr, overflow_p, range_p, truncate_p)
return convert (gnu_type, gnu_expr);
/* First convert the expression to its base type. This
- will never generate code, but makes the tests below much simpler.
+ will never generate code, but makes the tests below much simpler.
But don't do this if converting from an integer type to an unconstrained
array type since then we need to get the bounds from the original
(unpacked) type. */
@@ -4688,7 +4707,7 @@ convert_with_check (gnat_type, gnu_expr, overflow_p, range_p, truncate_p)
the comparison is done in the base type of the input, which
always has the proper signedness. First check for input
integer (which means output integer), output float (which means
- both float), or mixed, in which case we always compare.
+ both float), or mixed, in which case we always compare.
Note that we have to do the comparison which would *fail* in the
case of an error since if it's an FP comparison and one of the
values is a NaN or Inf, the comparison will fail. */
@@ -4744,7 +4763,7 @@ convert_with_check (gnat_type, gnu_expr, overflow_p, range_p, truncate_p)
if (TREE_CODE (gnu_ada_base_type) == INTEGER_TYPE
&& TYPE_HAS_ACTUAL_BOUNDS_P (gnu_ada_base_type)
&& TREE_CODE (gnu_result) == UNCONSTRAINED_ARRAY_REF)
- gnu_result = unchecked_convert (gnu_ada_base_type, gnu_result);
+ gnu_result = unchecked_convert (gnu_ada_base_type, gnu_result, 0);
else
gnu_result = convert (gnu_ada_base_type, gnu_result);
@@ -4760,10 +4779,10 @@ convert_with_check (gnat_type, gnu_expr, overflow_p, range_p, truncate_p)
return convert (gnu_type, gnu_result);
}
-/* Return 1 if GNU_EXPR can be directly addressed. This is the case
- unless it is an expression involving computation or if it involves
- a bitfield reference. This returns the same as
- gnat_mark_addressable in most cases. */
+/* Return 1 if GNU_EXPR can be directly addressed. This is the case unless
+ it is an expression involving computation or if it involves a bitfield
+ reference. This returns the same as gnat_mark_addressable in most
+ cases. */
static int
addressable_p (gnu_expr)
@@ -4771,18 +4790,25 @@ addressable_p (gnu_expr)
{
switch (TREE_CODE (gnu_expr))
{
- case UNCONSTRAINED_ARRAY_REF:
- case INDIRECT_REF:
case VAR_DECL:
case PARM_DECL:
case FUNCTION_DECL:
case RESULT_DECL:
+ /* All DECLs are addressable: if they are in a register, we can force
+ them to memory. */
+ return 1;
+
+ case UNCONSTRAINED_ARRAY_REF:
+ case INDIRECT_REF:
case CONSTRUCTOR:
case NULL_EXPR:
+ case SAVE_EXPR:
return 1;
case COMPONENT_REF:
return (! DECL_BIT_FIELD (TREE_OPERAND (gnu_expr, 1))
+ && (! DECL_NONADDRESSABLE_P (TREE_OPERAND (gnu_expr, 1))
+ || ! flag_strict_aliasing)
&& addressable_p (TREE_OPERAND (gnu_expr, 0)));
case ARRAY_REF: case ARRAY_RANGE_REF:
@@ -4803,7 +4829,7 @@ addressable_p (gnu_expr)
return (((TYPE_MODE (type) == TYPE_MODE (inner_type)
&& (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
|| TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT))
- || ((TYPE_MODE (type) == BLKmode
+ || ((TYPE_MODE (type) == BLKmode
|| TYPE_MODE (inner_type) == BLKmode)
&& (TYPE_ALIGN (type) <= TYPE_ALIGN (inner_type)
|| TYPE_ALIGN (inner_type) >= BIGGEST_ALIGNMENT
@@ -4890,7 +4916,7 @@ process_type (gnat_entity)
update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
TREE_TYPE (gnu_new));
- /* If this is a record type corresponding to a task or protected type
+ /* If this is a record type corresponding to a task or protected type
that is a completion of an incomplete type, perform a similar update
on the type. */
/* ??? Including protected types here is a guess. */
@@ -4913,7 +4939,7 @@ process_type (gnat_entity)
}
/* GNAT_ASSOC is the front of the Component_Associations of an N_Aggregate.
- GNU_TYPE is the GCC type of the corresponding record.
+ GNU_TYPE is the GCC type of the corresponding record.
Return a CONSTRUCTOR to build the record. */
@@ -5117,7 +5143,7 @@ protect_multiple_eval (exp)
}
/* This is equivalent to stabilize_reference in GCC's tree.c, but we know
- how to handle our new nodes and we take an extra argument that says
+ how to handle our new nodes and we take an extra argument that says
whether to force evaluation of everything. */
tree
@@ -5306,7 +5332,7 @@ build_unit_elab (gnat_unit, body_p, gnu_elab_list)
gnu_decl = create_subprog_decl (create_concat_name (gnat_unit,
body_p ?
"elabb" : "elabs"),
- NULL_TREE, void_ftype, NULL_TREE, 0, 1, 0,
+ NULL_TREE, void_ftype, NULL_TREE, 0, 1, 0,
0);
DECL_ELABORATION_PROC_P (gnu_decl) = 1;
@@ -5355,7 +5381,7 @@ build_unit_elab (gnat_unit, body_p, gnu_elab_list)
break;
}
- expand_end_bindings (getdecls (), kept_level_p (), 0);
+ expand_end_bindings (getdecls (), kept_level_p (), -1);
poplevel (kept_level_p (), 1, 0);
gnu_block_stack = TREE_CHAIN (gnu_block_stack);
end_subprog_body ();
@@ -5387,15 +5413,15 @@ set_lineno (gnat_node, write_note_p)
/* Use the identifier table to make a hashed, permanent copy of the filename,
since the name table gets reallocated after Gigi returns but before all
- the debugging information is output. The call to
- __gnat_to_canonical_file_spec translates filenames from pragmas
- Source_Reference that contain host style syntax not understood by gdb. */
+ the debugging information is output. The __gnat_to_canonical_file_spec
+ call translates filenames from pragmas Source_Reference that contain host
+ style syntax not understood by gdb. */
input_filename
= IDENTIFIER_POINTER
(get_identifier
(__gnat_to_canonical_file_spec
(Get_Name_String
- (Debug_Source_Name (Get_Source_File_Index (source_location))))));
+ (Full_Debug_Name (Get_Source_File_Index (source_location))))));
/* ref_filename is the reference file name as given by sinput (i.e no
directory) */
@@ -5403,7 +5429,7 @@ set_lineno (gnat_node, write_note_p)
= IDENTIFIER_POINTER
(get_identifier
(Get_Name_String
- (Reference_Name (Get_Source_File_Index (source_location)))));;
+ (Debug_Source_Name (Get_Source_File_Index (source_location)))));;
input_line = Get_Logical_Line_Number (source_location);
if (write_note_p)
@@ -5491,7 +5517,9 @@ post_error_ne_tree (msg, node, ent, t)
if (host_integerp (t, 1)
#if HOST_BITS_PER_WIDE_INT > HOST_BITS_PER_INT
- && compare_tree_int (t, 1 << (HOST_BITS_PER_INT - 2)) < 0
+ &&
+ compare_tree_int
+ (t, (((unsigned HOST_WIDE_INT) 1 << (HOST_BITS_PER_INT - 1)) - 1)) < 0
#endif
)
{
diff --git a/gcc/ada/tree_io.adb b/gcc/ada/tree_io.adb
index d0170dcb59f..370a40f2187 100644
--- a/gcc/ada/tree_io.adb
+++ b/gcc/ada/tree_io.adb
@@ -373,8 +373,11 @@ package body Tree_IO is
declare
B : Byte;
+ pragma Warnings (Off, B);
+
begin
B := Read_Byte;
+
exception
when Tree_Format_Error => return;
end;
diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb
index e77729eff18..ad10d500652 100644
--- a/gcc/ada/treepr.adb
+++ b/gcc/ada/treepr.adb
@@ -601,7 +601,7 @@ package body Treepr is
Write_Str ("Character code = ");
declare
- C : Char_Code := Char_Code (Val - Char_Code_Bias);
+ C : constant Char_Code := Char_Code (Val - Char_Code_Bias);
begin
Write_Int (Int (C));
@@ -1838,6 +1838,16 @@ package body Treepr is
Visit_Descendent (Field22 (N));
Visit_Descendent (Field23 (N));
+ -- Now an interesting kludge. Normally parents are always printed
+ -- since we traverse the tree in a downwards direction. There is
+ -- however an exception to this rule, which is the case where a
+ -- parent is constructed by the compiler and is not referenced
+ -- elsewhere in the tree. The following catches this case
+
+ if not Comes_From_Source (N) then
+ Visit_Descendent (Union_Id (Parent (N)));
+ end if;
+
-- You may be wondering why we omitted Field2 above. The answer
-- is that this is the Next_Entity field, and we want to treat
-- it rather specially. Why? Because a Next_Entity link does not
diff --git a/gcc/ada/treeprs.ads b/gcc/ada/treeprs.ads
index 6ec3c1d5751..433cb081975 100644
--- a/gcc/ada/treeprs.ads
+++ b/gcc/ada/treeprs.ads
@@ -6,11 +6,7 @@
-- --
-- S p e c --
-- --
--- Generated by xtreeprs revision using --
--- sinfo.ads revision 1.439 --
--- treeprs.adt revision 1.17 --
--- --
--- Copyright (C) 1992-1997 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- --
@@ -116,7 +112,7 @@ package Treeprs is
-- Record_Representation_Clause
"#Identifier$Mod_Clause%Component_Clauses&Next_Rep_Item" &
-- Attribute_Definition_Clause
- "$Name%Expression&Next_Rep_Item+From_At_Mod" &
+ "$Name%Expression&Next_Rep_Item+From_At_Mod2Check_Address_Alignment" &
-- Empty
"" &
-- Pragma
@@ -145,18 +141,18 @@ package Treeprs is
"" &
-- Op_Concat
"4Is_Component_Left_Opnd5Is_Component_Right_Opnd" &
- -- Op_Divide
- "5Treat_Fixed_As_Integer4Do_Division_Check9Rounded_Result" &
-- Op_Expon
"4Is_Power_Of_2_For_Shift" &
+ -- Op_Subtract
+ "" &
+ -- Op_Divide
+ "5Treat_Fixed_As_Integer4Do_Division_Check9Rounded_Result" &
-- Op_Mod
"5Treat_Fixed_As_Integer4Do_Division_Check" &
-- Op_Multiply
"5Treat_Fixed_As_Integer9Rounded_Result" &
-- Op_Rem
"5Treat_Fixed_As_Integer4Do_Division_Check" &
- -- Op_Subtract
- "" &
-- Op_And
"+Do_Length_Check" &
-- Op_Eq
@@ -194,24 +190,23 @@ package Treeprs is
-- Op_Plus
"" &
-- Attribute_Reference
- "%Prefix$Attribute_Name#Expressions&Entity&Associated_Node2Do_Access_C" &
- "heck8Do_Overflow_Check4Redundant_Use+OK_For_Stream5Must_Be_Byte_Al" &
- "igned" &
+ "%Prefix$Attribute_Name#Expressions&Entity&Associated_Node8Do_Overflow" &
+ "_Check4Redundant_Use+OK_For_Stream5Must_Be_Byte_Aligned" &
-- And_Then
"#Actions" &
-- Conditional_Expression
"#Expressions$Then_Actions%Else_Actions" &
-- Explicit_Dereference
- "%Prefix2Do_Access_Check" &
+ "%Prefix" &
-- Function_Call
"$Name%Parameter_Associations&First_Named_Actual#Controlling_Argument4" &
"Do_Tag_Check8Parameter_List_Truncated9ABE_Is_Certain" &
-- In
"" &
-- Indexed_Component
- "%Prefix#Expressions2Do_Access_Check" &
+ "%Prefix#Expressions" &
-- Integer_Literal
- "%Intval4Print_In_Hex" &
+ "$Original_Entity%Intval4Print_In_Hex" &
-- Not_In
"" &
-- Null
@@ -242,25 +237,26 @@ package Treeprs is
-- Range
"#Low_Bound$High_Bound2Includes_Infinities" &
-- Real_Literal
- "%Realval&Corresponding_Integer_Value2Is_Machine_Number" &
+ "$Original_Entity%Realval&Corresponding_Integer_Value2Is_Machine_Numbe" &
+ "r" &
-- Reference
"%Prefix" &
-- Selected_Component
- "%Prefix$Selector_Name&Associated_Node2Do_Access_Check4Do_Discriminant" &
- "_Check" &
+ "%Prefix$Selector_Name&Associated_Node4Do_Discriminant_Check2Is_In_Dis" &
+ "criminant_Check" &
-- Slice
- "%Prefix&Discrete_Range2Do_Access_Check" &
+ "%Prefix&Discrete_Range" &
-- String_Literal
"%Strval2Has_Wide_Character" &
-- Subprogram_Info
"#Identifier" &
-- Type_Conversion
- "&Subtype_Mark%Expression8Do_Overflow_Check4Do_Tag_Check+Do_Length_Che" &
+ "&Subtype_Mark%Expression4Do_Tag_Check+Do_Length_Check8Do_Overflow_Che" &
"ck2Float_Truncate9Rounded_Result5Conversion_OK" &
-- Unchecked_Expression
"%Expression" &
-- Unchecked_Type_Conversion
- "&Subtype_Mark%Expression2Kill_Range_Check" &
+ "&Subtype_Mark%Expression2Kill_Range_Check8No_Truncation" &
-- Subtype_Indication
"&Subtype_Mark%Constraint/Must_Not_Freeze" &
-- Component_Declaration
@@ -268,7 +264,7 @@ package Treeprs is
"re_Ids-Prev_Ids" &
-- Entry_Declaration
"#Defining_Identifier&Discrete_Subtype_Definition%Parameter_Specificat" &
- "ions" &
+ "ions'Corresponding_Body" &
-- Formal_Object_Declaration
"#Defining_Identifier6In_Present8Out_Present&Subtype_Mark%Expression,M" &
"ore_Ids-Prev_Ids" &
@@ -416,7 +412,7 @@ package Treeprs is
"$Name2Exception_Junk" &
-- Loop_Statement
"#Identifier$Iteration_Scheme%Statements&End_Label6Has_Created_Identif" &
- "ier" &
+ "ier7Is_Null_Loop" &
-- Null_Statement
"" &
-- Raise_Statement
@@ -462,7 +458,7 @@ package Treeprs is
"o_Elaboration_Code4Body_Required+Acts_As_Spec%First_Inlined_Subpro" &
"gram" &
-- Compilation_Unit_Aux
- "$Declarations#Actions'Pragmas_After" &
+ "$Declarations#Actions'Pragmas_After&Config_Pragmas" &
-- Component_Association
"#Choices$Loop_Actions%Expression" &
-- Component_List
@@ -538,7 +534,7 @@ package Treeprs is
"#Others_Discrete_Choices2All_Others" &
-- Package_Specification
"#Defining_Unit_Name$Visible_Declarations%Private_Declarations&End_Lab" &
- "el'Generic_Parent" &
+ "el'Generic_Parent9Limited_View_Installed" &
-- Parameter_Association
"$Selector_Name%Explicit_Actual_Parameter&Next_Named_Actual" &
-- Parameter_Specification
@@ -577,8 +573,9 @@ package Treeprs is
"$Name#Variants" &
-- With_Clause
"$Name&Library_Unit'Corresponding_Spec,First_Name-Last_Name4Context_In" &
- "stalled+Elaborate_Present6Elaborate_All_Present8Implicit_With.Unre" &
- "ferenced_In_Spec/No_Entities_Ref_In_Spec" &
+ "stalled+Elaborate_Present6Elaborate_All_Present7Implicit_With8Limi" &
+ "ted_Present9Limited_View_Installed.Unreferenced_In_Spec/No_Entitie" &
+ "s_Ref_In_Spec" &
-- With_Type_Clause
"$Name6Tagged_Present" &
-- Unused_At_End
@@ -593,207 +590,207 @@ package Treeprs is
N_Mod_Clause => 107,
N_Record_Representation_Clause => 133,
N_Attribute_Definition_Clause => 187,
- N_Empty => 229,
- N_Pragma => 229,
- N_Pragma_Argument_Association => 288,
- N_Error => 299,
- N_Defining_Character_Literal => 299,
- N_Defining_Identifier => 317,
- N_Defining_Operator_Symbol => 335,
- N_Expanded_Name => 353,
- N_Identifier => 428,
- N_Operator_Symbol => 504,
- N_Character_Literal => 551,
- N_Op_Add => 610,
- N_Op_Concat => 610,
- N_Op_Divide => 657,
- N_Op_Expon => 713,
- N_Op_Mod => 737,
- N_Op_Multiply => 778,
- N_Op_Rem => 816,
- N_Op_Subtract => 857,
- N_Op_And => 857,
- N_Op_Eq => 873,
- N_Op_Ge => 873,
- N_Op_Gt => 873,
- N_Op_Le => 873,
- N_Op_Lt => 873,
- N_Op_Ne => 873,
- N_Op_Or => 873,
- N_Op_Xor => 889,
- N_Op_Rotate_Left => 905,
- N_Op_Rotate_Right => 920,
- N_Op_Shift_Left => 935,
- N_Op_Shift_Right => 950,
- N_Op_Shift_Right_Arithmetic => 965,
- N_Op_Abs => 980,
- N_Op_Minus => 980,
- N_Op_Not => 980,
- N_Op_Plus => 980,
- N_Attribute_Reference => 980,
- N_And_Then => 1120,
- N_Conditional_Expression => 1128,
- N_Explicit_Dereference => 1166,
- N_Function_Call => 1189,
- N_In => 1310,
- N_Indexed_Component => 1310,
- N_Integer_Literal => 1345,
- N_Not_In => 1365,
- N_Null => 1365,
- N_Or_Else => 1365,
- N_Procedure_Call_Statement => 1373,
- N_Qualified_Expression => 1494,
- N_Raise_Constraint_Error => 1518,
- N_Raise_Program_Error => 1535,
- N_Raise_Storage_Error => 1552,
- N_Aggregate => 1569,
- N_Allocator => 1725,
- N_Extension_Aggregate => 1802,
- N_Range => 1905,
- N_Real_Literal => 1946,
- N_Reference => 2000,
- N_Selected_Component => 2007,
- N_Slice => 2082,
- N_String_Literal => 2120,
- N_Subprogram_Info => 2146,
- N_Type_Conversion => 2157,
- N_Unchecked_Expression => 2272,
- N_Unchecked_Type_Conversion => 2283,
- N_Subtype_Indication => 2324,
- N_Component_Declaration => 2364,
- N_Entry_Declaration => 2448,
- N_Formal_Object_Declaration => 2521,
- N_Formal_Type_Declaration => 2606,
- N_Full_Type_Declaration => 2707,
- N_Incomplete_Type_Declaration => 2795,
- N_Loop_Parameter_Specification => 2873,
- N_Object_Declaration => 2937,
- N_Protected_Type_Declaration => 3184,
- N_Private_Extension_Declaration => 3272,
- N_Private_Type_Declaration => 3386,
- N_Subtype_Declaration => 3512,
- N_Function_Specification => 3586,
- N_Procedure_Specification => 3678,
- N_Entry_Index_Specification => 3757,
- N_Freeze_Entity => 3805,
- N_Access_Function_Definition => 3873,
- N_Access_Procedure_Definition => 3929,
- N_Task_Type_Declaration => 3972,
- N_Package_Body_Stub => 4075,
- N_Protected_Body_Stub => 4127,
- N_Subprogram_Body_Stub => 4179,
- N_Task_Body_Stub => 4225,
- N_Function_Instantiation => 4277,
- N_Package_Instantiation => 4363,
- N_Procedure_Instantiation => 4449,
- N_Package_Body => 4535,
- N_Subprogram_Body => 4633,
- N_Protected_Body => 4860,
- N_Task_Body => 4942,
- N_Implicit_Label_Declaration => 5080,
- N_Package_Declaration => 5116,
- N_Single_Task_Declaration => 5185,
- N_Subprogram_Declaration => 5221,
- N_Use_Package_Clause => 5281,
- N_Generic_Package_Declaration => 5324,
- N_Generic_Subprogram_Declaration => 5421,
- N_Constrained_Array_Definition => 5494,
- N_Unconstrained_Array_Definition => 5558,
- N_Exception_Renaming_Declaration => 5607,
- N_Object_Renaming_Declaration => 5632,
- N_Package_Renaming_Declaration => 5704,
- N_Subprogram_Renaming_Declaration => 5740,
- N_Generic_Function_Renaming_Declaration => 5790,
- N_Generic_Package_Renaming_Declaration => 5826,
- N_Generic_Procedure_Renaming_Declaration => 5862,
- N_Abort_Statement => 5898,
- N_Accept_Statement => 5904,
- N_Assignment_Statement => 5999,
- N_Asynchronous_Select => 6085,
- N_Block_Statement => 6123,
- N_Case_Statement => 6288,
- N_Code_Statement => 6321,
- N_Conditional_Entry_Call => 6332,
- N_Delay_Relative_Statement => 6371,
- N_Delay_Until_Statement => 6382,
- N_Entry_Call_Statement => 6393,
- N_Free_Statement => 6440,
- N_Goto_Statement => 6482,
- N_Loop_Statement => 6502,
- N_Null_Statement => 6574,
- N_Raise_Statement => 6574,
- N_Requeue_Statement => 6579,
- N_Return_Statement => 6598,
- N_Selective_Accept => 6672,
- N_Timed_Entry_Call => 6708,
- N_Exit_Statement => 6749,
- N_If_Statement => 6764,
- N_Accept_Alternative => 6827,
- N_Delay_Alternative => 6903,
- N_Elsif_Part => 6955,
- N_Entry_Body_Formal_Part => 6999,
- N_Iteration_Scheme => 7060,
- N_Terminate_Alternative => 7117,
- N_Abortable_Part => 7156,
- N_Abstract_Subprogram_Declaration => 7167,
- N_Access_Definition => 7181,
- N_Access_To_Object_Definition => 7194,
- N_Case_Statement_Alternative => 7242,
- N_Compilation_Unit => 7270,
- N_Compilation_Unit_Aux => 7409,
- N_Component_Association => 7444,
- N_Component_List => 7476,
- N_Derived_Type_Definition => 7518,
- N_Decimal_Fixed_Point_Definition => 7576,
- N_Defining_Program_Unit_Name => 7636,
- N_Delta_Constraint => 7661,
- N_Designator => 7695,
- N_Digits_Constraint => 7711,
- N_Discriminant_Association => 7746,
- N_Discriminant_Specification => 7772,
- N_Enumeration_Type_Definition => 7839,
- N_Entry_Body => 7858,
- N_Entry_Call_Alternative => 7965,
- N_Exception_Declaration => 8012,
- N_Exception_Handler => 8061,
- N_Floating_Point_Definition => 8126,
- N_Formal_Decimal_Fixed_Point_Definition => 8169,
- N_Formal_Derived_Type_Definition => 8169,
- N_Formal_Discrete_Type_Definition => 8215,
- N_Formal_Floating_Point_Definition => 8215,
- N_Formal_Modular_Type_Definition => 8215,
- N_Formal_Ordinary_Fixed_Point_Definition => 8215,
- N_Formal_Package_Declaration => 8215,
- N_Formal_Private_Type_Definition => 8302,
- N_Formal_Signed_Integer_Type_Definition => 8350,
- N_Formal_Subprogram_Declaration => 8350,
- N_Generic_Association => 8389,
- N_Handled_Sequence_Of_Statements => 8437,
- N_Index_Or_Discriminant_Constraint => 8529,
- N_Itype_Reference => 8541,
- N_Label => 8547,
- N_Modular_Type_Definition => 8573,
- N_Number_Declaration => 8584,
- N_Ordinary_Fixed_Point_Definition => 8633,
- N_Others_Choice => 8675,
- N_Package_Specification => 8710,
- N_Parameter_Association => 8796,
- N_Parameter_Specification => 8854,
- N_Protected_Definition => 8983,
- N_Range_Constraint => 9055,
- N_Real_Range_Specification => 9072,
- N_Record_Definition => 9093,
- N_Signed_Integer_Type_Definition => 9179,
- N_Single_Protected_Declaration => 9200,
- N_Subunit => 9241,
- N_Task_Definition => 9277,
- N_Triggering_Alternative => 9415,
- N_Use_Type_Clause => 9462,
- N_Validate_Unchecked_Conversion => 9513,
- N_Variant => 9537,
- N_Variant_Part => 9616,
- N_With_Clause => 9630,
- N_With_Type_Clause => 9805,
- N_Unused_At_End => 9825);
+ N_Empty => 253,
+ N_Pragma => 253,
+ N_Pragma_Argument_Association => 312,
+ N_Error => 323,
+ N_Defining_Character_Literal => 323,
+ N_Defining_Identifier => 341,
+ N_Defining_Operator_Symbol => 359,
+ N_Expanded_Name => 377,
+ N_Identifier => 452,
+ N_Operator_Symbol => 528,
+ N_Character_Literal => 575,
+ N_Op_Add => 634,
+ N_Op_Concat => 634,
+ N_Op_Expon => 681,
+ N_Op_Subtract => 705,
+ N_Op_Divide => 705,
+ N_Op_Mod => 761,
+ N_Op_Multiply => 802,
+ N_Op_Rem => 840,
+ N_Op_And => 881,
+ N_Op_Eq => 897,
+ N_Op_Ge => 897,
+ N_Op_Gt => 897,
+ N_Op_Le => 897,
+ N_Op_Lt => 897,
+ N_Op_Ne => 897,
+ N_Op_Or => 897,
+ N_Op_Xor => 913,
+ N_Op_Rotate_Left => 929,
+ N_Op_Rotate_Right => 944,
+ N_Op_Shift_Left => 959,
+ N_Op_Shift_Right => 974,
+ N_Op_Shift_Right_Arithmetic => 989,
+ N_Op_Abs => 1004,
+ N_Op_Minus => 1004,
+ N_Op_Not => 1004,
+ N_Op_Plus => 1004,
+ N_Attribute_Reference => 1004,
+ N_And_Then => 1128,
+ N_Conditional_Expression => 1136,
+ N_Explicit_Dereference => 1174,
+ N_Function_Call => 1181,
+ N_In => 1302,
+ N_Indexed_Component => 1302,
+ N_Integer_Literal => 1321,
+ N_Not_In => 1357,
+ N_Null => 1357,
+ N_Or_Else => 1357,
+ N_Procedure_Call_Statement => 1365,
+ N_Qualified_Expression => 1486,
+ N_Raise_Constraint_Error => 1510,
+ N_Raise_Program_Error => 1527,
+ N_Raise_Storage_Error => 1544,
+ N_Aggregate => 1561,
+ N_Allocator => 1717,
+ N_Extension_Aggregate => 1794,
+ N_Range => 1897,
+ N_Real_Literal => 1938,
+ N_Reference => 2008,
+ N_Selected_Component => 2015,
+ N_Slice => 2099,
+ N_String_Literal => 2121,
+ N_Subprogram_Info => 2147,
+ N_Type_Conversion => 2158,
+ N_Unchecked_Expression => 2273,
+ N_Unchecked_Type_Conversion => 2284,
+ N_Subtype_Indication => 2339,
+ N_Component_Declaration => 2379,
+ N_Entry_Declaration => 2463,
+ N_Formal_Object_Declaration => 2555,
+ N_Formal_Type_Declaration => 2640,
+ N_Full_Type_Declaration => 2741,
+ N_Incomplete_Type_Declaration => 2829,
+ N_Loop_Parameter_Specification => 2907,
+ N_Object_Declaration => 2971,
+ N_Protected_Type_Declaration => 3218,
+ N_Private_Extension_Declaration => 3306,
+ N_Private_Type_Declaration => 3420,
+ N_Subtype_Declaration => 3546,
+ N_Function_Specification => 3620,
+ N_Procedure_Specification => 3712,
+ N_Entry_Index_Specification => 3791,
+ N_Freeze_Entity => 3839,
+ N_Access_Function_Definition => 3907,
+ N_Access_Procedure_Definition => 3963,
+ N_Task_Type_Declaration => 4006,
+ N_Package_Body_Stub => 4109,
+ N_Protected_Body_Stub => 4161,
+ N_Subprogram_Body_Stub => 4213,
+ N_Task_Body_Stub => 4259,
+ N_Function_Instantiation => 4311,
+ N_Package_Instantiation => 4397,
+ N_Procedure_Instantiation => 4483,
+ N_Package_Body => 4569,
+ N_Subprogram_Body => 4667,
+ N_Protected_Body => 4894,
+ N_Task_Body => 4976,
+ N_Implicit_Label_Declaration => 5114,
+ N_Package_Declaration => 5150,
+ N_Single_Task_Declaration => 5219,
+ N_Subprogram_Declaration => 5255,
+ N_Use_Package_Clause => 5315,
+ N_Generic_Package_Declaration => 5358,
+ N_Generic_Subprogram_Declaration => 5455,
+ N_Constrained_Array_Definition => 5528,
+ N_Unconstrained_Array_Definition => 5592,
+ N_Exception_Renaming_Declaration => 5641,
+ N_Object_Renaming_Declaration => 5666,
+ N_Package_Renaming_Declaration => 5738,
+ N_Subprogram_Renaming_Declaration => 5774,
+ N_Generic_Function_Renaming_Declaration => 5824,
+ N_Generic_Package_Renaming_Declaration => 5860,
+ N_Generic_Procedure_Renaming_Declaration => 5896,
+ N_Abort_Statement => 5932,
+ N_Accept_Statement => 5938,
+ N_Assignment_Statement => 6033,
+ N_Asynchronous_Select => 6119,
+ N_Block_Statement => 6157,
+ N_Case_Statement => 6322,
+ N_Code_Statement => 6355,
+ N_Conditional_Entry_Call => 6366,
+ N_Delay_Relative_Statement => 6405,
+ N_Delay_Until_Statement => 6416,
+ N_Entry_Call_Statement => 6427,
+ N_Free_Statement => 6474,
+ N_Goto_Statement => 6516,
+ N_Loop_Statement => 6536,
+ N_Null_Statement => 6621,
+ N_Raise_Statement => 6621,
+ N_Requeue_Statement => 6626,
+ N_Return_Statement => 6645,
+ N_Selective_Accept => 6719,
+ N_Timed_Entry_Call => 6755,
+ N_Exit_Statement => 6796,
+ N_If_Statement => 6811,
+ N_Accept_Alternative => 6874,
+ N_Delay_Alternative => 6950,
+ N_Elsif_Part => 7002,
+ N_Entry_Body_Formal_Part => 7046,
+ N_Iteration_Scheme => 7107,
+ N_Terminate_Alternative => 7164,
+ N_Abortable_Part => 7203,
+ N_Abstract_Subprogram_Declaration => 7214,
+ N_Access_Definition => 7228,
+ N_Access_To_Object_Definition => 7241,
+ N_Case_Statement_Alternative => 7289,
+ N_Compilation_Unit => 7317,
+ N_Compilation_Unit_Aux => 7456,
+ N_Component_Association => 7506,
+ N_Component_List => 7538,
+ N_Derived_Type_Definition => 7580,
+ N_Decimal_Fixed_Point_Definition => 7638,
+ N_Defining_Program_Unit_Name => 7698,
+ N_Delta_Constraint => 7723,
+ N_Designator => 7757,
+ N_Digits_Constraint => 7773,
+ N_Discriminant_Association => 7808,
+ N_Discriminant_Specification => 7834,
+ N_Enumeration_Type_Definition => 7901,
+ N_Entry_Body => 7920,
+ N_Entry_Call_Alternative => 8027,
+ N_Exception_Declaration => 8074,
+ N_Exception_Handler => 8123,
+ N_Floating_Point_Definition => 8188,
+ N_Formal_Decimal_Fixed_Point_Definition => 8231,
+ N_Formal_Derived_Type_Definition => 8231,
+ N_Formal_Discrete_Type_Definition => 8277,
+ N_Formal_Floating_Point_Definition => 8277,
+ N_Formal_Modular_Type_Definition => 8277,
+ N_Formal_Ordinary_Fixed_Point_Definition => 8277,
+ N_Formal_Package_Declaration => 8277,
+ N_Formal_Private_Type_Definition => 8364,
+ N_Formal_Signed_Integer_Type_Definition => 8412,
+ N_Formal_Subprogram_Declaration => 8412,
+ N_Generic_Association => 8451,
+ N_Handled_Sequence_Of_Statements => 8499,
+ N_Index_Or_Discriminant_Constraint => 8591,
+ N_Itype_Reference => 8603,
+ N_Label => 8609,
+ N_Modular_Type_Definition => 8635,
+ N_Number_Declaration => 8646,
+ N_Ordinary_Fixed_Point_Definition => 8695,
+ N_Others_Choice => 8737,
+ N_Package_Specification => 8772,
+ N_Parameter_Association => 8881,
+ N_Parameter_Specification => 8939,
+ N_Protected_Definition => 9068,
+ N_Range_Constraint => 9140,
+ N_Real_Range_Specification => 9157,
+ N_Record_Definition => 9178,
+ N_Signed_Integer_Type_Definition => 9264,
+ N_Single_Protected_Declaration => 9285,
+ N_Subunit => 9326,
+ N_Task_Definition => 9362,
+ N_Triggering_Alternative => 9500,
+ N_Use_Type_Clause => 9547,
+ N_Validate_Unchecked_Conversion => 9598,
+ N_Variant => 9622,
+ N_Variant_Part => 9701,
+ N_With_Clause => 9715,
+ N_With_Type_Clause => 9929,
+ N_Unused_At_End => 9949);
end Treeprs;
diff --git a/gcc/ada/treeprs.adt b/gcc/ada/treeprs.adt
index 16773cc8d24..4ae304f7955 100644
--- a/gcc/ada/treeprs.adt
+++ b/gcc/ada/treeprs.adt
@@ -6,8 +6,7 @@
-- --
-- T e m p l a t e --
-- --
--- --
--- Copyright (C) 1992-1997 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- --
diff --git a/gcc/ada/ttypes.ads b/gcc/ada/ttypes.ads
index fb9f5c2d8cc..2d31034e503 100644
--- a/gcc/ada/ttypes.ads
+++ b/gcc/ada/ttypes.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -193,6 +193,10 @@ package Ttypes is
-- The maximum alignment, in storage units, that an object or
-- type may require on the target machine.
+ Max_Unaligned_Field : constant Pos := Get_Max_Unaligned_Field;
+ -- The maximum supported size in bits for a field that is not aligned
+ -- on a storage unit boundary.
+
Bytes_Big_Endian : Boolean := Get_Bytes_BE /= 0;
-- Important note: for Ada purposes, the important setting is the bytes
-- endianness (Bytes_Big_Endian), not the bits value (Bits_Big_Endian).
diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads
index 65731227c65..a93dbb47054 100644
--- a/gcc/ada/types.ads
+++ b/gcc/ada/types.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -168,8 +168,8 @@ pragma Preelaborate (Types);
type Column_Number is range 0 .. 32767;
for Column_Number'Size use 16;
- -- Column number (assume that 2**15 is large enough, see declaration
- -- of Hostparm.Max_Line_Length)
+ -- Column number (assume that 2**15 is large enough, see declaration of
+ -- Hostparm.Max_Line_Length, and also processing for -gnatyM in Stylesw)
No_Column_Number : constant Column_Number := 0;
-- Special value used to indicate no column number
@@ -200,7 +200,10 @@ pragma Preelaborate (Types);
-- are allowed to accommodate the following special values.
No_Location : constant Source_Ptr := -1;
- -- Value used to indicate no source position set in a node
+ -- Value used to indicate no source position set in a node. A test for
+ -- a Source_Ptr value being >= No_Location is the apporoved way to test
+ -- for a standard value that does not include No_Location or any of the
+ -- following special definitions.
Standard_Location : constant Source_Ptr := -2;
-- Used for all nodes in the representation of package Standard other
@@ -211,6 +214,10 @@ pragma Preelaborate (Types);
Standard_ASCII_Location : constant Source_Ptr := -3;
-- Used for all nodes in the presentation of package Standard.ASCII
+ System_Location : constant Source_Ptr := -4;
+ -- Used to identify locations of pragmas scanned by Targparm, where we
+ -- know the location is in System, but we don't know exactly what line.
+
First_Source_Ptr : constant Source_Ptr := 0;
-- Starting source pointer index value for first source program
@@ -446,7 +453,7 @@ pragma Preelaborate (Types);
No_List : constant List_Id := List_High_Bound;
-- Used to indicate absence of a list. Note that the value is zero, which
- -- is the same as Empty, which is helpful in initializing nodes where a
+ -- is the same as Empty, which is helpful in intializing nodes where a
-- value of zero can represent either an empty node or an empty list.
Error_List : constant List_Id := List_Low_Bound;
@@ -568,10 +575,6 @@ pragma Preelaborate (Types);
No_Source_File : constant Source_File_Index := 0;
-- Value used to indicate no source file present
- System_Source_File_Index : constant Source_File_Index := 1;
- -- Value used for source file table entry for system.ads, which is
- -- always the first source file read (see unit Targparm for details).
-
subtype File_Name_Type is Name_Id;
-- File names are stored in the names table and this synonym is used to
-- indicate that a Name_Id value is being used to hold a simple file
@@ -665,35 +668,35 @@ pragma Preelaborate (Types);
-- Types used for Pragma Suppress Management --
-----------------------------------------------
+ type Check_Id is (
+ Access_Check,
+ Accessibility_Check,
+ Discriminant_Check,
+ Division_Check,
+ Elaboration_Check,
+ Index_Check,
+ Length_Check,
+ Overflow_Check,
+ Range_Check,
+ Storage_Check,
+ Tag_Check,
+ All_Checks);
+
-- The following record contains an entry for each recognized check name
-- for pragma Suppress. It is used to represent current settings of scope
-- based suppress actions from pragma Suppress or command line settings.
- type Suppress_Record is record
- Access_Checks : Boolean;
- Accessibility_Checks : Boolean;
- Discriminant_Checks : Boolean;
- Division_Checks : Boolean;
- Elaboration_Checks : Boolean;
- Index_Checks : Boolean;
- Length_Checks : Boolean;
- Overflow_Checks : Boolean;
- Range_Checks : Boolean;
- Storage_Checks : Boolean;
- Tag_Checks : Boolean;
- end record;
+ type Suppress_Array is
+ array (Check_Id range Access_Check .. Tag_Check) of Boolean;
+ pragma Pack (Suppress_Array);
-- To add a new check type to GNAT, the following steps are required:
- -- 1. Add an appropriate entry to the above record type
- -- 2. Add an entry to Snames spec and body for the new name
- -- 3. Add an entry to the definition of Check_Id in the Snames spec
- -- 4. Add a new entity flag definition in Einfo for the check
- -- 5. Add a new function to Sem.Util to handle the new check test
- -- 6. Add appropriate processing for pragma Suppress in Sem.Prag
- -- 7. Add a branch to the case statement in Sem.Ch8.Pop_Scope
- -- 8. Add a new Do_xxx_Check flag to Sinfo (if required)
- -- 9. Add appropriate checks for the new test
+ -- 1. Add an entry to Snames spec and body for the new name
+ -- 2. Add an entry to the definition of Check_Id above
+ -- 3. Add a new function to Checks to handle the new check test
+ -- 4. Add a new Do_xxx_Check flag to Sinfo (if required)
+ -- 5. Add appropriate checks for the new test
-----------------------------------
-- Global Exception Declarations --
@@ -745,14 +748,12 @@ pragma Preelaborate (Types);
-- 1. Modify the type and subtype declarations below appropriately,
-- keeping things in alphabetical order.
- -- 2. Modify the corresponding definitions in a-types.h, including
+ -- 2. Modify the corresponding definitions in types.h, including
-- the definition of last_reason_code.
-- 3. Add a new routine in Ada.Exceptions with the appropriate call
-- and static string constant
- -- 4. Initialize the new entry in raise_decls
-
type RT_Exception_Code is (
CE_Access_Check_Failed,
CE_Access_Parameter_Is_Null,
@@ -773,9 +774,9 @@ pragma Preelaborate (Types);
PE_Duplicated_Entry_Address,
PE_Explicit_Raise,
PE_Finalize_Raised_Exception,
- PE_Invalid_Data,
PE_Misaligned_Address_Value,
PE_Missing_Return,
+ PE_Overlaid_Controlled_Object,
PE_Potentially_Blocking_Operation,
PE_Stubbed_Subprogram_Called,
PE_Unchecked_Union_Restriction,
diff --git a/gcc/ada/types.h b/gcc/ada/types.h
index 3d8dbd50695..19d2fc7f03e 100644
--- a/gcc/ada/types.h
+++ b/gcc/ada/types.h
@@ -6,8 +6,7 @@
* *
* C Header File *
* *
- * *
- * 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- *
@@ -28,7 +27,7 @@
/* This is the C file that corresponds to the Ada package spec Types. It was
created manually from the files types.ads and types.adb.
- This package contains host independent type definitions which are used
+ This package contains host independent type definitions which are used
throughout the compiler modules. The comments in the C version are brief
reminders of the purpose of each declaration. For complete documentation,
see the Ada version of these definitions. */
@@ -81,15 +80,15 @@ typedef Char *Str_Ptr;
/* Types for the fat pointer used for strings and the template it
points to. */
typedef struct {int Low_Bound, High_Bound; } String_Template;
-typedef struct {const char *Array; String_Template *Bounds; }
+typedef struct {const char *Array; String_Template *Bounds; }
__attribute ((aligned (sizeof (char *) * 2))) Fat_Pointer;
/* Types for Node/Entity Kinds: */
/* The reason that these are defined here in the C version, rather than in the
corresponding packages is that the requirement for putting bodies of
- inlined stuff IN the C header changes the dependencies. Both a-sinfo.h
- and a-einfo.h now reference routines defined in tree.h.
+ inlined stuff IN the C header changes the dependencies. Both sinfo.h
+ and einfo.h now reference routines defined in tree.h.
Note: these types would more naturally be defined as unsigned char, but
once again, the annoying restriction on bit fields for some compilers
@@ -352,9 +351,9 @@ typedef Int Mechanism_Type;
#define PE_Duplicated_Entry_Address 15
#define PE_Explicit_Raise 16
#define PE_Finalize_Raised_Exception 17
-#define PE_Invalid_Data 18
-#define PE_Misaligned_Address_Value 19
-#define PE_Missing_Return 20
+#define PE_Misaligned_Address_Value 18
+#define PE_Missing_Return 19
+#define PE_Overlaid_Controlled_Object 20
#define PE_Potentially_Blocking_Operation 21
#define PE_Stubbed_Subprogram_Called 22
#define PE_Unchecked_Union_Restriction 23
diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb
index 5326b9c3da6..7b4e7139640 100644
--- a/gcc/ada/uintp.adb
+++ b/gcc/ada/uintp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -34,6 +34,8 @@
with Output; use Output;
with Tree_IO; use Tree_IO;
+with GNAT.HTable; use GNAT.HTable;
+
package body Uintp is
------------------------
@@ -69,10 +71,10 @@ package body Uintp is
Uints_Min : Uint;
Udigits_Min : Int;
-- These values are used to make sure that the mark/release mechanism
- -- does not destroy values saved in the U_Power tables. Whenever an
- -- entry is made in the U_Power tables, Uints_Min and Udigits_Min are
- -- updated to protect the entry, and Release never cuts back beyond
- -- these minimum values.
+ -- does not destroy values saved in the U_Power tables or in the hash
+ -- table used by UI_From_Int. Whenever an entry is made in either of
+ -- these tabls, Uints_Min and Udigits_Min are updated to protect the
+ -- entry, and Release never cuts back beyond these minimum values.
Int_0 : constant Int := 0;
Int_1 : constant Int := 1;
@@ -80,6 +82,27 @@ package body Uintp is
-- These values are used in some cases where the use of numeric literals
-- would cause ambiguities (integer vs Uint).
+ ----------------------------
+ -- UI_From_Int Hash Table --
+ ----------------------------
+
+ -- UI_From_Int uses a hash table to avoid duplicating entries and
+ -- wasting storage. This is particularly important for complex cases
+ -- of back annotation.
+
+ subtype Hnum is Nat range 0 .. 1022;
+
+ function Hash_Num (F : Int) return Hnum;
+ -- Hashing function
+
+ package UI_Ints is new Simple_HTable (
+ Header_Num => Hnum,
+ Element => Uint,
+ No_Element => No_Uint,
+ Key => Int,
+ Hash => Hash_Num,
+ Equal => "=");
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -201,6 +224,15 @@ package body Uintp is
return J;
end GCD;
+ --------------
+ -- Hash_Num --
+ --------------
+
+ function Hash_Num (F : Int) return Hnum is
+ begin
+ return Standard."mod" (F, Hnum'Range_Length);
+ end Hash_Num;
+
---------------
-- Image_Out --
---------------
@@ -324,7 +356,8 @@ package body Uintp is
----------------
procedure Image_Uint (U : Uint) is
- H : array (Int range 0 .. 15) of Character := "0123456789ABCDEF";
+ H : constant array (Int range 0 .. 15) of Character :=
+ "0123456789ABCDEF";
begin
if U >= Base then
@@ -428,6 +461,7 @@ package body Uintp is
Uints_Min := Uints.Last;
Udigits_Min := Udigits.Last;
+ UI_Ints.Reset;
end Initialize;
---------------------
@@ -557,7 +591,7 @@ package body Uintp is
begin
if UI_Is_In_Int_Range (Input) then
- Num := UI_To_Int (Input);
+ Num := abs (UI_To_Int (Input));
Bits := 0;
else
@@ -614,10 +648,10 @@ package body Uintp is
else
declare
- UE_Len : Pos := Uints.Table (UI).Length;
- UE_Loc : Int := Uints.Table (UI).Loc;
+ UE_Len : constant Pos := Uints.Table (UI).Length;
+ UE_Loc : constant Int := Uints.Table (UI).Loc;
- UD : Udigits.Table_Type (1 .. UE_Len) :=
+ UD : constant Udigits.Table_Type (1 .. UE_Len) :=
Udigits.Table (UE_Loc .. UE_Loc + UE_Len - 1);
begin
@@ -646,16 +680,16 @@ package body Uintp is
else
declare
- UE1_Len : Pos := Uints.Table (UI1).Length;
- UE1_Loc : Int := Uints.Table (UI1).Loc;
+ UE1_Len : constant Pos := Uints.Table (UI1).Length;
+ UE1_Loc : constant Int := Uints.Table (UI1).Loc;
- UD1 : Udigits.Table_Type (1 .. UE1_Len) :=
+ UD1 : constant Udigits.Table_Type (1 .. UE1_Len) :=
Udigits.Table (UE1_Loc .. UE1_Loc + UE1_Len - 1);
- UE2_Len : Pos := Uints.Table (UI2).Length;
- UE2_Loc : Int := Uints.Table (UI2).Loc;
+ UE2_Len : constant Pos := Uints.Table (UI2).Length;
+ UE2_Loc : constant Int := Uints.Table (UI2).Loc;
- UD2 : Udigits.Table_Type (1 .. UE2_Len) :=
+ UD2 : constant Udigits.Table_Type (1 .. UE2_Len) :=
Udigits.Table (UE2_Loc .. UE2_Loc + UE2_Len - 1);
begin
@@ -744,7 +778,7 @@ package body Uintp is
else
declare
- L_Length : Int := N_Digits (Left);
+ L_Length : constant Int := N_Digits (Left);
L_Vec : UI_Vector (1 .. L_Length);
Tmp_Int : Int;
Carry : Int;
@@ -818,7 +852,7 @@ package body Uintp is
else
declare
- L_Length : Int := N_Digits (Left);
+ L_Length : constant Int := N_Digits (Left);
L_Vec : UI_Vector (1 .. L_Length);
Most_Sig_Int : Int;
Least_Sig_Int : Int;
@@ -836,7 +870,6 @@ package body Uintp is
J := L_Length;
while J > Int_1 loop
-
Least_Sig_Int := Least_Sig_Int + Alt * (L_Vec (J) + Carry);
-- Least is in [-2 Base + 1 .. 2 * Base - 1]
@@ -1011,8 +1044,8 @@ package body Uintp is
-- Otherwise full circuit is needed
declare
- L_Length : Int := N_Digits (Left);
- R_Length : Int := N_Digits (Right);
+ L_Length : constant Int := N_Digits (Left);
+ R_Length : constant Int := N_Digits (Right);
L_Vec : UI_Vector (1 .. L_Length);
R_Vec : UI_Vector (1 .. R_Length);
Sum_Length : Int;
@@ -1571,39 +1604,51 @@ package body Uintp is
-----------------
function UI_From_Int (Input : Int) return Uint is
- begin
+ U : Uint;
+ begin
if Min_Direct <= Input and then Input <= Max_Direct then
return Uint (Int (Uint_Direct_Bias) + Input);
+ end if;
+
+ -- If already in the hash table, return entry
+
+ U := UI_Ints.Get (Input);
+
+ if U /= No_Uint then
+ return U;
+ end if;
-- For values of larger magnitude, compute digits into a vector and
-- call Vector_To_Uint.
- else
- declare
- Max_For_Int : constant := 3;
- -- Base is defined so that 3 Uint digits is sufficient
- -- to hold the largest possible Int value.
+ declare
+ Max_For_Int : constant := 3;
+ -- Base is defined so that 3 Uint digits is sufficient
+ -- to hold the largest possible Int value.
- V : UI_Vector (1 .. Max_For_Int);
+ V : UI_Vector (1 .. Max_For_Int);
- Temp_Integer : Int;
+ Temp_Integer : Int;
- begin
- for J in V'Range loop
- V (J) := 0;
- end loop;
+ begin
+ for J in V'Range loop
+ V (J) := 0;
+ end loop;
- Temp_Integer := Input;
+ Temp_Integer := Input;
- for J in reverse V'Range loop
- V (J) := abs (Temp_Integer rem Base);
- Temp_Integer := Temp_Integer / Base;
- end loop;
+ for J in reverse V'Range loop
+ V (J) := abs (Temp_Integer rem Base);
+ Temp_Integer := Temp_Integer / Base;
+ end loop;
- return Vector_To_Uint (V, Input < Int_0);
- end;
- end if;
+ U := Vector_To_Uint (V, Input < Int_0);
+ UI_Ints.Set (Input, U);
+ Uints_Min := Uints.Last;
+ Udigits_Min := Udigits.Last;
+ return U;
+ end;
end UI_From_Int;
------------
@@ -2183,7 +2228,7 @@ package body Uintp is
if (Right <= Uint_12) and then (Right >= Uint_Minus_12) then
- if (Left < Uint_0) then
+ if Left < Uint_0 then
Sign := -1;
else
Sign := 1;
diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads
index c982f1bb2a8..76a2633cfa1 100644
--- a/gcc/ada/uintp.ads
+++ b/gcc/ada/uintp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -71,6 +71,7 @@ package Uintp is
Uint_32 : constant Uint;
Uint_63 : constant Uint;
Uint_64 : constant Uint;
+ Uint_80 : constant Uint;
Uint_128 : constant Uint;
Uint_Minus_1 : constant Uint;
@@ -83,6 +84,9 @@ package Uintp is
Uint_Minus_8 : constant Uint;
Uint_Minus_9 : constant Uint;
Uint_Minus_12 : constant Uint;
+ Uint_Minus_36 : constant Uint;
+ Uint_Minus_63 : constant Uint;
+ Uint_Minus_80 : constant Uint;
Uint_Minus_128 : constant Uint;
-----------------
@@ -425,6 +429,7 @@ private
Uint_32 : constant Uint := Uint (Uint_Direct_Bias + 32);
Uint_63 : constant Uint := Uint (Uint_Direct_Bias + 63);
Uint_64 : constant Uint := Uint (Uint_Direct_Bias + 64);
+ Uint_80 : constant Uint := Uint (Uint_Direct_Bias + 80);
Uint_128 : constant Uint := Uint (Uint_Direct_Bias + 128);
Uint_Minus_1 : constant Uint := Uint (Uint_Direct_Bias - 1);
@@ -437,6 +442,9 @@ private
Uint_Minus_8 : constant Uint := Uint (Uint_Direct_Bias - 8);
Uint_Minus_9 : constant Uint := Uint (Uint_Direct_Bias - 9);
Uint_Minus_12 : constant Uint := Uint (Uint_Direct_Bias - 12);
+ Uint_Minus_36 : constant Uint := Uint (Uint_Direct_Bias - 36);
+ Uint_Minus_63 : constant Uint := Uint (Uint_Direct_Bias - 63);
+ Uint_Minus_80 : constant Uint := Uint (Uint_Direct_Bias - 80);
Uint_Minus_128 : constant Uint := Uint (Uint_Direct_Bias - 128);
type Save_Mark is record
diff --git a/gcc/ada/uintp.h b/gcc/ada/uintp.h
index bc560912b4b..35f5c9f8bc8 100644
--- a/gcc/ada/uintp.h
+++ b/gcc/ada/uintp.h
@@ -6,8 +6,7 @@
* *
* C Header File *
* *
- * *
- * Copyright (C) 1992-2001, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2002, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -38,21 +37,21 @@ struct Uint_Entry
/* See if a Uint is within the range of an integer. */
#define UI_Is_In_Int_Range uintp__ui_is_in_int_range
-extern Boolean UI_Is_In_Int_Range PARAMS((Uint));
+extern Boolean UI_Is_In_Int_Range (Uint);
/* Obtain Int value from Uint input. This will abort if the result is
out of range. */
#define UI_To_Int uintp__ui_to_int
-extern Int UI_To_Int PARAMS((Uint));
+extern Int UI_To_Int (Uint);
/* Convert an Int into a Uint. */
#define UI_From_Int uintp__ui_from_int
-extern Uint UI_From_Int PARAMS((int));
+extern Uint UI_From_Int (int);
/* Similarly, but return a GCC INTEGER_CST. Overflow is tested by the
constant-folding used to build the node. TYPE is the GCC type of the
resulting node. */
-extern tree UI_To_gnu PARAMS((Uint, tree));
+extern tree UI_To_gnu (Uint, tree);
/* Universal integers are represented by the Uint type which is an index into
the Uints_Ptr table containing Uint_Entry values. A Uint_Entry contains an
diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb
index e0471ea89bc..4675a013688 100644
--- a/gcc/ada/uname.adb
+++ b/gcc/ada/uname.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -225,7 +225,7 @@ package body Uname is
-------------------
procedure Add_Node_Name (Node : Node_Id) is
- Kind : Node_Kind := Nkind (Node);
+ Kind : constant Node_Kind := Nkind (Node);
begin
-- Just ignore an error node (someone else will give a message)
@@ -536,7 +536,7 @@ package body Uname is
Get_Name_String (Old);
declare
- Child : String := Name_Buffer (1 .. Name_Len);
+ Child : constant String := Name_Buffer (1 .. Name_Len);
begin
Get_Name_String (Newp);
diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb
index 4c745093efd..b484a135be5 100644
--- a/gcc/ada/urealp.adb
+++ b/gcc/ada/urealp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
@@ -55,7 +55,6 @@ package body Urealp is
Negative : Boolean;
-- Flag set if value is negative
-
end record;
package Ureals is new Table.Table (
@@ -69,16 +68,20 @@ package body Urealp is
-- The following universal reals are the values returned by the constant
-- functions. They are initialized by the initialization procedure.
- UR_M_0 : Ureal;
UR_0 : Ureal;
+ UR_M_0 : Ureal;
UR_Tenth : Ureal;
UR_Half : Ureal;
UR_1 : Ureal;
UR_2 : Ureal;
UR_10 : Ureal;
+ UR_10_36 : Ureal;
+ UR_M_10_36 : Ureal;
UR_100 : Ureal;
UR_2_128 : Ureal;
+ UR_2_80 : Ureal;
UR_2_M_128 : Ureal;
+ UR_2_M_80 : Ureal;
Num_Ureal_Constants : constant := 10;
-- This is used for an assertion check in Tree_Read and Tree_Write to
@@ -169,7 +172,6 @@ package body Urealp is
return UI_Decimal_Digits_Hi (Val.Num) -
Equivalent_Decimal_Exponent (Val) + 1;
end if;
-
end Decimal_Exponent_Hi;
-------------------------
@@ -209,7 +211,6 @@ package body Urealp is
return UI_Decimal_Digits_Lo (Val.Num) -
Equivalent_Decimal_Exponent (Val) - 1;
end if;
-
end Decimal_Exponent_Lo;
-----------------
@@ -266,9 +267,13 @@ package body Urealp is
UR_1 := UR_From_Components (Uint_1, Uint_1, 0, False);
UR_2 := UR_From_Components (Uint_1, Uint_Minus_1, 2, False);
UR_10 := UR_From_Components (Uint_1, Uint_Minus_1, 10, False);
+ UR_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, False);
+ UR_M_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, True);
UR_100 := UR_From_Components (Uint_1, Uint_Minus_2, 10, False);
UR_2_128 := UR_From_Components (Uint_1, Uint_Minus_128, 2, False);
UR_2_M_128 := UR_From_Components (Uint_1, Uint_128, 2, False);
+ UR_2_80 := UR_From_Components (Uint_1, Uint_Minus_80, 2, False);
+ UR_2_M_80 := UR_From_Components (Uint_1, Uint_80, 2, False);
end Initialize;
----------------
@@ -607,7 +612,7 @@ package body Urealp is
----------------
function UR_Ceiling (Real : Ureal) return Uint is
- Val : Ureal_Entry := Normalize (Ureals.Table (Real));
+ Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
begin
if Val.Negative then
@@ -770,9 +775,9 @@ package body Urealp is
---------------------
function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal is
+ X : constant Uint := abs N;
Bas : Ureal;
Val : Ureal_Entry;
- X : Uint := abs N;
Neg : Boolean;
IBas : Uint;
@@ -850,7 +855,7 @@ package body Urealp is
--------------
function UR_Floor (Real : Ureal) return Uint is
- Val : Ureal_Entry := Normalize (Ureals.Table (Real));
+ Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
begin
if Val.Negative then
@@ -860,9 +865,9 @@ package body Urealp is
end if;
end UR_Floor;
- -------------------------
- -- UR_From_Components --
- -------------------------
+ ------------------------
+ -- UR_From_Components --
+ ------------------------
function UR_From_Components
(Num : Uint;
@@ -1164,7 +1169,6 @@ package body Urealp is
Rbase => 0,
Negative => Rneg)));
end if;
-
end UR_Mul;
-----------
@@ -1260,7 +1264,7 @@ package body Urealp is
----------------
function UR_To_Uint (Real : Ureal) return Uint is
- Val : Ureal_Entry := Normalize (Ureals.Table (Real));
+ Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
Res : Uint;
begin
@@ -1305,11 +1309,8 @@ package body Urealp is
end if;
-- Constants in base 10 can be written in normal Ada literal style
- -- If the literal is negative enclose in parens to emphasize that
- -- it is part of the constant, and not a separate negation operator
if Val.Rbase = 10 then
-
UI_Write (Val.Num / 10);
Write_Char ('.');
UI_Write (Val.Num mod 10);
@@ -1374,7 +1375,6 @@ package body Urealp is
if Val.Negative then
Write_Char (')');
end if;
-
end UR_Write;
-------------
@@ -1423,6 +1423,24 @@ package body Urealp is
end Ureal_100;
-----------------
+ -- Ureal_10_36 --
+ -----------------
+
+ function Ureal_10_36 return Ureal is
+ begin
+ return UR_10_36;
+ end Ureal_10_36;
+
+ -------------------
+ -- Ureal_M_10_36 --
+ -------------------
+
+ function Ureal_M_10_36 return Ureal is
+ begin
+ return UR_M_10_36;
+ end Ureal_M_10_36;
+
+ -----------------
-- Ureal_2_128 --
-----------------
@@ -1431,6 +1449,15 @@ package body Urealp is
return UR_2_128;
end Ureal_2_128;
+ ----------------
+ -- Ureal_2_80 --
+ ----------------
+
+ function Ureal_2_80 return Ureal is
+ begin
+ return UR_2_80;
+ end Ureal_2_80;
+
-------------------
-- Ureal_2_M_128 --
-------------------
@@ -1440,6 +1467,15 @@ package body Urealp is
return UR_2_M_128;
end Ureal_2_M_128;
+ -------------------
+ -- Ureal_2_M_80 --
+ -------------------
+
+ function Ureal_2_M_80 return Ureal is
+ begin
+ return UR_2_M_80;
+ end Ureal_2_M_80;
+
----------------
-- Ureal_Half --
----------------
diff --git a/gcc/ada/urealp.ads b/gcc/ada/urealp.ads
index 21bda9234cf..05b847d4e3c 100644
--- a/gcc/ada/urealp.ads
+++ b/gcc/ada/urealp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- 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- --
@@ -110,12 +110,24 @@ package Urealp is
function Ureal_100 return Ureal;
-- Returns value 100.0
+ function Ureal_2_80 return Ureal;
+ -- Returns value 2.0 ** 80
+
+ function Ureal_2_M_80 return Ureal;
+ -- Returns value 2.0 ** (-80)
+
function Ureal_2_128 return Ureal;
-- Returns value 2.0 ** 128
function Ureal_2_M_128 return Ureal;
-- Returns value 2.0 ** (-128)
+ function Ureal_10_36 return Ureal;
+ -- Returns value 10.0 ** 36
+
+ function Ureal_M_10_36 return Ureal;
+ -- Returns value -(10.0
+
-----------------
-- Subprograms --
-----------------
diff --git a/gcc/ada/urealp.h b/gcc/ada/urealp.h
index 3d96cbcb199..1153f250e15 100644
--- a/gcc/ada/urealp.h
+++ b/gcc/ada/urealp.h
@@ -6,8 +6,7 @@
* *
* C Header File *
* *
- * *
- * Copyright (C) 1992-2001 Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2002 Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -31,22 +30,21 @@
/* Support for universal real arithmetic. */
#define Numerator urealp__numerator
-extern Uint Numerator PARAMS ((Ureal));
+extern Uint Numerator (Ureal);
#define Denominator urealp__denominator
-extern Uint Denominator PARAMS ((Ureal));
+extern Uint Denominator (Ureal);
#define Rbase urealp__rbase
-extern Nat Rbase PARAMS ((Ureal));
+extern Nat Rbase (Ureal);
#define UR_Is_Negative urealp__ur_is_negative
-extern Boolean UR_Is_Negative PARAMS ((Ureal));
+extern Boolean UR_Is_Negative (Ureal);
#define UR_Is_Zero urealp__ur_is_zero
-extern Boolean UR_Is_Zero PARAMS ((Ureal));
+extern Boolean UR_Is_Zero (Ureal);
enum Rounding_Mode {Floor = 0, Ceiling = 1, Round = 2, Round_Even = 3};
#define Machine eval_fat__machine
-extern Ureal Machine PARAMS ((Entity_Id, Ureal,
- enum Rounding_Mode));
+extern Ureal Machine (Entity_Id, Ureal, enum Rounding_Mode);
diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb
index 9da5bda3750..dad6005376b 100644
--- a/gcc/ada/usage.adb
+++ b/gcc/ada/usage.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- --
@@ -140,7 +140,7 @@ begin
-- Line for -gnatd switch
Write_Switch_Char ("d?");
- Write_Line ("Compiler debug option ? (a-z,A-Z,0-9), see debug.adb");
+ Write_Line ("Compiler debug option ? ([.]a-z,A-Z,0-9), see debug.adb");
-- Line for -gnatD switch
@@ -149,13 +149,28 @@ begin
-- Line for -gnatec switch
- Write_Switch_Char ("ec?");
- Write_Line ("Specify configuration pragmas file, e.g. -gnatec/x/f.adc");
+ Write_Switch_Char ("ec=?");
+ Write_Line ("Specify configuration pragmas file, e.g. -gnatec=/x/f.adc");
+
+ -- Line for -gnateD switch
+
+ Write_Switch_Char ("eD?");
+ Write_Line ("Define or redefine preprocessing symbol, e.g. -gnateDsym=val");
+
+ -- Line for -gnatef switch
+
+ Write_Switch_Char ("ef");
+ Write_Line ("Full source path in brief error messages");
-- Line for -gnatem switch
- Write_Switch_Char ("em?");
- Write_Line ("Specify mapping file, e.g. -gnatemmapping");
+ Write_Switch_Char ("em=?");
+ Write_Line ("Specify mapping file, e.g. -gnatem=mapping");
+
+ -- Line for -gnatep switch
+
+ Write_Switch_Char ("ep=?");
+ Write_Line ("Specify preprocessing data file, e.g. -gnatep=prep.data");
-- Line for -gnatE switch
@@ -210,7 +225,7 @@ begin
-- Line for -gnatm switch
Write_Switch_Char ("mnnn");
- Write_Line ("Limit number of detected errors to nnn (1-999)");
+ Write_Line ("Limit number of detected errors to nnn (1-999999)");
-- Line for -gnatn switch
@@ -305,6 +320,8 @@ begin
Write_Line (" M turn off checking for in out params");
Write_Line (" o turn on checking for operators/attributes");
Write_Line (" O turn off checking for operators/attributes");
+ Write_Line (" p turn on checking for parameters");
+ Write_Line (" P turn off checking for parameters");
Write_Line (" r turn on checking for returns");
Write_Line (" R turn off checking for returns");
Write_Line (" s turn on checking for subscripts");
@@ -317,32 +334,53 @@ begin
Write_Switch_Char ("wxx");
Write_Line ("Enable selected warning modes, xx = list of parameters:");
- Write_Line (" a turn on all optional warnings (except b,d,h)");
+ Write_Line (" a turn on all optional warnings (except b,d,h,l)");
Write_Line (" A turn off all optional warnings");
- Write_Line (" b turn on biased rounding warnings");
- Write_Line (" B turn off biased rounding warnings");
- Write_Line (" c turn on constant conditional warnings");
- Write_Line (" C* turn off constant conditional warnings");
- Write_Line (" d turn on implicit dereference warnings");
- Write_Line (" D* turn off implicit dereference warnings");
+ Write_Line (" c turn on warnings for constant conditional");
+ Write_Line (" C* turn off warnings for constant conditional");
+ Write_Line (" d turn on warnings for implicit dereference");
+ Write_Line (" D* turn off warnings for implicit dereference");
Write_Line (" e treat all warnings as errors");
- Write_Line (" f turn on unreferenced formal warnings");
- Write_Line (" F* turn off unreferenced formal warnings");
- Write_Line (" h turn on warnings for hiding variables");
- Write_Line (" H* turn off warnings for hiding variables");
- Write_Line (" i* turn on warnings for implementation units");
- Write_Line (" I turn off warnings for implementation units");
- Write_Line (" l turn on elaboration warnings");
- Write_Line (" L* turn off elaboration warnings");
- Write_Line (" o* turn on address clause overlay warnings");
- Write_Line (" O turn off address clause overlay warnings");
+ Write_Line (" f turn on warnings for unreferenced formal");
+ Write_Line (" F* turn off warnings for unreferenced formal");
+ Write_Line (" g* turn on warnings for unrecognized pragma");
+ Write_Line (" G turn off warnings for unrecognized pragma");
+ Write_Line (" h turn on warnings for hiding variable ");
+ Write_Line (" H* turn off warnings for hiding variable");
+ Write_Line (" i* turn on warnings for implementation unit");
+ Write_Line (" I turn off warnings for implementation unit");
+ Write_Line (" j turn on warnings for obsolescent " &
+ "(annex J) feature");
+ Write_Line (" J* turn off warnings for obsolescent " &
+ "(annex J) feature");
+ Write_Line (" k turn on warnings on constant variable");
+ Write_Line (" K* turn off warnings on constant variable");
+ Write_Line (" l turn on warnings for missing " &
+ "elaboration pragma");
+ Write_Line (" L* turn off warnings for missing " &
+ "elaboration pragma");
+ Write_Line (" m turn on warnings for variable assigned " &
+ "but not read");
+ Write_Line (" M* turn off warnings for variable assigned " &
+ "but not read");
+ Write_Line (" n* normal warning mode (cancels -gnatws/-gnatwe)");
+ Write_Line (" o* turn on warnings for address clause overlay");
+ Write_Line (" O turn off warnings for address clause overlay");
Write_Line (" p turn on warnings for ineffective pragma inline");
Write_Line (" P* turn off warnings for ineffective pragma inline");
- Write_Line (" r turn on redundant construct warnings");
- Write_Line (" R* turn off redundant construct warnings");
+ Write_Line (" r turn on warnings for redundant construct");
+ Write_Line (" R* turn off warnings for redundant construct");
Write_Line (" s suppress all warnings");
- Write_Line (" u turn on warnings for unused entities");
- Write_Line (" U* turn off warnings for unused entities");
+ Write_Line (" u turn on warnings for unused entity");
+ Write_Line (" U* turn off warnings for unused entity");
+ Write_Line (" v* turn on warnings for unassigned variable");
+ Write_Line (" V turn off warnings for unassigned variable");
+ Write_Line (" x* turn on warnings for export/import");
+ Write_Line (" X* turn off warnings for export/import");
+ Write_Line (" z* turn on size/align warnings for " &
+ "unchecked conversion");
+ Write_Line (" Z turn off size/align warnings for " &
+ "unchecked conversion");
Write_Line (" * indicates default in above list");
-- Line for -gnatW switch
@@ -387,21 +425,21 @@ begin
Write_Line (" f check no form feeds/vertical tabs in source");
Write_Line (" h check no horizontal tabs in source");
Write_Line (" i check if-then layout");
- Write_Line (" k check casing rules for keywords, identifiers");
+ Write_Line (" k check casing rules for keywords");
Write_Line (" l check reference manual layout");
Write_Line (" m check line length <= 79 characters");
Write_Line (" n check casing of package Standard identifiers");
Write_Line (" Mnnn check line length <= nnn characters");
Write_Line (" o check subprogram bodies in alphabetical order");
Write_Line (" p check pragma casing");
- Write_Line (" r check RM column layout");
+ Write_Line (" r check casing for identifier references");
Write_Line (" s check separate subprogram specs present");
Write_Line (" t check token separation rules");
-- Lines for -gnatz switch
Write_Switch_Char ("z");
- Write_Line ("Distribution stub generation (r/s for receiver/sender stubs)");
+ Write_Line ("Distribution stub generation (r/c for receiver/caller stubs)");
-- Line for -gnatZ switch
diff --git a/gcc/ada/utils.c b/gcc/ada/utils.c
index 186b0fdb175..c1c5ccf4ce4 100644
--- a/gcc/ada/utils.c
+++ b/gcc/ada/utils.c
@@ -6,7 +6,6 @@
* *
* C Implementation File *
* *
- * *
* Copyright (C) 1992-2003, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
@@ -154,18 +153,16 @@ static tree convert_to_fat_pointer PARAMS ((tree, tree));
static tree convert_to_thin_pointer PARAMS ((tree, tree));
static tree make_descriptor_field PARAMS ((const char *,tree, tree,
tree));
+static int value_factor_p PARAMS ((tree, int));
+static int potential_alignment_gap PARAMS ((tree, tree, tree));
/* Initialize the association of GNAT nodes to GCC trees. */
void
init_gnat_to_gnu ()
{
- Node_Id gnat_node;
-
- associate_gnat_to_gnu = (tree *) ggc_alloc (max_gnat_nodes * sizeof (tree));
-
- for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++)
- associate_gnat_to_gnu[gnat_node] = NULL_TREE;
+ associate_gnat_to_gnu
+ = (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree));
pending_elaborations = build_tree_list (NULL_TREE, NULL_TREE);
}
@@ -182,6 +179,10 @@ save_gnu_tree (gnat_entity, gnu_decl, no_check)
tree gnu_decl;
int no_check;
{
+ /* Check that GNAT_ENTITY is not already defined and that it is being set
+ to something which is a decl. Raise gigi 401 if not. Usually, this
+ means GNAT_ENTITY is defined twice, but occasionally is due to some
+ Gigi problem. */
if (gnu_decl
&& (associate_gnat_to_gnu[gnat_entity - First_Node_Id]
|| (! no_check && ! DECL_P (gnu_decl))))
@@ -491,9 +492,11 @@ gnat_init_decl_processing ()
build_common_tree_nodes (0);
/* In Ada, we use a signed type for SIZETYPE. Use the signed type
- corresponding to the size of ptr_mode. Make this here since we need
+ corresponding to the size of Pmode. In most cases when ptr_mode and
+ Pmode differ, C will use the width of ptr_mode as sizetype. But we get
+ far better code using the width of Pmode. Make this here since we need
this before we can expand the GNAT types. */
- set_sizetype (gnat_type_for_size (GET_MODE_BITSIZE (ptr_mode), 0));
+ set_sizetype (gnat_type_for_size (GET_MODE_BITSIZE (Pmode), 0));
build_common_tree_nodes_2 (0);
pushdecl (build_decl (TYPE_DECL, get_identifier (SIZE_TYPE), sizetype));
@@ -562,7 +565,6 @@ init_gigi_decls (long_long_float_type, exception_type)
NULL_TREE, 0, 1, 1, 0);
/* free is a function declaration tree for a function to free memory. */
-
free_decl
= create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
build_function_type (void_type_node,
@@ -611,6 +613,23 @@ init_gigi_decls (long_long_float_type, exception_type)
endlink)),
NULL_TREE, 0, 1, 1, 0);
+ /* Hooks to call when entering/leaving an exception handler. */
+ begin_handler_decl
+ = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
+ build_function_type (void_type_node,
+ tree_cons (NULL_TREE,
+ ptr_void_type_node,
+ endlink)),
+ NULL_TREE, 0, 1, 1, 0);
+
+ end_handler_decl
+ = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
+ build_function_type (void_type_node,
+ tree_cons (NULL_TREE,
+ ptr_void_type_node,
+ endlink)),
+ NULL_TREE, 0, 1, 1, 0);
+
/* If in no exception handlers mode, all raise statements are redirected to
__gnat_last_chance_handler. No need to redefine raise_nodefer_decl, since
this procedure will never be called in this mode. */
@@ -681,19 +700,6 @@ init_gigi_decls (long_long_float_type, exception_type)
main_identifier_node = get_identifier ("main");
}
-/* This function is called indirectly from toplev.c to handle incomplete
- declarations, i.e. VAR_DECL nodes whose DECL_SIZE is zero. To be precise,
- compile_file in toplev.c makes an indirect call through the function pointer
- incomplete_decl_finalize_hook which is initialized to this routine in
- init_decl_processing. */
-
-void
-gnat_finish_incomplete_decl (dont_care)
- tree dont_care ATTRIBUTE_UNUSED;
-{
- gigi_abort (405);
-}
-
/* Given a record type (RECORD_TYPE) and a chain of FIELD_DECL
nodes (FIELDLIST), finish constructing the record or union type.
If HAS_REP is nonzero, this record has a rep clause; don't call
@@ -741,6 +747,10 @@ finish_record_type (record_type, fieldlist, has_rep, defer_debug)
TYPE_SIZE (record_type) = bitsize_zero_node;
TYPE_SIZE_UNIT (record_type) = size_zero_node;
}
+ /* For all-repped records with a size specified, lay the QUAL_UNION_TYPE
+ out just like a UNION_TYPE, since the size will be fixed. */
+ else if (code == QUAL_UNION_TYPE)
+ code = UNION_TYPE;
}
else
{
@@ -847,29 +857,31 @@ finish_record_type (record_type, fieldlist, has_rep, defer_debug)
&& ! TYPE_CONTAINS_TEMPLATE_P (record_type))
SET_TYPE_ADA_SIZE (record_type, ada_size);
- size = round_up (size, TYPE_ALIGN (record_type));
- size_unit = round_up (size_unit, TYPE_ALIGN (record_type) / BITS_PER_UNIT);
-
- if (has_rep
- && ! (TREE_CODE (record_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (record_type)
- && TREE_CODE (size) != INTEGER_CST
- && contains_placeholder_p (size)))
+ if (has_rep)
{
- TYPE_SIZE (record_type) = size;
- TYPE_SIZE_UNIT (record_type) = size_unit;
- }
+ if (! (TREE_CODE (record_type) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (record_type)
+ && CONTAINS_PLACEHOLDER_P (size)))
+ {
+ TYPE_SIZE (record_type) = round_up (size, TYPE_ALIGN (record_type));
+ TYPE_SIZE_UNIT (record_type)
+ = round_up (size_unit,
+ TYPE_ALIGN (record_type) / BITS_PER_UNIT);
+ }
- if (has_rep)
- compute_record_mode (record_type);
+ compute_record_mode (record_type);
+ }
if (! defer_debug)
{
/* If this record is of variable size, rename it so that the
debugger knows it is and make a new, parallel, record
that tells the debugger how the record is laid out. See
- exp_dbug.ads. */
- if (var_size)
+ exp_dbug.ads. But don't do this for records that are padding
+ since they confuse GDB. */
+ if (var_size
+ && ! (TREE_CODE (record_type) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (record_type)))
{
tree new_record_type
= make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE
@@ -881,6 +893,7 @@ finish_record_type (record_type, fieldlist, has_rep, defer_debug)
? "XVU" : "XVE");
tree last_pos = bitsize_zero_node;
tree old_field;
+ tree prev_old_field = 0;
TYPE_NAME (new_record_type) = new_id;
TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT;
@@ -940,6 +953,13 @@ finish_record_type (record_type, fieldlist, has_rep, defer_debug)
pos = compute_related_constant (curpos,
round_up (last_pos, align));
}
+ else if (potential_alignment_gap (prev_old_field, old_field,
+ pos))
+ {
+ align = TYPE_ALIGN (field_type);
+ pos = compute_related_constant (curpos,
+ round_up (last_pos, align));
+ }
/* If we can't compute a position, set it to zero.
@@ -987,6 +1007,7 @@ finish_record_type (record_type, fieldlist, has_rep, defer_debug)
== QUAL_UNION_TYPE)
? bitsize_zero_node
: DECL_SIZE (old_field));
+ prev_old_field = old_field;
}
TYPE_FIELDS (new_record_type)
@@ -1016,26 +1037,33 @@ merge_sizes (last_size, first_bit, size, special, has_rep)
int has_rep;
{
tree type = TREE_TYPE (last_size);
+ tree new;
if (! special || TREE_CODE (size) != COND_EXPR)
{
- tree new = size_binop (PLUS_EXPR, first_bit, size);
-
+ new = size_binop (PLUS_EXPR, first_bit, size);
if (has_rep)
new = size_binop (MAX_EXPR, last_size, new);
-
- return new;
}
- return fold (build (COND_EXPR, type, TREE_OPERAND (size, 0),
- integer_zerop (TREE_OPERAND (size, 1))
- ? last_size : merge_sizes (last_size, first_bit,
- TREE_OPERAND (size, 1),
- 1, has_rep),
- integer_zerop (TREE_OPERAND (size, 2))
+ else
+ new = fold (build (COND_EXPR, type, TREE_OPERAND (size, 0),
+ integer_zerop (TREE_OPERAND (size, 1))
+ ? last_size : merge_sizes (last_size, first_bit,
+ TREE_OPERAND (size, 1),
+ 1, has_rep),
+ integer_zerop (TREE_OPERAND (size, 2))
? last_size : merge_sizes (last_size, first_bit,
TREE_OPERAND (size, 2),
1, has_rep)));
+
+ /* We don't need any NON_VALUE_EXPRs and they can confuse us (especially
+ when fed through substitute_in_expr) into thinking that a constant
+ size is not constant. */
+ while (TREE_CODE (new) == NON_LVALUE_EXPR)
+ new = TREE_OPERAND (new, 0);
+
+ return new;
}
/* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
@@ -1060,24 +1088,26 @@ compute_related_constant (op0, op1)
/* Utility function of above to split a tree OP which may be a sum, into a
constant part, which is returned, and a variable part, which is stored
- in *PVAR. *PVAR may be size_zero_node. All operations must be of
- sizetype. */
+ in *PVAR. *PVAR may be bitsize_zero_node. All operations must be of
+ bitsizetype. */
static tree
split_plus (in, pvar)
tree in;
tree *pvar;
{
- tree result = bitsize_zero_node;
+ /* Strip NOPS in order to ease the tree traversal and maximize the
+ potential for constant or plus/minus discovery. We need to be careful
+ to always return and set *pvar to bitsizetype trees, but it's worth
+ the effort. */
+ STRIP_NOPS (in);
- while (TREE_CODE (in) == NON_LVALUE_EXPR)
- in = TREE_OPERAND (in, 0);
+ *pvar = convert (bitsizetype, in);
- *pvar = in;
if (TREE_CODE (in) == INTEGER_CST)
{
*pvar = bitsize_zero_node;
- return in;
+ return convert (bitsizetype, in);
}
else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR)
{
@@ -1085,15 +1115,12 @@ split_plus (in, pvar)
tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var);
tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var);
- result = size_binop (PLUS_EXPR, result, lhs_con);
- result = size_binop (TREE_CODE (in), result, rhs_con);
-
if (lhs_var == TREE_OPERAND (in, 0)
&& rhs_var == TREE_OPERAND (in, 1))
return bitsize_zero_node;
*pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var);
- return result;
+ return size_binop (TREE_CODE (in), lhs_con, rhs_con);
}
else
return bitsize_zero_node;
@@ -1385,16 +1412,9 @@ create_field_decl (field_name, field_type, record_type, packed, size, pos,
TREE_READONLY (field_decl) = TREE_READONLY (field_type);
/* If FIELD_TYPE is BLKmode, we must ensure this is aligned to at least a
- byte boundary since GCC cannot handle less-aligned BLKmode bitfields.
- If it is a padding type where the inner field is of variable size, it
- must be at its natural alignment. Just handle the packed case here; we
- will disallow non-aligned rep clauses elsewhere. */
+ byte boundary since GCC cannot handle less-aligned BLKmode bitfields. */
if (packed && TYPE_MODE (field_type) == BLKmode)
- DECL_ALIGN (field_decl)
- = ((TREE_CODE (field_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (field_type)
- && ! TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (field_type))))
- ? TYPE_ALIGN (field_type) : BITS_PER_UNIT);
+ DECL_ALIGN (field_decl) = BITS_PER_UNIT;
/* If a size is specified, use it. Otherwise, see if we have a size
to use that may differ from the natural size of the object. */
@@ -1478,6 +1498,11 @@ create_field_decl (field_name, field_type, record_type, packed, size, pos,
if (must_pass_by_ref (field_type) || default_pass_by_ref (field_type))
addressable = 1;
+ /* ??? For now, we say that any field of aggregate type is addressable
+ because the front end may take 'Reference of it. */
+ if (AGGREGATE_TYPE_P (field_type))
+ addressable = 1;
+
/* Mark the decl as nonaddressable if it either is indicated so semantically
or if it is a bit field. */
DECL_NONADDRESSABLE_P (field_decl)
@@ -1512,6 +1537,30 @@ create_param_decl (param_name, param_type, readonly)
{
tree param_decl = build_decl (PARM_DECL, param_name, param_type);
+ /* Honor the PROMOTE_PROTOTYPES target macro, as not doing so can
+ lead to various ABI violations. */
+#ifdef PROMOTE_PROTOTYPES
+ if ((TREE_CODE (param_type) == INTEGER_TYPE
+ || TREE_CODE (param_type) == ENUMERAL_TYPE)
+ && TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node))
+ {
+ /* We have to be careful about biased types here. Make a subtype
+ of integer_type_node with the proper biasing. */
+ if (TREE_CODE (param_type) == INTEGER_TYPE
+ && TYPE_BIASED_REPRESENTATION_P (param_type))
+ {
+ param_type
+ = copy_type (build_range_type (integer_type_node,
+ TYPE_MIN_VALUE (param_type),
+ TYPE_MAX_VALUE (param_type)));
+
+ TYPE_BIASED_REPRESENTATION_P (param_type) = 1;
+ }
+ else
+ param_type = integer_type_node;
+ }
+#endif
+
DECL_ARG_TYPE (param_decl) = param_type;
DECL_ARG_TYPE_AS_WRITTEN (param_decl) = param_type;
TREE_READONLY (param_decl) = readonly;
@@ -1588,6 +1637,73 @@ get_pending_elaborations ()
return result;
}
+/* Return true if VALUE is a multiple of FACTOR. FACTOR must be a power
+ of 2. */
+
+static int
+value_factor_p (value, factor)
+ tree value;
+ int factor;
+{
+ if (host_integerp (value, 1))
+ return tree_low_cst (value, 1) % factor == 0;
+
+ if (TREE_CODE (value) == MULT_EXPR)
+ return (value_factor_p (TREE_OPERAND (value, 0), factor)
+ || value_factor_p (TREE_OPERAND (value, 1), factor));
+
+ return 0;
+}
+
+/* Given 2 consecutive field decls PREV_FIELD and CURR_FIELD, return true
+ unless we can prove these 2 fields are laid out in such a way that no gap
+ exist between the end of PREV_FIELD and the begining of CURR_FIELD. OFFSET
+ is the distance in bits between the end of PREV_FIELD and the starting
+ position of CURR_FIELD. It is ignored if null. */
+
+static int
+potential_alignment_gap (prev_field, curr_field, offset)
+ tree prev_field;
+ tree curr_field;
+ tree offset;
+{
+ /* If this is the first field of the record, there cannot be any gap */
+ if (!prev_field)
+ return 0;
+
+ /* If the previous field is a union type, then return False: The only
+ time when such a field is not the last field of the record is when
+ there are other components at fixed positions after it (meaning there
+ was a rep clause for every field), in which case we don't want the
+ alignment constraint to override them. */
+ if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE)
+ return 0;
+
+ /* If the distance between the end of prev_field and the begining of
+ curr_field is constant, then there is a gap if the value of this
+ constant is not null. */
+ if (offset && host_integerp (offset, 1))
+ return (!integer_zerop (offset));
+
+ /* If the size and position of the previous field are constant,
+ then check the sum of this size and position. There will be a gap
+ iff it is not multiple of the current field alignment. */
+ if (host_integerp (DECL_SIZE (prev_field), 1)
+ && host_integerp (bit_position (prev_field), 1))
+ return ((tree_low_cst (bit_position (prev_field), 1)
+ + tree_low_cst (DECL_SIZE (prev_field), 1))
+ % DECL_ALIGN (curr_field) != 0);
+
+ /* If both the position and size of the previous field are multiples
+ of the current field alignment, there can not be any gap. */
+ if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
+ && value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
+ return 0;
+
+ /* Fallback, return that there may be a potential gap */
+ return 1;
+}
+
/* Return nonzero if there are pending elaborations. */
int
@@ -2052,10 +2168,9 @@ max_size (exp, max_p)
case 'r':
/* If this contains a PLACEHOLDER_EXPR, it is the thing we want to
- modify. Otherwise, we abort since it is something we can't
- handle. */
- if (! contains_placeholder_p (exp))
- gigi_abort (406);
+ modify. Otherwise, we treat it like a variable. */
+ if (! CONTAINS_PLACEHOLDER_P (exp))
+ return exp;
type = TREE_TYPE (TREE_OPERAND (exp, 1));
return
@@ -2102,7 +2217,7 @@ max_size (exp, max_p)
else if (max_p && code == MIN_EXPR && TREE_OVERFLOW (lhs))
return rhs;
else if ((code == MINUS_EXPR || code == PLUS_EXPR)
- && (TREE_OVERFLOW (lhs)
+ && ((TREE_CONSTANT (lhs) && TREE_OVERFLOW (lhs))
|| operand_equal_p (lhs, TYPE_MAX_VALUE (type), 0))
&& ! TREE_CONSTANT (rhs))
return lhs;
@@ -2183,9 +2298,9 @@ build_template (template_type, array_type, expr)
/* If either MIN or MAX involve a PLACEHOLDER_EXPR, we must
surround them with a WITH_RECORD_EXPR giving EXPR as the
OBJECT. */
- if (! TREE_CONSTANT (min) && contains_placeholder_p (min))
+ if (CONTAINS_PLACEHOLDER_P (min))
min = build (WITH_RECORD_EXPR, TREE_TYPE (min), min, expr);
- if (! TREE_CONSTANT (max) && contains_placeholder_p (max))
+ if (CONTAINS_PLACEHOLDER_P (max))
max = build (WITH_RECORD_EXPR, TREE_TYPE (max), max, expr);
template_elts = tree_cons (TREE_CHAIN (field), max,
@@ -2552,17 +2667,39 @@ update_pointer_to (old_type, new_type)
type = TYPE_NEXT_VARIANT (type))
update_pointer_to (type, new_type);
- /* If no pointer or reference, we are done. Otherwise, get the new type with
- the same qualifiers as the old type and see if it is the same as the old
- type. */
+ /* If no pointer or reference, we are done. */
if (ptr == 0 && ref == 0)
return;
- new_type = build_qualified_type (new_type, TYPE_QUALS (old_type));
+ /* Merge the old type qualifiers in the new type.
+
+ Each old variant has qualifiers for specific reasons, and the new
+ designated type as well. Each set of qualifiers represents useful
+ information grabbed at some point, and merging the two simply unifies
+ these inputs into the final type description.
+
+ Consider for instance a volatile type frozen after an access to constant
+ type designating it. After the designated type freeze, we get here with a
+ volatile new_type and a dummy old_type with a readonly variant, created
+ when the access type was processed. We shall make a volatile and readonly
+ designated type, because that's what it really is.
+
+ We might also get here for a non-dummy old_type variant with different
+ qualifiers than the new_type ones, for instance in some cases of pointers
+ to private record type elaboration (see the comments around the call to
+ this routine from gnat_to_gnu_entity/E_Access_Type). We have to merge the
+ qualifiers in thoses cases too, to avoid accidentally discarding the
+ initial set, and will often end up with old_type == new_type then. */
+ new_type = build_qualified_type (new_type,
+ TYPE_QUALS (old_type)
+ | TYPE_QUALS (new_type));
+
+ /* If the new type and the old one are identical, there is nothing to
+ update. */
if (old_type == new_type)
return;
- /* First handle the simple case. */
+ /* Otherwise, first handle the simple case. */
if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE)
{
if (ptr != 0)
@@ -2699,12 +2836,24 @@ convert_to_fat_pointer (type, expr)
template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
- /* The result is a CONSTRUCTOR for the fat pointer. */
- return
- gnat_build_constructor (type,
- tree_cons (TYPE_FIELDS (type), expr,
- tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
- template_addr, NULL_TREE)));
+ /* The result is a CONSTRUCTOR for the fat pointer.
+
+ If expr is an argument of a foreign convention subprogram, the type it
+ points to is directly the component type. In this case, the expression
+ type may not match the corresponding FIELD_DECL type at this point, so we
+ call "convert" here to fix that up if necessary. This type consistency is
+ required, for instance because it ensures that possible later folding of
+ component_refs against this constructor always yields something of the
+ same type as the initial reference.
+
+ Note that the call to "build_template" above is still fine, because it
+ will only refer to the provided template_type in this case. */
+ return
+ gnat_build_constructor
+ (type, tree_cons (TYPE_FIELDS (type),
+ convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
+ tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
+ template_addr, NULL_TREE)));
}
/* Convert to a thin pointer type, TYPE. The only thing we know how to convert
@@ -2747,10 +2896,14 @@ convert (type, expr)
/* If EXPR is already the right type, we are done. */
if (type == etype)
return expr;
-
+ /* If we're converting between two aggregate types that have the same main
+ variant, just make a NOP_EXPR. */
+ else if (AGGREGATE_TYPE_P (type)
+ && TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))
+ return build1 (NOP_EXPR, type, expr);
/* If EXPR is a WITH_RECORD_EXPR, do the conversion inside and then make a
new one. */
- if (TREE_CODE (expr) == WITH_RECORD_EXPR)
+ else if (TREE_CODE (expr) == WITH_RECORD_EXPR)
return build (WITH_RECORD_EXPR, type,
convert (type, TREE_OPERAND (expr, 0)),
TREE_OPERAND (expr, 1));
@@ -2759,7 +2912,7 @@ convert (type, expr)
to the field. If the output type has padding, make a constructor
to build the record. If both input and output have padding and are
of variable size, do this as an unchecked conversion. */
- if (ecode == RECORD_TYPE && code == RECORD_TYPE
+ else if (ecode == RECORD_TYPE && code == RECORD_TYPE
&& TYPE_IS_PADDING_P (type) && TYPE_IS_PADDING_P (etype)
&& (! TREE_CONSTANT (TYPE_SIZE (type))
|| ! TREE_CONSTANT (TYPE_SIZE (etype))))
@@ -2797,10 +2950,9 @@ convert (type, expr)
/* If the result type is a padded type with a self-referentially-sized
field and the expression type is a record, do this as an
unchecked converstion. */
- else if (TREE_CODE (DECL_SIZE (TYPE_FIELDS (type))) != INTEGER_CST
- && contains_placeholder_p (DECL_SIZE (TYPE_FIELDS (type)))
- && TREE_CODE (etype) == RECORD_TYPE)
- return unchecked_convert (type, expr);
+ else if (TREE_CODE (etype) == RECORD_TYPE
+ && CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type))))
+ return unchecked_convert (type, expr, 0);
else
return
@@ -2827,13 +2979,17 @@ convert (type, expr)
return convert (type, build_component_ref (expr, NULL_TREE,
TYPE_FIELDS (etype)));
- /* If converting a type that does not contain a template into one
- that does, convert to the data type and then build the template. */
- if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type)
- && ! (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype)))
+ /* If converting to a type that contains a template, convert to the data
+ type and then build the template. */
+ if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type))
{
tree obj_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
+ /* If the source already has a template, get a reference to the
+ associated array only, as we are going to rebuild a template
+ for the target type anyway. */
+ expr = maybe_unconstrained_array (expr);
+
return
gnat_build_constructor
(type,
@@ -2856,6 +3012,7 @@ convert (type, expr)
/* Just set its type here. For TRANSFORM_EXPR, we will do the actual
conversion in gnat_expand_expr. NULL_EXPR does not represent
and actual value, so no conversion is needed. */
+ expr = copy_node (expr);
TREE_TYPE (expr) = type;
return expr;
@@ -2944,8 +3101,9 @@ convert (type, expr)
case INTEGER_TYPE:
if (TYPE_HAS_ACTUAL_BOUNDS_P (type)
- && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE))
- return unchecked_convert (type, expr);
+ && (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE
+ || (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))))
+ return unchecked_convert (type, expr, 0);
else if (TYPE_BIASED_REPRESENTATION_P (type))
return fold (build1 (CONVERT_EXPR, type,
fold (build (MINUS_EXPR, TREE_TYPE (type),
@@ -3009,14 +3167,22 @@ convert (type, expr)
/* In these cases, assume the front-end has validated the conversion.
If the conversion is valid, it will be a bit-wise conversion, so
it can be viewed as an unchecked conversion. */
- return unchecked_convert (type, expr);
+ return unchecked_convert (type, expr, 0);
case UNION_TYPE:
/* Just validate that the type is indeed that of a field
of the type. Then make the simple conversion. */
for (tem = TYPE_FIELDS (type); tem; tem = TREE_CHAIN (tem))
- if (TREE_TYPE (tem) == etype)
- return build1 (CONVERT_EXPR, type, expr);
+ {
+ if (TREE_TYPE (tem) == etype)
+ return build1 (CONVERT_EXPR, type, expr);
+ else if (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE
+ && (TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (tem))
+ || TYPE_IS_PADDING_P (TREE_TYPE (tem)))
+ && TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem))) == etype)
+ return build1 (CONVERT_EXPR, type,
+ convert (TREE_TYPE (tem), expr));
+ }
gigi_abort (413);
@@ -3131,17 +3297,21 @@ maybe_unconstrained_array (exp)
TREE_OPERAND (exp, 1));
case RECORD_TYPE:
- if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
+ /* If this is a padded type, convert to the unpadded type and see if
+ it contains a template. */
+ if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
{
- new
- = build_component_ref (exp, NULL_TREE,
- TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))));
+ new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE
- && TYPE_IS_PADDING_P (TREE_TYPE (new)))
- new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (new))), new);
-
- return new;
+ && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new)))
+ return
+ build_component_ref (new, NULL_TREE,
+ TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))));
}
+ else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
+ return
+ build_component_ref (exp, NULL_TREE,
+ TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))));
break;
default:
@@ -3151,12 +3321,14 @@ maybe_unconstrained_array (exp)
return exp;
}
-/* Return an expression that does an unchecked converstion of EXPR to TYPE. */
+/* Return an expression that does an unchecked converstion of EXPR to TYPE.
+ If NOTRUNC_P is set, truncation operations should be suppressed. */
tree
-unchecked_convert (type, expr)
+unchecked_convert (type, expr, notrunc_p)
tree type;
tree expr;
+ int notrunc_p;
{
tree etype = TREE_TYPE (expr);
@@ -3168,7 +3340,7 @@ unchecked_convert (type, expr)
new one. */
if (TREE_CODE (expr) == WITH_RECORD_EXPR)
return build (WITH_RECORD_EXPR, type,
- unchecked_convert (type, TREE_OPERAND (expr, 0)),
+ unchecked_convert (type, TREE_OPERAND (expr, 0), notrunc_p),
TREE_OPERAND (expr, 1));
/* If both types types are integral just do a normal conversion.
@@ -3226,7 +3398,7 @@ unchecked_convert (type, expr)
TYPE_FIELDS (rec_type) = field;
layout_type (rec_type);
- expr = unchecked_convert (rec_type, expr);
+ expr = unchecked_convert (rec_type, expr, notrunc_p);
expr = build_component_ref (expr, NULL_TREE, field);
}
@@ -3245,7 +3417,7 @@ unchecked_convert (type, expr)
layout_type (rec_type);
expr = gnat_build_constructor (rec_type, build_tree_list (field, expr));
- expr = unchecked_convert (type, expr);
+ expr = unchecked_convert (type, expr, notrunc_p);
}
/* We have a special case when we are converting between two
@@ -3269,7 +3441,8 @@ unchecked_convert (type, expr)
the result. We need not do this in the case where the input is
an integral type of the same precision and signedness or if the output
is a biased type or if both the input and output are unsigned. */
- if (INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) != 0
+ if (! notrunc_p
+ && INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) != 0
&& ! (TREE_CODE (type) == INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (type))
&& 0 != compare_tree_int (TYPE_RM_SIZE (type),
diff --git a/gcc/ada/utils2.c b/gcc/ada/utils2.c
index 1964be12276..c2ffdfbc153 100644
--- a/gcc/ada/utils2.c
+++ b/gcc/ada/utils2.c
@@ -6,7 +6,6 @@
* *
* C Implementation File *
* *
- * *
* Copyright (C) 1992-2003, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
@@ -31,6 +30,7 @@
#include "tm.h"
#include "tree.h"
#include "flags.h"
+#include "output.h"
#include "ada.h"
#include "types.h"
#include "atree.h"
@@ -137,15 +137,31 @@ get_ada_base_type (type)
/* EXP is a GCC tree representing an address. See if we can find how
strictly the object at that address is aligned. Return that alignment
- in bits. If we don't know anything about the alignment, return 0.
- We do not go merely by type information here since the check on
- N_Validate_Unchecked_Alignment does that. */
+ in bits. If we don't know anything about the alignment, return 0. */
unsigned int
known_alignment (exp)
tree exp;
{
+ unsigned int this_alignment;
unsigned int lhs, rhs;
+ unsigned int type_alignment;
+
+ /* For pointer expressions, we know that the designated object is always at
+ least as strictly aligned as the designated subtype, so we account for
+ both type and expression information in this case.
+
+ Beware that we can still get a dummy designated subtype here (e.g. Taft
+ Amendement types), in which the alignment information is meaningless and
+ should be ignored.
+
+ We always compute a type_alignment value and return the MAX of it
+ compared with what we get from the expression tree. Just set the
+ type_alignment value to 0 when the type information is to be ignored. */
+ type_alignment
+ = ((POINTER_TYPE_P (TREE_TYPE (exp))
+ && ! TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp))))
+ ? TYPE_ALIGN (TREE_TYPE (TREE_TYPE (exp))) : 0);
switch (TREE_CODE (exp))
{
@@ -154,7 +170,8 @@ known_alignment (exp)
case NON_LVALUE_EXPR:
/* Conversions between pointers and integers don't change the alignment
of the underlying object. */
- return known_alignment (TREE_OPERAND (exp, 0));
+ this_alignment = known_alignment (TREE_OPERAND (exp, 0));
+ break;
case PLUS_EXPR:
case MINUS_EXPR:
@@ -162,31 +179,40 @@ known_alignment (exp)
minimum of the two aligments. */
lhs = known_alignment (TREE_OPERAND (exp, 0));
rhs = known_alignment (TREE_OPERAND (exp, 1));
- return MIN (lhs, rhs);
+ this_alignment = MIN (lhs, rhs);
+ break;
case INTEGER_CST:
/* The first part of this represents the lowest bit in the constant,
but is it in bytes, not bits. */
- return MIN (BITS_PER_UNIT
+ this_alignment
+ = MIN (BITS_PER_UNIT
* (TREE_INT_CST_LOW (exp) & - TREE_INT_CST_LOW (exp)),
BIGGEST_ALIGNMENT);
+ break;
case MULT_EXPR:
/* If we know the alignment of just one side, use it. Otherwise,
use the product of the alignments. */
lhs = known_alignment (TREE_OPERAND (exp, 0));
rhs = known_alignment (TREE_OPERAND (exp, 1));
- if (lhs == 0 || rhs == 0)
- return MIN (BIGGEST_ALIGNMENT, MAX (lhs, rhs));
- return MIN (BIGGEST_ALIGNMENT, lhs * rhs);
+ if (lhs == 0 || rhs == 0)
+ this_alignment = MIN (BIGGEST_ALIGNMENT, MAX (lhs, rhs));
+ else
+ this_alignment = MIN (BIGGEST_ALIGNMENT, lhs * rhs);
+ break;
case ADDR_EXPR:
- return expr_align (TREE_OPERAND (exp, 0));
+ this_alignment = expr_align (TREE_OPERAND (exp, 0));
+ break;
default:
- return 0;
+ this_alignment = 0;
+ break;
}
+
+ return MAX (type_alignment, this_alignment);
}
/* We have a comparison or assignment operation on two types, T1 and T2,
@@ -366,10 +392,10 @@ compare_arrays (result_type, a1, a2)
comparison = build_binary_op (LT_EXPR, result_type, ub, lb);
- if (contains_placeholder_p (comparison))
+ if (CONTAINS_PLACEHOLDER_P (comparison))
comparison = build (WITH_RECORD_EXPR, result_type,
comparison, a1);
- if (contains_placeholder_p (length1))
+ if (CONTAINS_PLACEHOLDER_P (length1))
length1 = build (WITH_RECORD_EXPR, bt, length1, a1);
length_zero_p = 1;
@@ -397,9 +423,9 @@ compare_arrays (result_type, a1, a2)
/* Note that we know that UB2 and LB2 are constant and hence
cannot contain a PLACEHOLDER_EXPR. */
- if (contains_placeholder_p (comparison))
+ if (CONTAINS_PLACEHOLDER_P (comparison))
comparison = build (WITH_RECORD_EXPR, result_type, comparison, a1);
- if (contains_placeholder_p (length1))
+ if (CONTAINS_PLACEHOLDER_P (length1))
length1 = build (WITH_RECORD_EXPR, bt, length1, a1);
this_a1_is_null = build_binary_op (LT_EXPR, result_type, ub1, lb1);
@@ -409,9 +435,9 @@ compare_arrays (result_type, a1, a2)
/* Otherwise compare the computed lengths. */
else
{
- if (contains_placeholder_p (length1))
+ if (CONTAINS_PLACEHOLDER_P (length1))
length1 = build (WITH_RECORD_EXPR, bt, length1, a1);
- if (contains_placeholder_p (length2))
+ if (CONTAINS_PLACEHOLDER_P (length2))
length2 = build (WITH_RECORD_EXPR, bt, length2, a2);
comparison
@@ -446,7 +472,6 @@ compare_arrays (result_type, a1, a2)
if (type != 0)
a1 = convert (type, a1), a2 = convert (type, a2);
-
result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result,
fold (build (EQ_EXPR, result_type, a1, a2)));
@@ -770,8 +795,7 @@ build_binary_op (op_code, result_type, left_operand, right_operand)
involves a placeholder, since the RHS may not have the same
record type. */
if (operation_type != right_type
- && (! (TREE_CODE (TYPE_SIZE (operation_type)) != INTEGER_CST
- && contains_placeholder_p (TYPE_SIZE (operation_type)))))
+ && (! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (operation_type))))
{
/* For a variable-size type, with both BLKmode, convert using
CONVERT_EXPR instead of an unchecked conversion since we don't
@@ -818,8 +842,7 @@ build_binary_op (op_code, result_type, left_operand, right_operand)
right_operand = convert (TYPE_DOMAIN (left_type), right_operand);
if (! TREE_CONSTANT (right_operand)
- || ! TREE_CONSTANT (TYPE_MIN_VALUE (right_type))
- || op_code == ARRAY_RANGE_REF)
+ || ! TREE_CONSTANT (TYPE_MIN_VALUE (right_type)))
gnat_mark_addressable (left_operand);
modulus = 0;
@@ -911,9 +934,9 @@ build_binary_op (op_code, result_type, left_operand, right_operand)
best_type = left_base_type;
else if (TREE_CONSTANT (TYPE_SIZE (right_base_type)))
best_type = right_base_type;
- else if (! contains_placeholder_p (TYPE_SIZE (left_base_type)))
+ else if (! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (left_base_type)))
best_type = left_base_type;
- else if (! contains_placeholder_p (TYPE_SIZE (right_base_type)))
+ else if (! CONTAINS_PLACEHOLDER_P (TYPE_SIZE (right_base_type)))
best_type = right_base_type;
else
gigi_abort (504);
@@ -1163,7 +1186,7 @@ build_unary_op (op_code, result_type, operand)
and we need to have that type visible. */
if (TREE_CODE (TREE_TYPE (inner)) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (inner))
- && (contains_placeholder_p
+ && (CONTAINS_PLACEHOLDER_P
(TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
(TREE_TYPE (inner)))))))
inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))),
@@ -1238,6 +1261,17 @@ build_unary_op (op_code, result_type, operand)
default:
common:
+ /* If we are taking the address of a padded record whose field is
+ contains a template, take the address of the template. */
+ if (TREE_CODE (type) == RECORD_TYPE
+ && TYPE_IS_PADDING_P (type)
+ && TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE
+ && TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type))))
+ {
+ type = TREE_TYPE (TYPE_FIELDS (type));
+ operand = convert (type, operand);
+ }
+
if (type != error_mark_node)
operation_type = build_pointer_type (type);
@@ -1275,8 +1309,8 @@ build_unary_op (op_code, result_type, operand)
TREE_READONLY (result) = TREE_READONLY (TREE_TYPE (type));
}
- side_effects = (! TYPE_FAT_POINTER_P (type)
- && TYPE_VOLATILE (TREE_TYPE (type)));
+ side_effects
+ = (! TYPE_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type)));
break;
case NEGATE_EXPR:
@@ -1399,8 +1433,7 @@ build_cond_expr (result_type, condition_operand, true_operand, false_operand)
the operands and then dereference our result. */
if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE
- || (TREE_CODE (TYPE_SIZE (result_type)) != INTEGER_CST
- && contains_placeholder_p (TYPE_SIZE (result_type))))
+ || CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type)))
{
addr_p = 1;
result_type = build_pointer_type (result_type);
@@ -1413,21 +1446,18 @@ build_cond_expr (result_type, condition_operand, true_operand, false_operand)
/* If either operand is a SAVE_EXPR (possibly surrounded by
arithmetic, make sure it gets done. */
- while (TREE_CODE_CLASS (TREE_CODE (true_operand)) == '1'
- || (TREE_CODE_CLASS (TREE_CODE (true_operand)) == '2'
- && TREE_CONSTANT (TREE_OPERAND (true_operand, 1))))
- true_operand = TREE_OPERAND (true_operand, 0);
-
- while (TREE_CODE_CLASS (TREE_CODE (false_operand)) == '1'
- || (TREE_CODE_CLASS (TREE_CODE (false_operand)) == '2'
- && TREE_CONSTANT (TREE_OPERAND (false_operand, 1))))
- false_operand = TREE_OPERAND (false_operand, 0);
+ true_operand = skip_simple_arithmetic (true_operand);
+ false_operand = skip_simple_arithmetic (false_operand);
if (TREE_CODE (true_operand) == SAVE_EXPR)
result = build (COMPOUND_EXPR, result_type, true_operand, result);
+
if (TREE_CODE (false_operand) == SAVE_EXPR)
result = build (COMPOUND_EXPR, result_type, false_operand, result);
+ /* ??? Seems the code above is wrong, as it may move ahead of the COND
+ SAVE_EXPRs with side effects and not shared by both arms. */
+
if (addr_p)
result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
@@ -1528,7 +1558,9 @@ gnat_build_constructor (type, list)
if (! TREE_CONSTANT (TREE_VALUE (elmt))
|| (TREE_CODE (type) == RECORD_TYPE
&& DECL_BIT_FIELD (TREE_PURPOSE (elmt))
- && TREE_CODE (TREE_VALUE (elmt)) != INTEGER_CST))
+ && TREE_CODE (TREE_VALUE (elmt)) != INTEGER_CST)
+ || ! initializer_constant_valid_p (TREE_VALUE (elmt),
+ TREE_TYPE (TREE_VALUE (elmt))))
allconstant = 0;
if (TREE_SIDE_EFFECTS (TREE_VALUE (elmt)))
@@ -1665,7 +1697,7 @@ build_simple_component_ref (record_variable, component, field)
|| TYPE_VOLATILE (record_type))
TREE_THIS_VOLATILE (ref) = 1;
- return ref;
+ return fold (ref);
}
/* Like build_simple_component_ref, except that we give an error if the
@@ -1704,16 +1736,18 @@ build_component_ref (record_variable, component, field)
object dynamically on the stack frame. */
tree
-build_call_alloc_dealloc (gnu_obj, gnu_size, align, gnat_proc, gnat_pool)
+build_call_alloc_dealloc
+ (gnu_obj, gnu_size, align, gnat_proc, gnat_pool, gnat_node)
tree gnu_obj;
tree gnu_size;
int align;
Entity_Id gnat_proc;
Entity_Id gnat_pool;
+ Node_Id gnat_node;
{
tree gnu_align = size_int (align / BITS_PER_UNIT);
- if (TREE_CODE (gnu_size) != INTEGER_CST && contains_placeholder_p (gnu_size))
+ if (CONTAINS_PLACEHOLDER_P (gnu_size))
gnu_size = build (WITH_RECORD_EXPR, sizetype, gnu_size,
build_unary_op (INDIRECT_REF, NULL_TREE, gnu_obj));
@@ -1812,7 +1846,11 @@ build_call_alloc_dealloc (gnu_obj, gnu_size, align, gnat_proc, gnat_pool)
return build (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align);
}
else
- return build_call_1_expr (malloc_decl, gnu_size);
+ {
+ if (Nkind (gnat_node) != N_Allocator || !Comes_From_Source (gnat_node))
+ Check_No_Implicit_Heap_Alloc (gnat_node);
+ return build_call_1_expr (malloc_decl, gnu_size);
+ }
}
/* Build a GCC tree to correspond to allocating an object of TYPE whose
@@ -1822,12 +1860,13 @@ build_call_alloc_dealloc (gnu_obj, gnu_size, align, gnat_proc, gnat_pool)
the storage pool to use. */
tree
-build_allocator (type, init, result_type, gnat_proc, gnat_pool)
+build_allocator (type, init, result_type, gnat_proc, gnat_pool, gnat_node)
tree type;
tree init;
tree result_type;
Entity_Id gnat_proc;
Entity_Id gnat_pool;
+ Node_Id gnat_node;
{
tree size = TYPE_SIZE_UNIT (type);
tree result;
@@ -1854,8 +1893,7 @@ build_allocator (type, init, result_type, gnat_proc, gnat_pool)
size = TYPE_SIZE_UNIT (storage_type);
- if (TREE_CODE (size) != INTEGER_CST
- && contains_placeholder_p (size))
+ if (CONTAINS_PLACEHOLDER_P (size))
size = build (WITH_RECORD_EXPR, sizetype, size, init);
/* If the size overflows, pass -1 so the allocator will raise
@@ -1865,7 +1903,7 @@ build_allocator (type, init, result_type, gnat_proc, gnat_pool)
storage = build_call_alloc_dealloc (NULL_TREE, size,
TYPE_ALIGN (storage_type),
- gnat_proc, gnat_pool);
+ gnat_proc, gnat_pool, gnat_node);
storage = convert (storage_ptr_type, protect_multiple_eval (storage));
if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
@@ -1916,15 +1954,14 @@ build_allocator (type, init, result_type, gnat_proc, gnat_pool)
than the size from the type. */
if (init != 0 && TYPE_SIZE_UNIT (TREE_TYPE (init)) != 0
&& (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST
- || (TREE_CODE (size) != INTEGER_CST
- && contains_placeholder_p (size))))
+ || CONTAINS_PLACEHOLDER_P (size)))
size = TYPE_SIZE_UNIT (TREE_TYPE (init));
/* If the size is still self-referential, reference the initializing
expression, if it is present. If not, this must have been a
call to allocate a library-level object, in which case we use
the maximum size. */
- if (TREE_CODE (size) != INTEGER_CST && contains_placeholder_p (size))
+ if (CONTAINS_PLACEHOLDER_P (size))
{
if (init == 0)
size = max_size (size, 1);
@@ -1946,8 +1983,9 @@ build_allocator (type, init, result_type, gnat_proc, gnat_pool)
{
tree new_type = make_aligning_type (type, TYPE_ALIGN (type), size);
- result = build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE (new_type),
- BIGGEST_ALIGNMENT, Empty, Empty);
+ result = build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE_UNIT (new_type),
+ BIGGEST_ALIGNMENT, Empty,
+ Empty, gnat_node);
result = save_expr (result);
result = convert (build_pointer_type (new_type), result);
result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
@@ -1960,7 +1998,9 @@ build_allocator (type, init, result_type, gnat_proc, gnat_pool)
result = convert (result_type,
build_call_alloc_dealloc (NULL_TREE, size,
TYPE_ALIGN (type),
- gnat_proc, gnat_pool));
+ gnat_proc,
+ gnat_pool,
+ gnat_node));
/* If we have an initial value, put the new address into a SAVE_EXPR, assign
the value, and return the address. Do this with a COMPOUND_EXPR. */
@@ -2000,8 +2040,7 @@ fill_vms_descriptor (expr, gnat_formal)
{
tree init = DECL_INITIAL (field);
- if (TREE_CODE (init) != INTEGER_CST
- && contains_placeholder_p (init))
+ if (CONTAINS_PLACEHOLDER_P (init))
init = build (WITH_RECORD_EXPR, TREE_TYPE (init), init, expr);
const_list = tree_cons (field, convert (TREE_TYPE (field), init),
@@ -2027,6 +2066,10 @@ gnat_mark_addressable (expr_node)
case ARRAY_RANGE_REF:
case REALPART_EXPR:
case IMAGPART_EXPR:
+ case VIEW_CONVERT_EXPR:
+ case CONVERT_EXPR:
+ case NON_LVALUE_EXPR:
+ case GNAT_NOP_EXPR:
case NOP_EXPR:
expr_node = TREE_OPERAND (expr_node, 0);
break;
@@ -2038,7 +2081,7 @@ gnat_mark_addressable (expr_node)
case VAR_DECL:
case PARM_DECL:
case RESULT_DECL:
- put_var_into_stack (expr_node, /*rescan=*/true);
+ put_var_into_stack (expr_node, true);
TREE_ADDRESSABLE (expr_node) = 1;
return true;
diff --git a/gcc/ada/validsw.adb b/gcc/ada/validsw.adb
index 11ef50029c3..d61c97e37bb 100644
--- a/gcc/ada/validsw.adb
+++ b/gcc/ada/validsw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -119,8 +119,6 @@ package body Validsw is
C : Character;
begin
- Reset_Validity_Check_Options;
-
J := Options'First;
while J <= Options'Last loop
C := Options (J);
@@ -150,6 +148,9 @@ package body Validsw is
when 'o' =>
Validity_Check_Operands := True;
+ when 'p' =>
+ Validity_Check_Parameters := True;
+
when 'r' =>
Validity_Check_Returns := True;
@@ -177,6 +178,9 @@ package body Validsw is
when 'O' =>
Validity_Check_Operands := False;
+ when 'P' =>
+ Validity_Check_Parameters := False;
+
when 'R' =>
Validity_Check_Returns := False;
@@ -193,6 +197,7 @@ package body Validsw is
Validity_Check_In_Out_Params := True;
Validity_Check_In_Params := True;
Validity_Check_Operands := True;
+ Validity_Check_Parameters := True;
Validity_Check_Returns := True;
Validity_Check_Subscripts := True;
Validity_Check_Tests := True;
@@ -204,6 +209,7 @@ package body Validsw is
Validity_Check_In_Out_Params := False;
Validity_Check_In_Params := False;
Validity_Check_Operands := False;
+ Validity_Check_Parameters := False;
Validity_Check_Returns := False;
Validity_Check_Subscripts := False;
Validity_Check_Tests := False;
diff --git a/gcc/ada/validsw.ads b/gcc/ada/validsw.ads
index 7a7b4d4fcd4..6fad21054af 100644
--- a/gcc/ada/validsw.ads
+++ b/gcc/ada/validsw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-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- --
@@ -82,6 +82,15 @@ package Validsw is
-- pragma, then operands of all predefined operators and attributes
-- will be validity checked.
+ Validity_Check_Parameters : Boolean := False;
+ -- This controls validity treatment for parameters within a subprogram.
+ -- Normally if validity checking is enabled for parameters on a call
+ -- (Validity_Check_In[_Out]_Params) then an assumption is made that the
+ -- parameter values are valid on entry and not checked again within a
+ -- procedure. Setting Validity_Check_Parameters removes this assumption
+ -- and ensures that no assumptions are made about parameters, so that
+ -- they will always be checked.
+
Validity_Check_Returns : Boolean := False;
-- Controls validity checking of returned values. If this switch is set
-- to True using -gnatVr, or an 'r' in the argument of a Validity_Checks
@@ -102,6 +111,11 @@ package Validsw is
-- switch is set to True using -gnatVt, or a 't' in the argument of a
-- Validity_Checks pragma, then all such conditions are validity checked.
+ Force_Validity_Checks : Boolean := False;
+ -- Normally, operands that do not come from source (i.e. cases of expander
+ -- generated code) are not checked, if this flag is set True, then checking
+ -- of such operands is forced (if Validity_Check_Operands is set).
+
-----------------
-- Subprograms --
-----------------
diff --git a/gcc/ada/vms_conv.adb b/gcc/ada/vms_conv.adb
new file mode 100644
index 00000000000..f028b3084a9
--- /dev/null
+++ b/gcc/ada/vms_conv.adb
@@ -0,0 +1,1998 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- V M S _ C O N V --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1996-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Hostparm;
+with Osint; use Osint;
+with Sdefault; use Sdefault;
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Text_IO; use Ada.Text_IO;
+
+with Gnatvsn;
+
+package body VMS_Conv is
+
+ Param_Count : Natural := 0;
+ -- Number of parameter arguments so far
+
+ Arg_Num : Natural;
+ -- Argument number
+
+ Commands : Item_Ptr;
+ -- Pointer to head of list of command items, one for each command, with
+ -- the end of the list marked by a null pointer.
+
+ Last_Command : Item_Ptr;
+ -- Pointer to last item in Commands list
+
+ Command : Item_Ptr;
+ -- Pointer to command item for current command
+
+ Make_Commands_Active : Item_Ptr := null;
+ -- Set to point to Command entry for COMPILE, BIND, or LINK as appropriate
+ -- if a COMMANDS_TRANSLATION switch has been encountered while processing
+ -- a MAKE Command.
+
+ package Buffer is new Table.Table
+ (Table_Component_Type => Character,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 4096,
+ Table_Increment => 2,
+ Table_Name => "Buffer");
+
+ function Init_Object_Dirs return Argument_List;
+ -- Get the list of the object directories
+
+ function Invert_Sense (S : String) return VMS_Data.String_Ptr;
+ -- Given a unix switch string S, computes the inverse (adding or
+ -- removing ! characters as required), and returns a pointer to
+ -- the allocated result on the heap.
+
+ function Is_Extensionless (F : String) return Boolean;
+ -- Returns true if the filename has no extension.
+
+ function Match (S1, S2 : String) return Boolean;
+ -- Determines whether S1 and S2 match. This is a case insensitive match.
+
+ function Match_Prefix (S1, S2 : String) return Boolean;
+ -- Determines whether S1 matches a prefix of S2. This is also a case
+ -- insensitive match (for example Match ("AB","abc") is True).
+
+ function Matching_Name
+ (S : String;
+ Itm : Item_Ptr;
+ Quiet : Boolean := False)
+ return Item_Ptr;
+ -- Determines if the item list headed by Itm and threaded through the
+ -- Next fields (with null marking the end of the list), contains an
+ -- entry that uniquely matches the given string. The match is case
+ -- insensitive and permits unique abbreviation. If the match succeeds,
+ -- then a pointer to the matching item is returned. Otherwise, an
+ -- appropriate error message is written. Note that the discriminant
+ -- of Itm is used to determine the appropriate form of this message.
+ -- Quiet is normally False as shown, if it is set to True, then no
+ -- error message is generated in a not found situation (null is still
+ -- returned to indicate the not-found situation).
+
+ function OK_Alphanumerplus (S : String) return Boolean;
+ -- Checks that S is a string of alphanumeric characters,
+ -- returning True if all alphanumeric characters,
+ -- False if empty or a non-alphanumeric character is present.
+
+ function OK_Integer (S : String) return Boolean;
+ -- Checks that S is a string of digits, returning True if all digits,
+ -- False if empty or a non-digit is present.
+
+ procedure Place (C : Character);
+ -- Place a single character in the buffer, updating Ptr
+
+ procedure Place (S : String);
+ -- Place a string character in the buffer, updating Ptr
+
+ procedure Place_Lower (S : String);
+ -- Place string in buffer, forcing letters to lower case, updating Ptr
+
+ procedure Place_Unix_Switches (S : VMS_Data.String_Ptr);
+ -- Given a unix switch string, place corresponding switches in Buffer,
+ -- updating Ptr appropriatelly. Note that in the case of use of ! the
+ -- result may be to remove a previously placed switch.
+
+ procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr);
+ -- Check that N is a valid command or option name, i.e. that it is of the
+ -- form of an Ada identifier with upper case letters and underscores.
+
+ procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr);
+ -- Check that S is a valid switch string as described in the syntax for
+ -- the switch table item UNIX_SWITCH or else begins with a backquote.
+
+ ----------------------
+ -- Init_Object_Dirs --
+ ----------------------
+
+ function Init_Object_Dirs return Argument_List is
+ Object_Dirs : Integer;
+ Object_Dir : Argument_List (1 .. 256);
+ Object_Dir_Name : String_Access;
+
+ begin
+ Object_Dirs := 0;
+ Object_Dir_Name := String_Access (Object_Dir_Default_Name);
+ Get_Next_Dir_In_Path_Init (Object_Dir_Name);
+
+ loop
+ declare
+ Dir : constant String_Access :=
+ String_Access (Get_Next_Dir_In_Path (Object_Dir_Name));
+ begin
+ exit when Dir = null;
+ Object_Dirs := Object_Dirs + 1;
+ Object_Dir (Object_Dirs) :=
+ new String'("-L" &
+ To_Canonical_Dir_Spec
+ (To_Host_Dir_Spec
+ (Normalize_Directory_Name (Dir.all).all,
+ True).all, True).all);
+ end;
+ end loop;
+
+ Object_Dirs := Object_Dirs + 1;
+ Object_Dir (Object_Dirs) := new String'("-lgnat");
+
+ if Hostparm.OpenVMS then
+ Object_Dirs := Object_Dirs + 1;
+ Object_Dir (Object_Dirs) := new String'("-ldecgnat");
+ end if;
+
+ return Object_Dir (1 .. Object_Dirs);
+ end Init_Object_Dirs;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ Command_List :=
+ (Bind =>
+ (Cname => new S'("BIND"),
+ Usage => new S'("GNAT BIND file[.ali] /qualifiers"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatbind"),
+ Unixsws => null,
+ Switches => Bind_Switches'Access,
+ Params => new Parameter_Array'(1 => File),
+ Defext => "ali"),
+
+ Chop =>
+ (Cname => new S'("CHOP"),
+ Usage => new S'("GNAT CHOP file [directory] /qualifiers"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatchop"),
+ Unixsws => null,
+ Switches => Chop_Switches'Access,
+ Params => new Parameter_Array'(1 => File, 2 => Optional_File),
+ Defext => " "),
+
+ Clean =>
+ (Cname => new S'("CLEAN"),
+ Usage => new S'("GNAT CLEAN /qualifiers files"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatclean"),
+ Unixsws => null,
+ Switches => Clean_Switches'Access,
+ Params => new Parameter_Array'(1 => File),
+ Defext => " "),
+
+ Compile =>
+ (Cname => new S'("COMPILE"),
+ Usage => new S'("GNAT COMPILE filespec[,...] /qualifiers"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatmake"),
+ Unixsws => new Argument_List'(1 => new String'("-f"),
+ 2 => new String'("-u"),
+ 3 => new String'("-c")),
+ Switches => GCC_Switches'Access,
+ Params => new Parameter_Array'(1 => Files_Or_Wildcard),
+ Defext => " "),
+
+ Elim =>
+ (Cname => new S'("ELIM"),
+ Usage => new S'("GNAT ELIM name /qualifiers"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatelim"),
+ Unixsws => null,
+ Switches => Elim_Switches'Access,
+ Params => new Parameter_Array'(1 => Other_As_Is),
+ Defext => "ali"),
+
+ Find =>
+ (Cname => new S'("FIND"),
+ Usage => new S'("GNAT FIND pattern[:sourcefile[:line"
+ & "[:column]]] filespec[,...] /qualifiers"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatfind"),
+ Unixsws => null,
+ Switches => Find_Switches'Access,
+ Params => new Parameter_Array'(1 => Other_As_Is,
+ 2 => Files_Or_Wildcard),
+ Defext => "ali"),
+
+ Krunch =>
+ (Cname => new S'("KRUNCH"),
+ Usage => new S'("GNAT KRUNCH file [/COUNT=nnn]"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatkr"),
+ Unixsws => null,
+ Switches => Krunch_Switches'Access,
+ Params => new Parameter_Array'(1 => File),
+ Defext => " "),
+
+ Library =>
+ (Cname => new S'("LIBRARY"),
+ Usage => new S'("GNAT LIBRARY /[CREATE | SET | DELETE]"
+ & "=directory [/CONFIG=file]"),
+ VMS_Only => True,
+ Unixcmd => new S'("gnatlbr"),
+ Unixsws => null,
+ Switches => Lbr_Switches'Access,
+ Params => new Parameter_Array'(1 .. 0 => File),
+ Defext => " "),
+
+ Link =>
+ (Cname => new S'("LINK"),
+ Usage => new S'("GNAT LINK file[.ali]"
+ & " [extra obj_&_lib_&_exe_&_opt files]"
+ & " /qualifiers"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatlink"),
+ Unixsws => null,
+ Switches => Link_Switches'Access,
+ Params => new Parameter_Array'(1 => Unlimited_Files),
+ Defext => "ali"),
+
+ List =>
+ (Cname => new S'("LIST"),
+ Usage => new S'("GNAT LIST /qualifiers object_or_ali_file"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatls"),
+ Unixsws => null,
+ Switches => List_Switches'Access,
+ Params => new Parameter_Array'(1 => Unlimited_Files),
+ Defext => "ali"),
+
+ Make =>
+ (Cname => new S'("MAKE"),
+ Usage => new S'("GNAT MAKE file /qualifiers (includes "
+ & "COMPILE /qualifiers)"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatmake"),
+ Unixsws => null,
+ Switches => Make_Switches'Access,
+ Params => new Parameter_Array'(1 => File),
+ Defext => " "),
+
+ Name =>
+ (Cname => new S'("NAME"),
+ Usage => new S'("GNAT NAME /qualifiers naming-pattern "
+ & "[naming-patterns]"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatname"),
+ Unixsws => null,
+ Switches => Name_Switches'Access,
+ Params => new Parameter_Array'(1 => Unlimited_As_Is),
+ Defext => " "),
+
+ Preprocess =>
+ (Cname => new S'("PREPROCESS"),
+ Usage =>
+ new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatprep"),
+ Unixsws => null,
+ Switches => Prep_Switches'Access,
+ Params => new Parameter_Array'(1 .. 3 => File),
+ Defext => " "),
+
+ Pretty =>
+ (Cname => new S'("PRETTY"),
+ Usage => new S'("GNAT PRETTY /qualifiers source_file"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatpp"),
+ Unixsws => null,
+ Switches => Pretty_Switches'Access,
+ Params => new Parameter_Array'(1 => File),
+ Defext => " "),
+
+ Shared =>
+ (Cname => new S'("SHARED"),
+ Usage => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt"
+ & "files] /qualifiers"),
+ VMS_Only => True,
+ Unixcmd => new S'("gcc"),
+ Unixsws =>
+ new Argument_List'(new String'("-shared") & Init_Object_Dirs),
+ Switches => Shared_Switches'Access,
+ Params => new Parameter_Array'(1 => Unlimited_Files),
+ Defext => " "),
+
+ Standard =>
+ (Cname => new S'("STANDARD"),
+ Usage => new S'("GNAT STANDARD"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatpsta"),
+ Unixsws => null,
+ Switches => Standard_Switches'Access,
+ Params => new Parameter_Array'(1 .. 0 => File),
+ Defext => " "),
+
+ Stub =>
+ (Cname => new S'("STUB"),
+ Usage => new S'("GNAT STUB file [directory]/qualifiers"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatstub"),
+ Unixsws => null,
+ Switches => Stub_Switches'Access,
+ Params => new Parameter_Array'(1 => File, 2 => Optional_File),
+ Defext => " "),
+
+ Xref =>
+ (Cname => new S'("XREF"),
+ Usage => new S'("GNAT XREF filespec[,...] /qualifiers"),
+ VMS_Only => False,
+ Unixcmd => new S'("gnatxref"),
+ Unixsws => null,
+ Switches => Xref_Switches'Access,
+ Params => new Parameter_Array'(1 => Files_Or_Wildcard),
+ Defext => "ali")
+ );
+ end Initialize;
+
+ ------------------
+ -- Invert_Sense --
+ ------------------
+
+ function Invert_Sense (S : String) return VMS_Data.String_Ptr is
+ Sinv : String (1 .. S'Length * 2);
+ -- Result (for sure long enough)
+
+ Sinvp : Natural := 0;
+ -- Pointer to output string
+
+ begin
+ for Sp in S'Range loop
+ if Sp = S'First or else S (Sp - 1) = ',' then
+ if S (Sp) = '!' then
+ null;
+ else
+ Sinv (Sinvp + 1) := '!';
+ Sinv (Sinvp + 2) := S (Sp);
+ Sinvp := Sinvp + 2;
+ end if;
+
+ else
+ Sinv (Sinvp + 1) := S (Sp);
+ Sinvp := Sinvp + 1;
+ end if;
+ end loop;
+
+ return new String'(Sinv (1 .. Sinvp));
+ end Invert_Sense;
+
+ ----------------------
+ -- Is_Extensionless --
+ ----------------------
+
+ function Is_Extensionless (F : String) return Boolean is
+ begin
+ for J in reverse F'Range loop
+ if F (J) = '.' then
+ return False;
+ elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then
+ return True;
+ end if;
+ end loop;
+
+ return True;
+ end Is_Extensionless;
+
+ -----------
+ -- Match --
+ -----------
+
+ function Match (S1, S2 : String) return Boolean is
+ Dif : constant Integer := S2'First - S1'First;
+
+ begin
+
+ if S1'Length /= S2'Length then
+ return False;
+
+ else
+ for J in S1'Range loop
+ if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end if;
+ end Match;
+
+ ------------------
+ -- Match_Prefix --
+ ------------------
+
+ function Match_Prefix (S1, S2 : String) return Boolean is
+ begin
+ if S1'Length > S2'Length then
+ return False;
+ else
+ return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1));
+ end if;
+ end Match_Prefix;
+
+ -------------------
+ -- Matching_Name --
+ -------------------
+
+ function Matching_Name
+ (S : String;
+ Itm : Item_Ptr;
+ Quiet : Boolean := False)
+ return Item_Ptr
+ is
+ P1, P2 : Item_Ptr;
+
+ procedure Err;
+ -- Little procedure to output command/qualifier/option as appropriate
+ -- and bump error count.
+
+ ---------
+ -- Err --
+ ---------
+
+ procedure Err is
+ begin
+ if Quiet then
+ return;
+ end if;
+
+ Errors := Errors + 1;
+
+ if Itm /= null then
+ case Itm.Id is
+ when Id_Command =>
+ Put (Standard_Error, "command");
+
+ when Id_Switch =>
+ if Hostparm.OpenVMS then
+ Put (Standard_Error, "qualifier");
+ else
+ Put (Standard_Error, "switch");
+ end if;
+
+ when Id_Option =>
+ Put (Standard_Error, "option");
+
+ end case;
+ else
+ Put (Standard_Error, "input");
+
+ end if;
+
+ Put (Standard_Error, ": ");
+ Put (Standard_Error, S);
+ end Err;
+
+ -- Start of processing for Matching_Name
+
+ begin
+ -- If exact match, that's the one we want
+
+ P1 := Itm;
+ while P1 /= null loop
+ if Match (S, P1.Name.all) then
+ return P1;
+ else
+ P1 := P1.Next;
+ end if;
+ end loop;
+
+ -- Now check for prefix matches
+
+ P1 := Itm;
+ while P1 /= null loop
+ if P1.Name.all = "/<other>" then
+ return P1;
+
+ elsif not Match_Prefix (S, P1.Name.all) then
+ P1 := P1.Next;
+
+ else
+ -- Here we have found one matching prefix, so see if there is
+ -- another one (which is an ambiguity)
+
+ P2 := P1.Next;
+ while P2 /= null loop
+ if Match_Prefix (S, P2.Name.all) then
+ if not Quiet then
+ Put (Standard_Error, "ambiguous ");
+ Err;
+ Put (Standard_Error, " (matches ");
+ Put (Standard_Error, P1.Name.all);
+
+ while P2 /= null loop
+ if Match_Prefix (S, P2.Name.all) then
+ Put (Standard_Error, ',');
+ Put (Standard_Error, P2.Name.all);
+ end if;
+
+ P2 := P2.Next;
+ end loop;
+
+ Put_Line (Standard_Error, ")");
+ end if;
+
+ return null;
+ end if;
+
+ P2 := P2.Next;
+ end loop;
+
+ -- If we fall through that loop, then there was only one match
+
+ return P1;
+ end if;
+ end loop;
+
+ -- If we fall through outer loop, there was no match
+
+ if not Quiet then
+ Put (Standard_Error, "unrecognized ");
+ Err;
+ New_Line (Standard_Error);
+ end if;
+
+ return null;
+ end Matching_Name;
+
+ -----------------------
+ -- OK_Alphanumerplus --
+ -----------------------
+
+ function OK_Alphanumerplus (S : String) return Boolean is
+ begin
+ if S'Length = 0 then
+ return False;
+
+ else
+ for J in S'Range loop
+ if not (Is_Alphanumeric (S (J)) or else
+ S (J) = '_' or else S (J) = '$')
+ then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end if;
+ end OK_Alphanumerplus;
+
+ ----------------
+ -- OK_Integer --
+ ----------------
+
+ function OK_Integer (S : String) return Boolean is
+ begin
+ if S'Length = 0 then
+ return False;
+
+ else
+ for J in S'Range loop
+ if not Is_Digit (S (J)) then
+ return False;
+ end if;
+ end loop;
+
+ return True;
+ end if;
+ end OK_Integer;
+
+ --------------------
+ -- Output_Version --
+ --------------------
+
+ procedure Output_Version is
+ begin
+ Put ("GNAT ");
+ Put (Gnatvsn.Gnat_Version_String);
+ Put_Line (" Copyright 1996-2003 Free Software Foundation, Inc.");
+ end Output_Version;
+
+ -----------
+ -- Place --
+ -----------
+
+ procedure Place (C : Character) is
+ begin
+ Buffer.Increment_Last;
+ Buffer.Table (Buffer.Last) := C;
+ end Place;
+
+ procedure Place (S : String) is
+ begin
+ for J in S'Range loop
+ Place (S (J));
+ end loop;
+ end Place;
+
+ -----------------
+ -- Place_Lower --
+ -----------------
+
+ procedure Place_Lower (S : String) is
+ begin
+ for J in S'Range loop
+ Place (To_Lower (S (J)));
+ end loop;
+ end Place_Lower;
+
+ -------------------------
+ -- Place_Unix_Switches --
+ -------------------------
+
+ procedure Place_Unix_Switches (S : VMS_Data.String_Ptr) is
+ P1, P2, P3 : Natural;
+ Remove : Boolean;
+ Slen, Sln2 : Natural;
+ Wild_Card : Boolean := False;
+
+ begin
+ P1 := S'First;
+ while P1 <= S'Last loop
+ if S (P1) = '!' then
+ P1 := P1 + 1;
+ Remove := True;
+ else
+ Remove := False;
+ end if;
+
+ P2 := P1;
+ pragma Assert (S (P1) = '-' or else S (P1) = '`');
+
+ while P2 < S'Last and then S (P2 + 1) /= ',' loop
+ P2 := P2 + 1;
+ end loop;
+
+ -- Switch is now in S (P1 .. P2)
+
+ Slen := P2 - P1 + 1;
+
+ if Remove then
+ Wild_Card := S (P2) = '*';
+
+ if Wild_Card then
+ Slen := Slen - 1;
+ P2 := P2 - 1;
+ end if;
+
+ P3 := 1;
+ while P3 <= Buffer.Last - Slen loop
+ if Buffer.Table (P3) = ' '
+ and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) =
+ S (P1 .. P2)
+ and then (Wild_Card
+ or else
+ P3 + Slen = Buffer.Last
+ or else
+ Buffer.Table (P3 + Slen + 1) = ' ')
+ then
+ Sln2 := Slen;
+
+ if Wild_Card then
+ while P3 + Sln2 /= Buffer.Last
+ and then Buffer.Table (P3 + Sln2 + 1) /= ' '
+ loop
+ Sln2 := Sln2 + 1;
+ end loop;
+ end if;
+
+ Buffer.Table (P3 .. Buffer.Last - Sln2 - 1) :=
+ Buffer.Table (P3 + Sln2 + 1 .. Buffer.Last);
+ Buffer.Set_Last (Buffer.Last - Sln2 - 1);
+
+ else
+ P3 := P3 + 1;
+ end if;
+ end loop;
+
+ if Wild_Card then
+ P2 := P2 + 1;
+ end if;
+
+ else
+ pragma Assert (S (P2) /= '*');
+ Place (' ');
+
+ if S (P1) = '`' then
+ P1 := P1 + 1;
+ end if;
+
+ Place (S (P1 .. P2));
+ end if;
+
+ P1 := P2 + 2;
+ end loop;
+ end Place_Unix_Switches;
+
+ --------------------------------
+ -- Validate_Command_Or_Option --
+ --------------------------------
+
+ procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is
+ begin
+ pragma Assert (N'Length > 0);
+
+ for J in N'Range loop
+ if N (J) = '_' then
+ pragma Assert (N (J - 1) /= '_');
+ null;
+ else
+ pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
+ null;
+ end if;
+ end loop;
+ end Validate_Command_Or_Option;
+
+ --------------------------
+ -- Validate_Unix_Switch --
+ --------------------------
+
+ procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is
+ begin
+ if S (S'First) = '`' then
+ return;
+ end if;
+
+ pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
+
+ for J in S'First + 1 .. S'Last loop
+ pragma Assert (S (J) /= ' ');
+
+ if S (J) = '!' then
+ pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
+ null;
+ end if;
+ end loop;
+ end Validate_Unix_Switch;
+
+ --------------------
+ -- VMS_Conversion --
+ --------------------
+
+ -- This function is *far* too long and *far* too heavily nested, it
+ -- needs procedural abstraction ???
+
+ procedure VMS_Conversion (The_Command : out Command_Type) is
+ begin
+ Buffer.Init;
+
+ -- First we must preprocess the string form of the command and options
+ -- list into the internal form that we use.
+
+ for C in Real_Command_Type loop
+ declare
+ Command : Item_Ptr := new Command_Item;
+
+ Last_Switch : Item_Ptr;
+ -- Last switch in list
+
+ begin
+ -- Link new command item into list of commands
+
+ if Last_Command = null then
+ Commands := Command;
+ else
+ Last_Command.Next := Command;
+ end if;
+
+ Last_Command := Command;
+
+ -- Fill in fields of new command item
+
+ Command.Name := Command_List (C).Cname;
+ Command.Usage := Command_List (C).Usage;
+ Command.Command := C;
+
+ if Command_List (C).Unixsws = null then
+ Command.Unix_String := Command_List (C).Unixcmd;
+ else
+ declare
+ Cmd : String (1 .. 5_000);
+ Last : Natural := 0;
+ Sws : constant Argument_List_Access :=
+ Command_List (C).Unixsws;
+
+ begin
+ Cmd (1 .. Command_List (C).Unixcmd'Length) :=
+ Command_List (C).Unixcmd.all;
+ Last := Command_List (C).Unixcmd'Length;
+
+ for J in Sws'Range loop
+ Last := Last + 1;
+ Cmd (Last) := ' ';
+ Cmd (Last + 1 .. Last + Sws (J)'Length) :=
+ Sws (J).all;
+ Last := Last + Sws (J)'Length;
+ end loop;
+
+ Command.Unix_String := new String'(Cmd (1 .. Last));
+ end;
+ end if;
+
+ Command.Params := Command_List (C).Params;
+ Command.Defext := Command_List (C).Defext;
+
+ Validate_Command_Or_Option (Command.Name);
+
+ -- Process the switch list
+
+ for S in Command_List (C).Switches'Range loop
+ declare
+ SS : constant VMS_Data.String_Ptr :=
+ Command_List (C).Switches (S);
+ P : Natural := SS'First;
+ Sw : Item_Ptr := new Switch_Item;
+
+ Last_Opt : Item_Ptr;
+ -- Pointer to last option
+
+ begin
+ -- Link new switch item into list of switches
+
+ if Last_Switch = null then
+ Command.Switches := Sw;
+ else
+ Last_Switch.Next := Sw;
+ end if;
+
+ Last_Switch := Sw;
+
+ -- Process switch string, first get name
+
+ while SS (P) /= ' ' and SS (P) /= '=' loop
+ P := P + 1;
+ end loop;
+
+ Sw.Name := new String'(SS (SS'First .. P - 1));
+
+ -- Direct translation case
+
+ if SS (P) = ' ' then
+ Sw.Translation := T_Direct;
+ Sw.Unix_String := new String'(SS (P + 1 .. SS'Last));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ if SS (P - 1) = '>' then
+ Sw.Translation := T_Other;
+
+ elsif SS (P + 1) = '`' then
+ null;
+
+ -- Create the inverted case (/NO ..)
+
+ elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then
+ Sw := new Switch_Item;
+ Last_Switch.Next := Sw;
+ Last_Switch := Sw;
+
+ Sw.Name :=
+ new String'("/NO" & SS (SS'First + 1 .. P - 1));
+ Sw.Translation := T_Direct;
+ Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last));
+ Validate_Unix_Switch (Sw.Unix_String);
+ end if;
+
+ -- Directories translation case
+
+ elsif SS (P + 1) = '*' then
+ pragma Assert (SS (SS'Last) = '*');
+ Sw.Translation := T_Directories;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ -- Directory translation case
+
+ elsif SS (P + 1) = '%' then
+ pragma Assert (SS (SS'Last) = '%');
+ Sw.Translation := T_Directory;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ -- File translation case
+
+ elsif SS (P + 1) = '@' then
+ pragma Assert (SS (SS'Last) = '@');
+ Sw.Translation := T_File;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ -- No space file translation case
+
+ elsif SS (P + 1) = '<' then
+ pragma Assert (SS (SS'Last) = '>');
+ Sw.Translation := T_No_Space_File;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ -- Numeric translation case
+
+ elsif SS (P + 1) = '#' then
+ pragma Assert (SS (SS'Last) = '#');
+ Sw.Translation := T_Numeric;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ -- Alphanumerplus translation case
+
+ elsif SS (P + 1) = '|' then
+ pragma Assert (SS (SS'Last) = '|');
+ Sw.Translation := T_Alphanumplus;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ -- String translation case
+
+ elsif SS (P + 1) = '"' then
+ pragma Assert (SS (SS'Last) = '"');
+ Sw.Translation := T_String;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
+ Validate_Unix_Switch (Sw.Unix_String);
+
+ -- Commands translation case
+
+ elsif SS (P + 1) = '?' then
+ Sw.Translation := T_Commands;
+ Sw.Unix_String := new String'(SS (P + 2 .. SS'Last));
+
+ -- Options translation case
+
+ else
+ Sw.Translation := T_Options;
+ Sw.Unix_String := new String'("");
+
+ P := P + 1; -- bump past =
+ while P <= SS'Last loop
+ declare
+ Opt : Item_Ptr := new Option_Item;
+ Q : Natural;
+ begin
+ -- Link new option item into options list
+
+ if Last_Opt = null then
+ Sw.Options := Opt;
+ else
+ Last_Opt.Next := Opt;
+ end if;
+
+ Last_Opt := Opt;
+
+ -- Fill in fields of new option item
+
+ Q := P;
+ while SS (Q) /= ' ' loop
+ Q := Q + 1;
+ end loop;
+
+ Opt.Name := new String'(SS (P .. Q - 1));
+ Validate_Command_Or_Option (Opt.Name);
+
+ P := Q + 1;
+ Q := P;
+
+ while Q <= SS'Last and then SS (Q) /= ' ' loop
+ Q := Q + 1;
+ end loop;
+
+ Opt.Unix_String := new String'(SS (P .. Q - 1));
+ Validate_Unix_Switch (Opt.Unix_String);
+ P := Q + 1;
+ end;
+ end loop;
+ end if;
+ end;
+ end loop;
+ end;
+ end loop;
+
+ -- If no parameters, give complete list of commands
+
+ if Argument_Count = 0 then
+ Output_Version;
+ New_Line;
+ Put_Line ("List of available commands");
+ New_Line;
+
+ while Commands /= null loop
+ Put (Commands.Usage.all);
+ Set_Col (53);
+ Put_Line (Commands.Unix_String.all);
+ Commands := Commands.Next;
+ end loop;
+
+ raise Normal_Exit;
+ end if;
+
+ Arg_Num := 1;
+
+ -- Loop through arguments
+
+ while Arg_Num <= Argument_Count loop
+
+ Process_Argument : declare
+ Argv : String_Access;
+ Arg_Idx : Integer;
+
+ function Get_Arg_End
+ (Argv : String;
+ Arg_Idx : Integer)
+ return Integer;
+ -- Begins looking at Arg_Idx + 1 and returns the index of the
+ -- last character before a slash or else the index of the last
+ -- character in the string Argv.
+
+ -----------------
+ -- Get_Arg_End --
+ -----------------
+
+ function Get_Arg_End
+ (Argv : String;
+ Arg_Idx : Integer)
+ return Integer
+ is
+ begin
+ for J in Arg_Idx + 1 .. Argv'Last loop
+ if Argv (J) = '/' then
+ return J - 1;
+ end if;
+ end loop;
+
+ return Argv'Last;
+ end Get_Arg_End;
+
+ -- Start of processing for Process_Argument
+
+ begin
+ Argv := new String'(Argument (Arg_Num));
+ Arg_Idx := Argv'First;
+
+ <<Tryagain_After_Coalesce>>
+ loop
+ declare
+ Next_Arg_Idx : Integer;
+ Arg : String_Access;
+
+ begin
+ Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
+ Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
+
+ -- The first one must be a command name
+
+ if Arg_Num = 1 and then Arg_Idx = Argv'First then
+
+ Command := Matching_Name (Arg.all, Commands);
+
+ if Command = null then
+ raise Error_Exit;
+ end if;
+
+ The_Command := Command.Command;
+
+ -- Give usage information if only command given
+
+ if Argument_Count = 1 and then Next_Arg_Idx = Argv'Last
+ and then Command.Command /= VMS_Conv.Standard
+ then
+ Output_Version;
+ New_Line;
+ Put_Line
+ ("List of available qualifiers and options");
+ New_Line;
+
+ Put (Command.Usage.all);
+ Set_Col (53);
+ Put_Line (Command.Unix_String.all);
+
+ declare
+ Sw : Item_Ptr := Command.Switches;
+
+ begin
+ while Sw /= null loop
+ Put (" ");
+ Put (Sw.Name.all);
+
+ case Sw.Translation is
+
+ when T_Other =>
+ Set_Col (53);
+ Put_Line (Sw.Unix_String.all &
+ "/<other>");
+
+ when T_Direct =>
+ Set_Col (53);
+ Put_Line (Sw.Unix_String.all);
+
+ when T_Directories =>
+ Put ("=(direc,direc,..direc)");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
+ Put (" direc ");
+ Put (Sw.Unix_String.all);
+ Put_Line (" direc ...");
+
+ when T_Directory =>
+ Put ("=directory");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
+
+ if Sw.Unix_String (Sw.Unix_String'Last)
+ /= '='
+ then
+ Put (' ');
+ end if;
+
+ Put_Line ("directory ");
+
+ when T_File | T_No_Space_File =>
+ Put ("=file");
+ Set_Col (53);
+ Put (Sw.Unix_String.all);
+
+ if Sw.Translation = T_File
+ and then Sw.Unix_String
+ (Sw.Unix_String'Last)
+ /= '='
+ then
+ Put (' ');
+ end if;
+
+ Put_Line ("file ");
+
+ when T_Numeric =>
+ Put ("=nnn");
+ Set_Col (53);
+
+ if Sw.Unix_String (Sw.Unix_String'First)
+ = '`'
+ then
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First + 1
+ .. Sw.Unix_String'Last));
+ else
+ Put (Sw.Unix_String.all);
+ end if;
+
+ Put_Line ("nnn");
+
+ when T_Alphanumplus =>
+ Put ("=xyz");
+ Set_Col (53);
+
+ if Sw.Unix_String (Sw.Unix_String'First)
+ = '`'
+ then
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First + 1
+ .. Sw.Unix_String'Last));
+ else
+ Put (Sw.Unix_String.all);
+ end if;
+
+ Put_Line ("xyz");
+
+ when T_String =>
+ Put ("=");
+ Put ('"');
+ Put ("<string>");
+ Put ('"');
+ Set_Col (53);
+
+ Put (Sw.Unix_String.all);
+
+ if Sw.Unix_String (Sw.Unix_String'Last)
+ /= '='
+ then
+ Put (' ');
+ end if;
+
+ Put ("<string>");
+ New_Line;
+
+ when T_Commands =>
+ Put (" (switches for ");
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First + 7
+ .. Sw.Unix_String'Last));
+ Put (')');
+ Set_Col (53);
+ Put (Sw.Unix_String
+ (Sw.Unix_String'First
+ .. Sw.Unix_String'First + 5));
+ Put_Line (" switches");
+
+ when T_Options =>
+ declare
+ Opt : Item_Ptr := Sw.Options;
+
+ begin
+ Put_Line ("=(option,option..)");
+
+ while Opt /= null loop
+ Put (" ");
+ Put (Opt.Name.all);
+
+ if Opt = Sw.Options then
+ Put (" (D)");
+ end if;
+
+ Set_Col (53);
+ Put_Line (Opt.Unix_String.all);
+ Opt := Opt.Next;
+ end loop;
+ end;
+
+ end case;
+
+ Sw := Sw.Next;
+ end loop;
+ end;
+
+ raise Normal_Exit;
+ end if;
+
+ -- Special handling for internal debugging switch /?
+
+ elsif Arg.all = "/?" then
+ Display_Command := True;
+
+ -- Copy -switch unchanged
+
+ elsif Arg (Arg'First) = '-' then
+ Place (' ');
+ Place (Arg.all);
+
+ -- Copy quoted switch with quotes stripped
+
+ elsif Arg (Arg'First) = '"' then
+ if Arg (Arg'Last) /= '"' then
+ Put (Standard_Error, "misquoted argument: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+
+ else
+ Place (' ');
+ Place (Arg (Arg'First + 1 .. Arg'Last - 1));
+ end if;
+
+ -- Parameter Argument
+
+ elsif Arg (Arg'First) /= '/'
+ and then Make_Commands_Active = null
+ then
+ Param_Count := Param_Count + 1;
+
+ if Param_Count <= Command.Params'Length then
+
+ case Command.Params (Param_Count) is
+
+ when File | Optional_File =>
+ declare
+ Normal_File : constant String_Access :=
+ To_Canonical_File_Spec
+ (Arg.all);
+
+ begin
+ Place (' ');
+ Place_Lower (Normal_File.all);
+
+ if Is_Extensionless (Normal_File.all)
+ and then Command.Defext /= " "
+ then
+ Place ('.');
+ Place (Command.Defext);
+ end if;
+ end;
+
+ when Unlimited_Files =>
+ declare
+ Normal_File :
+ constant String_Access :=
+ To_Canonical_File_Spec (Arg.all);
+
+ File_Is_Wild : Boolean := False;
+ File_List : String_Access_List_Access;
+
+ begin
+ for J in Arg'Range loop
+ if Arg (J) = '*'
+ or else Arg (J) = '%'
+ then
+ File_Is_Wild := True;
+ end if;
+ end loop;
+
+ if File_Is_Wild then
+ File_List := To_Canonical_File_List
+ (Arg.all, False);
+
+ for J in File_List.all'Range loop
+ Place (' ');
+ Place_Lower (File_List.all (J).all);
+ end loop;
+
+ else
+ Place (' ');
+ Place_Lower (Normal_File.all);
+
+ if Is_Extensionless (Normal_File.all)
+ and then Command.Defext /= " "
+ then
+ Place ('.');
+ Place (Command.Defext);
+ end if;
+ end if;
+
+ Param_Count := Param_Count - 1;
+ end;
+
+ when Other_As_Is =>
+ Place (' ');
+ Place (Arg.all);
+
+ when Unlimited_As_Is =>
+ Place (' ');
+ Place (Arg.all);
+ Param_Count := Param_Count - 1;
+
+ when Files_Or_Wildcard =>
+
+ -- Remove spaces from a comma separated list
+ -- of file names and adjust control variables
+ -- accordingly.
+
+ while Arg_Num < Argument_Count and then
+ (Argv (Argv'Last) = ',' xor
+ Argument (Arg_Num + 1)
+ (Argument (Arg_Num + 1)'First) = ',')
+ loop
+ Argv := new String'
+ (Argv.all & Argument (Arg_Num + 1));
+ Arg_Num := Arg_Num + 1;
+ Arg_Idx := Argv'First;
+ Next_Arg_Idx :=
+ Get_Arg_End (Argv.all, Arg_Idx);
+ Arg := new String'
+ (Argv (Arg_Idx .. Next_Arg_Idx));
+ end loop;
+
+ -- Parse the comma separated list of VMS
+ -- filenames and place them on the command
+ -- line as space separated Unix style
+ -- filenames. Lower case and add default
+ -- extension as appropriate.
+
+ declare
+ Arg1_Idx : Integer := Arg'First;
+
+ function Get_Arg1_End
+ (Arg : String; Arg_Idx : Integer)
+ return Integer;
+ -- Begins looking at Arg_Idx + 1 and
+ -- returns the index of the last character
+ -- before a comma or else the index of the
+ -- last character in the string Arg.
+
+ ------------------
+ -- Get_Arg1_End --
+ ------------------
+
+ function Get_Arg1_End
+ (Arg : String; Arg_Idx : Integer)
+ return Integer
+ is
+ begin
+ for J in Arg_Idx + 1 .. Arg'Last loop
+ if Arg (J) = ',' then
+ return J - 1;
+ end if;
+ end loop;
+
+ return Arg'Last;
+ end Get_Arg1_End;
+
+ begin
+ loop
+ declare
+ Next_Arg1_Idx :
+ constant Integer :=
+ Get_Arg1_End (Arg.all, Arg1_Idx);
+
+ Arg1 :
+ constant String :=
+ Arg (Arg1_Idx .. Next_Arg1_Idx);
+
+ Normal_File :
+ constant String_Access :=
+ To_Canonical_File_Spec (Arg1);
+
+ begin
+ Place (' ');
+ Place_Lower (Normal_File.all);
+
+ if Is_Extensionless (Normal_File.all)
+ and then Command.Defext /= " "
+ then
+ Place ('.');
+ Place (Command.Defext);
+ end if;
+
+ Arg1_Idx := Next_Arg1_Idx + 1;
+ end;
+
+ exit when Arg1_Idx > Arg'Last;
+
+ -- Don't allow two or more commas in
+ -- a row
+
+ if Arg (Arg1_Idx) = ',' then
+ Arg1_Idx := Arg1_Idx + 1;
+ if Arg1_Idx > Arg'Last or else
+ Arg (Arg1_Idx) = ','
+ then
+ Put_Line
+ (Standard_Error,
+ "Malformed Parameter: " &
+ Arg.all);
+ Put (Standard_Error, "usage: ");
+ Put_Line (Standard_Error,
+ Command.Usage.all);
+ raise Error_Exit;
+ end if;
+ end if;
+
+ end loop;
+ end;
+ end case;
+ end if;
+
+ -- Qualifier argument
+
+ else
+ -- This code is too heavily nested, should be
+ -- separated out as separate subprogram ???
+
+ declare
+ Sw : Item_Ptr;
+ SwP : Natural;
+ P2 : Natural;
+ Endp : Natural := 0; -- avoid warning!
+ Opt : Item_Ptr;
+
+ begin
+ SwP := Arg'First;
+ while SwP < Arg'Last
+ and then Arg (SwP + 1) /= '='
+ loop
+ SwP := SwP + 1;
+ end loop;
+
+ -- At this point, the switch name is in
+ -- Arg (Arg'First..SwP) and if that is not the
+ -- whole switch, then there is an equal sign at
+ -- Arg (SwP + 1) and the rest of Arg is what comes
+ -- after the equal sign.
+
+ -- If make commands are active, see if we have
+ -- another COMMANDS_TRANSLATION switch belonging
+ -- to gnatmake.
+
+ if Make_Commands_Active /= null then
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Command.Switches,
+ Quiet => True);
+
+ if Sw /= null
+ and then Sw.Translation = T_Commands
+ then
+ null;
+
+ else
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Make_Commands_Active.Switches,
+ Quiet => False);
+ end if;
+
+ -- For case of GNAT MAKE or CHOP, if we cannot
+ -- find the switch, then see if it is a
+ -- recognized compiler switch instead, and if
+ -- so process the compiler switch.
+
+ elsif Command.Name.all = "MAKE"
+ or else Command.Name.all = "CHOP" then
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Command.Switches,
+ Quiet => True);
+
+ if Sw = null then
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Matching_Name
+ ("COMPILE", Commands).Switches,
+ Quiet => False);
+ end if;
+
+ -- For all other cases, just search the relevant
+ -- command.
+
+ else
+ Sw :=
+ Matching_Name
+ (Arg (Arg'First .. SwP),
+ Command.Switches,
+ Quiet => False);
+ end if;
+
+ if Sw /= null then
+ case Sw.Translation is
+
+ when T_Direct =>
+ Place_Unix_Switches (Sw.Unix_String);
+ if SwP < Arg'Last
+ and then Arg (SwP + 1) = '='
+ then
+ Put (Standard_Error,
+ "qualifier options ignored: ");
+ Put_Line (Standard_Error, Arg.all);
+ end if;
+
+ when T_Directories =>
+ if SwP + 1 > Arg'Last then
+ Put (Standard_Error,
+ "missing directories for: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+
+ elsif Arg (SwP + 2) /= '(' then
+ SwP := SwP + 2;
+ Endp := Arg'Last;
+
+ elsif Arg (Arg'Last) /= ')' then
+
+ -- Remove spaces from a comma separated
+ -- list of file names and adjust
+ -- control variables accordingly.
+
+ if Arg_Num < Argument_Count and then
+ (Argv (Argv'Last) = ',' xor
+ Argument (Arg_Num + 1)
+ (Argument (Arg_Num + 1)'First) = ',')
+ then
+ Argv :=
+ new String'(Argv.all
+ & Argument
+ (Arg_Num + 1));
+ Arg_Num := Arg_Num + 1;
+ Arg_Idx := Argv'First;
+ Next_Arg_Idx
+ := Get_Arg_End (Argv.all, Arg_Idx);
+ Arg := new String'
+ (Argv (Arg_Idx .. Next_Arg_Idx));
+ goto Tryagain_After_Coalesce;
+ end if;
+
+ Put (Standard_Error,
+ "incorrectly parenthesized " &
+ "or malformed argument: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+
+ else
+ SwP := SwP + 3;
+ Endp := Arg'Last - 1;
+ end if;
+
+ while SwP <= Endp loop
+ declare
+ Dir_Is_Wild : Boolean := False;
+ Dir_Maybe_Is_Wild : Boolean := False;
+ Dir_List : String_Access_List_Access;
+ begin
+ P2 := SwP;
+
+ while P2 < Endp
+ and then Arg (P2 + 1) /= ','
+ loop
+
+ -- A wildcard directory spec on
+ -- VMS will contain either * or
+ -- % or ...
+
+ if Arg (P2) = '*' then
+ Dir_Is_Wild := True;
+
+ elsif Arg (P2) = '%' then
+ Dir_Is_Wild := True;
+
+ elsif Dir_Maybe_Is_Wild
+ and then Arg (P2) = '.'
+ and then Arg (P2 + 1) = '.'
+ then
+ Dir_Is_Wild := True;
+ Dir_Maybe_Is_Wild := False;
+
+ elsif Dir_Maybe_Is_Wild then
+ Dir_Maybe_Is_Wild := False;
+
+ elsif Arg (P2) = '.'
+ and then Arg (P2 + 1) = '.'
+ then
+ Dir_Maybe_Is_Wild := True;
+
+ end if;
+
+ P2 := P2 + 1;
+ end loop;
+
+ if Dir_Is_Wild then
+ Dir_List := To_Canonical_File_List
+ (Arg (SwP .. P2), True);
+
+ for J in Dir_List.all'Range loop
+ Place_Unix_Switches
+ (Sw.Unix_String);
+ Place_Lower
+ (Dir_List.all (J).all);
+ end loop;
+
+ else
+ Place_Unix_Switches
+ (Sw.Unix_String);
+ Place_Lower
+ (To_Canonical_Dir_Spec
+ (Arg (SwP .. P2), False).all);
+ end if;
+
+ SwP := P2 + 2;
+ end;
+ end loop;
+
+ when T_Directory =>
+ if SwP + 1 > Arg'Last then
+ Put (Standard_Error,
+ "missing directory for: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+
+ else
+ Place_Unix_Switches (Sw.Unix_String);
+
+ -- Some switches end in "=". No space
+ -- here
+
+ if Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
+ then
+ Place (' ');
+ end if;
+
+ Place_Lower
+ (To_Canonical_Dir_Spec
+ (Arg (SwP + 2 .. Arg'Last),
+ False).all);
+ end if;
+
+ when T_File | T_No_Space_File =>
+ if SwP + 1 > Arg'Last then
+ Put (Standard_Error,
+ "missing file for: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+
+ else
+ Place_Unix_Switches (Sw.Unix_String);
+
+ -- Some switches end in "=". No space
+ -- here.
+
+ if Sw.Translation = T_File
+ and then Sw.Unix_String
+ (Sw.Unix_String'Last) /= '='
+ then
+ Place (' ');
+ end if;
+
+ Place_Lower
+ (To_Canonical_File_Spec
+ (Arg (SwP + 2 .. Arg'Last)).all);
+ end if;
+
+ when T_Numeric =>
+ if
+ OK_Integer (Arg (SwP + 2 .. Arg'Last))
+ then
+ Place_Unix_Switches (Sw.Unix_String);
+ Place (Arg (SwP + 2 .. Arg'Last));
+
+ else
+ Put (Standard_Error, "argument for ");
+ Put (Standard_Error, Sw.Name.all);
+ Put_Line
+ (Standard_Error, " must be numeric");
+ Errors := Errors + 1;
+ end if;
+
+ when T_Alphanumplus =>
+ if
+ OK_Alphanumerplus
+ (Arg (SwP + 2 .. Arg'Last))
+ then
+ Place_Unix_Switches (Sw.Unix_String);
+ Place (Arg (SwP + 2 .. Arg'Last));
+
+ else
+ Put (Standard_Error, "argument for ");
+ Put (Standard_Error, Sw.Name.all);
+ Put_Line (Standard_Error,
+ " must be alphanumeric");
+ Errors := Errors + 1;
+ end if;
+
+ when T_String =>
+
+ -- A String value must be extended to the
+ -- end of the Argv, otherwise strings like
+ -- "foo/bar" get split at the slash.
+ --
+ -- The begining and ending of the string
+ -- are flagged with embedded nulls which
+ -- are removed when building the Spawn
+ -- call. Nulls are use because they won't
+ -- show up in a /? output. Quotes aren't
+ -- used because that would make it
+ -- difficult to embed them.
+
+ Place_Unix_Switches (Sw.Unix_String);
+ if Next_Arg_Idx /= Argv'Last then
+ Next_Arg_Idx := Argv'Last;
+ Arg := new String'
+ (Argv (Arg_Idx .. Next_Arg_Idx));
+
+ SwP := Arg'First;
+ while SwP < Arg'Last and then
+ Arg (SwP + 1) /= '=' loop
+ SwP := SwP + 1;
+ end loop;
+ end if;
+ Place (ASCII.NUL);
+ Place (Arg (SwP + 2 .. Arg'Last));
+ Place (ASCII.NUL);
+
+ when T_Commands =>
+
+ -- Output -largs/-bargs/-cargs
+
+ Place (' ');
+ Place (Sw.Unix_String
+ (Sw.Unix_String'First ..
+ Sw.Unix_String'First + 5));
+
+ if Sw.Unix_String
+ (Sw.Unix_String'First + 7 ..
+ Sw.Unix_String'Last) =
+ "MAKE"
+ then
+ Make_Commands_Active := null;
+
+ else
+ -- Set source of new commands, also
+ -- setting this non-null indicates that
+ -- we are in the special commands mode
+ -- for processing the -xargs case.
+
+ Make_Commands_Active :=
+ Matching_Name
+ (Sw.Unix_String
+ (Sw.Unix_String'First + 7 ..
+ Sw.Unix_String'Last),
+ Commands);
+ end if;
+
+ when T_Options =>
+ if SwP + 1 > Arg'Last then
+ Place_Unix_Switches
+ (Sw.Options.Unix_String);
+ SwP := Endp + 1;
+
+ elsif Arg (SwP + 2) /= '(' then
+ SwP := SwP + 2;
+ Endp := Arg'Last;
+
+ elsif Arg (Arg'Last) /= ')' then
+ Put
+ (Standard_Error,
+ "incorrectly parenthesized " &
+ "argument: ");
+ Put_Line (Standard_Error, Arg.all);
+ Errors := Errors + 1;
+ SwP := Endp + 1;
+
+ else
+ SwP := SwP + 3;
+ Endp := Arg'Last - 1;
+ end if;
+
+ while SwP <= Endp loop
+ P2 := SwP;
+
+ while P2 < Endp
+ and then Arg (P2 + 1) /= ','
+ loop
+ P2 := P2 + 1;
+ end loop;
+
+ -- Option name is in Arg (SwP .. P2)
+
+ Opt := Matching_Name (Arg (SwP .. P2),
+ Sw.Options);
+
+ if Opt /= null then
+ Place_Unix_Switches
+ (Opt.Unix_String);
+ end if;
+
+ SwP := P2 + 2;
+ end loop;
+
+ when T_Other =>
+ Place_Unix_Switches
+ (new String'(Sw.Unix_String.all &
+ Arg.all));
+
+ end case;
+ end if;
+ end;
+ end if;
+
+ Arg_Idx := Next_Arg_Idx + 1;
+ end;
+
+ exit when Arg_Idx > Argv'Last;
+
+ end loop;
+ end Process_Argument;
+
+ Arg_Num := Arg_Num + 1;
+ end loop;
+
+ -- Gross error checking that the number of parameters is correct.
+ -- Not applicable to Unlimited_Files parameters.
+
+ if (Param_Count = Command.Params'Length - 1
+ and then Command.Params (Param_Count + 1) = Unlimited_Files)
+ or else Param_Count <= Command.Params'Length
+ then
+ null;
+
+ else
+ Put_Line (Standard_Error,
+ "Parameter count of "
+ & Integer'Image (Param_Count)
+ & " not equal to expected "
+ & Integer'Image (Command.Params'Length));
+ Put (Standard_Error, "usage: ");
+ Put_Line (Standard_Error, Command.Usage.all);
+ Errors := Errors + 1;
+ end if;
+
+ if Errors > 0 then
+ raise Error_Exit;
+ else
+ -- Prepare arguments for a call to spawn, filtering out
+ -- embedded nulls place there to delineate strings.
+
+ declare
+ P1, P2 : Natural;
+ Inside_Nul : Boolean := False;
+ Arg : String (1 .. 1024);
+ Arg_Ctr : Natural;
+
+ begin
+ P1 := 1;
+
+ while P1 <= Buffer.Last and then Buffer.Table (P1) = ' ' loop
+ P1 := P1 + 1;
+ end loop;
+
+ Arg_Ctr := 1;
+ Arg (Arg_Ctr) := Buffer.Table (P1);
+
+ while P1 <= Buffer.Last loop
+
+ if Buffer.Table (P1) = ASCII.NUL then
+ if Inside_Nul then
+ Inside_Nul := False;
+ else
+ Inside_Nul := True;
+ end if;
+ end if;
+
+ if Buffer.Table (P1) = ' ' and then not Inside_Nul then
+ P1 := P1 + 1;
+ Arg_Ctr := Arg_Ctr + 1;
+ Arg (Arg_Ctr) := Buffer.Table (P1);
+
+ else
+ Last_Switches.Increment_Last;
+ P2 := P1;
+
+ while P2 < Buffer.Last
+ and then (Buffer.Table (P2 + 1) /= ' ' or else
+ Inside_Nul)
+ loop
+ P2 := P2 + 1;
+ Arg_Ctr := Arg_Ctr + 1;
+ Arg (Arg_Ctr) := Buffer.Table (P2);
+ if Buffer.Table (P2) = ASCII.NUL then
+ Arg_Ctr := Arg_Ctr - 1;
+ if Inside_Nul then
+ Inside_Nul := False;
+ else
+ Inside_Nul := True;
+ end if;
+ end if;
+ end loop;
+
+ Last_Switches.Table (Last_Switches.Last) :=
+ new String'(String (Arg (1 .. Arg_Ctr)));
+ P1 := P2 + 2;
+ Arg_Ctr := 1;
+ Arg (Arg_Ctr) := Buffer.Table (P1);
+ end if;
+ end loop;
+ end;
+ end if;
+ end VMS_Conversion;
+
+end VMS_Conv;
diff --git a/gcc/ada/vms_conv.ads b/gcc/ada/vms_conv.ads
new file mode 100644
index 00000000000..3e3216608b4
--- /dev/null
+++ b/gcc/ada/vms_conv.ads
@@ -0,0 +1,296 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- V M S _ C O N V --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package is part of the GNAT driver. It contains a procedure
+-- VMS_Conversion to convert the command line in VMS form to the wquivalent
+-- command line with switches for the GNAT tools that the GNAT driver will
+-- invoke.
+--
+-- The qualifier declarations are contained in package VMS_Data.
+
+with Table;
+with VMS_Data; use VMS_Data;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+
+package VMS_Conv is
+
+ -- A table to keep the switches on the command line
+
+ package Last_Switches is new Table.Table
+ (Table_Component_Type => String_Access,
+ Table_Index_Type => Integer,
+ Table_Low_Bound => 1,
+ Table_Initial => 20,
+ Table_Increment => 100,
+ Table_Name => "Gnatcmd.Last_Switches");
+
+ Normal_Exit : exception;
+ -- Raise this exception for normal program termination
+
+ Error_Exit : exception;
+ -- Raise this exception if error detected
+
+ Errors : Natural := 0;
+ -- Count errors detected
+
+ Display_Command : Boolean := False;
+ -- Set true if /? switch causes display of generated command (on VMS)
+
+ -------------------
+ -- COMMAND TABLE --
+ -------------------
+
+ -- The command table contains an entry for each command recognized by
+ -- GNATCmd. The entries are represented by an array of records.
+
+ type Parameter_Type is
+ -- A parameter is defined as a whitespace bounded string, not begining
+ -- with a slash. (But see note under FILES_OR_WILDCARD).
+ (File,
+ -- A required file or directory parameter.
+
+ Optional_File,
+ -- An optional file or directory parameter.
+
+ Other_As_Is,
+ -- A parameter that's passed through as is (not canonicalized)
+
+ Unlimited_Files,
+ -- An unlimited number of whitespace separate file or directory
+ -- parameters including wildcard specifications.
+
+ Unlimited_As_Is,
+ -- Un unlimited number of whitespace separated paameters that are
+ -- passed through as is (not canonicalized).
+
+ Files_Or_Wildcard);
+ -- A comma separated list of files and/or wildcard file specifications.
+ -- A comma preceded by or followed by whitespace is considered as a
+ -- single comma character w/o whitespace.
+
+ type Parameter_Array is array (Natural range <>) of Parameter_Type;
+ type Parameter_Ref is access all Parameter_Array;
+
+ type Command_Type is
+ (Bind, Chop, Clean, Compile, Elim, Find, Krunch, Library, Link, List,
+ Make, Name, Preprocess, Pretty, Shared, Standard, Stub, Xref, Undefined);
+
+ type Alternate_Command is (Comp, Ls, Kr, Pp, Prep, Psta);
+ -- Alternate command libel for non VMS system
+
+ Corresponding_To : constant array (Alternate_Command) of Command_Type :=
+ (Comp => Compile,
+ Ls => List,
+ Kr => Krunch,
+ Prep => Preprocess,
+ Pp => Pretty,
+ Psta => Standard);
+ -- Mapping of alternate commands to commands
+
+ subtype Real_Command_Type is Command_Type range Bind .. Xref;
+
+ type Command_Entry is record
+ Cname : String_Ptr;
+ -- Command name for GNAT xxx command
+
+ Usage : String_Ptr;
+ -- A usage string, used for error messages
+
+ Unixcmd : String_Ptr;
+ -- Corresponding Unix command
+
+ Unixsws : Argument_List_Access;
+ -- Switches for the Unix command
+
+ VMS_Only : Boolean;
+ -- When True, the command can only be used on VMS
+
+ Switches : Switches_Ptr;
+ -- Pointer to array of switch strings
+
+ Params : Parameter_Ref;
+ -- Describes the allowable types of parameters.
+ -- Params (1) is the type of the first parameter, etc.
+ -- An empty parameter array means this command takes no parameters.
+
+ Defext : String (1 .. 3);
+ -- Default extension. If non-blank, then this extension is supplied by
+ -- default as the extension for any file parameter which does not have
+ -- an extension already.
+ end record;
+
+ -------------------------
+ -- INTERNAL STRUCTURES --
+ -------------------------
+
+ -- The switches and commands are defined by strings in the previous
+ -- section so that they are easy to modify, but internally, they are
+ -- kept in a more conveniently accessible form described in this
+ -- section.
+
+ -- Commands, command qualifers and options have a similar common format
+ -- so that searching for matching names can be done in a common manner.
+
+ type Item_Id is (Id_Command, Id_Switch, Id_Option);
+
+ type Translation_Type is
+ (
+ T_Direct,
+ -- A qualifier with no options.
+ -- Example: GNAT MAKE /VERBOSE
+
+ T_Directories,
+ -- A qualifier followed by a list of directories
+ -- Example: GNAT COMPILE /SEARCH=([], [.FOO], [.BAR])
+
+ T_Directory,
+ -- A qualifier followed by one directory
+ -- Example: GNAT LIBRARY /SET=[.VAXFLOATLIB]
+
+ T_File,
+ -- A qualifier followed by a filename
+ -- Example: GNAT LINK /EXECUTABLE=FOO.EXE
+
+ T_No_Space_File,
+ -- A qualifier followed by a filename
+ -- Example: GNAT MAKE /PROJECT_FILE=PRJ.GPR
+
+ T_Numeric,
+ -- A qualifier followed by a numeric value.
+ -- Example: GNAT CHOP /FILE_NAME_MAX_LENGTH=39
+
+ T_String,
+ -- A qualifier followed by a quoted string. Only used by
+ -- /IDENTIFICATION qualifier.
+ -- Example: GNAT LINK /IDENTIFICATION="3.14a1 version"
+
+ T_Options,
+ -- A qualifier followed by a list of options.
+ -- Example: GNAT COMPILE /REPRESENTATION_INFO=(ARRAYS,OBJECTS)
+
+ T_Commands,
+ -- A qualifier followed by a list. Only used for
+ -- MAKE /COMPILER_QUALIFIERS /BINDER_QUALIFIERS /LINKER_QUALIFIERS
+ -- (gnatmake -cargs -bargs -largs )
+ -- Example: GNAT MAKE ... /LINKER_QUALIFIERS /VERBOSE FOOBAR.OBJ
+
+ T_Other,
+ -- A qualifier passed directly to the linker. Only used
+ -- for LINK and SHARED if no other match is found.
+ -- Example: GNAT LINK FOO.ALI /SYSSHR
+
+ T_Alphanumplus
+ -- A qualifier followed by a legal linker symbol prefix. Only used
+ -- for BIND /BUILD_LIBRARY (gnatbind -Lxyz).
+ -- Example: GNAT BIND /BUILD_LIBRARY=foobar
+ );
+
+ type Item (Id : Item_Id);
+ type Item_Ptr is access all Item;
+
+ type Item (Id : Item_Id) is record
+ Name : String_Ptr;
+ -- Name of the command, switch (with slash) or option
+
+ Next : Item_Ptr;
+ -- Pointer to next item on list, always has the same Id value
+
+ Command : Command_Type := Undefined;
+
+ Unix_String : String_Ptr := null;
+ -- Corresponding Unix string. For a command, this is the unix command
+ -- name and possible default switches. For a switch or option it is
+ -- the unix switch string.
+
+ case Id is
+
+ when Id_Command =>
+
+ Switches : Item_Ptr;
+ -- Pointer to list of switch items for the command, linked
+ -- through the Next fields with null terminating the list.
+
+ Usage : String_Ptr;
+ -- Usage information, used only for errors and the default
+ -- list of commands output.
+
+ Params : Parameter_Ref;
+ -- Array of parameters
+
+ Defext : String (1 .. 3);
+ -- Default extension. If non-blank, then this extension is
+ -- supplied by default as the extension for any file parameter
+ -- which does not have an extension already.
+
+ when Id_Switch =>
+
+ Translation : Translation_Type;
+ -- Type of switch translation. For all cases, except Options,
+ -- this is the only field needed, since the Unix translation
+ -- is found in Unix_String.
+
+ Options : Item_Ptr;
+ -- For the Options case, this field is set to point to a list
+ -- of options item (for this case Unix_String is null in the
+ -- main switch item). The end of the list is marked by null.
+
+ when Id_Option =>
+
+ null;
+ -- No special fields needed, since Name and Unix_String are
+ -- sufficient to completely described an option.
+
+ end case;
+ end record;
+
+ subtype Command_Item is Item (Id_Command);
+ subtype Switch_Item is Item (Id_Switch);
+ subtype Option_Item is Item (Id_Option);
+
+ ------------------
+ -- SWITCH TABLE --
+ ------------------
+
+ -- The switch tables contain an entry for each switch recognized by the
+ -- command processor. It is initialized by procedure Initialize.
+
+ Command_List : array (Real_Command_Type) of Command_Entry;
+
+ ----------------
+ -- Procedures --
+ ----------------
+
+ procedure Initialize;
+ -- Initialized the switch table Command_List
+
+ procedure Output_Version;
+ -- Output the version of this program
+
+ procedure VMS_Conversion (The_Command : out Command_Type);
+ -- Converts VMS command line to equivalent Unix command line
+
+end VMS_Conv;
diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads
new file mode 100644
index 00000000000..72f5942cfae
--- /dev/null
+++ b/gcc/ada/vms_data.ads
@@ -0,0 +1,4991 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- V M S _ D A T A --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 1996-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- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package contains, for each of the command of the GNAT driver, one
+-- constant array; each component of this array is a string that defines,
+-- in coded form as explained below, the conversion of a VMS qualifier of the
+-- command to the corresponding switch of the GNAT tool corresponding to the
+-- command.
+
+-- This package is used by the GNAT driver to invokes the GNAT tools with the
+-- switches corresponding to the VMS qualifier and by the Project Manager to
+-- convert VMS qualifiers in project files to their corresponding switch
+-- values.
+
+-- This package is also an input to the tool that generates the VMS GNAT
+-- help information automatically.
+
+-- NOTE: the format of this package must follow the following rules, so that
+-- the VMS GNAT help tool works properly:
+
+-- - Each command zone (where the eventual qualifiers are declared must
+-- begin with a boxed comment of the form:
+
+-- ---------------------------------
+-- -- Switches for GNAT <COMMAND> --
+-- ---------------------------------
+
+-- where <COMMAND> is the name of a GNAT command in capital letters, for
+-- example BIND, COMPILE, XREF, ...
+
+-- - each qualifier declaration must be followed either by
+-- - a comment starting with "-- NODOC", to indicate that there is
+-- no documentation for this qualifier, or
+-- - a contiguous sequence of comments that constitute the
+-- documentation of the qualifier.
+
+-- - each command zone ends with the declaration of the contant array
+-- for the command, of the form:
+
+-- <Command>__Switches : aliased constant Switches :=
+
+package VMS_Data is
+
+ ----------------
+ -- QUALIFIERS --
+ ----------------
+
+ -- The syntax of a qualifier delaration is as follows:
+
+ -- SWITCH_STRING ::= "/ command-qualifier-name TRANSLATION"
+
+ -- TRANSLATION ::=
+ -- DIRECT_TRANSLATION
+ -- | DIRECTORIES_TRANSLATION
+ -- | FILE_TRANSLATION
+ -- | NO_SPACE_FILE_TRANSL
+ -- | NUMERIC_TRANSLATION
+ -- | STRING_TRANSLATION
+ -- | OPTIONS_TRANSLATION
+ -- | COMMANDS_TRANSLATION
+ -- | ALPHANUMPLUS_TRANSLATION
+ -- | OTHER_TRANSLATION
+
+ -- DIRECT_TRANSLATION ::= space UNIX_SWITCHES
+ -- DIRECTORIES_TRANSLATION ::= =* UNIX_SWITCH *
+ -- DIRECTORY_TRANSLATION ::= =% UNIX_SWITCH %
+ -- FILE_TRANSLATION ::= =@ UNIX_SWITCH @
+ -- NO_SPACE_FILE_TRANSL ::= =< UNIX_SWITCH >
+ -- NUMERIC_TRANSLATION ::= =# UNIX_SWITCH # | # number #
+ -- STRING_TRANSLATION ::= =" UNIX_SWITCH "
+ -- OPTIONS_TRANSLATION ::= =OPTION {space OPTION}
+ -- COMMANDS_TRANSLATION ::= =? ARGS space command-name
+ -- ALPHANUMPLUS_TRANSLATION ::= =| UNIX_SWITCH |
+
+ -- UNIX_SWITCHES ::= UNIX_SWITCH {, UNIX_SWITCH}
+
+ -- UNIX_SWITCH ::= unix-switch-string | !unix-switch-string | `string'
+
+ -- OPTION ::= option-name space UNIX_SWITCHES
+
+ -- ARGS ::= -cargs | -bargs | -largs
+
+ -- Here command-qual is the name of the switch recognized by the GNATCmd.
+ -- This is always given in upper case in the templates, although in the
+ -- actual commands, either upper or lower case is allowed.
+
+ -- The unix-switch-string always starts with a minus, and has no commas
+ -- or spaces in it. Case is significant in the unix switch string. If a
+ -- unix switch string is preceded by the not sign (!) it means that the
+ -- effect of the corresponding command qualifer is to remove any previous
+ -- occurrence of the given switch in the command line.
+
+ -- The DIRECTORIES_TRANSLATION format is used where a list of directories
+ -- is given. This possible corresponding formats recognized by GNATCmd are
+ -- as shown by the following example for the case of PATH
+
+ -- PATH=direc
+ -- PATH=(direc,direc,direc,direc)
+
+ -- When more than one directory is present for the DIRECTORIES case, then
+ -- multiple instances of the corresponding unix switch are generated,
+ -- with the file name being substituted for the occurrence of *.
+
+ -- The FILE_TRANSLATION format is similar except that only a single
+ -- file is allowed, not a list of files, and only one unix switch is
+ -- generated as a result.
+
+ -- the NO_SPACE_FILE_TRANSL is similar to FILE_TRANSLATION, except that
+ -- no space is inserted between the switch and the file name.
+
+ -- The NUMERIC_TRANSLATION format is similar to the FILE_TRANSLATION case
+ -- except that the parameter is a decimal integer in the range 0 to 999.
+
+ -- For the OPTIONS_TRANSLATION case, GNATCmd similarly permits one or
+ -- more options to appear (although only in some cases does the use of
+ -- multiple options make logical sense). For example, taking the
+ -- case of ERRORS for GCC, the following are all allowed:
+
+ -- /ERRORS=BRIEF
+ -- /ERRORS=(FULL,VERBOSE)
+ -- /ERRORS=(BRIEF IMMEDIATE)
+
+ -- If no option is provided (e.g. just /ERRORS is written), then the
+ -- first option in the list is the default option. For /ERRORS this
+ -- is NORMAL, so /ERRORS with no option is equivalent to /ERRORS=NORMAL.
+
+ -- The COMMANDS_TRANSLATION case is only used for gnatmake, to correspond
+ -- to the use of -cargs, -bargs and -largs (the ARGS string as indicated
+ -- is one of these three possibilities). The name given by COMMAND is the
+ -- corresponding command name to be used to interprete the switches to be
+ -- passed on. Switches of this type set modes, e.g. /COMPILER_QUALIFIERS
+ -- sets the mode so that all subsequent switches, up to another switch
+ -- with COMMANDS_TRANSLATION apply to the corresponding commands issued
+ -- by the make utility. For example
+
+ -- /COMPILER_QUALIFIERS /LIST /BINDER_QUALIFIERS /MAIN
+ -- /COMPILER_QUALIFIERS /NOLIST /COMPILE_CHECKS=SYNTAX
+
+ -- Clearly these switches must come at the end of the list of switches
+ -- since all subsequent switches apply to an issued command.
+
+ -- For the DIRECT_TRANSLATION case, an implicit additional qualifier
+ -- declaration is created by prepending NO to the name of the qualifer,
+ -- and then inverting the sense of the UNIX_SWITCHES string. For example,
+ -- given the qualifier definition:
+
+ -- "/LIST -gnatl"
+
+ -- An implicit qualifier definition is created:
+
+ -- "/NOLIST !-gnatl"
+
+ -- In the case where, a ! is already present, inverting the sense of the
+ -- switch means removing it.
+
+ subtype S is String;
+ -- A synonym to shorten the table
+
+ type String_Ptr is access constant String;
+ -- String pointer type used throughout
+
+ type Switches is array (Natural range <>) of String_Ptr;
+ -- Type used for array of swtiches
+
+ type Switches_Ptr is access constant Switches;
+
+ ----------------------------
+ -- Switches for GNAT BIND --
+ ----------------------------
+
+
+ S_Bind_Bind : aliased constant S := "/BIND_FILE=" &
+ "ADA " &
+ "-A " &
+ "C " &
+ "-C";
+ -- /BIND_FILE[=bind-file-option]
+ --
+ -- Specifies the language of the binder generated file.
+ --
+ -- ADA (D) Binder file is Ada.
+ --
+ -- C Binder file is 'C'.
+
+ S_Bind_Build : aliased constant S := "/BUILD_LIBRARY=|" &
+ "-L|";
+ -- /BUILD_LIBRARY=xxx
+ --
+ -- Binds the units for library building. In this case the adainit and
+ -- adafinal procedures are rename to xxxinit and xxxfinal. Implies
+ -- /NOMAIN.
+
+ S_Bind_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+ -- /CURRENT_DIRECTORY (D)
+ -- /NOCURRENT_DIRECTORY
+ --
+ -- Look for source, library or object files in the default directory.
+
+ S_Bind_Debug : aliased constant S := "/DEBUG=" &
+ "TRACEBACK " &
+ "-g2 " &
+ "ALL " &
+ "-g3 " &
+ "NONE " &
+ "-g0 " &
+ "SYMBOLS " &
+ "-g1 " &
+ "NOSYMBOLS " &
+ "!-g1 " &
+ "LINK " &
+ "-g3 " &
+ "NOTRACEBACK " &
+ "!-g2";
+ -- /DEBUG[=debug-level]
+ -- /NODEBUG
+ --
+ -- Specify level of debugging information generated for the elaboration
+ -- routine. See corresponding qualifier for GNAT COMPILE.
+
+ S_Bind_DebugX : aliased constant S := "/NODEBUG " &
+ "!-g";
+ -- NODOC (see /DEBUG)
+
+ S_Bind_Elab : aliased constant S := "/ELABORATION_DEPENDENCIES " &
+ "-e";
+ -- /ELABORATION_DEPENDENCIES
+ -- /NOELABORATION_DEPENDENCIES (D)
+ --
+ -- Output complete list of elaboration-order dependencies, showing the
+ -- reason for each dependency. This output can be rather extensive but may
+ -- be useful in diagnosing problems with elaboration order. The output is
+ -- written to SYS$OUTPUT.
+
+ S_Bind_Error : aliased constant S := "/ERROR_LIMIT=#" &
+ "-m#";
+ -- /ERROR_LIMIT=nnn
+ --
+ -- Limit number of detected errors to nnn (1-999999).
+
+ S_Bind_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
+ "-X" & '"';
+ -- /EXTERNAL_REFERENCE="name=val"
+ --
+ -- Specifies an external reference to the project manager. Useful only if
+ -- /PROJECT_FILE is used.
+ --
+ -- Example:
+ -- /EXTERNAL_REFERENCE="DEBUG=TRUE"
+
+ S_Bind_Force : aliased constant S := "/FORCE_ELAB_FLAGS " &
+ "-F";
+ -- /NOFORCE_ELAB_FLAGS (D)
+ -- /FORCE_ELAB_FLAGS
+ --
+ -- Force checking of elaboration Flags
+
+ S_Bind_Help : aliased constant S := "/HELP " &
+ "-h";
+ -- /HELP
+ --
+ -- Output usage information.
+
+ S_Bind_Init : aliased constant S := "/INITIALIZE_SCALARS=" &
+ "INVALID " &
+ "-Sin " &
+ "LOW " &
+ "-Slo " &
+ "HIGH " &
+ "-Shi";
+ -- /INITIALIZE_SCALARS[=scalar-option]
+ --
+ -- Indicate how uninitialized scalar values for which a pragma
+ -- Initialize_Scalars applies should be initialized.
+ -- scalar-option may be one of the following:
+ --
+ -- INVALID (D) Initialize with an invalid value.
+ -- LOW Initialize with the lowest valid value of the subtype.
+ -- HIGH Initialize with the highest valid value of the subtype.
+
+ S_Bind_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
+ "-aO*";
+ -- /LIBRARY_SEARCH=(direc[,...])
+ --
+ -- When looking for library and object files look also in directories
+ -- specified.
+
+ S_Bind_Linker : aliased constant S := "/LINKER_OPTION_LIST " &
+ "-K";
+ -- /NOLINKER_OPTION_LIST (D)
+ -- /LINKER_OPTION_LIST
+ --
+ -- Output linker options to SYS$OUTPUT. Includes library search
+ -- paths, contents of pragmas Ident and Linker_Options, and
+ -- libraries added by GNAT BIND.
+
+ S_Bind_Main : aliased constant S := "/MAIN " &
+ "!-n";
+ -- /MAIN (D)
+ --
+ -- The main program is in Ada.
+ --
+ -- /NOMAIN
+ --
+ -- The main program is not in Ada.
+
+ S_Bind_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
+ "DEFAULT " &
+ "-vP0 " &
+ "MEDIUM " &
+ "-vP1 " &
+ "HIGH " &
+ "-vP2";
+ -- /MESSAGES_PROJECT_FILE[=messages-option]
+ --
+ -- Specifies the "verbosity" of the parsing of project files.
+ -- messages-option may be one of the following:
+ --
+ -- DEFAULT (D) No messages are output if there is no error or warning.
+ --
+ -- MEDIUM A small number of messages are output.
+ --
+ -- HIGH A great number of messages are output, most of them not
+ -- being useful for the user.
+
+ S_Bind_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
+ "-nostdinc";
+ -- /NOSTD_INCLUDES
+ --
+ -- Do not look for sources the in the system default directory.
+
+ S_Bind_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
+ "-nostdlib";
+ -- /NOSTD_LIBRARIES
+ --
+ -- Do not look for library files in the system default directory.
+
+ S_Bind_No_Time : aliased constant S := "/NO_TIME_STAMP_CHECK " &
+ "-t";
+ -- NODOC (see /TIME_STAMP_CHECK)
+
+ S_Bind_Object : aliased constant S := "/OBJECT_LIST " &
+ "-O";
+ -- /NOOBJECT_LIST (D)
+ -- /OBJECT_LIST
+ --
+ -- Output full names of all the object files that must be linker to
+ -- provide the Ada component of the program. The output is written to
+ -- SYS$OUTPUT.
+
+ S_Bind_Order : aliased constant S := "/ORDER_OF_ELABORATION " &
+ "-l";
+ -- /NOORDER_OF_ELABORATION (D)
+ -- /ORDER_OF_ELABORATION
+ --
+ -- Output chosen elaboration order. The output is written to SYS$OUTPUT.
+
+ S_Bind_Output : aliased constant S := "/OUTPUT=@" &
+ "-o@";
+ -- /OUTPUT=filename
+ --
+ -- File name to use for the program containing the elaboration code.
+
+ S_Bind_OutputX : aliased constant S := "/NOOUTPUT " &
+ "-c";
+ -- /NOOUTPUT
+ --
+ -- Check only. Do not generate the binder output file.
+ --
+ -- In this mode the binder performs all error checks but does not generate
+ -- an output file.
+
+ S_Bind_Pess : aliased constant S := "/PESSIMISTIC_ELABORATION " &
+ "-p";
+ -- /PESSIMISTIC_ELABORATION
+ --
+ -- Causes the binder to choose a "pessimistic" elaboration order, i.e. one
+ -- which is most likely to cause elaboration order problems. This can be
+ -- useful in testing portable code to make sure that there are no missing
+ -- elaborate pragmas.
+
+ S_Bind_Project : aliased constant S := "/PROJECT_FILE=<" &
+ "-P>";
+ -- /PROJECT_FILE=filename
+ --
+ -- Specifies the main project file to be used. The project files rooted
+ -- at the main project file will be parsed before the invocation of the
+ -- binder. The source and object directories to be searched will be
+ -- communicated to the binder through logical names ADA_PRJ_INCLUDE_FILE
+ -- and ADA_PRJ_OBJECTS_FILE.
+
+ S_Bind_Read : aliased constant S := "/READ_SOURCES=" &
+ "ALL " &
+ "-s " &
+ "NONE " &
+ "-x " &
+ "AVAILABLE " &
+ "!-x,!-s";
+ -- /READ_SOURCES[=(keyword[,...])]
+ -- /NOREAD_SOURCES
+ --
+ -- The following keyword are accepted:
+ --
+ -- ALL (D) Require source files to be present. In this mode, the
+ -- binder insists on being able to locate all source files
+ -- that are referenced and checks their consistency. In
+ -- normal mode, if a source file cannot be located it is
+ -- simply ignored. If you specify the ALL keyword, a
+ -- missing source file is an error.
+ --
+ -- NONE Exclude source files. In this mode, the binder only
+ -- checks that ALI files are consistent with one another.
+ -- source files are not accessed. The binder runs faster
+ -- in this mode, and there is still a guarantee that the
+ -- resulting program is self-consistent.
+ --
+ -- If a source file has been edited since it was last
+ -- compiled and you specify the NONE keyword, the binder
+ -- will not detect that the object file is out of date
+ -- with the source file.
+ --
+ -- This is the same as specifying /NOREAD_SOURCES.
+ --
+ -- AVAILABLE Check that object files are consistent with one
+ -- another and are consistent with any source files that
+ -- can be located.
+
+ S_Bind_ReadX : aliased constant S := "/NOREAD_SOURCES " &
+ "-x";
+ -- NODOC (see /READ_SOURCES)
+
+ S_Bind_Rename : aliased constant S := "/RENAME_MAIN=<" &
+ "-M>";
+ -- /RENAME_MAIN=xxx
+ --
+ -- Renames the generated main program from main to xxx.
+ -- This is useful in the case of some cross-building environments, where
+ -- the actual main program is separate from the one generated
+ -- by GNAT BIND.
+
+ S_Bind_Report : aliased constant S := "/REPORT_ERRORS=" &
+ "VERBOSE " &
+ "-v " &
+ "BRIEF " &
+ "-b " &
+ "DEFAULT " &
+ "!-b,!-v";
+ -- /REPORT_ERRORS[=(keyword[,...])]
+ -- VERBOSE (D)
+ -- BRIEF
+ -- DEFAULT
+ -- /NOREPORT_ERRORS
+ --
+ -- With the DEFAULT keyword (which is not the default when the binder is
+ -- run from GNAT BIND) or the /NOREPORT_ERRORS qualifier, brief error
+ -- messages are generated to SYS$ERROR. If the VERBOSE keyword is
+ -- present, a header is written to SYS$OUTPUT and any error messages are
+ -- directed to SYS$OUTPUT All that is written to SYS$ERROR is a brief
+ -- summary message.
+ --
+ -- If the BRIEF keyword is specified, the binder will generate brief error
+ -- messages to SYS$ERROR even if verbose mode is specified. This is
+ -- relevant only when used together with the VERBOSE keyword or /VERBOSE
+ -- qualifier.
+
+ S_Bind_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
+ "!-b,!-v";
+ -- NODOC (see /REPORT_ERRORS)
+
+
+ S_Bind_Restr : aliased constant S := "/RESTRICTION_LIST " &
+ "-r";
+ -- /NORESTRICTION_LIST (D)
+ -- /RESTRICTION_LIST
+ --
+ -- Generate list of pragma Rerstrictions that could be applied to the
+ -- current unit. This is useful for code audit purposes, and also may be
+ -- used to improve code generation in some cases.
+
+ S_Bind_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" &
+ "--RTS=|";
+ -- /RUNTIME_SYSTEM=xxx
+ --
+ -- Binds against an alternate runtime system named xxx or RTS-xxx.
+
+ S_Bind_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+ -- /SEARCH=(directory[,...])
+ --
+ -- When looking for source or object files also look in directories
+ -- specified.
+ --
+ -- This is the same as specifying both /LIBRARY_SEARCH and /SOURCE_SEARCH
+ -- for a directory.
+
+ S_Bind_Shared : aliased constant S := "/SHARED " &
+ "-shared";
+ -- /SHARED (D)
+ -- /NOSHARED
+ --
+ -- Link against a shared GNAT run time when available.
+
+ S_Bind_Slice : aliased constant S := "/TIME_SLICE=#" &
+ "-T#";
+ -- /TIME_SLICE=nnn
+ --
+ -- Set the time slice value to nnn milliseconds. A value of zero means no
+ -- time slicing and also indicates to the tasking run time to match as
+ -- close as possible to the annex D requirements of the RM.
+
+ S_Bind_Source : aliased constant S := "/SOURCE_SEARCH=*" &
+ "-aI*";
+ -- /SOURCE_SEARCH=(directory[,...])
+ --
+ -- When looking for source files also look in directories specified.
+
+ S_Bind_Store : aliased constant S := "/STORE_TRACEBACKS " &
+ "-E";
+ -- /STORE_TRACEBACKS (D)
+ -- /NOSTORE_TRACEBACKS
+ --
+ -- Store tracebacks in exception occurrences.
+ -- This is the default on VMS, with the zero-cost exception mechanism.
+ -- This qualifier has no impact, except when using the setjmp/longjmp
+ -- exception mechanism, with the GNAT COMPILE qualifier /LONGJMP_SETJMP.
+
+ S_Bind_Time : aliased constant S := "/TIME_STAMP_CHECK " &
+ "!-t";
+ -- /TIME_STAMP_CHECK (D)
+ --
+ -- Time stamp errors will be treated as errors.
+ --
+ -- /NOTIME_STAMP_CHECK
+ --
+ -- Ignore time stamp errors. Any time stamp error messages are treated as
+ -- warning messages. This switch essentially disconnects the normal
+ -- consistency checking, and the resulting program may have undefined
+ -- semantics if inconsistent units are present.
+ --
+ -- This means that /NOTIME_STAMP_CHECK should be used only in unusual
+ -- situations, with extreme care.
+
+ S_Bind_Verbose : aliased constant S := "/VERBOSE " &
+ "-v";
+ -- /VERBOSE (D)
+ -- /NOVERBOSE
+ --
+ -- Equivalent to /REPORT_ERRORS=VERBOSE.
+
+ S_Bind_Warn : aliased constant S := "/WARNINGS=" &
+ "NORMAL " &
+ "!-ws,!-we " &
+ "SUPPRESS " &
+ "-ws " &
+ "ERROR " &
+ "-we";
+ -- /WARNINGS[=(keyword[,...])]
+ -- /NOWARNINGS
+ --
+ -- The following keywords are supported:
+ --
+ -- NORMAL (D) Print warning messages and treat them as warning.
+ -- SUPPRESS Suppress all warning messages (same as /NOWARNINGS).
+ -- ERROR Treat any warning messages as fatal errors
+
+ S_Bind_WarnX : aliased constant S := "/NOWARNINGS " &
+ "-ws";
+ -- NODOC (see /WARNINGS)
+
+ S_Bind_Zero : aliased constant S := "/ZERO_MAIN " &
+ "-z";
+ -- /NOZERO_MAIN (D)
+ -- /ZERO_MAIN
+ --
+ -- Normally the binder checks that the unit name given on the command line
+ -- corresponds to a suitable main subprogram. When /ZERO_MAIN is used,
+ -- a list of ALI files can be given, and the execution of the program
+ -- consists of elaboration of these units in an appropriate order.
+
+ Bind_Switches : aliased constant Switches :=
+ (S_Bind_Bind 'Access,
+ S_Bind_Build 'Access,
+ S_Bind_Current 'Access,
+ S_Bind_Debug 'Access,
+ S_Bind_DebugX 'Access,
+ S_Bind_Elab 'Access,
+ S_Bind_Error 'Access,
+ S_Bind_Ext 'Access,
+ S_Bind_Force 'Access,
+ S_Bind_Help 'Access,
+ S_Bind_Init 'Access,
+ S_Bind_Library 'Access,
+ S_Bind_Linker 'Access,
+ S_Bind_Main 'Access,
+ S_Bind_Mess 'Access,
+ S_Bind_Nostinc 'Access,
+ S_Bind_Nostlib 'Access,
+ S_Bind_No_Time 'Access,
+ S_Bind_Object 'Access,
+ S_Bind_Order 'Access,
+ S_Bind_Output 'Access,
+ S_Bind_OutputX 'Access,
+ S_Bind_Pess 'Access,
+ S_Bind_Project 'Access,
+ S_Bind_Read 'Access,
+ S_Bind_ReadX 'Access,
+ S_Bind_Rename 'Access,
+ S_Bind_Report 'Access,
+ S_Bind_ReportX 'Access,
+ S_Bind_Restr 'Access,
+ S_Bind_RTS 'Access,
+ S_Bind_Search 'Access,
+ S_Bind_Shared 'Access,
+ S_Bind_Slice 'Access,
+ S_Bind_Source 'Access,
+ S_Bind_Store 'Access,
+ S_Bind_Time 'Access,
+ S_Bind_Verbose 'Access,
+ S_Bind_Warn 'Access,
+ S_Bind_WarnX 'Access,
+ S_Bind_Zero 'Access);
+
+ ----------------------------
+ -- Switches for GNAT CHOP --
+ ----------------------------
+
+ S_Chop_Comp : aliased constant S := "/COMPILATION " &
+ "-c";
+ -- /NOCOMPILATION (D)
+ -- /COMPILATION
+ --
+ -- Compilation mode, handle configuration pragmas strictly according to
+ -- RM rules.
+
+ S_Chop_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
+ "-k#";
+ -- /FILE_NAME_MAX_LENGTH[=nnn]
+ --
+ -- Limit generated file names to NNN (default of 8) characters. This is
+ -- useful if the resulting set of files is required to be interoperable
+ -- with systems like MS-DOS which limit the length of file names.
+
+ S_Chop_Help : aliased constant S := "/HELP " &
+ "-h";
+ -- /NOHELP (D)
+ -- /HELP
+ --
+ -- Print usage information.
+
+ S_Chop_Over : aliased constant S := "/OVERWRITE " &
+ "-w";
+ -- /NOOVERWRITE (D)
+ -- /OVERWRITE
+ --
+ -- Overwrite existing file names. Normally GNAT CHOP regards it as a
+ -- fatal error situation if there is already a file with the same name as
+ -- a file it would otherwise output. The /OVERWRITE qualifier bypasses
+ -- this check, and any such existing files will be silently overwritten.
+
+ S_Chop_Pres : aliased constant S := "/PRESERVE " &
+ "-p";
+ -- /NOPRESERVE (D)
+ -- /PRESERVE
+ --
+ -- Causes the file modification time stamp of the input file to be
+ -- preserved and used for the time stamp of the output file(s). This may
+ -- be useful for preserving coherency of time stamps in an enviroment
+ -- where gnatchop is used as part of a standard build process.
+
+ S_Chop_Quiet : aliased constant S := "/QUIET " &
+ "-q";
+ -- /NOQUIET (D)
+ -- /QUIET
+ --
+ -- Work quietly, only output warnings and errors.
+
+ S_Chop_Ref : aliased constant S := "/REFERENCE " &
+ "-r";
+ -- /NOREFERENCE (D)
+ -- /REFERENCE
+ --
+ -- Generate "Source_Reference" pragmas. Use this qualifier if the output
+ -- files are regarded as temporary and development is to be done in terms
+ -- of the original unchopped file. The /REFERENCE qualifier causes
+ -- "Source_Reference" pragmas to be inserted into each of the generated
+ -- files to refers back to the original file name and line number. The
+ -- result is that all error messages refer back to the original unchopped
+ -- file.
+ --
+ -- In addition, the debugging information placed into the object file
+ -- (when the /DEBUG qualifier of GNAT COMPILE or GNAT MAKE is specified)
+ -- also refers back to this original file so that tools like profilers
+ -- and debuggers will give information in terms of the original unchopped
+ -- file.
+
+ S_Chop_Verb : aliased constant S := "/VERBOSE " &
+ "-v";
+ -- /NOVERBOSE (D)
+ -- /VERBOSE
+ --
+ -- The version number and copyright notice are output, as well as exact
+ -- copies of the gnat1 commands spawned to obtain the chop control
+ -- information.
+
+ Chop_Switches : aliased constant Switches :=
+ (S_Chop_Comp 'Access,
+ S_Chop_File 'Access,
+ S_Chop_Help 'Access,
+ S_Chop_Over 'Access,
+ S_Chop_Pres 'Access,
+ S_Chop_Quiet 'Access,
+ S_Chop_Ref 'Access,
+ S_Chop_Verb 'Access);
+
+ -----------------------------
+ -- Switches for GNAT CLEAN --
+ -----------------------------
+
+ S_Clean_Compil : aliased constant S := "/COMPILER_FILES_ONLY " &
+ "-c";
+ -- /NOCOMPILER_FILES_ONLY (D)
+ -- /COMPILER_FILES_ONLY
+ --
+ -- Only attempt to delete the files produced by the compiler, not those
+ -- produced by the binder or the linker. The files that are not to be
+ -- deleted are library files, interface copy files, binder generated files
+ -- and executable files.
+
+ S_Clean_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+ -- /CURRENT_DIRECTORY (D)
+ --
+ -- Look for ALI or object files in the directory where GNAT CLEAN was
+ -- invoked.
+ --
+ -- /NOCURRENT_DIRECTORY
+ --
+ -- Do not look for ALI or object files in the directory where GNAT CLEAN
+ -- was invoked.
+
+ S_Clean_Delete : aliased constant S := "/DELETE " &
+ "!-n";
+ -- /DELETE (D)
+ --
+ -- Delete the files that are not read-only.
+ --
+ -- /NODELETE
+ --
+ -- Informative-only mode. Do not delete any files. Output the list of the
+ -- files that would have been deleted if this switch was not specified.
+
+ S_Clean_Dirobj : aliased constant S := "/DIRECTORY_OBJECTS=@" &
+ "-D@";
+ -- /DIRECTORY_OBJECTS=<file>
+ --
+ -- Find the object files and .ALI files in <file>.
+ -- This qualifier is not compatible with /PROJECT_FILE.
+
+ S_Clean_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
+ "-X" & '"';
+ -- /EXTERNAL_REFERENCE="name=val"
+ --
+ -- Specifies an external reference to the project manager. Useful only if
+ -- /PROJECT_FILE is used.
+ --
+ -- Example:
+ -- /EXTERNAL_REFERENCE="DEBUG=TRUE"
+
+ S_Clean_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " &
+ "-F";
+ -- /NOFULL_PATH_IN_BRIEF_MESSAGES (D)
+ -- /FULL_PATH_IN_BRIEF_MESSAGES
+ --
+ -- When using project files, if some errors or warnings are detected
+ -- during parsing and verbose mode is not in effect (no use of qualifier
+ -- /VERBOSE), then error lines start with the full path name of the
+ -- project file, rather than its simple file name.
+
+ S_Clean_Help : aliased constant S := "/HELP " &
+ "-h";
+ -- /NOHELP (D)
+ -- /HELP
+ --
+ -- Output a message explaining the usage of gnatclean.
+
+ S_Clean_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
+ "DEFAULT " &
+ "-vP0 " &
+ "MEDIUM " &
+ "-vP1 " &
+ "HIGH " &
+ "-vP2";
+ -- /MESSAGES_PROJECT_FILE[=messages-option]
+ --
+ -- Specifies the "verbosity" of the parsing of project files.
+ -- messages-option may be one of the following:
+ --
+ -- DEFAULT (D) No messages are output if there is no error or warning.
+ --
+ -- MEDIUM A small number of messages are output.
+ --
+ -- HIGH A great number of messages are output, most of them not
+ -- being useful for the user.
+
+
+ S_Clean_Object : aliased constant S := "/OBJECT_SEARCH=*" &
+ "-aO*";
+ -- /OBJECT_SEARCH=(directory,...)
+ --
+ -- When searching for library and object files, look in the specified
+ -- directories. The order in which library files are searched is the same
+ -- as for MAKE.
+
+ S_Clean_Project : aliased constant S := "/PROJECT_FILE=<" &
+ "-P>";
+ -- /PROJECT_FILE=filename
+ --
+ -- Specifies the main project file to be used. The project files rooted
+ -- at the main project file will be parsed before the invocation of the
+ -- compiler. The source and object directories to be searched will be
+ -- communicated to gnatclean through logical names ADA_PRJ_INCLUDE_FILE
+ -- and ADA_PRJ_OBJECTS_FILE.
+
+ S_Clean_Quiet : aliased constant S := "/QUIET " &
+ "-q";
+ -- /NOQUIET (D)
+ -- /QUIET
+ --
+ -- Quiet output. If there are no error, do not ouuput anything, except in
+ -- verbose mode (qualifier /VERBOSE) or in informative-only mode
+ -- (qualifier /NODELETE).
+
+ S_Clean_Recurs : aliased constant S := "/RECURSIVE " &
+ "-r";
+ -- /NORECURSIVE (D)
+ -- /RECURSIVE
+ --
+ -- When a project file is specified (using switch -P), clean all imported
+ -- and extended project files, recursively. If this qualifier is not
+ -- specified, only the files related to the main project file are to be
+ -- deleted. This qualifier has no effect if no project file is specified.
+
+ S_Clean_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+ -- /SEARCH=(directory,...)
+ --
+ -- Equivalent to /OBJECT_SEARCH=(directory,...).
+
+ S_Clean_Verbose : aliased constant S := "/VERBOSE " &
+ "-v";
+ -- /NOVERBOSE (D)
+ -- /VERBOSE
+ --
+ -- Verbose mode.
+
+ Clean_Switches : aliased constant Switches :=
+ (S_Clean_Compil 'Access,
+ S_Clean_Current'Access,
+ S_Clean_Delete 'Access,
+ S_Clean_Dirobj 'Access,
+ S_Clean_Ext 'Access,
+ S_Clean_Full 'Access,
+ S_Clean_Help 'Access,
+ S_Clean_Mess 'Access,
+ S_Clean_Object 'Access,
+ S_Clean_Project'Access,
+ S_Clean_Quiet 'Access,
+ S_Clean_Recurs 'Access,
+ S_Clean_Search 'Access,
+ S_Clean_Verbose'Access);
+
+ -------------------------------
+ -- Switches for GNAT COMPILE --
+ -------------------------------
+
+ S_GCC_Ada_83 : aliased constant S := "/83 " &
+ "-gnat83";
+ -- /NO83 (D)
+ -- /83
+ --
+ -- Although GNAT is primarily an Ada 95 compiler, it accepts this
+ -- qualifier to specify that an Ada 83 mode program is being compiled. If
+ -- you specify this qualifier, GNAT rejects Ada 95 extensions and applies
+ -- Ada 83 semantics. It is not possible to guarantee this qualifier does
+ -- a perfect job; for example, some subtle tests of pathological cases,
+ -- such as are found in ACVC tests that have been removed from the ACVC
+ -- suite for Ada 95, may not compile correctly. However for practical
+ -- purposes, using this qualifier should ensure that programs that
+ -- compile correctly under the /83 qualifier can be ported reasonably
+ -- easily to an Ada 83 compiler. This is the main use of this qualifier.
+ --
+ -- With few exceptions (most notably the need to use "<>" on
+ -- unconstrained generic formal parameters), it is not necessary to use
+ -- this qualifier switch when compiling Ada 83 programs, because, with
+ -- rare and obscure exceptions, Ada 95 is upwardly compatible with Ada
+ -- 83. This means that a correct Ada 83 program is usually also a correct
+ -- Ada 95 program.
+
+ S_GCC_Ada_95 : aliased constant S := "/95 " &
+ "!-gnat83";
+ -- /95 (D)
+ --
+ -- Same as /NO83.
+ --
+ -- /NO95
+ --
+ -- Same as /83.
+
+ S_GCC_Asm : aliased constant S := "/ASM " &
+ "-S,!-c";
+ -- /NOASM (D)
+ -- /ASM
+ --
+ -- Use to cause the assembler source file to be generated, using S as the
+ -- filetype, instead of the object file. This may be useful if you need
+ -- to examine the generated assembly code.
+
+ S_GCC_Checks : aliased constant S := "/CHECKS=" &
+ "FULL " &
+ "-gnato,!-gnatE,!-gnatp " &
+ "OVERFLOW " &
+ "-gnato " &
+ "ELABORATION " &
+ "-gnatE " &
+ "ASSERTIONS " &
+ "-gnata " &
+ "DEFAULT " &
+ "!-gnato,!-gnatp " &
+ "STACK " &
+ "-fstack-check " &
+ "SUPPRESS_ALL " &
+ "-gnatp";
+ -- /NOCHECKS
+ -- /CHECKS[=(keyword[,...])]
+ --
+ -- If you compile with the default options, GNAT will insert many runtime
+ -- checks into the compiled code, including code that performs range
+ -- checking against constraints, but not arithmetic overflow checking for
+ -- integer operations (including division by zero) or checks for access
+ -- before elaboration on subprogram calls. All other runtime checks, as
+ -- required by the Ada 95 Reference Manual, are generated by default.
+ --
+ -- You may specify one or more of the following keywords to the /CHECKS
+ -- qualifier to modify this behavior:
+ --
+ -- DEFAULT The behavior described above. This is the default
+ -- if the /CHECKS qualifier is not present on the
+ -- command line. Same as /NOCHECKS.
+ --
+ -- OVERFLOW Enables overflow checking for integer operations and
+ -- checks for access before elaboration on subprogram
+ -- calls. This causes GNAT to generate slower and larger
+ -- executable programs by adding code to check for both
+ -- overflow and division by zero (resulting in raising
+ -- "Constraint_Error" as required by Ada semantics).
+ -- Similarly, GNAT does not generate elaboration check
+ -- by default, and you must specify this keyword to
+ -- enable them.
+ --
+ -- Note that this keyword does not affect the code
+ -- generated for any floating-point operations; it
+ -- applies only to integer operations. For floating-point,
+ -- GNAT has the "Machine_Overflows" attribute set to
+ -- "False" and the normal mode of operation is to generate
+ -- IEEE NaN and infinite values on overflow or invalid
+ -- operations (such as dividing 0.0 by 0.0).
+ --
+ -- ELABORATION Enables dynamic checks for access-before-elaboration
+ -- on subprogram calls and generic instantiations.
+ --
+ -- ASSERTIONS The pragmas "Assert" and "Debug" normally have no
+ -- effect and are ignored. This keyword causes "Assert"
+ -- and "Debug" pragmas to be activated.
+ --
+ -- SUPPRESS_ALL Suppress all runtime checks as though you have "pragma
+ -- Suppress (all_checks)" in your source. Use this switch
+ -- to improve the performance of the code at the expense
+ -- of safety in the presence of invalid data or program
+ -- bugs.
+ --
+ -- DEFAULT Suppress the effect of any option OVERFLOW or
+ -- ASSERTIONS.
+ --
+ -- FULL (D) Similar to OVERFLOW, but suppress the effect of any
+ -- option ELABORATION or SUPPRESS_ALL.
+ --
+ -- These keywords only control the default setting of the checks. You
+ -- may modify them using either "Suppress" (to remove checks) or
+ -- "Unsuppress" (to add back suppressed checks) pragmas in your program
+ -- source.
+
+ S_GCC_ChecksX : aliased constant S := "/NOCHECKS " &
+ "-gnatp,!-gnato,!-gnatE";
+ -- NODOC (see /CHECKS)
+
+ S_GCC_Compres : aliased constant S := "/COMPRESS_NAMES " &
+ "-gnatC";
+ -- /NOCOMPRESS_NAMES (D)
+ -- /COMPRESS_NAMES
+ --
+ -- Compress debug information and external symbol name table entries.
+ -- In the generated debugging information, and also in the case of long
+ -- external names, the compiler uses a compression mechanism if the name
+ -- is very long. This compression method uses a checksum, and avoids
+ -- trouble on some operating systems which have difficulty with very long
+ -- names.
+
+ S_GCC_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" &
+ "-gnatec>";
+ -- /CONFIGURATION_PRAGMAS_FILE=file
+ --
+ -- Specify a configuration pragmas file that need to be taken into account
+
+ S_GCC_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+ -- /CURRENT_DIRECTORY (D)
+ -- /NOCURRENT_DIRECTORY
+ --
+ -- Look for source files in the default directory.
+
+ S_GCC_Data : aliased constant S := "/DATA_PREPROCESSING=<" &
+ "-gnatep>";
+ -- /DATA_PREPROCESSING=file_name
+ --
+ -- This qualifier indicates to the compiler the file name (without
+ -- directory information) of the preprocessor data file to use.
+ -- The preprocessor data file should be found in the source directories.
+ --
+ -- A preprocessing data file is a text file with significant lines
+ -- indicating how should be preprocessed either a specific source or all
+ -- sources not mentioned in other lines. A significant line is a non
+ -- empty, non comment line. Comments are similar to Ada comments.
+ --
+ -- Each significant line starts with either a literal string or the
+ -- character '*'. A literal string is the file name (without directory
+ -- information) of the source to preprocess. A character '*' indicates the
+ -- preprocessing for all the sources that are not specified explicitly on
+ -- other lines. It is an error to have two lines with the same file name
+ -- or two lines starting with the character '*'.
+ --
+ -- After the file name or the character '*', another optional literal
+ -- string indicating the file name of the definition file to be used for
+ -- preprocessing. (see 15.3 Form of Definitions File. The definition files
+ -- are found by the compiler in one of the source directories. In some
+ -- cases, when compiling a source in a directory other than the current
+ -- directory, if the definition file is in the current directory, it may
+ -- be necessary to add the current directory as a source directory through
+ -- qualifier "/SEARCH=[]", otherwise the compiler would not find the
+ -- definition file.
+ --
+ -- Then, optionally, switches similar to those of gnatprep may be found.
+ -- Those switches are:
+ --
+ -- -b Causes both preprocessor lines and the lines deleted by
+ -- preprocessing to be replaced by blank lines, preserving
+ -- the line number. This switch is always implied;
+ -- however, if specified after `-c' it cancels the effect
+ -- of `-c'.
+ --
+ -- -c Causes both preprocessor lines and the lines deleted by
+ -- preprocessing to be retained as comments marked with
+ -- the special string "--! ".
+ --
+ -- -Dsymbol=value Define or redefine a symbol, associated with value.
+ -- A symbol is an Ada identifier, or an Ada reserved word,
+ -- with the exception of "if", "else", "elsif", "end",
+ -- "and", "or" and "then". value is either a literal
+ -- string, an Ada identifier or any Ada reserved word.
+ -- A symbol declared with this switch replaces a symbol
+ -- with the same name defined in a definition file.
+ --
+ -- -s Causes a sorted list of symbol names and values to be
+ -- listed on the standard output file.
+ --
+ -- -u Causes undefined symbols to be treated as having the
+ -- value FALSE in the context of a preprocessor test.
+ -- In the absence of this option, an undefined symbol
+ -- in a #if or #elsif test will be treated as an error.
+ --
+ -- Examples of valid lines in a preprocessor data file:
+ --
+ -- "toto.adb" "prep.def" -u
+ -- -- preprocess "toto.adb", using definition file "prep.def",
+ -- -- undefined symbol are False.
+ --
+ -- * -c -DVERSION=V101
+ -- -- preprocess all other sources without a definition file;
+ -- -- suppressed lined are commented; symbol VERSION has the value
+ -- -- V101.
+ --
+ -- "titi.adb" "prep2.def" -s
+ -- -- preprocess "titi.adb", using definition file "prep2.def";
+ -- -- list all symbols with their values.
+
+ S_GCC_Debug : aliased constant S := "/DEBUG=" &
+ "SYMBOLS " &
+ "-g2 " &
+ "NOSYMBOLS " &
+ "!-g2 " &
+ "TRACEBACK " &
+ "-g1 " &
+ "ALL " &
+ "-g3 " &
+ "NONE " &
+ "-g0 " &
+ "NOTRACEBACK " &
+ "-g0";
+ -- /DEBUG[=debug-level]
+ -- /NODEBUG
+ --
+ -- Specifies how much debugging information is to be included in
+ -- the resulting object fie.
+ --
+ -- 'debug-level' is one of the following:
+ --
+ -- SYMBOLS (D) Include both debugger symbol records and traceback
+ -- in the object file.
+ --
+ -- ALL Include debugger symbol records, traceback plus
+ -- extra debug information in the object file.
+ --
+ -- NONE Excludes both debugger symbol records and traceback
+ -- from the object file. Same as /NODEBUG.
+ --
+ -- TRACEBACK Includes only traceback records in the object
+ -- file. This is the default when /DEBUG is not used.
+
+ S_GCC_DebugX : aliased constant S := "/NODEBUG " &
+ "!-g";
+ -- NODOC (see /Debug)
+
+ S_GCC_Dist : aliased constant S := "/DISTRIBUTION_STUBS=" &
+ "RECEIVER " &
+ "-gnatzr " &
+ "CALLER " &
+ "-gnatzc";
+ -- /NODISTRIBUTION_STUBS (D)
+ -- /DISTRIBUTION_STUBS[=dist-opt]
+ --
+ -- 'dist-opt' is either RECEIVER (the default) or SENDER and indicates
+ -- that stubs for use in distributed programs (see the Distributed
+ -- Systems Annex of the Ada RM) should be generated.
+
+ S_GCC_DistX : aliased constant S := "/NODISTRIBUTION_STUBS " &
+ "!-gnatzr,!-gnatzc";
+ -- NODOC (see /DISTRIBUTION_STUBS)
+
+ S_GCC_Error : aliased constant S := "/ERROR_LIMIT=#" &
+ "-gnatm#";
+ -- /NOERROR_LIMIT (D)
+ -- /ERROR_LIMIT=nnn
+ --
+ -- NNN is a decimal integer in the range of 1 to 999999 and limits the
+ -- number of error messages to be generated to that number. Once that
+ -- number has been reached, the compilation is abandoned.
+ -- Specifying 999999 is equivalent to /NOERROR_LIMIT.
+
+ S_GCC_ErrorX : aliased constant S := "/NOERROR_LIMIT " &
+ "-gnatm999999";
+ -- NODOC (see /ERROR_LIMIT)
+
+ S_GCC_Expand : aliased constant S := "/EXPAND_SOURCE " &
+ "-gnatG";
+ -- /NOEXPAND_SOURCE (D)
+ -- /EXPAND_SOURCE
+ --
+ -- Produces a listing of the expanded code in Ada source form. For
+ -- example, all tasking constructs are reduced to appropriate run-time
+ -- library calls.
+
+ S_GCC_Extend : aliased constant S := "/EXTENSIONS_ALLOWED " &
+ "-gnatX";
+ -- /NOEXTENSIONS_ALLOWED (D)
+ -- /EXTENSIONS_ALLOWED
+ --
+ -- GNAT specific language extensions allowed.
+
+ S_GCC_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
+ "-X" & '"';
+ -- /EXTERNAL_REFERENCE="name=val"
+ --
+ -- Specifies an external reference to the project manager. Useful only if
+ -- /PROJECT_FILE is used.
+ --
+ -- Example:
+ -- /EXTERNAL_REFERENCE="DEBUG=TRUE"
+
+ S_GCC_File : aliased constant S := "/FILE_NAME_MAX_LENGTH=#" &
+ "-gnatk#";
+ -- /FILE_NAME_MAX_LENGTH=nnn
+ --
+ -- Activates file name "krunching". NNN, a decimal integer in the range
+ -- 1-999, indicates the maximum allowable length of a file name (not
+ -- including the ADS or ADB filetype. The default is not to enable file
+ -- name krunching.
+
+ S_GCC_Force : aliased constant S := "/FORCE_ALI " &
+ "-gnatQ";
+ -- /NOFORCE_ALI (D)
+ -- /FORCE_ALI
+ --
+ -- In normal operation mode, the .ALI file is not generated if any
+ -- illegalities are detected in the program. The use of this qualifier
+ -- forces generation of the .ALI file. This file is marked as being
+ -- in error, so it cannot be used for binding purposes, but it does
+ -- contain reasonably complete cross-reference information, and thus may
+ -- be useful for use by tools (e.g. semantic browing tools or integrated
+ -- development environments) that are driven from the .ALI file.
+
+ S_GCC_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " &
+ "-gnatef";
+ -- /NOFULL_PATH_IN_BRIEF_MESSAGES (D)
+ -- /FULL_PATH_IN_BRIEF_MESSAGES
+ --
+ -- When using project files, if some errors or warnings are detected
+ -- during parsing and verbose mode is not in effect (no use of qualifier
+ -- /VERBOSE), then error lines start with the full path name of the
+ -- project file, rather than its simple file name.
+
+ S_GCC_Help : aliased constant S := "/HELP " &
+ "-gnath";
+ -- /NOHELP (D)
+ -- /HELP
+ --
+ -- Output usage information.
+
+ S_GCC_Ident : aliased constant S := "/IDENTIFIER_CHARACTER_SET=" &
+ "DEFAULT " &
+ "-gnati1 " &
+ "1 " &
+ "-gnati1 " &
+ "2 " &
+ "-gnati2 " &
+ "3 " &
+ "-gnati3 " &
+ "4 " &
+ "-gnati4 " &
+ "5 " &
+ "-gnati5 " &
+ "PC " &
+ "-gnatip " &
+ "PC850 " &
+ "-gnati8 " &
+ "FULL_UPPER " &
+ "-gnatif " &
+ "NO_UPPER " &
+ "-gnatin " &
+ "WIDE " &
+ "-gnatiw";
+ -- /NOIDENTIFIER_CHARACTER_SET (D)
+ -- /IDENTIFIER_CHARACTER_SET=char-set
+ --
+ -- Normally GNAT recognizes the Latin-1 character set in source program
+ -- identifiers, as described in the reference manual. This qualifier
+ -- causes GNAT to recognize alternate character sets in identifiers.
+ -- 'char-set' is one of the following strings indicating the character
+ -- set:
+ --
+ -- DEFAULT (D) Equivalent to 1, below. Also equivalent to
+ -- /NOIDENTIFIER_CHARACTER_SET.
+ --
+ -- 1 The basic character set is Latin-1. This character
+ -- set is defined by ISO standard 8859, part 1. The lower
+ -- half (character codes 16#00# ... 16#7F#) is identical
+ -- to standard ASCII coding, but the upper half is used
+ -- to represent additional characters. This includes
+ -- extended letters used by European languages, such as
+ -- the umlaut used in German.
+ --
+ -- You may use any of these extended characters freely
+ -- in character or string literals. In addition, the
+ -- extended characters that represent letters can be
+ -- used in identifiers.
+ --
+ -- 2 Latin-2 letters allowed in identifiers, with uppercase
+ -- and lowercase equivalence.
+ --
+ -- 3 Latin-3 letters allowed in identifiers, with uppercase
+ -- and lower case equivalence.
+ --
+ -- 4 Latin-4 letters allowed in identifiers, with uppercase
+ -- and lower case equivalence.
+ --
+ -- PC IBM PC code page 437. This code page is the normal
+ -- default for PCs in the U.S. It corresponds to the
+ -- original IBM PC character set. This set has some, but
+ -- not all, of the extended Latin-1 letters, but these
+ -- letters do not have the same encoding as Latin-1. In
+ -- this mode, these letters are allowed in identifiers
+ -- with uppercase and lowercase equivalence.
+ --
+ -- PC850 This code page (850) is a modification of 437 extended
+ -- to include all the Latin-1 letters, but still not with
+ -- the usual Latin-1 encoding. In this mode, all these
+ -- letters are allowed in identifiers with uppercase and
+ -- lower case equivalence.
+ --
+ -- FULL_UPPER Any character in the range 80-FF allowed in
+ -- identifiers, and all are considered distinct. In
+ -- other words, there are no uppercase and lower case
+ -- equivalences in this range.
+ --
+ -- NO_UPPER No upper-half characters in the range 80-FF are
+ -- allowed in identifiers. This gives Ada 95
+ -- compatibility for identifier names.
+ --
+ -- WIDE GNAT allows wide character codes to appear in
+ -- character and string literals, and also optionally
+ -- in identifiers. See the /WIDE_CHARACTER_ENCODING
+ -- qualifier for information on encoding formats.
+
+ S_GCC_IdentX : aliased constant S := "/NOIDENTIFIER_CHARACTER_SET " &
+ "-gnati1";
+ -- NODOC (see /IDENTIFIER_CHARACTER_SET)
+
+ S_GCC_Immed : aliased constant S := "/IMMEDIATE_ERRORS " &
+ "-gnatdO";
+ -- /NOIMMEDIATE_ERRORS (D)
+ -- /IMMEDIATE_ERRORS
+ --
+ -- Causes errors to be displayed as soon as they are encountered, rather
+ -- than after compilation is terminated. If GNAT terminates prematurely
+ -- or goes into an infinite loop, the last error message displayed may
+ -- help to pinpoint the culprit.
+
+ S_GCC_Inline : aliased constant S := "/INLINE=" &
+ "PRAGMA " &
+ "-gnatn " &
+ "FULL " &
+ "-gnatN " &
+ "SUPPRESS " &
+ "-fno-inline";
+ -- /NOINLINE (D)
+ -- /INLINE[=keyword]
+ --
+ -- Selects the level of inlining for your program. In the absence of this
+ -- qualifier, GNAT does not attempt inlining across units and does not
+ -- need to access the bodies of subprograms for which "pragma Inline" is
+ -- specified if they are not in the current unit.
+ --
+ -- The supported keywords are as follows:
+ --
+ -- PRAGMA (D) Recognize and process "Inline" pragmas. However,
+ -- for the inlining to actually occur, optimization
+ -- must be enabled. This enables inlining across unit
+ -- boundaries, that is, inlining a call in one unit of
+ -- a subprogram declared in a with'ed unit. The compiler
+ -- will access these bodies, creating an extra source
+ -- dependency for the resulting object file, and where
+ -- possible, the call will be inlined.
+ --
+ -- This qualifier also turns on full optimization and
+ -- requests GNAT to try to attempt automatic inlining
+ -- of small subprograms within a unit.
+ --
+ -- Specifying /OPTIMIZE=NONE will disable the main effect
+ -- of this qualifier, but you may specify other
+ -- optimization options, to get either lower
+ -- (/OPTIMIZE=SOME) or higher (/OPTIMIZE=UNROLL_LOOPS)
+ -- levels of optimization.
+ --
+ -- FULL Front end inlining. The front end inlining activated
+ -- by this switch is generally more extensive, and quite
+ -- often more effective than the standard PRAGMA inlining
+ -- mode. It will also generate additional dependencies.
+ --
+ -- SUPPRESS Suppresses all inlining, even if other optimization
+ -- or inlining switches are set.
+
+ S_GCC_InlineX : aliased constant S := "/NOINLINE " &
+ "!-gnatn,!-gnatN";
+ -- NODOC (see /INLINE)
+
+ S_GCC_Jumps : aliased constant S := "/LONGJMP_SETJMP " &
+ "-gnatL";
+ -- /NOLONGJMP_SETJMP (D)
+ -- /LONGJMP_SETJMP
+ --
+ -- Causes the longjmp/setjmp approach to be used for exception handling.
+ --
+ -- The default mechanism for OpenVMS is zero cost exceptions. This
+ -- qualifier can be used to modify this default, but it must be used for
+ -- all units in the partition, including all run-time library units.
+ -- One way to achieve this is to use the /ALL_FILES and /FORCE_COMPILE
+ -- for gnatmake.
+ -- This option is rarely used. One case in which it may be advantageous is
+ -- in an application where exception raising is common and the overall
+ -- performance of the application is improved by favoring exception
+ -- propagation.
+
+ S_GCC_Length : aliased constant S := "/MAX_LINE_LENGTH=#" &
+ "-gnatyM#";
+ -- /MAX_LINE_LENGTH=nnn
+ --
+ -- Set maximum line length.
+ -- The length of lines must not exceed the given value nnn.
+
+ S_GCC_List : aliased constant S := "/LIST " &
+ "-gnatl";
+ -- /NOLIST (D)
+ -- /LIST
+ --
+ -- Cause a full listing of the file to be generated.
+
+ S_GCC_Mapping : aliased constant S := "/MAPPING_FILE=<" &
+ "-gnatem>";
+ -- /MAPPING_FILE=file_name
+ --
+ -- Use mapping file file_name
+ --
+ -- A mapping file is a way to communicate to the compiler two mappings:
+ -- from unit names to file names (without any directory information) and
+ -- from file names to path names (with full directory information).
+ -- These mappings are used by the compiler to short-circuit the path
+ -- search.
+ --
+ -- The use of mapping files is not required for correct operation of the
+ -- compiler, but mapping files can improve efficiency, particularly when
+ -- sources are read over a slow network connection. In normal operation,
+ -- you need not be concerned with the format or use of mapping files,
+ -- and /MAPPING_FILE is not a qualifier that you would use explicitly.
+ -- It is intended only for use by automatic tools such as GNAT MAKE
+ -- running under the project file facility. The description here of the
+ -- format of mapping files is provided for completeness and for possible
+ -- use by other tools.
+ --
+ -- A mapping file is a sequence of sets of three lines. In each set, the
+ -- first line is the unit name, in lower case, with "%s" appended for
+ -- specifications and "%b" appended for bodies; the second line is the
+ -- file name; and the third line is the path name.
+ --
+ -- Example:
+ --
+ -- main%b
+ -- main.2_ada
+ -- /gnat/project1/sources/main.2_ada
+ --
+ -- When qualifier ?MAPPING_FILE is specified, the compiler will create in
+ -- memory the two mappings from the specified file. If there is any
+ -- problem (non existent file, truncated file or duplicate entries),
+ -- no mapping will be created.
+ --
+ -- Several /MAPPING_FILE qualifiers may be specified; however, only the
+ -- last one on the command line will be taken into account.
+ --
+ -- When using a project file, GNAT MAKE creates a temporary mapping file
+ -- and communicates it to the compiler using this switch.
+
+ S_GCC_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
+ "DEFAULT " &
+ "-vP0 " &
+ "MEDIUM " &
+ "-vP1 " &
+ "HIGH " &
+ "-vP2";
+ -- /MESSAGES_PROJECT_FILE[=messages-option]
+ --
+ -- Specifies the "verbosity" of the parsing of project files.
+ -- messages-option may be one of the following:
+ --
+ -- DEFAULT (D) No messages are output if there is no error or warning.
+ --
+ -- MEDIUM A small number of messages are output.
+ --
+ -- HIGH A great number of messages are output, most of them not
+ -- being useful for the user.
+
+ S_GCC_Noadc : aliased constant S := "/NO_GNAT_ADC " &
+ "-gnatA";
+ -- /NO_GNAT_ADC
+ --
+ -- Cause the compiler to ignore any configuration pragmas file GNAT.ADC
+ -- in the default directory. Implied by qualifier /PROJECT_FILE.
+ -- Often used in conjunction with qualifier /CONFIGURATION_PRAGMAS_FILE.
+
+ S_GCC_Noload : aliased constant S := "/NOLOAD " &
+ "-gnatc";
+ -- /NOLOAD
+ --
+ -- Cause the compiler to operate in semantic check mode with full
+ -- checking for all illegalities specified in the reference manual, but
+ -- without generation of any source code (no object or ALI file
+ -- generated).
+ --
+ -- Since dependent files must be accessed, you must follow the GNAT
+ -- semantic restrictions on file structuring to operate in this mode:
+ --
+ -- o The needed source files must be accessible.
+ -- o Each file must contain only one compilation unit.
+ -- o The file name and unit name must match.
+ --
+ -- The output consists of error messages as appropriate. No object file
+ -- or ALI file is generated. The checking corresponds exactly to the
+ -- notion of legality in the Ada reference manual.
+ --
+ -- Any unit can be compiled in semantics-checking-only mode, including
+ -- units that would not normally be compiled (generic library units,
+ -- subunits, and specifications where a separate body is present).
+
+ S_GCC_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
+ "-nostdinc";
+ -- /NOSTD_INCLUDES
+ --
+ -- Do not look in the default directory for source files of the runtime.
+
+ S_GCC_Opt : aliased constant S := "/OPTIMIZE=" &
+ "ALL " &
+ "-O2,!-O0,!-O1,!-O3 " &
+ "NONE " &
+ "-O0,!-O1,!-O2,!-O3 " &
+ "SOME " &
+ "-O1,!-O0,!-O2,!-O3 " &
+ "DEVELOPMENT " &
+ "-O1,!-O0,!-O2,!-O3 " &
+ "UNROLL_LOOPS " &
+ "-funroll-loops " &
+ "INLINING " &
+ "-O3,!-O0,!-O1,!-O2";
+ -- /NOOPTIMIZE (D)
+ -- /OPTIMIZE[=(keyword[,...])]
+ --
+ -- Selects the level of optimization for your program. The supported
+ -- keywords are as follows:
+ --
+ -- ALL (D) Perform most optimizations, including those that
+ -- may be expensive.
+ --
+ -- NONE Do not do any optimizations. Same as /NOOPTIMIZE.
+ --
+ -- SOME Perform some optimizations, but omit ones that
+ -- are costly.
+ --
+ -- DEVELOPMENT Same as SOME.
+ --
+ -- INLINING Full optimization, and also attempt automatic inlining
+ -- of small subprograms within a unit
+ --
+ -- UNROLL_LOOPS Try to unroll loops. This keyword may be specified
+ -- with any keyword above other than NONE. Loop
+ -- unrolling usually, but not always, improves the
+ -- performance of programs.
+
+ S_GCC_OptX : aliased constant S := "/NOOPTIMIZE " &
+ "-O0,!-O1,!-O2,!-O3";
+ -- NODOC (see /OPTIMIZE)
+
+ S_GCC_Polling : aliased constant S := "/POLLING " &
+ "-gnatP";
+ -- /NOPOLLING (D)
+ -- /POLLING
+ --
+ -- Enable polling. See the description of pragma Polling in the GNAT
+ -- Reference Manual for full details.
+
+ S_GCC_Project : aliased constant S := "/PROJECT_FILE=<" &
+ "-P>";
+ -- /PROJECT_FILE=filename
+ --
+ -- Specifies the main project file to be used. The project files rooted
+ -- at the main project file will be parsed before the invocation of the
+ -- compiler. The source and object directories to be searched will be
+ -- communicated to the compiler through logical names
+ -- ADA_PRJ_INCLUDE_FILE and ADA_PRJ_OBJECTS_FILE.
+
+ S_GCC_Report : aliased constant S := "/REPORT_ERRORS=" &
+ "VERBOSE " &
+ "-gnatv " &
+ "BRIEF " &
+ "-gnatb " &
+ "FULL " &
+ "-gnatf " &
+ "IMMEDIATE " &
+ "-gnatdO " &
+ "DEFAULT " &
+ "!-gnatb,!-gnatv";
+ -- /NOREPORT_ERRORS (D)
+ -- /REPORT_ERRORS[=(keyword[,...])]
+ --
+ -- Change the way errors are reported. The following keywords are
+ -- supported:
+ --
+ -- VERBOSE (D) Verbose mode. Full error output with source lines
+ -- to SYS$OUTPUT.
+ --
+ -- BRIEF Generate the brief format error messages to
+ -- SYS$OUTPUT as well as the verbose format message or
+ -- full listing.
+ --
+ -- FULL Normally, the compiler suppresses error messages that
+ -- are likely to be redundant. This keyword causes all
+ -- error messages to be generated. One particular effect
+ -- is for the case of references to undefined variables.
+ -- If a given variable is referenced several times, the
+ -- normal format of messages produces one error. With
+ -- FULL, each undefined reference produces a separate
+ -- error message.
+ --
+ -- IMMEDIATE Normally, the compiler saves up error messages and
+ -- generates them at the end of compilation in proper
+ -- sequence. This keyword causes error messages to be
+ -- generated as soon as they are detected. The use of
+ -- IMMEDIATE usually causes error messages to be
+ -- generated out of sequence. Use it when the compiler
+ -- blows up due to an internal error. In this case, the
+ -- error messages may be lost. Sometimes blowups are
+ -- the result of mishandled error messages, so you may
+ -- want to run with this keyword to determine whether
+ -- any error messages were generated.
+ --
+ -- DEFAULT Turn off VERBOSE and BRIEF. Same as /NOREPORT_ERRORS.
+
+ S_GCC_ReportX : aliased constant S := "/NOREPORT_ERRORS " &
+ "!-gnatb,!-gnatv";
+ -- NODOC (see /REPORT_ERRORS)
+
+ S_GCC_Repinfo : aliased constant S := "/REPRESENTATION_INFO=" &
+ "DEFAULT " &
+ "-gnatR " &
+ "NONE " &
+ "-gnatR0 " &
+ "ARRAYS " &
+ "-gnatR1 " &
+ "ARRAYS_FILE " &
+ "-gnatR1s " &
+ "OBJECTS " &
+ "-gnatR2 " &
+ "OBJECTS_FILE " &
+ "-gnatR2s " &
+ "SYMBOLIC " &
+ "-gnatR3 " &
+ "SYMBOLIC_FILE " &
+ "-gnatR3s";
+ -- /NOREPRESENTATION_INFO (D)
+ -- /REPRESENTATION_INFO[=(keyword[,...])]
+ --
+ -- This qualifier controls output from the compiler of a listing showing
+ -- representation information for declared types and objects.
+ --
+ -- ARRAYS (D) Size and alignment information is listed for
+ -- declared array and record types.
+ --
+ -- ARRAYS_FILE Similar to ARRAYS, but the output is to a file
+ -- with the name 'file_rep' where 'file' is the name
+ -- of the corresponding source file.
+ --
+ -- NONE no information is output (equivalent to omitting
+ -- the /REPRESENTATION_INFO qualifiers).
+ --
+ -- OBJECTS Size and alignment information is listed for all
+ -- declared types and objects.
+ --
+ -- OBJECTS_FILE Similar to OBJECTS, but the output is to a file
+ -- with the name 'file_rep' where 'file' is the name
+ -- of the corresponding source file.
+ --
+ -- SYMBOLIC Symbolic expression information for values that
+ -- are computed at run time for variant records.
+ --
+ -- SYMBOLIC_FILE Similar to SYMBOLIC, but the output is to a file
+ -- with the name 'file_rep' where 'file' is the name
+ -- of the corresponding source file.
+ --
+ -- DEFAULT Equivalent to ARRAYS.
+
+ S_GCC_RepinfX : aliased constant S := "/NOREPRESENTATION_INFO " &
+ "!-gnatR";
+ -- NODOC (see /REPRESENTATION_INFO)
+
+ S_GCC_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" &
+ "--RTS=|";
+ -- /RUNTIME_SYSTEM=xxx
+ --
+ -- Build against an alternate runtime system named xxx or RTS-xxx.
+
+ S_GCC_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+ -- /SEARCH=(directory[,...])
+ --
+ -- When looking for source files also look in directories specified.
+
+ S_GCC_Style : aliased constant S := "/STYLE_CHECKS=" &
+ "ALL_BUILTIN " &
+ "-gnaty " &
+ "1 " &
+ "-gnaty1 " &
+ "2 " &
+ "-gnaty2 " &
+ "3 " &
+ "-gnaty3 " &
+ "4 " &
+ "-gnaty4 " &
+ "5 " &
+ "-gnaty5 " &
+ "6 " &
+ "-gnaty6 " &
+ "7 " &
+ "-gnaty7 " &
+ "8 " &
+ "-gnaty8 " &
+ "9 " &
+ "-gnaty9 " &
+ "ATTRIBUTE " &
+ "-gnatya " &
+ "BLANKS " &
+ "-gnatyb " &
+ "COMMENTS " &
+ "-gnatyc " &
+ "END " &
+ "-gnatye " &
+ "VTABS " &
+ "-gnatyf " &
+ "GNAT " &
+ "-gnatg " &
+ "HTABS " &
+ "-gnatyh " &
+ "IF_THEN " &
+ "-gnatyi " &
+ "KEYWORD " &
+ "-gnatyk " &
+ "LAYOUT " &
+ "-gnatyl " &
+ "LINE_LENGTH " &
+ "-gnatym " &
+ "STANDARD_CASING " &
+ "-gnatyn " &
+ "ORDERED_SUBPROGRAMS " &
+ "-gnatyo " &
+ "NONE " &
+ "!-gnatg,!-gnaty* " &
+ "PRAGMA " &
+ "-gnatyp " &
+ "REFERENCES " &
+ "-gnatyr " &
+ "SPECS " &
+ "-gnatys " &
+ "TOKEN " &
+ "-gnatyt ";
+ -- /NOSTYLE_CHECKS (D)
+ -- /STYLE_CHECKS[=(keyword,[...])]
+ --
+ -- Normally, GNAT permits any code layout consistent with the reference
+ -- manual requirements. This qualifier imposes style checking on the
+ -- input source code. The following keywords are supported:
+ --
+ -- ALL_BUILTIN (D) Equivalent to the following list of options:
+ -- 3, ATTRIBUTE, BLANKS, COMMENTS, END, VTABS,
+ -- HTABS, IF_THEN, KEYWORD, LAYOUT, LINE_LENGTH,
+ -- PRAGMA, REFERENCES, SPECS, TOKEN.
+ --
+ -- 1 .. 9 Specify indentation level from 1 to 9.
+ -- The general style of required indentation is as
+ -- specified by the examples in the Ada Reference
+ -- Manual. Full line comments must be aligned with
+ -- the -- starting on a column that is a multiple
+ -- of the alignment level.
+ --
+ -- ATTRIBUTE Check attribute casing.
+ -- Attribute names, including the case of keywords
+ -- such as digits used as attributes names,
+ -- must be written in mixed case, that is,
+ -- the initial letter and any letter following an
+ -- underscore must be uppercase.
+ -- All other letters must be lowercase.
+ --
+ -- BLANKS Blanks not allowed at statement end.
+ -- Trailing blanks are not allowed at the end of
+ -- statements. The purpose of this rule, together
+ -- with option HTABS (no horizontal tabs), is to
+ -- enforce a canonical format for the use of
+ -- blanks to separate source tokens.
+ --
+ -- COMMENTS Check comments.
+ -- Comments must meet the following set of rules:
+ --
+ -- * The "--" that starts the column must either
+ -- start in column one, or else at least one
+ -- blank must precede this sequence.
+ --
+ -- * Comments that follow other tokens on a line
+ -- must have at least one blank following the
+ -- "--" at the start of the comment.
+ --
+ -- * Full line comments must have two blanks
+ -- following the "--" that starts the comment,
+ -- with the following exceptions.
+ --
+ -- * A line consisting only of the "--"
+ -- characters, possibly preceded by blanks is
+ -- permitted.
+ --
+ -- * A comment starting with "--x" where x is
+ -- a special character is permitted. This
+ -- allows proper processing of the output
+ -- generated by specialized tools including
+ -- gnatprep (where --! is used) and the SPARK
+ -- annnotation language (where --# is used).
+ -- For the purposes of this rule, a special
+ -- character is defined as being in one of the
+ -- ASCII ranges 16#21#..16#2F# or
+ -- 16#3A#..16#3F#.
+ --
+ -- * A line consisting entirely of minus signs,
+ -- possibly preceded by blanks, is permitted.
+ -- This allows the construction of box
+ -- comments where lines of minus signs are
+ -- used to form the top and bottom of the box.
+ --
+ -- * If a comment starts and ends with "--" is
+ -- permitted as long as at least one blank
+ -- follows the initial "--". Together with
+ -- the preceding rule, this allows the
+ -- construction of box comments, as shown in
+ -- the following example:
+ --
+ --
+ -- ---------------------------
+ -- -- This is a box comment --
+ -- -- with two text lines. --
+ -- ---------------------------
+ --
+ -- END Check end/exit labels.
+ -- Optional labels on end statements ending
+ -- subprograms and on exit statements exiting
+ -- named loops, are required to be present.
+ --
+ -- GNAT Enforces a set of style conventions that
+ -- correspond to the style used in the GNAT
+ -- source code. All compiler units are always
+ -- compile with this keyword specified.
+ --
+ -- You can find the full documentation for the
+ -- style conventions imposed by this keyword
+ -- in the body of the package "Style" in the
+ -- compiler sources.
+ --
+ -- You should not normally use this keyword.
+ -- However, you MUST use it for compiling any
+ -- language-defined unit, or for adding children
+ -- to any language-defined unit other than
+ -- "Standard".
+ --
+ -- HTABS No horizontal tabs.
+ -- Horizontal tab characters are not permitted in
+ -- the source text. Together with the BLANKS
+ -- (no blanks at end of line) option, this
+ -- enforces a canonical form for the use of blanks
+ -- to separate source tokens.
+ --
+ -- IF_THEN Check if-then layout.
+ -- The keyword then must appear either on the
+ -- same line as the corresponding if, or on a line
+ -- on its own, lined up under the if with at least
+ -- one non-blank line in between containing all or
+ -- part of the condition to be tested.
+ --
+ -- KEYWORD Check keyword casing.
+ -- All keywords must be in lower case (with the
+ -- exception of keywords such as digits used as
+ -- attribute names to which this check does not
+ -- apply).
+ --
+ -- LAYOUT Check layout.
+ -- Layout of statement and declaration constructs
+ -- must follow the recommendations in the Ada
+ -- Reference Manual, as indicated by the form of
+ -- the syntax rules. For example an else keyword
+ -- must be lined up with the corresponding if
+ -- keyword.
+ --
+ -- There are two respects in which the style rule
+ -- enforced by this check option are more liberal
+ -- than those in the Ada Reference Manual.
+ -- First in the case of record declarations,
+ -- it is permissible to put the record keyword on
+ -- the same line as the type keyword, and then
+ -- the end in end record must line up under type.
+ -- For example, either of the following two
+ -- layouts is acceptable:
+ --
+ -- type q is record
+ -- a : integer;
+ -- b : integer;
+ -- end record;
+ --
+ -- type q is
+ -- record
+ -- a : integer;
+ -- b : integer;
+ -- end record;
+ --
+ -- Second, in the case of a block statement,
+ -- a permitted alternative is to put the block
+ -- label on the same line as the declare or begin
+ -- keyword, and then line the end keyword up under
+ -- the block label. For example both the following
+ -- are permitted:
+ --
+ --
+ --
+ -- Block : declare
+ -- A : Integer := 3;
+ -- begin
+ -- Proc (A, A);
+ -- end Block;
+ --
+ -- Block :
+ -- declare
+ -- A : Integer := 3;
+ -- begin
+ -- Proc (A, A);
+ -- end Block;
+ --
+ -- The same alternative format is allowed for
+ -- loops. For example, both of the following are
+ -- permitted:
+ --
+ --
+ --
+ -- Clear : while J < 10 loop
+ -- A (J) := 0;
+ -- end loop Clear;
+ --
+ -- Clear :
+ -- while J < 10 loop
+ -- A (J) := 0;
+ -- end loop Clear;
+ --
+ --
+ --
+ -- LINE_LENGTH Check maximum line length.
+ -- The length of source lines must not exceed 79
+ -- characters, including any trailing blanks
+ -- The value of 79 allows convenient display on
+ -- an 80 character wide device or window, allowing
+ -- for possible special treatment of 80 character
+ -- lines.
+ --
+ -- ORDERED_SUBPROGRAMS Check order of subprogram bodies.
+ -- All subprogram bodies in a given scope (e.g.
+ -- a package body) must be in alphabetical order.
+ -- The ordering rule uses normal Ada rules for
+ -- comparing strings, ignoring casing of letters,
+ -- except that if there is a trailing numeric
+ -- suffix, then the value of this suffix is used
+ -- in the ordering (e.g. Junk2 comes before
+ -- Junk10).
+ --
+ -- NONE The default behavior. Same as /NOSTYLE_CHECKS.
+ --
+ -- PRAGMA Check pragma casing.
+ -- Pragma names must be written in mixed case,
+ -- that is, the initial letter and any letter
+ -- following an underscore must be uppercase.
+ -- All other letters must be lowercase.
+ --
+ -- REFERENCES Check references.
+ -- All identifier references must be cased in the
+ -- same way as the corresponding declaration.
+ -- No specific casing style is imposed on
+ -- identifiers. The only requirement is for
+ -- consistency of references with declarations.
+ --
+ -- RM_COLUMN_LAYOUT Enforce the layout conventions suggested by
+ -- the examples and syntax rules of the Ada
+ -- Language Reference Manual. For example, an
+ -- "else" must line up with an "if" and code in
+ -- the "then" and "else" parts must be indented.
+ -- The compiler considers violations of the
+ -- layout rules a syntax error if you specify
+ -- this keyword.
+ --
+ -- SPECS Check separate specs.
+ -- Separate declarations ("specs") are required
+ -- for subprograms (a body is not allowed to serve
+ -- as its own declaration). The only exception is
+ -- that parameterless library level procedures are
+ -- not required to have a separate declaration.
+ -- This exception covers the most frequent form of
+ -- main program procedures.
+ --
+ -- STANDARD_CASING Check casing of entities in Standard.
+ -- Any identifier from Standard must be cased to
+ -- match the presentation in the Ada Reference
+ -- Manual (for example, Integer and ASCII.NUL).
+ --
+ -- TOKEN Check token spacing.
+ -- The following token spacing rules are enforced:
+ --
+ -- * The keywords abs and not must be followed
+ -- by a space.
+ --
+ -- * The token => must be surrounded by spaces.
+ --
+ -- * The token <> must be preceded by a space or
+ -- a left parenthesis.
+ --
+ -- * Binary operators other than ** must be
+ -- surrounded by spaces. There is no
+ -- restriction on the layout of the ** binary
+ -- operator.
+ --
+ -- * Colon must be surrounded by spaces.
+ --
+ -- * Colon-equal (assignment) must be surrounded
+ -- by spaces.
+ --
+ -- * Comma must be the first non-blank character
+ -- on the line, or be immediately preceded by
+ -- a non-blank character, and must be followed
+ -- by a space.
+ --
+ -- * If the token preceding a left paren ends
+ -- with a letter or digit, then a space must
+ -- separate the two tokens.
+ --
+ -- * A right parenthesis must either be the
+ -- first non-blank character on a line, or it
+ -- must be preceded by a non-blank character.
+ --
+ -- * A semicolon must not be preceded by
+ -- a space, and must not be followed by
+ -- a non-blank character.
+ --
+ -- * A unary plus or minus may not be followed
+ -- by a space.
+ --
+ -- * A vertical bar must be surrounded by
+ -- spaces.
+ --
+ -- In the above rules, appearing in column one is
+ -- always permitted, that is, counts as meeting
+ -- either a requirement for a required preceding
+ -- space, or as meeting a requirement for no
+ -- preceding space.
+ --
+ -- Appearing at the end of a line is also always
+ -- permitted, that is, counts as meeting either
+ -- a requirement for a following space,
+ -- or as meeting a requirement for no following
+ -- space.
+ --
+ -- VTABS No form feeds or vertical tabs.
+ -- Form feeds or vertical tab characters are not
+ -- permitted in the source text.
+
+ S_GCC_StyleX : aliased constant S := "/NOSTYLE_CHECKS " &
+ "!-gnatg,!-gnaty*";
+ -- NODOC (see /STYLE_CHECKS)
+
+ S_GCC_Symbol : aliased constant S := "/SYMBOL_PREPROCESSING=" & '"' &
+ "-gnateD" & '"';
+ -- /SYMBOL_PREPROCESSING="symbol=value"
+ --
+ -- Define or redefine a preprocessing symbol, associated with value.
+ -- If "=value" is not specified, then the value of the symbol is True.
+ -- A symbol is an identifier, following normal Ada (case-insensitive)
+ -- rules for its syntax, and value is any sequence (including an empty
+ -- sequence) of characters from the set (letters, digits, period,
+ -- underline). Ada reserved words may be used as symbols, with the
+ -- exceptions of "if", "else", "elsif", "end", "and", "or" and "then".
+ --
+ -- A symbol declared with this qualifier on the command line replaces
+ -- a symbol with the same name either in a definition file or specified
+ -- with a switch -D in the preprocessor data file.
+ --
+ -- This qualifier is similar to qualifier /ASSOCIATE of
+ -- GNAT PREPROCESSING.
+
+ S_GCC_Syntax : aliased constant S := "/SYNTAX_ONLY " &
+ "-gnats";
+ -- /NOSYNTAX_ONLY (D)
+ -- /SYNTAX_ONLY
+ --
+ -- Run GNAT in syntax checking only mode. You can check a series of
+ -- files in a single command, and can use wild cards to specify such a
+ -- group of files.
+ --
+ -- You may use other qualifiers in conjunction with this qualifier. In
+ -- particular, /LIST and /REPORT_ERRORS=VERBOSE are useful to control the
+ -- format of any generated error messages.
+ --
+ -- The output is simply the error messages, if any. No object file or ALI
+ -- file is generated by a syntax-only compilation. Also, no units other
+ -- than the one specified are accessed. For example, if a unit "X" with's
+ -- a unit "Y", compiling unit "X" in syntax check only mode does not
+ -- access the source file containing unit "Y".
+ --
+ -- Normally, GNAT allows only a single unit in a source file. However,
+ -- this restriction does not apply in syntax-check-only mode, and it is
+ -- possible to check a file containing multiple compilation units
+ -- concatenated together. This is primarily used by the GNAT CHOP
+ -- command.
+
+ S_GCC_Table : aliased constant S := "/TABLE_MULTIPLIER=#" &
+ "-gnatT#";
+ -- /TABLE_MULTIPLIER=nnn
+ --
+ -- All compiler tables start at nnn times usual starting size.
+
+ S_GCC_Trace : aliased constant S := "/TRACE_UNITS " &
+ "-gnatdc";
+ -- /TRACE_UNITS
+ -- /NOTRACE_UNITS
+ --
+ -- This switch that does for the frontend what /VERBOSE does for the
+ -- backend. The system prints the name of each unit, either a compilation
+ -- unit or nested unit, as it is being analyzed.
+
+ S_GCC_Tree : aliased constant S := "/TREE_OUTPUT " &
+ "-gnatt";
+ -- /TREE_OUTPUT
+ -- /NOTREE_OUTPUT
+ --
+ -- Cause GNAT to write the internal tree for a unit to a file (with the
+ -- filetype ATB for a body or ATS for a spec). This is not normally
+ -- required, but is used by separate analysis tools. Typically these
+ -- tools do the necessary compilations automatically, so you should never
+ -- have to specify this switch in normal operation.
+
+ S_GCC_Trys : aliased constant S := "/TRY_SEMANTICS " &
+ "-gnatq";
+ -- /TRY_SEMANTICS
+ -- /NOTRY_SEMANTICS
+ --
+ -- In normal operation mode the compiler first parses the program and
+ -- determines if there are any syntax errors. If there are, appropriate
+ -- error messages are generated and compilation is immediately
+ -- terminated. This qualifier tells GNAT to continue with semantic
+ -- analysis even if syntax errors have been found. This may enable the
+ -- detection of more errors in a single run. On the other hand, the
+ -- semantic analyzer is more likely to encounter some internal fatal
+ -- error when given a syntactically invalid tree.
+
+ S_GCC_Units : aliased constant S := "/UNITS_LIST " &
+ "-gnatu";
+ -- /NOUNITS_LIST (D)
+ -- /UNITS_LIST
+ --
+ -- Print a list of units required by this compilation on SYS$OUTPUT. The
+ -- listing includes all units on which the unit being compiled depends
+ -- either directly or indirectly.
+
+ S_GCC_Unique : aliased constant S := "/UNIQUE_ERROR_TAG " &
+ "-gnatU";
+ -- /NOUNIQUE_ERROR_TAG (D)
+ -- /UNIQUE_ERROR_TAG
+ --
+ -- Tag compiler error messages with the string "error: ".
+
+ S_GCC_Upcase : aliased constant S := "/UPPERCASE_EXTERNALS " &
+ "-gnatF";
+ -- /NOUPPERCASE_EXTERNALS (D)
+ -- /UPPERCASE_EXTERNALS
+ --
+ -- Fold default and explicit external names in pragmas Import and Export
+ -- to uppercase for compatibility with the default behavior of DEC C.
+
+ S_GCC_Valid : aliased constant S := "/VALIDITY_CHECKING=" &
+ "DEFAULT " &
+ "-gnatVd " &
+ "NODEFAULT " &
+ "-gnatVD " &
+ "COPIES " &
+ "-gnatVc " &
+ "NOCOPIES " &
+ "-gnatVC " &
+ "FLOATS " &
+ "-gnatVf " &
+ "NOFLOATS " &
+ "-gnatVF " &
+ "IN_PARAMS " &
+ "-gnatVi " &
+ "NOIN_PARAMS " &
+ "-gnatVI " &
+ "MOD_PARAMS " &
+ "-gnatVm " &
+ "NOMOD_PARAMS " &
+ "-gnatVM " &
+ "OPERANDS " &
+ "-gnatVo " &
+ "NOOPERANDS " &
+ "-gnatVO " &
+ "PARAMETERS " &
+ "-gnatVp " &
+ "NOPARAMETERS " &
+ "-gnatVP " &
+ "RETURNS " &
+ "-gnatVr " &
+ "NORETURNS " &
+ "-gnatVR " &
+ "SUBSCRIPTS " &
+ "-gnatVs " &
+ "NOSUBSCRIPTS " &
+ "-gnatVS " &
+ "TESTS " &
+ "-gnatVt " &
+ "NOTESTS " &
+ "-gnatVT " &
+ "ALL " &
+ "-gnatVa " &
+ "NONE " &
+ "-gnatVn";
+ -- /VALIDITY_CHECKING[=(keyword,[...])]
+ --
+ -- Control level of validity checking.
+ --
+ -- DEFAULT (D) In this mode checks are made to prevent
+ -- erroneous behavior in accordance with the RM.
+ -- Notably extra checks may be needed for case
+ -- statements and subscripted array assignments.
+ --
+ -- NONE No special checks for invalid values are
+ -- performed. This means that references to
+ -- uninitialized variables can cause erroneous
+ -- behavior from constructs like case statements
+ -- and subscripted array assignments. In this
+ -- mode, invalid values can lead to erroneous
+ -- behavior.
+ --
+ -- FULL Every assignment is checked for validity, so
+ -- that it is impossible to assign invalid values.
+ -- The RM specifically allows such assignments,
+ -- but in this mode, invalid values can never be
+ -- assigned, and an attempt to perform such an
+ -- assignment immediately raises Constraint_Error.
+ -- This behavior is allowed (but not required) by
+ -- the RM. This mode is intended as a debugging aid,
+ -- and may be useful in helping to track down
+ -- uninitialized variables. It may be useful to
+ -- use this in conjunction with the Normalize_Scalars
+ -- pragma which attempts to initialize with invalid
+ -- values where possible.
+
+ S_GCC_Verbose : aliased constant S := "/VERBOSE " &
+ "-v";
+ -- /VERBOSE
+ -- /NOVERBOSE
+ --
+ -- Show commands generated by the GCC driver. Normally used only for
+ -- debugging purposes or if you need to be sure what version of the
+ -- compiler you are executing.
+
+ S_GCC_Warn : aliased constant S := "/WARNINGS=" &
+ "DEFAULT " &
+ "!-gnatws,!-gnatwe " &
+ "ALL " &
+ "-gnatwa " &
+ "NOALL " &
+ "-gnatwA " &
+ "ALL_GCC " &
+ "-Wall " &
+ "BIASED_ROUNDING " &
+ "-gnatwb " &
+ "NOBIASED_ROUNDING " &
+ "-gnatwB " &
+ "CONDITIONALS " &
+ "-gnatwc " &
+ "NOCONDITIONALS " &
+ "-gnatwC " &
+ "CONSTANT_VARIABLES " &
+ "-gnatwk " &
+ "NOCONSTANT_VARIABLES " &
+ "-gnatwK " &
+ "IMPLICIT_DEREFERENCE " &
+ "-gnatwd " &
+ "NO_IMPLICIT_DEREFERENCE " &
+ "-gnatwD " &
+ "ELABORATION " &
+ "-gnatwl " &
+ "NOELABORATION " &
+ "-gnatwL " &
+ "ERRORS " &
+ "-gnatwe " &
+ "HIDING " &
+ "-gnatwh " &
+ "NOHIDING " &
+ "-gnatwH " &
+ "IMPLEMENTATION " &
+ "-gnatwi " &
+ "NOIMPLEMENTATION " &
+ "-gnatwI " &
+ "INEFFECTIVE_INLINE " &
+ "-gnatwp " &
+ "NOINEFFECTIVE_INLINE " &
+ "-gnatwP " &
+ "MODIFIED_UNREF " &
+ "-gnatwm " &
+ "NOMODIFIED_UNREF " &
+ "-gnatwM " &
+ "OPTIONAL " &
+ "-gnatwa " &
+ "NOOPTIONAL " &
+ "-gnatwA " &
+ "NORMAL " &
+ "-gnatwn " &
+ "OBSOLESCENT " &
+ "-gnatwj " &
+ "NOOBSOLESCENT " &
+ "-gnatwJ " &
+ "OVERLAYS " &
+ "-gnatwo " &
+ "NOOVERLAYS " &
+ "-gnatwO " &
+ "REDUNDANT " &
+ "-gnatwr " &
+ "NOREDUNDANT " &
+ "-gnatwR " &
+ "SUPPRESS " &
+ "-gnatws " &
+ "UNINITIALIZED " &
+ "-Wuninitialized " &
+ "UNREFERENCED_FORMALS " &
+ "-gnatwf " &
+ "NOUNREFERENCED_FORMALS " &
+ "-gnatwF " &
+ "UNRECOGNIZED_PRAGMAS " &
+ "-gnatwg " &
+ "NOUNRECOGNIZED_PRAGMAS " &
+ "-gnatwG " &
+ "UNUSED " &
+ "-gnatwu " &
+ "NOUNUSED " &
+ "-gnatwU " &
+ "VARIABLES_UNINITIALIZED " &
+ "-gnatwv " &
+ "NOVARIABLES_UNINITIALIZED " &
+ "-gnatwV " &
+ "IMPORT_EXPORT_PRAGMAS " &
+ "-gnatwx " &
+ "NOIMPORT_EXPORT_PRAGMAS " &
+ "-gnatwX " &
+ "UNCHECKED_CONVERSIONS " &
+ "-gnatwz " &
+ "NOUNCHECKED_CONVERSIONS " &
+ "-gnatwZ";
+ -- /NOWARNINGS
+ --
+ -- Suppress the output of all warning messages from the GNAT front end.
+ -- Note that it does not suppress warnings from the gcc back end.
+ --
+ -- /WARNINGS[=(keyword[,...])]
+ --
+ -- In addition to error messages, corresponding to illegalities as
+ -- defined in the reference manual, the compiler detects two kinds of
+ -- warning situations. First, the compiler considers some constructs
+ -- suspicious and generates a warning message to alert you to a possible
+ -- error. Second, if the compiler detects a situation that is sure to
+ -- raise an exception at runtime, it generates a warning message.
+ --
+ -- You may specify the following keywords to change this behavior:
+ --
+ -- DEFAULT (D) The default behavior above.
+ --
+ -- ALL Activate all optional warnings.
+ -- Activates most optional warning messages,
+ -- see remaining list in this section for
+ -- details on optional warning messages that
+ -- can be individually controlled.
+ -- The warnings that are not turned on by
+ -- this option are BIASED_ROUNDING,
+ -- IMPLICIT_DEREFERENCE, HIDING and
+ -- ELABORATION. All other optional Ada
+ -- warnings are turned on.
+ --
+ -- NOALL Suppress all optional errors.
+ -- Suppresses all optional warning messages
+ -- that can be activated by option ALL.
+ --
+ -- ALL_GCC Request additional messages from the GCC
+ -- backend. Most of these are not relevant
+ -- to Ada.
+ --
+ -- BIASED_ROUNDING Activate warnings on biased rounding.
+ -- If a static floating-point expression has
+ -- a value that is exactly half way between
+ -- two adjacent machine numbers, then the
+ -- rules of Ada (Ada Reference Manual,
+ -- para 4.9(38)) require that this rounding
+ -- be done away from zero, even if the normal
+ -- unbiased rounding rules at run time would
+ -- require rounding towards zero.
+ --
+ -- This warning message alerts you to such
+ -- instances where compile-time rounding and
+ -- run-time rounding are not equivalent.
+ -- If it is important to get proper run-time
+ -- rounding, then you can force this by
+ -- making one of the operands into a
+ -- variable. The default is that such
+ -- warnings are not generated. Note that
+ -- /WARNINGS=ALL does not affect the setting
+ -- of this warning option.
+ --
+ -- NOBIASED_ROUNDING Suppress warnings on biased rounding.
+ -- Disable warnings on biased rounding.
+ --
+ -- CONDITIONALS Activate warnings for conditional
+ -- Expressions used in tests that are known
+ -- to be True or False at compile time. The
+ -- default is that such warnings are not
+ -- generated.
+ --
+ -- NOCONDITIONALS Suppress warnings for conditional
+ -- expressions used in tests that are known
+ -- to be True or False at compile time.
+ --
+ -- IMPLICIT_DEREFERENCE Activate warnings on implicit dereferencing.
+ -- The use of a prefix of an access type in an
+ -- indexed component, slice, or selected component
+ -- without an explicit .all will generate
+ -- a warning. With this warning enabled, access
+ -- checks occur only at points where an explicit
+ -- .all appears in the source code (assuming no
+ -- warnings are generated as a result of this
+ -- option). The default is that such warnings are
+ -- not generated. Note that /WARNINGS=ALL does not
+ -- affect the setting of this warning option.
+ --
+ -- NOIMPLICIT_DEREFERENCE Suppress warnings on implicit dereferencing.
+ -- in indexed components, slices, and selected
+ -- components.
+ --
+ -- ELABORATION Activate warnings on missing pragma
+ -- Elaborate_All statements. The default is
+ -- that such warnings are not generated.
+ --
+ -- NOELABORATION Suppress warnings on missing pragma
+ -- Elaborate_All statements.
+ --
+ -- ERRORS Warning messages are to be treated as errors.
+ -- The warning string still appears, but the
+ -- warning messages are counted as errors, and
+ -- prevent the generation of an object file.
+ --
+ -- HIDING Activate warnings on hiding declarations.
+ -- A declaration is considered hiding if it is
+ -- for a non-overloadable entity, and it declares
+ -- an entity with the same name as some other
+ -- entity that is directly or use-visible. The
+ -- default is that such warnings are not
+ -- generated.
+ --
+ -- NOHIDING Suppress warnings on hiding declarations.
+ --
+ -- IMPLEMENTATION Activate warnings for a with of an internal
+ -- GNAT implementation unit, defined as any unit
+ -- from the Ada, Interfaces, GNAT, DEC or
+ -- System hierarchies that is not documented in
+ -- either the Ada Reference Manual or the GNAT
+ -- Programmer's Reference Manual. Such units are
+ -- intended only for internal implementation
+ -- purposes and should not be with'ed by user
+ -- programs. The default is that such warnings
+ -- are generated.
+ --
+ -- NOIMPLEMENTATION Disables warnings for a with of an internal
+ -- GNAT implementation unit.
+ --
+ -- INEFFECTIVE_INLINE Activate warnings on ineffective pragma Inlines
+ -- Activates warnings for failure of front end
+ -- inlining (activated by /INLINE=FULL) to inline
+ -- a particular call. There are many reasons for
+ -- not being able to inline a call, including most
+ -- commonly that the call is too complex to
+ -- inline. This warning can also be turned on
+ -- using /INLINE=FULL.
+ --
+ -- NOINEFFECTIVE_INLINE Suppress warnings on ineffective pragma Inlines
+ -- Suppresses warnings on ineffective pragma
+ -- Inlines. If the inlining mechanism cannot
+ -- inline a call, it will simply ignore the
+ -- request silently.
+ --
+ -- MODIFIED_UNREF Activates warnings for variables that are
+ -- assigned (using an initialization value or with
+ -- one or more assignment statements) but whose
+ -- value is never read. The warning is suppressed
+ -- for volatile variables and also for variables
+ -- that are renamings of other variables or for
+ -- which an address clause is given. This warning
+ -- can also be turned on using /WARNINGS/OPTIONAL.
+ --
+ -- NOMODIFIED_UNREF Disables warnings for variables that are
+ -- assigned or initialized, but never read.
+ --
+ -- NORMAL Sets normal warning mode, in which enabled
+ -- warnings are issued and treated as warnings
+ -- rather than errors. This is the default mode.
+ -- It can be used to cancel the effect of an
+ -- explicit /WARNINGS=SUPPRESS or
+ -- /WARNINGS=ERRORS. It also cancels the effect
+ -- of the implicit /WARNINGS=ERRORS that is
+ -- activated by the use of /STYLE=GNAT.
+ --
+ -- OBSOLESCENT Activates warnings for calls to subprograms
+ -- marked with pragma Obsolescent and for use of
+ -- features in Annex J of the Ada Reference
+ -- Manual. In the case of Annex J, not all
+ -- features are flagged. In particular use of the
+ -- renamed packages (like Text_IO), use of package
+ -- ASCII and use of the attribute 'Constrained are
+ -- not flagged, since these are very common and
+ -- would generate many annoying positive warnings.
+ -- The default is that such warnings are not
+ -- generated.
+ --
+ -- NOOBSOLESCENT Disables warnings on use of obsolescent
+ -- features.
+ --
+ -- OPTIONAL Activate all optional warning messages.
+ -- See other options under this qualifier
+ -- for details on optional warning messages
+ -- that can be individually controlled. The
+ -- one exception is that /WARNINGS=OPTIONAL
+ -- doesn't activate warnings for hiding
+ -- variables (/WARNINGS=HIDING), so if this
+ -- warning is required it must be explicitly
+ -- set.
+ --
+ -- NOOPTIONAL Suppress all optional warning messages.
+ -- See other options under this qualifier
+ -- for details on optional warning messages
+ -- that can be individually controlled.
+ --
+ -- OVERLAYS Activate warnings for possibly unintended
+ -- initialization effects of defining address
+ -- clauses that cause one variable to overlap
+ -- another. The default is that such warnings
+ -- are generated.
+ --
+ -- NOOVERLAYS Suppress warnings on possibly unintended
+ -- initialization effects of defining address
+ -- clauses that cause one variable to overlap
+ -- another.
+ --
+ -- REDUNDANT Activate warnings for redundant constructs.
+ -- In particular assignments of a variable to
+ -- itself, and a type conversion that converts
+ -- an object to its own type. The default
+ -- is that such warnings are not generated.
+ --
+ -- NOREDUNDANT Suppress warnings for redundant constructs.
+ --
+ -- SUPPRESS Completely suppresse the output of all warning
+ -- messages. Same as /NOWARNINGS.
+ --
+ -- UNCHECKED_CONVERSIONS Activates warnings on unchecked conversions.
+ -- Causes warnings to be generated for
+ -- unchecked conversions when the two types are
+ -- known at compile time to have different sizes.
+ -- The default is that such warnings are
+ -- generated.
+ --
+ -- NOUNCHECKED_CONVERSIONS Suppress warnings for unchecked conversions.
+ --
+ -- UNINITIALIZED Generate warnings for uninitialized variables.
+ -- This is a GCC option, not an Ada option.
+ -- You must also specify the /OPTIMIZE qualifier
+ -- with a value other than NONE (in other words,
+ -- this keyword works only if optimization is
+ -- turned on).
+ --
+ -- UNREFERENCED_FORMALS Activate warnings on unreferenced formals.
+ -- Causes a warning to be generated if a formal
+ -- parameter is not referenced in the body of
+ -- the subprogram. This warning can also be turned
+ -- on using option ALL or UNUSED.
+ --
+ -- NOUNREFERENCED_FORMALS Suppress warnings on unreferenced formals.
+ -- Suppresses warnings for unreferenced formal
+ -- parameters. Note that the combination UNUSED
+ -- followed by NOUNREFERENCED_FORMALS has the
+ -- effect of warning on unreferenced entities
+ -- other than subprogram formals.
+ --
+ -- UNUSED Activates warnings to be generated for entities
+ -- that are defined but not referenced, and for
+ -- units that are with'ed and not referenced. In
+ -- the case of packages, a warning is also
+ -- generated if no entities in the package are
+ -- referenced. This means that if the package
+ -- is referenced but the only references are in
+ -- use clauses or renames declarations, a warning
+ -- is still generated. A warning is also generated
+ -- for a generic package that is with'ed but never
+ -- instantiated. In the case where a package or
+ -- subprogram body is compiled, and there is a
+ -- with on the corresponding spec that is only
+ -- referenced in the body, a warning is also
+ -- generated, noting that the with can be moved
+ -- to the body. The default is that such warnings
+ -- are not generated.
+ --
+ -- NOUNUSED Suppress warnings for unused entities and
+ -- packages.
+ --
+ -- VARIABLES_UNINITIALIZED Activates warnings on unassigned variables.
+ -- Causes warnings to be generated when a variable
+ -- is accessed which may not be properly
+ -- uninitialized.
+ -- The default is that such warnings are
+ -- generated.
+ --
+ -- NOVARIABLES_UNINITIALIZED Suppress warnings for uninitialized
+ -- variables.
+
+ S_GCC_WarnX : aliased constant S := "/NOWARNINGS " &
+ "-gnatws";
+ -- NODOC (see /WARNINGS)
+
+ S_GCC_No_Back : aliased constant S := "/NO_BACK_END_WARNINGS " &
+ "-w";
+ -- /NO_BACK_END_WARNINGS
+ --
+ -- Inhibit all warning messages of the GCC back-end.
+
+ S_GCC_Wide : aliased constant S := "/WIDE_CHARACTER_ENCODING=" &
+ "BRACKETS " &
+ "-gnatWb " &
+ "NONE " &
+ "-gnatWn " &
+ "HEX " &
+ "-gnatWh " &
+ "UPPER " &
+ "-gnatWu " &
+ "SHIFT_JIS " &
+ "-gnatWs " &
+ "UTF8 " &
+ "-gnatW8 " &
+ "EUC " &
+ "-gnatWe";
+ -- /NOWIDE_CHARACTER_ENCODING (D)
+ -- /WIDE_CHARACTER_ENCODING[=encode-type]
+ --
+ -- Specifies the mechanism used to encode wide characters. 'encode-type'
+ -- is one of the following:
+ --
+ -- BRACKETS (D) A wide character is encoded as ["xxxx"] where XXXX
+ -- are four hexadecimal digits representing the coding
+ -- ('Pos value) of the character in type
+ -- Wide_Character. The hexadecimal digits may use upper
+ -- or lower case letters.
+ --
+ -- This notation can also be used for upper half
+ -- Character values using the format ["xx"] where XX is
+ -- two hexadecimal digits representing the coding ('Pos
+ -- value) of the character in type Character (or
+ -- Wide_Character). The hexadecimal digits may use upper
+ -- of lower case.
+ --
+ -- NONE No wide characters are allowed. Same
+ -- as /NOWIDE_CHARCTER_ENCODING.
+ --
+ -- HEX In this encoding, a wide character is represented by
+ -- the following five character sequence: ESC a b c d
+ -- Where 'a', 'b', 'c', and 'd' are the four hexadecimal
+ -- characters (using uppercase letters) of the wide
+ -- character code. For example, ESC A345 is used to
+ -- represent the wide character with code 16#A345#. This
+ -- scheme is compatible with use of the full
+ -- Wide_Character set.
+ --
+ -- UPPER The wide character with encoding 16#abcd# where the
+ -- upper bit is on (in other words, "a" is in the range
+ -- 8-F) is represented as two bytes, 16#ab# and 16#cd#.
+ -- The second byte may never be a format control
+ -- character, but is not required to be in the upper
+ -- half. This method can be also used for shift-JIS or
+ -- EUC, where the internal coding matches the external
+ -- coding.
+ --
+ -- SHIFT_JIS A wide character is represented by a two-character
+ -- sequence, 16#ab# and 16#cd#, with the restrictions
+ -- described for upper-half encoding as described above.
+ -- The internal character code is the corresponding JIS
+ -- character according to the standard algorithm for
+ -- Shift-JIS conversion. Only characters defined in the
+ -- JIS code set table can be used with this encoding
+ -- method.
+ --
+ -- UTF8 A wide character is represented using
+ -- UCS Transformation Format 8 (UTF-8) as defined in Annex
+ -- R of ISO 10646-1/Am.2. Depending on the character
+ -- value, the representation is a one, two, or three byte
+ -- sequence:
+ --
+ -- 16#0000#-16#007f#: 2#0xxxxxxx#
+ -- 16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx#
+ -- 16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx#
+ --
+ -- where the xxx bits correspond to the left-padded bits
+ -- of the the 16-bit character value. Note that all lower
+ -- half ASCII characters are represented as ASCII bytes
+ -- and all upper half characters and other wide characters
+ -- are represented as sequences of upper-half (The full
+ -- UTF-8 scheme allows for encoding 31-bit characters as
+ -- 6-byte sequences, but in this implementation, all UTF-8
+ -- sequences of four or more bytes length will be treated
+ -- as illegal).
+ --
+ -- EUC A wide character is represented by a two-character
+ -- sequence 16#ab# and 16#cd#, with both characters being
+ -- in the upper half. The internal character code is the
+ -- corresponding JIS character according to the EUC
+ -- encoding algorithm. Only characters defined in the JIS
+ -- code set table can be used with this encoding method.
+
+ S_GCC_WideX : aliased constant S := "/NOWIDE_CHARACTER_ENCODING " &
+ "-gnatWn";
+ -- NODOC (see /WIDE_CHARACTER_ENCODING)
+
+ S_GCC_Xdebug : aliased constant S := "/XDEBUG " &
+ "-gnatD";
+ -- /NOXDEBUG (D)
+ -- /XDEBUG
+ --
+ -- Output expanded source files for source level debugging.
+ -- The expanded source (see /EXPAND_SOURCE) is written to files
+ -- with names formed by appending "_DG" to the input file name,
+ -- The debugging information generated by the /DEBUG qualifier will then
+ -- refer to the generated file. This allows source level debugging using
+ -- the generated code which is sometimes useful for complex code, for
+ -- example to find out exactly which part of a complex construction
+ -- raised an exception.
+
+ S_GCC_Xref : aliased constant S := "/XREF=" &
+ "GENERATE " &
+ "!-gnatx " &
+ "SUPPRESS " &
+ "-gnatx";
+ -- /XREF[=keyword]
+ --
+ -- Normally the compiler generates full cross-referencing information in
+ -- the .ALI file. This information is used by a number of tools,
+ -- including GNAT FIND and GNAT XREF.
+ --
+ -- GENERATE (D) Generate cross-referencing information.
+ --
+ -- SUPPRESS Suppress cross-referencing information.
+ -- This saves some space and may slightly
+ -- speed up compilation, but means that some
+ -- tools cannot be used.
+
+ S_GCC_Zero : aliased constant S := "/ZERO_COST_EXCEPTIONS " &
+ "-gnatZ";
+ -- /ZERO_COST_EXCEPTIONS
+ -- /NOZERO_COST_EXCEPTIONS
+ --
+ -- As zero-cost exceptions is the default on VMS, this qualifier has
+ -- no effect, except that it cancels the effect of a previous
+ -- /LONGJMP_SETJUMP qualifier.
+
+ GCC_Switches : aliased constant Switches :=
+ (S_GCC_Ada_83 'Access,
+ S_GCC_Ada_95 'Access,
+ S_GCC_Asm 'Access,
+ S_GCC_Checks 'Access,
+ S_GCC_ChecksX 'Access,
+ S_GCC_Compres 'Access,
+ S_GCC_Config 'Access,
+ S_GCC_Current 'Access,
+ S_GCC_Debug 'Access,
+ S_GCC_DebugX 'Access,
+ S_GCC_Data 'Access,
+ S_GCC_Dist 'Access,
+ S_GCC_DistX 'Access,
+ S_GCC_Error 'Access,
+ S_GCC_ErrorX 'Access,
+ S_GCC_Expand 'Access,
+ S_GCC_Extend 'Access,
+ S_GCC_Ext 'Access,
+ S_GCC_File 'Access,
+ S_GCC_Force 'Access,
+ S_GCC_Full 'Access,
+ S_GCC_Help 'Access,
+ S_GCC_Ident 'Access,
+ S_GCC_IdentX 'Access,
+ S_GCC_Immed 'Access,
+ S_GCC_Inline 'Access,
+ S_GCC_InlineX 'Access,
+ S_GCC_Jumps 'Access,
+ S_GCC_Length 'Access,
+ S_GCC_List 'Access,
+ S_GCC_Mapping 'Access,
+ S_GCC_Mess 'Access,
+ S_GCC_Noadc 'Access,
+ S_GCC_Noload 'Access,
+ S_GCC_Nostinc 'Access,
+ S_GCC_Opt 'Access,
+ S_GCC_OptX 'Access,
+ S_GCC_Polling 'Access,
+ S_GCC_Project 'Access,
+ S_GCC_Report 'Access,
+ S_GCC_ReportX 'Access,
+ S_GCC_Repinfo 'Access,
+ S_GCC_RepinfX 'Access,
+ S_GCC_RTS 'Access,
+ S_GCC_Search 'Access,
+ S_GCC_Style 'Access,
+ S_GCC_StyleX 'Access,
+ S_GCC_Symbol 'Access,
+ S_GCC_Syntax 'Access,
+ S_GCC_Table 'Access,
+ S_GCC_Trace 'Access,
+ S_GCC_Tree 'Access,
+ S_GCC_Trys 'Access,
+ S_GCC_Units 'Access,
+ S_GCC_Unique 'Access,
+ S_GCC_Upcase 'Access,
+ S_GCC_Valid 'Access,
+ S_GCC_Verbose 'Access,
+ S_GCC_Warn 'Access,
+ S_GCC_WarnX 'Access,
+ S_GCC_Wide 'Access,
+ S_GCC_WideX 'Access,
+ S_GCC_No_Back 'Access,
+ S_GCC_Xdebug 'Access,
+ S_GCC_Xref 'Access,
+ S_GCC_Zero 'Access);
+
+ ----------------------------
+ -- Switches for GNAT ELIM --
+ ----------------------------
+
+ S_Elim_All : aliased constant S := "/ALL " &
+ "-a";
+ -- /NOALL (D)
+ -- /ALL
+ --
+ -- Also look for subprograms from the GNAT run time that can be
+ -- eliminated. Note that when 'gnat.adc' is produced using this switch,
+ -- the entire program must be recompiled with qualifier /ALL_FILES of
+ -- GNAT MAKE.
+
+ S_Elim_Bind : aliased constant S := "/BIND_FILE=<" &
+ "-b>";
+ -- /BIND_FILE=file_name
+ --
+ -- Specifies file_name as the bind file to process. If this qualifier is
+ -- not used, the name of the bind file is computed from the full expanded
+ -- Ada name of a main subprogram.
+
+ S_Elim_Comp : aliased constant S := "/COMPILER=@" &
+ "--GCC=@";
+ -- /COMPILER=path_name
+ --
+ -- Instructs GNAT ELIM to use a specific gcc compiler instead of one
+ -- available on the path.
+
+ S_Elim_Config : aliased constant S := "/CONFIGURATION_PRAGMAS=<" &
+ "-C>";
+ -- /CONFIGURATION_PRAGMAS=path_name
+ --
+ -- Specifies a file that contains configuration pragmas.
+ -- The file must be specified with absolute path.
+
+ S_Elim_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+ -- /CURRENT_DIRECTORY (D)
+ -- /NOCURRENT_DIRECTORY
+ --
+ -- Look for source files in the default directory.
+
+ S_Elim_GNATMAKE : aliased constant S := "/GNATMAKE=@" &
+ "--GNATMAKE=@";
+ -- /GNATMAKE=path_name
+ --
+ -- Instructs GNAT MAKE to use a specific gnatmake instead of one available
+ -- on the path.
+
+ S_Elim_Quiet : aliased constant S := "/QUIET " &
+ "-q";
+ -- /NOQUIET (D)
+ -- /QUIET
+ --
+ -- Quiet mode: by default GNAT ELIM outputs to the standard error stream
+ -- the number of program units left to be processed. This option turns
+ -- this trace off.
+
+ S_Elim_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+ -- /SEARCH=(directory, ...)
+ --
+ -- When looking for source files also look in the specified directories.
+
+ S_Elim_Verb : aliased constant S := "/VERBOSE " &
+ "-v";
+ -- /NOVERBOSE (D)
+ -- /VERBOSE
+ --
+ -- Verbose mode: GNAT ELIM version information is output as Ada comments
+ -- to the standard output stream. Also, in addition to the number of
+ -- program units left, GNAT ELIM will output the name of the current unit
+ -- being processed.
+
+ Elim_Switches : aliased constant Switches :=
+ (S_Elim_All 'Access,
+ S_Elim_Bind 'Access,
+ S_Elim_Comp 'Access,
+ S_Elim_Config 'Access,
+ S_Elim_Current 'Access,
+ S_Elim_GNATMAKE'Access,
+ S_Elim_Quiet 'Access,
+ S_Elim_Search 'Access,
+ S_Elim_Verb 'Access);
+
+ ----------------------------
+ -- Switches for GNAT FIND --
+ ----------------------------
+
+ S_Find_All : aliased constant S := "/ALL_FILES " &
+ "-a";
+ -- /NOALL_FILES (D)
+ -- /ALL_FILES
+ --
+ -- If this switch is present, FIND and XREF will parse the read-only
+ -- files found in the library search path. Otherwise, these files will
+ -- be ignored. This option can be used to protect Gnat sources or your
+ -- own libraries from being parsed, thus making FIND and XREF much
+ -- faster, and their output much smaller.
+
+ S_Find_Deriv : aliased constant S := "/DERIVED_TYPE_INFORMATION " &
+ "-d";
+ -- /NODERIVED_TYPE_INFORMATION (D)
+ -- /DERIVED_TYPE_INFORMATION
+ --
+ -- Output the parent type reference for each matching derived types.
+
+ S_Find_Expr : aliased constant S := "/EXPRESSIONS " &
+ "-e";
+ -- /NOEXPRESSIONS (D)
+ -- /EXPRESSIONS
+ --
+ -- By default, FIND accepts the simple regular expression set for pattern.
+ -- If this switch is set, then the pattern will be considered as a full
+ -- Unix-style regular expression.
+
+ S_Find_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
+ "-X" & '"';
+ -- /EXTERNAL_REFERENCE="name=val"
+ --
+ -- Specifies an external reference to the project manager. Useful only if
+ -- /PROJECT_FILE is used.
+ --
+ -- Example:
+ -- /EXTERNAL_REFERENCE="DEBUG=TRUE"
+
+ S_Find_Full : aliased constant S := "/FULL_PATHNAME " &
+ "-f";
+ -- /NOFULL_PATHNAME (D)
+ -- /FULL_PATHNAME
+ --
+ -- If this switch is set, the output file names will be preceded by their
+ -- directory (if the file was found in the search path). If this switch
+ -- is not set, the directory will not be printed.
+
+ S_Find_Ignore : aliased constant S := "/IGNORE_LOCALS " &
+ "-g";
+ -- /NOIGNORE_LOCALS (D)
+ -- /IGNORE_LOCALS
+ --
+ -- If this switch is set, information is output only for library-level
+ -- entities, ignoring local entities. The use of this switch may
+ -- accelerate FIND and XREF.
+
+ S_Find_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
+ "DEFAULT " &
+ "-vP0 " &
+ "MEDIUM " &
+ "-vP1 " &
+ "HIGH " &
+ "-vP2";
+ -- /MESSAGES_PROJECT_FILE[=messages-option]
+ --
+ -- Specifies the "verbosity" of the parsing of project files.
+ -- messages-option may be one of the following:
+ --
+ -- DEFAULT (D) No messages are output if there is no error or warning.
+ --
+ -- MEDIUM A small number of messages are output.
+ --
+ -- HIGH A great number of messages are output, most of them not
+ -- being useful for the user.
+
+ S_Find_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
+ "-nostdinc";
+ -- /NOSTD_INCLUDES
+ --
+ -- Do not look for sources in the system default directory.
+
+ S_Find_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
+ "-nostdlib";
+ -- /NOSTD_LIBRARIES
+ --
+ -- Do not look for library files in the system default directory.
+
+ S_Find_Object : aliased constant S := "/OBJECT_SEARCH=*" &
+ "-aO*";
+ -- /OBJECT_SEARCH=(directory,...)
+ --
+ -- When searching for library and object files, look in the specified
+ -- directories. The order in which library files are searched is the same
+ -- as for MAKE.
+
+ S_Find_Print : aliased constant S := "/PRINT_LINES " &
+ "-s";
+ -- /NOPRINT_LINES (D)
+ -- /PRINT_LINES
+ --
+ -- Output the content of the Ada source file lines were the entity was
+ -- found.
+
+ S_Find_Project : aliased constant S := "/PROJECT=@" &
+ "-p@";
+ -- /PROJECT=file
+ --
+ -- Specify a project file to use. By default, FIND and XREF will try to
+ -- locate a project file in the current directory.
+ --
+ -- If a project file is either specified or found by the tools, then the
+ -- content of the source directory and object directory lines are added
+ -- as if they had been specified respectively by /SOURCE_SEARCH and
+ -- /OBJECT_SEARCH.
+ --
+ -- This qualifier is not compatible with /PROJECT_FILE
+
+ S_Find_Prj : aliased constant S := "/PROJECT_FILE=<" &
+ "-P>";
+ -- /PROJECT_FILE=filename
+ --
+ -- Specifies the main project file to be used. The project files rooted
+ -- at the main project file will be parsed before looking for sources.
+ -- The source and object directories to be searched will be communicated
+ -- to gnatfind through logical names ADA_PRJ_INCLUDE_FILE and
+ -- ADA_PRJ_OBJECTS_FILE.
+
+ S_Find_Ref : aliased constant S := "/REFERENCES " &
+ "-r";
+ -- /NOREFERENCES (D)
+ -- /REFERENCES
+ --
+ -- By default, FIND will output only the information about the
+ -- declaration, body or type completion of the entities. If this switch
+ -- is set, the FIND will locate every reference to the entities in the
+ -- files specified on the command line (or in every file in the search
+ -- path if no file is given on the command line).
+
+ S_Find_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+ -- /SEARCH=(directory,...)
+ --
+ -- Equivalent to:
+ -- /OBJECT_SEARCH=(directory,...) /SOURCE_SEARCH=(directory,...)
+
+ S_Find_Source : aliased constant S := "/SOURCE_SEARCH=*" &
+ "-aI*";
+ -- /SOURCE_SEARCH=(directory,...)
+ --
+ -- When looking for source files also look in the specified directories.
+ -- The order in which source file search is undertaken is the same as for
+ -- MAKE.
+
+ S_Find_Types : aliased constant S := "/TYPE_HIERARCHY " &
+ "-t";
+ -- /NOTYPE_HIERARCHY (D)
+ -- /TYPE_HIERARCHY
+ --
+ -- Output the type hierarchy for the specified type. It acts like the
+ -- /DERIVED_TYPE_INFORMATION qualifier, but recursively from parent type
+ -- to parent type. When this qualifier is specified it is not possible to
+ -- specify more than one file.
+
+ Find_Switches : aliased constant Switches :=
+ (S_Find_All 'Access,
+ S_Find_Deriv 'Access,
+ S_Find_Expr 'Access,
+ S_Find_Ext 'Access,
+ S_Find_Full 'Access,
+ S_Find_Ignore 'Access,
+ S_Find_Mess 'Access,
+ S_Find_Nostinc 'Access,
+ S_Find_Nostlib 'Access,
+ S_Find_Object 'Access,
+ S_Find_Print 'Access,
+ S_Find_Project 'Access,
+ S_Find_Prj 'Access,
+ S_Find_Ref 'Access,
+ S_Find_Search 'Access,
+ S_Find_Source 'Access,
+ S_Find_Types 'Access);
+
+ ------------------------------
+ -- Switches for GNAT KRUNCH --
+ ------------------------------
+
+ S_Krunch_Count : aliased constant S := "/COUNT=#" &
+ "`#";
+ -- /COUNT=39 (D)
+ -- /COUNT=nnn
+ --
+ -- Limit file names to nnn characters (where nnn is a decimal
+ -- integer). The maximum file name length is 39, but if you want to
+ -- generate a set of files that would be usable if ported to a system
+ -- with some different maximum file length, then a different value can
+ -- be specified.
+
+ Krunch_Switches : aliased constant Switches :=
+ (1 .. 1 => S_Krunch_Count 'Access);
+
+ -------------------------------
+ -- Switches for GNAT LIBRARY --
+ -------------------------------
+
+ S_Lbr_Config : aliased constant S := "/CONFIG=@" &
+ "--config=@";
+ -- /CONFIG=file
+ --
+ -- File containing configuration pragmas.
+
+ S_Lbr_Create : aliased constant S := "/CREATE=%" &
+ "--create=%";
+ -- /CREATE=directory
+ --
+ -- Directory to create and build alternate library in.
+
+ S_Lbr_Delete : aliased constant S := "/DELETE=%" &
+ "--delete=%";
+ -- /DELETE=directory
+ --
+ -- Directory containing alternate library to be deleted.
+
+ S_Lbr_Set : aliased constant S := "/SET=%" &
+ "--set=%";
+ -- /SET=directory
+ --
+ -- Directory containing alternate library to be made the current library.
+
+ Lbr_Switches : aliased constant Switches :=
+ (S_Lbr_Config 'Access,
+ S_Lbr_Create 'Access,
+ S_Lbr_Delete 'Access,
+ S_Lbr_Set 'Access);
+
+ ----------------------------
+ -- Switches for GNAT LINK --
+ ----------------------------
+
+ S_Link_Bind : aliased constant S := "/BIND_FILE=" &
+ "ADA " &
+ "-A " &
+ "C " &
+ "-C";
+ -- /BIND_FILE=[bind-file-option]
+ --
+ -- Specifies the language of the binder generated file.
+ --
+ -- ADA (D) Binder file is Ada.
+ --
+ -- C Binder file is 'C'.
+
+ S_Link_Debug : aliased constant S := "/DEBUG=" &
+ "ALL " &
+ "-g3 " &
+ "NONE " &
+ "-g0 " &
+ "TRACEBACK " &
+ "-g1 " &
+ "NOTRACEBACK " &
+ "-g0";
+ -- /NODEBUG (D)
+ -- /DEBUG[=debug-option]
+ --
+ -- Specifies the amount of debugging information included. 'debug-option'
+ -- is one of the following:
+ --
+ -- ALL (D) Include full debugging information.
+ --
+ -- NONE Provide no debugging information. Same as /NODEBUG.
+ --
+ -- TRACEBACK Provide sufficient debug information for a traceback.
+ --
+ -- NOTRACEBACK Same as NONE.
+
+ S_Link_Nodebug : aliased constant S := "/NODEBUG " &
+ "-g0";
+ -- NODOC (see /DEBUG)
+
+ S_Link_Execut : aliased constant S := "/EXECUTABLE=@" &
+ "-o@";
+ -- /EXECUTABLE=exec-name
+ --
+ -- 'exec-name' specifies an alternative name for the generated executable
+ -- program. If this qualifier switch is omitted, the executable is called
+ -- the name of the main unit. So "$ GNAT LINK TRY.ALI" creates an
+ -- executable called TRY.EXE.
+
+ S_Link_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
+ "-X" & '"';
+ -- /EXTERNAL_REFERENCE="name=val"
+ --
+ -- Specifies an external reference to the project manager. Useful only if
+ -- /PROJECT_FILE is used.
+ --
+ -- Example:
+ -- /EXTERNAL_REFERENCE="DEBUG=TRUE"
+
+ S_Link_Forlink : aliased constant S := "/FOR_LINKER=" & '"' &
+ "--for-linker=" & '"';
+ -- /FOR_LINKER=<string>
+ --
+ -- Transmit the option <string> to the underlying linker.
+
+ S_Link_Force : aliased constant S := "/FORCE_OBJECT_FILE_LIST " &
+ "-f";
+ -- /NOFORCE_OBJECT_FILE_LIST (D)
+ -- /FORCE_OBJECT_FILE_LIST
+ --
+ -- Forces the generation of a file that contains commands for the linker.
+ -- This is useful in some cases to deal with special situations where the
+ -- command line length is exceeded.
+
+ S_Link_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
+ "--for-linker=IDENT=" &
+ '"';
+ -- /IDENTIFICATION="<string>"
+ --
+ -- "<string>" specifies the string to be stored in the image file ident-
+ -- ification field in the image header. It overrides any pragma Ident
+ -- specified string.
+
+ S_Link_Libdir : aliased constant S := "/LIBDIR=*" &
+ "-L*";
+ -- /LIBDIR=(directory, ...)
+ --
+ -- Look for libraries in the specified directories.
+
+ S_Link_Library : aliased constant S := "/LIBRARY=|" &
+ "-l|";
+ -- /LYBRARY=xyz
+ --
+ -- Link with library named "xyz".
+
+ S_Link_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
+ "DEFAULT " &
+ "-vP0 " &
+ "MEDIUM " &
+ "-vP1 " &
+ "HIGH " &
+ "-vP2";
+ -- /MESSAGES_PROJECT_FILE[=messages-option]
+ --
+ -- Specifies the "verbosity" of the parsing of project files.
+ -- messages-option may be one of the following:
+ --
+ -- DEFAULT (D) No messages are output if there is no error or warning.
+ --
+ -- MEDIUM A small number of messages are output.
+ --
+ -- HIGH A great number of messages are output, most of them not
+ -- being useful for the user.
+
+ S_Link_Nocomp : aliased constant S := "/NOCOMPILE " &
+ "-n";
+ -- /NOCOMPILE
+ --
+ -- Do not compile the file generated by the binder.
+ -- This may be used when a link is rerun with different options,
+ -- but there is no need to recompile the binder generated file.
+
+ S_Link_Noinhib : aliased constant S := "/NOINHIBIT-EXEC " &
+ "--for-linker=--noinhibit-exec";
+ -- /NOINHIBIT-EXEC
+ --
+ -- Delete executable if there are errors or warnings.
+
+ S_Link_Nofiles : aliased constant S := "/NOSTART_FILES " &
+ "-nostartfiles";
+ -- /NOSTART_FILES
+ --
+ -- Link in default image initialization and startup functions.
+
+ S_Link_Project : aliased constant S := "/PROJECT_FILE=<" &
+ "-P>";
+ -- /PROJECT_FILE=filename
+ --
+ -- Specifies the main project file to be used. The project files rooted
+ -- at the main project file will be parsed before the invocation of the
+ -- linker.
+ -- The source and object directories to be searched will be communicated
+ -- to the linker through logical names ADA_PRJ_INCLUDE_FILE and
+ -- ADA_PRJ_OBJECTS_FILE.
+
+ S_Link_Return : aliased constant S := "/RETURN_CODES=" &
+ "POSIX " &
+ "!-mvms-return-codes " &
+ "VMS " &
+ "-mvms-return-codes";
+ -- /RETURN_CODES=POSIX (D)
+ -- /RETURN_CODES=VMS
+ --
+ -- Specifies the style of codes returned by
+ -- Ada.Command_Line.Set_Exit_Status.
+ --
+ -- POSIX (D) Return Posix compatible exit codes.
+ --
+ -- VMS Return VMS compatible exit codes. The value returned
+ -- is identically equal to the Set_Exit_Status parameter.
+
+ S_Link_Static : aliased constant S := "/STATIC " &
+ "--for-linker=-static";
+ -- /NOSTATIC (D)
+ -- /STATIC
+ --
+ -- Indicate to the linker that the link is static.
+
+ S_Link_Verb : aliased constant S := "/VERBOSE " &
+ "-v";
+ -- /NOVERBOSE (D)
+ -- /VERBOSE
+ --
+ -- Causes additional information to be output, including a full list of
+ -- the included object files. This switch option is most useful when you
+ -- want to see what set of object files are being used in the link step.
+
+ S_Link_ZZZZZ : aliased constant S := "/<other> " &
+ "--for-linker=";
+ -- /<other>
+ --
+ -- Any other switch that will be transmited to the underlying linker.
+
+ Link_Switches : aliased constant Switches :=
+ (S_Link_Bind 'Access,
+ S_Link_Debug 'Access,
+ S_Link_Nodebug 'Access,
+ S_Link_Execut 'Access,
+ S_Link_Ext 'Access,
+ S_Link_Forlink 'Access,
+ S_Link_Force 'Access,
+ S_Link_Ident 'Access,
+ S_Link_Libdir 'Access,
+ S_Link_Library 'Access,
+ S_Link_Mess 'Access,
+ S_Link_Nocomp 'Access,
+ S_Link_Nofiles 'Access,
+ S_Link_Noinhib 'Access,
+ S_Link_Project 'Access,
+ S_Link_Return 'Access,
+ S_Link_Static 'Access,
+ S_Link_Verb 'Access,
+ S_Link_ZZZZZ 'Access);
+
+ ----------------------------
+ -- Switches for GNAT LIST --
+ ----------------------------
+
+ S_List_All : aliased constant S := "/ALL_UNITS " &
+ "-a";
+ -- /NOALL_UNITS (D)
+ -- /ALL_UNITS
+ --
+ -- Consider all units, including those of the predefined Ada library.
+ -- Especially useful with /DEPENDENCIES.
+
+ S_List_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+ -- /CURRENT_DIRECTORY (D)
+ -- /NOCURRENT_DIRECTORY
+ --
+ -- Look for source, library or object files in the default directory.
+
+ S_List_Depend : aliased constant S := "/DEPENDENCIES " &
+ "-d";
+ -- /NODEPENDENCIES (D)
+ -- /DEPENDENCIES
+
+ S_List_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
+ "-X" & '"';
+ -- /EXTERNAL_REFERENCE="name=val"
+ --
+ -- Specifies an external reference to the project manager. Useful only if
+ -- /PROJECT_FILE is used.
+ --
+ -- Example:
+ -- /EXTERNAL_REFERENCE="DEBUG=TRUE"
+
+ S_List_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
+ "DEFAULT " &
+ "-vP0 " &
+ "MEDIUM " &
+ "-vP1 " &
+ "HIGH " &
+ "-vP2";
+ -- /MESSAGES_PROJECT_FILE[=messages-option]
+ --
+ -- Specifies the "verbosity" of the parsing of project files.
+ -- messages-option may be one of the following:
+ --
+ -- DEFAULT (D) No messages are output if there is no error or warning.
+ --
+ -- MEDIUM A small number of messages are output.
+ --
+ -- HIGH A great number of messages are output, most of them not
+ -- being useful for the user.
+
+ S_List_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
+ "-nostdinc";
+ -- /NOSTD_INCLUDES
+ --
+ -- Do not look for sources of the run time in the standard directory.
+
+ S_List_Object : aliased constant S := "/OBJECT_SEARCH=*" &
+ "-aO*";
+ -- /OBJECT_SEARCH=(directory,...)
+ --
+ -- When looking for library and object files look also in the specified
+ -- directories.
+
+ S_List_Output : aliased constant S := "/OUTPUT=" &
+ "SOURCES " &
+ "-s " &
+ "DEPEND " &
+ "-d " &
+ "OBJECTS " &
+ "-o " &
+ "UNITS " &
+ "-u " &
+ "OPTIONS " &
+ "-h " &
+ "VERBOSE " &
+ "-v ";
+ -- /OUTPUT=(option,option,...)
+ --
+ -- SOURCES (D) Only output information about source files.
+ --
+ -- DEPEND List sources from which specified units depend on.
+ --
+ -- OBJECTS Only output information about object files.
+ --
+ -- UNITS Only output information about compilation units.
+ --
+ -- OPTIONS Output the list of options.
+ --
+ -- VERBOSE Output the complete source and object paths.
+ -- Do not use the default column layout but instead
+ -- use long format giving as much as information
+ -- possible on each requested units, including
+ -- special characteristics.
+
+ S_List_Project : aliased constant S := "/PROJECT_FILE=<" &
+ "-P>";
+ -- /PROJECT_FILE=filename
+ --
+ -- Specifies the main project file to be used. The project files rooted
+ -- at the main project file will be parsed before doing any listing.
+ -- The source and object directories to be searched will be communicated
+ -- to gnatlist through logical names ADA_PRJ_INCLUDE_FILE and
+ -- ADA_PRJ_OBJECTS_FILE.
+
+ S_List_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+ -- /SEARCH=(directory,...)
+ --
+ -- Search the specified directories for both source and object files.
+
+ S_List_Source : aliased constant S := "/SOURCE_SEARCH=*" &
+ "-aI*";
+ -- /SOURCE_SEARCH=(directory,...)
+ --
+ -- When looking for source files also look in the specified directories.
+
+ List_Switches : aliased constant Switches :=
+ (S_List_All 'Access,
+ S_List_Current 'Access,
+ S_List_Depend 'Access,
+ S_List_Ext 'Access,
+ S_List_Mess 'Access,
+ S_List_Nostinc 'Access,
+ S_List_Object 'Access,
+ S_List_Output 'Access,
+ S_List_Project 'Access,
+ S_List_Search 'Access,
+ S_List_Source 'Access);
+
+ ----------------------------
+ -- Switches for GNAT MAKE --
+ ----------------------------
+
+ S_Make_Actions : aliased constant S := "/ACTIONS=" &
+ "COMPILE " &
+ "-c " &
+ "BIND " &
+ "-b " &
+ "LINK " &
+ "-l ";
+ -- /ACTIONS=(keyword[,...])
+ --
+ -- GNAT MAKE default behavior is to check if the sources are up to date,
+ -- compile those sources that are not up to date, bind the main source,
+ -- then link the executable.
+ --
+ -- With the /ACTIONS qualifier, GNAT MAKE may be restricted to one or
+ -- two of these three steps:
+ --
+ -- o Compile
+ -- o Bind
+ -- o Link
+ --
+ --
+ -- You may specify one or more of the following keywords to the /ACTIONS
+ -- qualifier:
+ --
+ -- BIND Bind only. Can be combined with /ACTIONS=COMPILE
+ -- to do compilation and binding, but no linking.
+ -- Can be combined with /ACTIONS=LINK to do binding and
+ -- linking. When not combined with /ACTIONS=COMPILE,
+ -- all the units in the closure of the main program must
+ -- have been previously compiled and must be up to date.
+ --
+ -- COMPILE Compile only. Do not perform binding, except when
+ -- /ACTIONS=BIND is also specified. Do not perform
+ -- linking, except if both /ACTIONS=BIND and /ACTIONS=LINK
+ -- are also specified.
+ --
+ -- LINK Link only. Can be combined with /ACTIONS=BIND to do
+ -- binding and linking. Linking will not be performed
+ -- if combined with /ACTIONS=COMPILE but not with
+ -- /ACTIONS=BIND\. When not combined with /ACTIONS=BIND
+ -- all the units in the closure of the main program must
+ -- have been previously compiled and must be up to date,
+ -- and the main program need to have been bound.
+
+ S_Make_All : aliased constant S := "/ALL_FILES " &
+ "-a";
+ -- /NOALL_FILES (D)
+ -- /ALL_FILES
+ --
+ -- Consider all files in the make process, even the GNAT internal system
+ -- files (for example, the predefined Ada library files). By default,
+ -- GNAT MAKE does not check these files (however, if there is an
+ -- installation problem, it will be caught when GNAT MAKE binds your
+ -- program). You may have to specify this qualifier if you are working on
+ -- GNAT itself. The vast majority of GNAT MAKE users never need to
+ -- specify this switch. All GNAT internal files with will be compiled
+ -- with /STYLE_CHECK=GNAT.
+
+ S_Make_Allproj : aliased constant S := "/ALL_PROJECTS " &
+ "-U";
+ -- /NOALL_PROJECTS (D)
+ -- /ALL_PROJECTS
+ --
+ -- Implies /Unique.
+ -- When used without project files, it is equivalent to /UNIQUE.
+ -- When used with a project file wit no main (neither on the command
+ -- line nor in the attribute Main) check every source of every project,
+ -- recompile all sources that are not up to date and rebuild libraries
+ -- if necessary.
+
+ S_Make_Bind : aliased constant S := "/BINDER_QUALIFIERS=?" &
+ "-bargs BIND";
+ -- /BINDER_QUALIFIERS
+ --
+ -- Any qualifiers specified after this qualifier other than
+ -- /COMPILER_QUALIFIERS, /LINKER_QUALIFIERS and /MAKE_QUALIFIERS will be
+ -- passed to any GNAT BIND commands generated by GNAT MAKE.
+
+ S_Make_Comp : aliased constant S := "/COMPILER_QUALIFIERS=?" &
+ "-cargs COMPILE";
+ -- /COMPILER_QUALIFIERS
+ --
+ -- Any qualifiers specified after this qualifier other than
+ -- /BINDER_QUALIFIERS, /LINKER_QUALIFIERS and /MAKE_QUALIFIERS will be
+ -- passed to any GNAT COMPILE commands generated by GNAT MAKE.
+
+ S_Make_Cond : aliased constant S := "/CONDITIONAL_SOURCE_SEARCH=*" &
+ "-A*";
+ -- /CONDITIONAL_SOURCE_SEARCH=dir
+ --
+ -- Equivalent to "/SOURCE_SEARCH=dir /SKIP_MISSING=dir".
+
+ S_Make_Cont : aliased constant S := "/CONTINUE_ON_ERROR " &
+ "-k";
+ -- /NOCONTINUE_ON_ERROR (D)
+ -- /CONTINUE_ON_ERROR
+ --
+ -- Keep going. Continue as much as possible after a compilation error.
+ -- To ease the programmer's task in case of compilation errors, the list
+ -- of sources for which the compile fails is given when GNAT MAKE
+ -- terminates.
+
+ S_Make_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+ -- /CURRENT_DIRECTORY (D)
+ -- /NOCURRENT_DIRECTORY
+ --
+ -- Look for source, library or object files in the default directory.
+
+ S_Make_Dep : aliased constant S := "/DEPENDENCIES_LIST " &
+ "-M";
+ -- /NODEPENDENCIES_LIST (D)
+ -- /DEPENDENCIES_LIST
+ --
+ -- Check if all objects are up to date. If they are, output the object
+ -- dependences to SYS$OUTPUT in a form that can be directly exploited in
+ -- a Unix-style Makefile. By default, each source file is prefixed with
+ -- its (relative or absolute) directory name. This name is whatever you
+ -- specified in the various /SOURCE_SEARCH and /SEARCH qualifiers. If
+ -- you also speficy the /QUIET qualifier, only the source file names,
+ -- without relative paths, are output. If you just specify the
+ -- /DEPENDENCY_LIST qualifier, dependencies of the GNAT internal system
+ -- files are omitted. This is typically what you want. If you also
+ -- specify the /ALL_FILES qualifier, dependencies of the GNAT internal
+ -- files are also listed. Note that dependencies of the objects in
+ -- external Ada libraries (see the /SKIP_MISSING qualifier) are never
+ -- reported.
+
+ S_Make_Dirobj : aliased constant S := "/DIRECTORY_OBJECTS=@" &
+ "-D@";
+ -- /DIRECTORY_OBJECTS=<file>
+ --
+ -- Put all object files and .ALI files in <file>.
+ -- This qualifier is not compatible with /PROJECT_FILE.
+
+ S_Make_Doobj : aliased constant S := "/DO_OBJECT_CHECK " &
+ "-n";
+ -- /NODO_OBJECT_CHECK (D)
+ -- /DO_OBJECT_CHECK
+ --
+ -- Don't compile, bind, or link. Output a single command that will
+ -- recompile an out of date unit, if any. Repeated use of this option,
+ -- followed by carrying out the indicated compilation, will eventually
+ -- result in recompiling all required units.
+ --
+ -- If any ALI is missing during the process, GNAT MAKE halts and
+ -- displays an error message.
+
+ S_Make_Execut : aliased constant S := "/EXECUTABLE=@" &
+ "-o@";
+ -- /EXECUTABLE=exec-name
+ --
+ -- The name of the final executable program will be 'exec_name'. If this
+ -- qualifier is omitted the default name for the executable will be the
+ -- name of the input file with an EXE filetype. You may prefix
+ -- 'exec_name' with a relative or absolute directory path.
+
+ S_Make_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
+ "-X" & '"';
+ -- /EXTERNAL_REFERENCE="name=val"
+ --
+ -- Specifies an external reference to the project manager. Useful only if
+ -- /PROJECT_FILE is used.
+ --
+ -- Example:
+ -- /EXTERNAL_REFERENCE="DEBUG=TRUE"
+
+ S_Make_Force : aliased constant S := "/FORCE_COMPILE " &
+ "-f";
+ -- /NOFORCE_COMPILE (D)
+ -- /FORCE_COMPILE
+ --
+ -- Force recompilations. Recompile all sources, even though some object
+ -- files may be up to date, but don't recompile predefined or GNAT
+ -- internal files unless the /ALL_FILES qualfier is also specified.
+
+ S_Make_Full : aliased constant S := "/FULL_PATH_IN_BRIEF_MESSAGES " &
+ "-F";
+ -- /NOFULL_PATH_IN_BRIEF_MESSAGES (D)
+ -- /FULL_PATH_IN_BRIEF_MESSAGES
+ --
+ -- When using project files, if some errors or warnings are detected
+ -- during parsing and verbose mode is not in effect (no use of qualifier
+ -- /VERBOSE), then error lines start with the full path name of the
+ -- project file, rather than its simple file name.
+
+ S_Make_Inplace : aliased constant S := "/IN_PLACE " &
+ "-i";
+ -- /NOIN_PLACE (D)
+ -- /IN_PLACE
+ --
+ -- In normal mode, GNAT MAKE compiles all object files and ALI files
+ -- into the current directory. If the /IN_PLACE switch is used,
+ -- then instead object files and ALI files that already exist are over-
+ -- written in place. This means that once a large project is organized
+ -- into separate directories in the desired manner, then GNAT MAKE will
+ -- automatically maintain and update this organization. If no ALI files
+ -- are found on the Ada object path, the new object and ALI files are
+ -- created in the directory containing the source being compiled.
+
+ S_Make_Library : aliased constant S := "/LIBRARY_SEARCH=*" &
+ "-L*";
+ -- /LIBRARY_SEARCH=(directory[,...])
+ --
+ -- Add the specified directories to the list of directories in which the
+ -- linker will search for libraries.
+
+ S_Make_Link : aliased constant S := "/LINKER_QUALIFIERS=?" &
+ "-largs LINK";
+ -- /LINKER_QUALIFIERS
+ --
+ -- Any qualifiers specified after this qualifier other than
+ -- /COMPILER_QUALIFIERS, /BINDER_QUALIFIERS and /MAKE_QUALIFIERS will be
+ -- passed to any GNAT LINK commands generated by GNAT LINK.
+
+ S_Make_Make : aliased constant S := "/MAKE_QUALIFIERS=?" &
+ "-margs MAKE";
+ -- /MAKE_QUALIFIERS
+ --
+ -- Any qualifiers specified after this qualifier other than
+ -- /COMPILER_QUALIFIERS, /BINDER_QUALIFIERS and /LINKER_QUALIFIERS
+ -- are for the benefit of GNAT MAKE itself.
+
+ S_Make_Mapping : aliased constant S := "/MAPPING " &
+ "-C";
+ -- /NOMAPPING (D)
+ -- /MAPPING
+ --
+ -- Use a mapping file. A mapping file is a way to communicate to the
+ -- compiler two mappings: from unit names to file names (without any
+ -- directory information) and from file names to path names (with full
+ -- directory information). These mappings are used by the compiler to
+ -- short-circuit the path search. When GNAT MAKE is invoked with this
+ -- qualifier, it will create a mapping file, initially populated by the
+ -- project manager, if /PROJECT_File= is used, otherwise initially empty.
+ -- Each invocation of the compiler will add the newly accessed sources to
+ -- the mapping file. This will improve the source search during the next
+ -- invocations of the compiler
+
+ S_Make_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
+ "DEFAULT " &
+ "-vP0 " &
+ "MEDIUM " &
+ "-vP1 " &
+ "HIGH " &
+ "-vP2";
+ -- /MESSAGES_PROJECT_FILE[=messages-option]
+ --
+ -- Specifies the "verbosity" of the parsing of project files.
+ -- messages-option may be one of the following:
+ --
+ -- DEFAULT (D) No messages are output if there is no error or warning.
+ --
+ -- MEDIUM A small number of messages are output.
+ --
+ -- HIGH A great number of messages are output, most of them not
+ -- being useful for the user.
+
+ S_Make_Minimal : aliased constant S := "/MINIMAL_RECOMPILATION " &
+ "-m";
+ -- /NOMINIMAL_RECOMPILATION (D)
+ -- /MINIMAL_RECOMPILATION
+ --
+ -- Specifies that the minimum necessary amount of recompilation
+ -- be performed. In this mode GNAT MAKE ignores time stamp differences
+ -- when the only modifications to a source file consist in
+ -- adding/removing comments, empty lines, spaces or tabs.
+
+ S_Make_Nolink : aliased constant S := "/NOLINK " &
+ "-c";
+ -- /NOLINK
+ --
+ -- Compile only. Do not perform binding and linking. If the root unit is
+ -- not a main unit, this is the default. Otherwise GNAT MAKE will
+ -- attempt binding and linking unless all objects are up to date and the
+ -- executable is more recent than the objects.
+ -- This is equivalent to /ACTIONS=COMPILE
+
+ S_Make_Nomain : aliased constant S := "/NOMAIN " &
+ "-z";
+ -- /NOMAIN
+ --
+ -- No main subprogram. Bind and link the program even if the unit name
+ -- given on the command line is a package name. The resulting executable
+ -- will execute the elaboration routines of the package and its closure,
+ -- then the finalization routines.
+
+ S_Make_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
+ "-nostdinc";
+ -- /NOSTD_INCLUDES
+ --
+ -- Do not look for sources the in the system default directory.
+
+ S_Make_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
+ "-nostdlib";
+ -- /NOSTD_LIBRARIES
+ --
+ -- Do not look for library files in the system default directory.
+
+ S_Make_Object : aliased constant S := "/OBJECT_SEARCH=*" &
+ "-aO*";
+ -- /OBJECT_SEARCH=(directory[,...])
+ --
+ -- When looking for library and object files look also in the specified
+ -- directories.
+
+ S_Make_Proc : aliased constant S := "/PROCESSES=#" &
+ "-j#";
+ -- /NOPROCESSES (D)
+ -- /PROCESSES=NNN
+ --
+ -- Use NNN processes to carry out the (re)complations. If you have a
+ -- multiprocessor machine, compilations will occur in parallel. In the
+ -- event of compilation errors, messages from various compilations might
+ -- get interspersed (but GNAT MAKE will give you the full ordered list of
+ -- failing compiles at the end). This can at times be annoying. To get a
+ -- clean list of error messages don't use this qualifier.
+
+ S_Make_Nojobs : aliased constant S := "/NOPROCESSES " &
+ "-j1";
+ -- NODOC (see /PROCESS)
+
+ S_Make_Project : aliased constant S := "/PROJECT_FILE=<" &
+ "-P>";
+ -- /PROJECT_FILE=filename
+ --
+ -- Specifies the main project file to be used. The project files rooted
+ -- at the main project file will be parsed before any other processing to
+ -- set the building environment.
+
+ S_Make_Quiet : aliased constant S := "/QUIET " &
+ "-q";
+ -- /NOQUIET (D)
+ -- /QUIET
+ --
+ -- When this qualifiers is specified, the commands carried out by GNAT
+ -- MAKE are not displayed.
+
+ S_Make_Reason : aliased constant S := "/REASONS " &
+ "-v";
+ -- /NOREASONS (D)
+ -- /REASONS
+ --
+ -- Displays the reason for all recompilations GNAT MAKE decides are
+ -- necessary.
+
+ S_Make_RTS : aliased constant S := "/RUNTIME_SYSTEM=|" &
+ "--RTS=|";
+ -- /RUNTIME_SYSTEM=xxx
+ --
+ -- Build against an alternate runtime system named xxx or RTS-xxx.
+
+ S_Make_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+ -- /SEARCH=(directory[,...])
+ --
+ -- Search the specified directories for both source and object files.
+
+ S_Make_Skip : aliased constant S := "/SKIP_MISSING=*" &
+ "-aL*";
+ -- /SKIP_MISSING=(directory[,...])
+ --
+ -- Skip missing library sources if ALI in 'directory'.
+
+ S_Make_Source : aliased constant S := "/SOURCE_SEARCH=*" &
+ "-aI*";
+ -- /SOURCE_SEARCH=(directory[,...])
+ --
+ -- When looking for source files also look in the specified directories.
+
+ S_Make_Switch : aliased constant S := "/SWITCH_CHECK " &
+ "-s";
+ -- /NOSWITCH_CHECK (D)
+ -- /SWITCH_CHECK
+ --
+ -- Recompile if compiler switches have changed since last compilation.
+ -- All compiler switches but -I and -o are taken into account in the
+ -- following way: orders between different "first letter" switches are
+ -- ignored, but orders between same switches are taken into account.
+ -- For example, -O -O2 is different than -O2 -O, but -g -O is equivalent
+ -- to -O -g.
+
+ S_Make_Unique : aliased constant S := "/UNIQUE " &
+ "-u";
+ -- /NOUNIQUE (D)
+ -- /UNIQUE
+ --
+ -- Recompile at most the main file. It implies /ACTIONS=COMPILE.
+ -- Combined with /FORCE_COMPILE, it is equivalent to calling the compiler
+ -- directly.
+
+ S_Make_Use_Map : aliased constant S := "/USE_MAPPING_File=@" &
+ "-C=@";
+ -- /USE_MAPPING_FILE=file_name
+ --
+ -- Use a specific mapping file. The file 'file_name', specified as a path
+ -- name (absolute or relative) by this qualifier, should already exist,
+ -- otherwise the qualifier is ineffective. The specified mapping file
+ -- will be communicated to the compiler. This switch is not compatible
+ -- with a project file (/PROJECT_FILE=) or with multiple compiling
+ -- processes (/PROCESSES=nnn, when nnn is greater than 1).
+
+ S_Make_Verbose : aliased constant S := "/VERBOSE " &
+ "-v";
+ -- /NOVERBOSE (D)
+ -- /VERBOSE
+ --
+ -- Displays the reason for all recompilations GNAT MAKE decides are
+ -- necessary.
+
+ Make_Switches : aliased constant Switches :=
+ (S_Make_Actions 'Access,
+ S_Make_All 'Access,
+ S_Make_Allproj 'Access,
+ S_Make_Bind 'Access,
+ S_Make_Comp 'Access,
+ S_Make_Cond 'Access,
+ S_Make_Cont 'Access,
+ S_Make_Current 'Access,
+ S_Make_Dep 'Access,
+ S_Make_Dirobj 'Access,
+ S_Make_Doobj 'Access,
+ S_Make_Execut 'Access,
+ S_Make_Ext 'Access,
+ S_Make_Force 'Access,
+ S_Make_Full 'Access,
+ S_Make_Inplace 'Access,
+ S_Make_Library 'Access,
+ S_Make_Link 'Access,
+ S_Make_Make 'Access,
+ S_Make_Mapping 'Access,
+ S_Make_Mess 'Access,
+ S_Make_Minimal 'Access,
+ S_Make_Nolink 'Access,
+ S_Make_Nomain 'Access,
+ S_Make_Nostinc 'Access,
+ S_Make_Nostlib 'Access,
+ S_Make_Object 'Access,
+ S_Make_Proc 'Access,
+ S_Make_Nojobs 'Access,
+ S_Make_Project 'Access,
+ S_Make_Quiet 'Access,
+ S_Make_Reason 'Access,
+ S_Make_RTS 'Access,
+ S_Make_Search 'Access,
+ S_Make_Skip 'Access,
+ S_Make_Source 'Access,
+ S_Make_Switch 'Access,
+ S_Make_Unique 'Access,
+ S_Make_Use_Map 'Access,
+ S_Make_Verbose 'Access);
+
+ ----------------------------
+ -- Switches for GNAT NAME --
+ ----------------------------
+
+ S_Name_Conf : aliased constant S := "/CONFIG_FILE=<" &
+ "-c>";
+ -- /CONFIG_FILE=path_name
+ --
+ -- Create a configuration pragmas file 'path_name' (instead of the default
+ -- 'gnat.adc'). 'path_name' may include directory information. 'path_name'
+ -- must be writable. There may be only one qualifier /CONFIG_FILE.
+ -- This qualifier is not compatible with qualifier /PROJECT_FILE.
+
+ S_Name_Dirs : aliased constant S := "/SOURCE_DIRS=*" &
+ "-d*";
+ -- /SOURCE_DIRS=(directory, ...)
+ --
+ -- Look for source files in the specified directories. When this qualifier
+ -- is specified, the current working directory will not be searched for
+ -- source files, unless it is explicitly specified with a qualifier
+ -- /SOURCE_DIRS or /DIRS_FILE. Several qualifiers /SOURCE_DIRS may be
+ -- specified. If a directory is specified as a relative path, it is
+ -- relative to the directory of the configuration pragmas file specified
+ -- with qualifier /CONFIG_FILE, or to the directory of the project file
+ -- specified with qualifier /PROJECT_FILE or, if neither qualifier
+ -- /CONFIG_FILE nor qualifier /PROJECT_FILE are specified, it is relative
+ -- to the current working directory. The directories specified with
+ -- qualifiers /SOURCE_DIRS must exist and be readable.
+
+ S_Name_Dfile : aliased constant S := "/DIRS_FILE=<" &
+ "-D>";
+ -- /DIRS_FILE=file_name
+ --
+ -- Look for source files in all directories listed in text file
+ -- 'file_name'. 'file_name' must be an existing, readable text file.
+ -- Each non empty line in the specified file must be a directory.
+ -- Specifying qualifier /DIRS_FILE is equivalent to specifying as many
+ -- qualifiers /SOURCE_DIRS as there are non empty lines in the specified
+ -- text file.
+
+ S_Name_Frng : aliased constant S := "/FOREIGN_PATTERN=" & '"' &
+ "-f" & '"';
+ -- /FOREIGN_PATTERN=<string>
+ --
+ -- Specify a foreign pattern.
+ -- Using this qualifier, it is possible to add sources of languages other
+ -- than Ada to the list of sources of a project file. It is only useful
+ -- if a qualifier /PROJECT_FILE is used. For example,
+ --
+ -- GNAT NAME /PROJECT_FILE=PRJ /FOREIGN_PATTERN="*.C" "*.ADA"
+ --
+ -- will look for Ada units in all files with the '.ADA' extension, and
+ -- will add to the list of file for project PRJ.GPR the C files with
+ -- extension ".C".
+
+ S_Name_Help : aliased constant S := "/HELP " &
+ "-h";
+ -- /NOHELP (D)
+ -- /HELP
+ --
+ -- Output usage information to the standard output stream.
+
+ S_Name_Proj : aliased constant S := "/PROJECT_FILE=<" &
+ "-P>";
+ -- /PROJECT_FILE=file_name
+ --
+ -- Create or update a project file. 'file_name' may include directory
+ -- information. The specified file must be writable. There may be only
+ -- one qualifier /PROJECT_FILE. When a qualifier /PROJECT_DILE is
+ -- specified, no qualifier /CONFIG_FILE may be specified.
+
+ S_Name_Verbose : aliased constant S := "/VERBOSE " &
+ "-v";
+ -- /NOVERBOSE (D)
+ -- /VERBOSE
+ --
+ -- Verbose mode. Output detailed explanation of behavior to the standard
+ -- output stream. This includes name of the file written, the name of the
+ -- directories to search and, for each file in those directories whose
+ -- name matches at least one of the Naming Patterns, an indication of
+ -- whether the file contains a unit, and if so the name of the unit.
+
+ S_Name_Excl : aliased constant S := "/EXCLUDED_PATTERN=" & '"' &
+ "-x" & '"';
+ -- /EXCLUDED_PATTERN=<string>
+ --
+ -- Specify an excluded pattern.
+ -- Using this qualifier, it is possible to exclude some files that would
+ -- match the Naming patterns. For example,
+ --
+ -- GNAT NAME /EXCLUDED_PATTERN="*_NT.ADA" "*.ADA"
+ --
+ -- will look for Ada units in all files with the '.ADA' extension, except
+ -- those whose names end with '_NT.ADA'.
+
+ Name_Switches : aliased constant Switches :=
+ (S_Name_Conf 'Access,
+ S_Name_Dirs 'Access,
+ S_Name_Dfile 'Access,
+ S_Name_Frng 'Access,
+ S_Name_Help 'Access,
+ S_Name_Proj 'Access,
+ S_Name_Verbose 'Access,
+ S_Name_Excl 'Access);
+
+ ----------------------------------
+ -- Switches for GNAT PREPROCESS --
+ ----------------------------------
+
+ S_Prep_Assoc : aliased constant S := "/ASSOCIATE=" & '"' &
+ "-D" & '"';
+ -- /ASSOCIATE="name=val"
+ --
+ -- Defines a new symbol, associated with value. If no value is given
+ -- on the command line, then symbol is considered to be True.
+ -- This qualifier can be used in place of a definition file.
+
+ S_Prep_Blank : aliased constant S := "/BLANK_LINES " &
+ "-b";
+ -- /NOBLANK_LINES (D)
+ -- /BLANK_LINES
+ --
+ -- Causes both preprocessor lines and the lines deleted by preprocessing
+ -- to be replaced by blank lines in the output source file, thus
+ -- preserving line numbers in the output file.
+
+ S_Prep_Com : aliased constant S := "/COMMENTS " &
+ "-c";
+ -- /NOCOMMENTS (D)
+ -- /COMMENTS
+ --
+ -- /COMMENTS causes both preprocessor lines and the lines deleted
+ -- by preprocessing to be retained in the output source as comments marked
+ -- with the special string "--! ". This option will result in line numbers
+ -- being preserved in the output file.
+ --
+ -- /NOCOMMENTS causes both preprocessor lines and the lines deleted by
+ -- preprocessing to be replaced by blank lines in the output source file,
+ -- thus preserving line numbers in the output file.
+
+ S_Prep_Ref : aliased constant S := "/REFERENCE " &
+ "-r";
+ -- /NOREFERENCE (D)
+ -- /REFERENCE
+ --
+ -- Causes a "Source_Reference" pragma to be generated that references the
+ -- original input file, so that error messages will use the file name of
+ -- this original file. Also implies /BLANK_LINES if /COMMENTS is not
+ -- specified.
+
+ S_Prep_Remove : aliased constant S := "/REMOVE " &
+ "!-b,!-c";
+ -- /REMOVE (D)
+ -- /NOREMOVE
+ --
+ -- Preprocessor lines and deleted lines are completely removed from the
+ -- output.
+
+ S_Prep_Symbols : aliased constant S := "/SYMBOLS " &
+ "-s";
+ -- /NOSYMBOLS (D)
+ -- /SYMBOLS
+ --
+ -- Causes a sorted list of symbol names and values to be listed on
+ -- SYS$OUTPUT.
+
+ S_Prep_Undef : aliased constant S := "/UNDEFINED " &
+ "-u";
+ -- /NOUNDEFINED (D)
+ -- /UNDEFINED
+
+ Prep_Switches : aliased constant Switches :=
+ (S_Prep_Assoc 'Access,
+ S_Prep_Blank 'Access,
+ S_Prep_Com 'Access,
+ S_Prep_Ref 'Access,
+ S_Prep_Remove 'Access,
+ S_Prep_Symbols 'Access,
+ S_Prep_Undef 'Access);
+
+ ------------------------------
+ -- Switches for GNAT PRETTY --
+ ------------------------------
+
+ S_Pretty_Align : aliased constant S := "/ALIGN=" &
+ "DEFAULT " &
+ "-A1234 " &
+ "OFF " &
+ "-A0 " &
+ "COLONS " &
+ "-A1 " &
+ "DECLARATIONS " &
+ "-A2 " &
+ "STATEMENTS " &
+ "-A3 " &
+ "ARROWS " &
+ "-A4";
+ -- /ALIGN[=align-option, align-option, ...]
+ --
+ -- Set alignments. By default, all alignments (colons in declarations,
+ -- initialisations in declarations, assignments and arrow delimiters) are
+ -- ON.
+ --
+ -- align-option may be one of the following:
+ --
+ -- OFF (D) Set all alignments to OFF
+ -- COLONS Set alignments of colons in declarations to ON
+ -- DECLARATIONS Set alignments of initialisations in declarations to ON
+ -- STATEMENTS Set alignments of assignments statements to ON
+ -- ARROWS Set alignments of arrow delimiters to ON.
+ --
+ -- Specifying one of the ON options without first specifying the OFF
+ -- option has no effect, because by default all alignments are set to ON.
+
+ S_Pretty_Attrib : aliased constant S := "/ATTRIBUTE_CASING=" &
+ "MIXED_CASE " &
+ "-aM " &
+ "LOWER_CASE " &
+ "-aL " &
+ "UPPER_CASE " &
+ "-aU";
+ -- /ATTRIBUTE_CASING[=casing-option]
+ --
+ -- Set the case of the attributes. By default the attributes are in mixed
+ -- case.
+ -- casing-option may be one of the following:
+ --
+ -- MIXED_CASE (D)
+ -- LOWER_CASE
+ -- UPPER_CASE
+
+ S_Pretty_Comments : aliased constant S := "/COMMENTS_LAYOUT=" &
+ "DEFAULT " &
+ "-c1 " &
+ "STANDARD_INDENT " &
+ "-c2 " &
+ "GNAT_BEGINNING " &
+ "-c3 " &
+ "REFORMAT " &
+ "-c4";
+ -- /COMMENTS_LAYOUT[=layout-option, layout-option, ...]
+ --
+ -- Set the comment layout. By default, comments use the GNAT style comment
+ -- line indentation.
+ -- layout-option may be one of the following:
+ --
+ -- DEFAULT (D) GNAT style comment line indentation
+ -- STANDARD_INDENT Standard comment line indentation
+ -- GNAT_BEGINNING GNAT style comment beginning
+ -- REFORMAT Reformat comment blocks
+ --
+ -- All combinations of layout options are allowed, except for DEFAULT
+ -- and STANDARD_INDENT which are mutually exclusive.
+ --
+ -- The difference between "GNAT style comment line indentation" and
+ -- "standard comment line indentation" is the following: for standard
+ -- comment indentation, any comment line is indented as if it were
+ -- a declaration or statement at the same place.
+ -- For GNAT style comment indentation, comment lines which are
+ -- immediately followed by if or case statement alternative, record
+ -- variant or 'begin' keyword are indented as the keyword that follows
+ -- them.:
+ --
+ -- Standard indentation:
+ --
+ -- if A then
+ -- null;
+ -- -- some comment
+ -- else
+ -- null;
+ -- end if;
+ --
+ -- GNAT style indentation:
+ --
+ -- if A then
+ -- null;
+ -- -- some comment
+ -- else
+ -- null;
+ -- end if;
+ --
+ -- Option "GNAT style comment beginning" means that for each comment
+ -- which is not considered as non-formattable separator (that is, the
+ -- comment line contains only dashes, or a comment line ends with two
+ -- dashes), there will be at least two spaces between starting "--" and
+ -- the first non-blank character of the comment.
+
+ S_Pretty_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" &
+ "-gnatec>";
+ -- /CONFIGURATION_PRAGMAS_FILE=file
+ --
+ -- Specify a configuration pragmas file that need to be passed to the
+ -- compiler.
+
+ S_Pretty_Constr : aliased constant S := "/CONSTRUCT_LAYOUT=" &
+ "GNAT " &
+ "-l1 " &
+ "COMPACT " &
+ "-l2 " &
+ "UNCOMPACT " &
+ "-l3";
+ -- /CONSTRUCT_LAYOUT[=construct-option]
+ --
+ -- Set construct layout. Default is GNAT style layout.
+ -- construct-option may be one of the following:
+ --
+ -- GNAT (D)
+ -- COMPACT
+ -- UNCOMPACT
+ --
+ -- The difference between GNAT style and Compact layout on one hand
+ -- and Uncompact layout on the other hand can be illustrated by the
+ -- following examples:
+ --
+ -- GNAT style and Uncompact layout
+ -- Compact layout
+ --
+ -- type q is record type q is
+ -- a : integer; record
+ -- b : integer; a : integer;
+ -- end record; b : integer;
+ -- end record;
+ --
+ --
+ -- Block : declare Block :
+ -- A : Integer := 3; declare
+ -- begin A : Integer := 3;
+ -- Proc (A, A); begin
+ -- end Block; Proc (A, A);
+ -- end Block;
+ --
+ -- Clear : for J in 1 .. 10 loop Clear :
+ -- A (J) := 0; for J in 1 .. 10 loop
+ -- end loop Clear; A (J) := 0;
+ -- end loop Clear;
+ --
+ --
+ -- A further difference between GNAT style layout and compact layout is
+ -- that in GNAT style layout compound statements, return statements and
+ -- bodies are always separated by empty lines.
+
+ S_Pretty_Comind : aliased constant S := "/CONTINUATION_INDENT=#" &
+ "-cl#";
+ -- /CONTINUATION_INDENT=nnn
+ --
+ -- Indentation level for continuation lines, nnn from 1 .. 9.
+ -- The default value is one less then the (normal) indentation level,
+ -- unless the indentation is set to 1: in that case the default value for
+ -- continuation line indentation is also 1.
+
+ S_Pretty_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
+ "-X" & '"';
+ -- /EXTERNAL_REFERENCE="name=val"
+ --
+ -- Specifies an external reference to the project manager. Useful only if
+ -- /PROJECT_FILE is used.
+ --
+ -- Example:
+ -- /EXTERNAL_REFERENCE="DEBUG=TRUE"
+
+ S_Pretty_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+ -- /CURRENT_DIRECTORY (D)
+ --
+ -- Look for source files in the current working directory.
+ --
+ -- /NOCURRENT_DIRECTORY
+ -- Do not look for source files in the current working directory.
+
+ S_Pretty_Dico : aliased constant S := "/DICTIONARY=*" &
+ "-D*";
+ -- /DICTIONARY=(file_name, ...)
+ --
+ -- Use each specified file as a dictionary file that defines the casing
+ -- for a set of specified names, thereby overriding the effect on these
+ -- names by any explicit or implicit /NAME_CASING qualifier.
+ --
+ -- GNAT PRETTY implicitly uses a default dictionary file to define the
+ -- casing for the Ada predefined names and the names declared in the GNAT
+ -- libraries.
+ --
+ -- The structure of a dictionary file, and details on the conventions
+ -- used in the default dictionary file, are defined in the GNAT User's
+ -- Guide.
+
+ S_Pretty_Forced : aliased constant S := "/FORCED_OUTPUT=@" &
+ "-of@";
+ -- /FORCED_OUTPUT=file
+ --
+ -- Write the output into the specified file, overriding any possibly
+ -- existing file.
+
+ S_Pretty_Indent : aliased constant S := "/INDENTATION_LEVEL=#" &
+ "-i#";
+ -- /INDENTATION_LEVEL=nnn
+ --
+ -- Specify the number of spaces to add for each indentation level.
+ -- nnn must be between 1 and 9. The default is 3.
+
+ S_Pretty_Keyword : aliased constant S := "/KEYWORD_CASING=" &
+ "LOWER_CASE " &
+ "-kL " &
+ "UPPER_CASE " &
+ "-kU";
+ -- /KEYWORD_CASING[=keyword-option]
+ --
+ -- Specify the case of Ada keywords. The default is keywords in lower
+ -- case.
+ -- keyword-option may be one of the following:
+ --
+ -- LOWER_CASE (D)
+ -- UPPER_CASE
+
+ S_Pretty_Maxlen : aliased constant S := "/LINE_LENGTH_MAX=#" &
+ "-M#";
+ -- /LINE_LENGTH_MAX=nnn
+ --
+ -- Set the maximum line length, nnn from 32 ..256. The default is 79.
+
+ S_Pretty_Maxind : aliased constant S := "/MAX_INDENT=#" &
+ "-T#";
+ -- /MAX_INDENT=nnn
+ --
+ -- Do not use an additional indentation level for case alternatives
+ -- and variants if their number is nnn or more. The default is 10.
+ -- If nnn is zero, an additional indentation level is used for any number
+ -- of case alternatives and variants.
+
+ S_Pretty_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
+ "DEFAULT " &
+ "-vP0 " &
+ "MEDIUM " &
+ "-vP1 " &
+ "HIGH " &
+ "-vP2";
+ -- /MESSAGES_PROJECT_FILE[=messages-option]
+ --
+ -- Specifies the "verbosity" of the parsing of project files.
+ -- messages-option may be one of the following:
+ --
+ -- DEFAULT (D) No messages are output if there is no error or warning.
+ --
+ -- MEDIUM A small number of messages are output.
+ --
+ -- HIGH A great number of messages are output, most of them not
+ -- being useful for the user.
+
+ S_Pretty_Names : aliased constant S := "/NAME_CASING=" &
+ "AS_DECLARED " &
+ "-nD " &
+ "LOWER_CASE " &
+ "-nL " &
+ "UPPER_CASE " &
+ "-nU " &
+ "MIXED_CASE " &
+ "-nM";
+ -- /NAME_CASING[=name-option]
+ --
+ -- Specify the casing of names.
+ -- 'name-option' may be one of:
+ --
+ -- AS_DECLARED (D) Name casing for defining occurrences are as they
+ -- appear in the source file.
+ --
+ -- LOWER_CASE Names are in lower case.
+ --
+ -- UPPER_CASE Names are in upper case.
+ --
+ -- MIXED_CASE Names are in mixed case.
+
+ S_Pretty_No_Labels : aliased constant S := "/NO_MISSED_LABELS " &
+ "-e";
+ -- /NO_MISSED_LABELS
+ --
+ -- Do not insert missing end/exit labels. The end label is the name of
+ -- a construct that may optionally appear at the end of the construct.
+ -- This includes the names of packages and subprograms.
+ -- Similarly, the exit label is the name of a loop that may appear as the
+ -- argument of an exit statement within the loop. By default, GNAT PRETTY
+ -- inserts these end/exit labels when they are absent in the original
+ -- source. This qualifier /NO_MISSED_LABELS suppresses this insertion,
+ -- so that the formatted source reflects the original.
+
+ S_Pretty_Output : aliased constant S := "/OUTPUT=@" &
+ "-o@";
+ -- /OUTPUT=file
+ --
+ -- Write the output to the specified file. If the file already exists,
+ -- an error is reported.
+
+ S_Pretty_Override : aliased constant S := "/OVERRIDING_REPLACE " &
+ "-rf";
+ -- /NOOVERRIDING_REPLACE (D)
+ -- /OVERRIDING_REPLACE
+ --
+ -- Replace the argument source with the pretty-printed source and copy the
+ -- argument source into filename.NPP, overriding any existing file if
+ -- needed.
+
+ S_Pretty_Pragma : aliased constant S := "/PRAGMA_CASING=" &
+ "MIXED_CASE " &
+ "-pM " &
+ "LOWER_CASE " &
+ "-pL " &
+ "UPPER_CASE " &
+ -- /PRAGMA_CASING[=pragma-option]
+ --
+ -- Set the case of pragma identifiers. The default is Mixed case.
+ -- pragma-option may be one of the following:
+ --
+ -- MIXED_CASE (D)
+ -- LOWER_CASE
+ -- UPPER_CASE
+ "-pU";
+ S_Pretty_Project : aliased constant S := "/PROJECT_FILE=<" &
+ "-P>";
+ -- /PROJECT_FILE=filename
+ --
+ -- Specifies the main project file to be used. The project files rooted
+ -- at the main project file will be parsed before any other processing to
+ -- set the building environment.
+
+ S_Pretty_Replace : aliased constant S := "/REPLACE " &
+ "-r";
+ -- /NOREPLACE (D)
+ -- /REPLACE
+ --
+ -- Replace the argument source with the pretty-printed source and copy the
+ -- argument source into filename.NPP. If filename.NPP already exists,
+ -- report an error and exit.
+
+ S_Pretty_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+ -- /SEARCH=(directory[,...])
+ --
+ -- When looking for source files also look in directories specified.
+
+ S_Pretty_Specific : aliased constant S := "/SPECIFIC_CASING " &
+ "-D-";
+ -- /SPECIFIC_CASING
+ --
+ -- Do not use the default dictionary file; instead, use the casing
+ -- defined by a qualifier /NAME_CASING and/or any explicit dictionary
+ -- file specified by a qualifier /DICTIONARY.
+
+ S_Pretty_Standard : aliased constant S := "/STANDARD_OUTPUT " &
+ "-pipe";
+ -- /NOSTANDARD_OUTPUT (D)
+ -- /STANDARD_OUTPUT
+ --
+ -- Redirect the output to the standard output.
+
+ S_Pretty_Verbose : aliased constant S := "/VERBOSE " &
+ "-v";
+ -- /NOVERBOSE (D)
+ -- /VERBOSE
+ --
+ -- Verbose mode; GNAT PRETTY generates version information and then a
+ -- trace of the actions it takes to produce or obtain the ASIS tree.
+
+ S_Pretty_Warnings : aliased constant S := "/WARNINGS " &
+ "-w";
+ -- /NOWARNINGS (D)
+ -- /WARNINGS
+ --
+ -- Issue a warning to the standard error stream if it is not possible
+ -- to provide the required layout in the result source.
+ -- By default such warnings are not activated.
+
+ Pretty_Switches : aliased constant Switches :=
+ (S_Pretty_Align 'Access,
+ S_Pretty_Attrib 'Access,
+ S_Pretty_Comments 'Access,
+ S_Pretty_Config 'Access,
+ S_Pretty_Constr 'Access,
+ S_Pretty_Comind 'Access,
+ S_Pretty_Ext 'Access,
+ S_Pretty_Current 'Access,
+ S_Pretty_Dico 'Access,
+ S_Pretty_Forced 'Access,
+ S_Pretty_Indent 'Access,
+ S_Pretty_Keyword 'Access,
+ S_Pretty_Maxlen 'Access,
+ S_Pretty_Maxind 'Access,
+ S_Pretty_Mess 'Access,
+ S_Pretty_Names 'Access,
+ S_Pretty_No_Labels 'Access,
+ S_Pretty_Output 'Access,
+ S_Pretty_Override 'Access,
+ S_Pretty_Pragma 'Access,
+ S_Pretty_Replace 'Access,
+ S_Pretty_Project 'Access,
+ S_Pretty_Search 'Access,
+ S_Pretty_Specific 'Access,
+ S_Pretty_Standard 'Access,
+ S_Pretty_Verbose 'Access,
+ S_Pretty_Warnings 'Access);
+
+ ------------------------------
+ -- Switches for GNAT SHARED --
+ ------------------------------
+
+ S_Shared_Debug : aliased constant S := "/DEBUG=" &
+ "ALL " &
+ "-g3 " &
+ "NONE " &
+ "-g0 " &
+ "TRACEBACK " &
+ "-g1 " &
+ "NOTRACEBACK " &
+ "-g0";
+ -- /DEBUG[=debug-option]
+ -- /NODEBUG
+ --
+ -- Specifies the amount of debugging information included. 'debug-option'
+ -- is one of the following:
+ --
+ -- ALL (D) Include full debugging information.
+ --
+ -- NONE Provide no debugging information. Same as /NODEBUG.
+ --
+ -- TRACEBACK Provide sufficient debug information for a traceback.
+ --
+ -- NOTRACEBACK Same as NONE.
+
+ S_Shared_Image : aliased constant S := "/IMAGE=@" &
+ "-o@";
+ -- /IMAGE=image-name
+ --
+ -- 'image-name' specifies the name for the generated shared library.
+
+ S_Shared_Ident : aliased constant S := "/IDENTIFICATION=" & '"' &
+ "--for-linker=IDENT=" &
+ '"';
+ -- /IDENTIFICATION="<string>"
+ --
+ -- "<string>" specifies the string to be stored in the image file ident-
+ -- ification field in the image header. It overrides any pragma Ident
+ -- specified string.
+
+ S_Shared_Nofiles : aliased constant S := "/NOSTART_FILES " &
+ "-nostartfiles";
+ -- /NOSTART_FILES
+ --
+ -- Link in default image initialization and startup functions.
+
+ S_Shared_Noinhib : aliased constant S := "/NOINHIBIT-IMAGE " &
+ "--for-linker=--noinhibit-exec";
+ -- /NOINHIBIT-IMAGE
+ --
+ -- Delete image if there are errors or warnings.
+
+ S_Shared_Verb : aliased constant S := "/VERBOSE " &
+ "-v";
+ -- /NOVERBOSE (D)
+ -- /VERBOSE
+ --
+ -- Causes additional information to be output, including a full list of
+ -- the included object files. This switch option is most useful when you
+ -- want to see what set of object files are being used in the link step.
+
+ S_Shared_ZZZZZ : aliased constant S := "/<other> " &
+ "--for-linker=";
+ -- /<other>
+ --
+ -- Any other switch transmitted to the underlying linker.
+
+ Shared_Switches : aliased constant Switches :=
+ (S_Shared_Debug 'Access,
+ S_Shared_Image 'Access,
+ S_Shared_Ident 'Access,
+ S_Shared_Nofiles 'Access,
+ S_Shared_Noinhib 'Access,
+ S_Shared_Verb 'Access,
+ S_Shared_ZZZZZ 'Access);
+
+ --------------------------------
+ -- Switches for GNAT STANDARD --
+ --------------------------------
+
+ Standard_Switches : aliased constant Switches := (1 .. 0 => null);
+
+ ----------------------------
+ -- Switches for GNAT STUB --
+ ----------------------------
+
+ S_Stub_Config : aliased constant S := "/CONFIGURATION_PRAGMAS_FILE=<" &
+ "-gnatec>";
+ -- /CONFIGURATION_PRAGMAS_FILE=filespec
+ --
+ -- Specifies a configuration pragmas file that must be taken into account
+ -- when compiling.
+
+ S_Stub_Current : aliased constant S := "/CURRENT_DIRECTORY " &
+ "!-I-";
+ -- /CURRENT_DIRECTORY (D)
+ -- /NOCURRENT_DIRECTORY
+ --
+ -- Look for source, library or object files in the default directory.
+
+ S_Stub_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
+ "-X" & '"';
+ -- /EXTERNAL_REFERENCE="name=val"
+ --
+ -- Specifies an external reference to the project manager. Useful only if
+ -- /PROJECT_FILE is used.
+ --
+ -- Example:
+ -- /EXTERNAL_REFERENCE="DEBUG=TRUE"
+
+ S_Stub_Full : aliased constant S := "/FULL " &
+ "-f";
+ -- /NOFULL (D)
+ -- /FULL
+ --
+ -- If the destination directory already contains a file with the name of
+ -- the body file for the argument file spec, replace it with the generated
+ -- body stub. If /FULL is not used and there is already a body file, this
+ -- existing body file is not replaced.
+
+ S_Stub_Header : aliased constant S := "/HEADER=" &
+ "GENERAL " &
+ "-hg " &
+ "SPEC " &
+ "-hs";
+ -- /HEADER[=header-option]
+ --
+ -- Specifies the form of the comment header above the generated body stub.
+ -- If no /HEADER qualifier is specified, there is no comment header.
+ -- header-option is one of the following:
+ --
+ --
+ -- GENERAL (D) Put a sample comment header into the body stub.
+ --
+ -- SPEC Put the comment header (i.e., all the comments
+ -- preceding the compilation unit) from the source of the
+ -- library unit declaration into the body stub.
+
+ S_Stub_Indent : aliased constant S := "/INDENTATION=#" &
+ "-i#";
+ -- /INDENTATION=nnn
+ --
+ -- (nnn is a non-negative integer). Set the indentation level in the
+ -- generated body stub to nnn. nnn=0 means "no indentation".
+ -- Default insdentation is 3.
+
+ S_Stub_Keep : aliased constant S := "/KEEP " &
+ "-k";
+ -- /NOKEEP (D)
+ -- /KEEP
+ --
+ -- Do not delete the tree file (i.e., the snapshot of the compiler
+ -- internal structures used by gnatstub) after creating the body stub.
+
+ S_Stub_Length : aliased constant S := "/LINE_LENGTH=#" &
+ "-l#";
+ -- /LINE_LENGTH=nnn
+ --
+ -- (n is a non-negative integer). Set the maximum line length in the body
+ -- stub to nnn. Default is 78.
+
+ S_Stub_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
+ "DEFAULT " &
+ "-vP0 " &
+ "MEDIUM " &
+ "-vP1 " &
+ "HIGH " &
+ "-vP2";
+ -- /MESSAGES_PROJECT_FILE[=messages-option]
+ --
+ -- Specifies the "verbosity" of the parsing of project files.
+ -- messages-option may be one of the following:
+ --
+ -- DEFAULT (D) No messages are output if there is no error or warning.
+ --
+ -- MEDIUM A small number of messages are output.
+ --
+ -- HIGH A great number of messages are output, most of them not
+ -- being useful for the user.
+
+ S_Stub_Output : aliased constant S := "/OUTPUT=@" &
+ "-o@";
+ -- /OUTPUT=filespec
+ --
+ -- Body file name. This should be set if the argument file name does not
+ -- follow the GNAT file naming conventions. If this switch is omitted,
+ -- the default name for the body will be obtained from the argument file
+ -- name according to the GNAT file naming conventions.
+
+ S_Stub_Project : aliased constant S := "/PROJECT_FILE=<" &
+ "-P>";
+ -- /PROJECT_FILE=filename
+ --
+ -- Specifies the main project file to be used. The project files rooted
+ -- at the main project file will be parsed before any other processing.
+ -- The source and object directories to be searched will be communicated
+ -- to gnatstub through logical names ADA_PRJ_INCLUDE_FILE and
+ -- ADA_PRJ_OBJECTS_FILE.
+
+ S_Stub_Quiet : aliased constant S := "/QUIET " &
+ "-q";
+ -- /NOQUIET (D)
+ -- /QUIET
+ --
+ -- Quiet mode: do not generate a confirmation when a body is successfully
+ -- created, and do not generate a message when a body is not required for
+ -- an argument unit.
+
+ S_Stub_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+ -- /SEARCH=(directory[,...])
+ --
+ -- When looking for source files also look in directories specified.
+
+ S_Stub_Tree : aliased constant S := "/TREE_FILE=" &
+ "OVERWRITE " &
+ "-t " &
+ "SAVE " &
+ "-k " &
+ "REUSE " &
+ "-r";
+ -- /TREE_FILE[=treefile-option]
+ --
+ -- Specify what to do with the tree file.
+ -- treefile-option is one of the following:
+ --
+ -- OVERWRITE (D) Overwrite the existing tree file. If the current
+ -- directory already contains the file which, according
+ -- to the GNAT file naming rules should be considered
+ -- as a tree file for the argument source file,
+ -- gnatstub will refuse to create the tree file needed
+ -- to create a sample body unless this option is chosen.
+ --
+ -- SAVE Do not remove the tree file (i.e., the snapshot
+ -- of the compiler internal structures used by gnatstub)
+ -- after creating the body stub.
+ --
+ -- REUSE Reuse the tree file (if it exists) instead of
+ -- creating it.
+ -- Instead of creating the tree file for the library
+ -- unit declaration, gnatstub tries to find it in the
+ -- current directory and use it for creating a body.
+ -- If the tree file is not found, no body is created.
+ -- This option also implies `SAVE', whether or not the
+ -- latter is set explicitly.
+
+ S_Stub_Verbose : aliased constant S := "/VERBOSE " &
+ "-v";
+ -- /NOVERBOSE (D)
+ -- /VERBOSE
+ --
+ -- Verbose mode: generate version information.
+
+ Stub_Switches : aliased constant Switches :=
+ (S_Stub_Config 'Access,
+ S_Stub_Current 'Access,
+ S_Stub_Ext 'Access,
+ S_Stub_Full 'Access,
+ S_Stub_Header 'Access,
+ S_Stub_Indent 'Access,
+ S_Stub_Keep 'Access,
+ S_Stub_Length 'Access,
+ S_Stub_Mess 'Access,
+ S_Stub_Output 'Access,
+ S_Stub_Project 'Access,
+ S_Stub_Quiet 'Access,
+ S_Stub_Search 'Access,
+ S_Stub_Tree 'Access,
+ S_Stub_Verbose 'Access);
+
+ ----------------------------
+ -- Switches for GNAT XREF --
+ ----------------------------
+
+ S_Xref_All : aliased constant S := "/ALL_FILES " &
+ "-a";
+ -- /NOALL_FILES (D)
+ -- /ALL_FILES
+ --
+ -- If this switch is present, FIND and XREF will parse the read-only
+ -- files found in the library search path. Otherwise, these files will
+ -- be ignored. This option can be used to protect Gnat sources or your
+ -- own libraries from being parsed, thus making FIND and XREF much
+ -- faster, and their output much smaller.
+
+ S_Xref_Deriv : aliased constant S := "/DERIVED_TYPES " &
+ "-d";
+ -- /NODERIVED_TYPES (D)
+ -- /DERIVED_TYPES
+ --
+ -- Output the parent type reference for each matching derived types.
+
+ S_Xref_Ext : aliased constant S := "/EXTERNAL_REFERENCE=" & '"' &
+ "-X" & '"';
+ -- /EXTERNAL_REFERENCE="name=val"
+ --
+ -- Specifies an external reference to the project manager. Useful only if
+ -- /PROJECT_FILE is used.
+ --
+ -- Example:
+ -- /EXTERNAL_REFERENCE="DEBUG=TRUE"
+
+ S_Xref_Full : aliased constant S := "/FULL_PATHNAME " &
+ "-f";
+ -- /NOFULL_PATHNAME (D)
+ -- /FULL_PATHNAME
+ --
+ -- If this switch is set, the output file names will be preceded by their
+ -- directory (if the file was found in the search path). If this switch
+ -- is not set, the directory will not be printed.
+
+ S_Xref_Global : aliased constant S := "/IGNORE_LOCALS " &
+ "-g";
+ -- /NOIGNORE_LOCALS (D)
+ -- /IGNORE_LOCALS
+ --
+ -- If this switch is set, information is output only for library-level
+ -- entities, ignoring local entities. The use of this switch may
+ -- accelerate FIND and XREF.
+
+ S_Xref_Mess : aliased constant S := "/MESSAGES_PROJECT_FILE=" &
+ "DEFAULT " &
+ "-vP0 " &
+ "MEDIUM " &
+ "-vP1 " &
+ "HIGH " &
+ "-vP2";
+ -- /MESSAGES_PROJECT_FILE[=messages-option]
+ --
+ -- Specifies the "verbosity" of the parsing of project files.
+ -- messages-option may be one of the following:
+ --
+ -- DEFAULT (D) No messages are output if there is no error or warning.
+ --
+ -- MEDIUM A small number of messages are output.
+ --
+ -- HIGH A great number of messages are output, most of them not
+ -- being useful for the user.
+
+ S_Xref_Nostinc : aliased constant S := "/NOSTD_INCLUDES " &
+ "-nostdinc";
+ -- /NOSTD_INCLUDES
+ --
+ -- Do not look for sources in the system default directory.
+
+ S_Xref_Nostlib : aliased constant S := "/NOSTD_LIBRARIES " &
+ "-nostdlib";
+ -- /NOSTD_LIBRARIES
+ --
+ -- Do not look for library files in the system default directory.
+
+ S_Xref_Object : aliased constant S := "/OBJECT_SEARCH=*" &
+ "-aO*";
+ -- /OBJECT_SEARCH=(directory,...)
+ --
+ -- When searching for library and object files, look in the specified
+ -- directories. The order in which library files are searched is the same
+ -- as for MAKE.
+
+ S_Xref_Project : aliased constant S := "/PROJECT=@" &
+ "-p@";
+ -- /PROJECT=file
+ --
+ -- Specify a project file to use. By default, FIND and XREF will try to
+ -- locate a project file in the current directory.
+ --
+ -- If a project file is either specified or found by the tools, then the
+ -- content of the source directory and object directory lines are added
+ -- as if they had been specified respectively by /SOURCE_SEARCH and
+ -- /OBJECT_SEARCH.
+
+ S_Xref_Prj : aliased constant S := "/PROJECT_FILE=<" &
+ "-P>";
+ -- /PROJECT_FILE=filename
+ --
+ -- Specifies the main project file to be used. The project files rooted
+ -- at the main project file will be parsed before doing any processing.
+ -- The source and object directories to be searched will be communicated
+ -- to gnatxref through logical names ADA_PRJ_INCLUDE_FILE and
+ -- ADA_PRJ_OBJECTS_FILE.
+
+ S_Xref_Search : aliased constant S := "/SEARCH=*" &
+ "-I*";
+ -- /SEARCH=(directory,...)
+ --
+ -- Equivalent to:
+ -- /OBJECT_SEARCH=(directory,...) /SOURCE_SEARCH=(directory,...)
+
+ S_Xref_Source : aliased constant S := "/SOURCE_SEARCH=*" &
+ "-aI*";
+ -- /SOURCE_SEARCH=(directory,...)
+ --
+ -- When looking for source files also look in the specified directories.
+ -- The order in which source file search is undertaken is the same as for
+ -- MAKE.
+
+ S_Xref_Output : aliased constant S := "/UNUSED " &
+ "-u";
+ -- /SOURCE_SEARCH=(directory,...)
+ --
+ -- When looking for source files also look in the specified directories.
+ -- The order in which source file search is undertaken is the same as for
+ -- MAKE.
+
+ S_Xref_Tags : aliased constant S := "/TAGS " &
+ "-v";
+ -- /NOTAGS (D)
+ -- /TAGS
+ --
+ -- Print a 'tags' file for vi.
+
+ Xref_Switches : aliased constant Switches :=
+ (S_Xref_All 'Access,
+ S_Xref_Deriv 'Access,
+ S_Xref_Ext 'Access,
+ S_Xref_Full 'Access,
+ S_Xref_Global 'Access,
+ S_Xref_Mess 'Access,
+ S_Xref_Nostinc 'Access,
+ S_Xref_Nostlib 'Access,
+ S_Xref_Object 'Access,
+ S_Xref_Project 'Access,
+ S_Xref_Prj 'Access,
+ S_Xref_Search 'Access,
+ S_Xref_Source 'Access,
+ S_Xref_Output 'Access,
+ S_Xref_Tags 'Access);
+
+end VMS_Data;
diff --git a/gcc/ada/vxaddr2line.adb b/gcc/ada/vxaddr2line.adb
new file mode 100644
index 00000000000..f8dc2717458
--- /dev/null
+++ b/gcc/ada/vxaddr2line.adb
@@ -0,0 +1,456 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- V X A D D R 2 L I N E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2002, 2003 Ada Core Technologies, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
+-- MA 02111-1307, USA. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This program is meant to be used with vxworks to compute symbolic
+-- backtraces on the host from non-symbolic backtraces obtained on the target.
+--
+-- The basic idea is to automate the computation of the necessary address
+-- adjustments prior to calling addr2line when the application has only been
+-- partially linked on the host.
+--
+-- Variants for various targets are supported, and the command line should
+-- be like :
+--
+-- <target>-addr2line [-a <target_arch>] <exe_file> <ref_address>
+-- <backtrace addresses>
+--
+-- Where:
+-- <target_arch> :
+-- selects the target architecture. In the absence of this parameter the
+-- default variant is chosen based on the Detect_Arch result. Generally,
+-- this parameter will only be used if vxaddr2line is recompiled manually.
+-- Otherwise, the command name will always be of the form
+-- <target>-vxaddr2line where there is no ambiguity on the target's
+-- architecture.
+--
+-- <exe_file> :
+-- The name of the partially linked binary file for the application.
+--
+-- <ref_address> :
+-- Runtime address (on the target) of a reference symbol you choose,
+-- which name shall match the value of the Ref_Symbol variable declared
+-- below. A symbol with a small offset from the beginning of the text
+-- segment is better, so "adainit" is a good choice.
+--
+-- <backtrace addresses> :
+-- The call chain addresses you obtained at run time on the target and
+-- for which you want a symbolic association.
+--
+-- TO ADD A NEW ARCHITECTURE add an appropriate value to Architecture type
+-- (in a format <host>_<target>), and then an appropriate value to Config_List
+-- array
+
+with Text_IO; use Text_IO;
+with Ada.Integer_Text_IO; use Ada.Integer_Text_IO;
+with Ada.Command_Line; use Ada.Command_Line;
+with Ada.Strings.Fixed; use Ada.Strings.Fixed;
+
+with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.Expect; use GNAT.Expect;
+with GNAT.Regpat; use GNAT.Regpat;
+
+procedure VxAddr2Line is
+
+ Ref_Symbol : String := "adainit";
+ -- This is the name of the reference symbol which runtime address shall
+ -- be provided as the <ref_address> argument.
+
+ -- All supported architectures
+ type Architecture is
+ (WINDOWS_POWERPC,
+ WINDOWS_M68K,
+ SOLARIS_POWERPC,
+ DEC_ALPHA);
+
+ type Arch_Record is record
+ Addr2line_Binary : String_Access;
+ -- Name of the addr2line utility to use.
+
+ Nm_Binary : String_Access;
+ -- Name of the host nm utility, which will be used to find out the
+ -- offset of the reference symbol in the text segment of the partially
+ -- linked executable.
+
+ Addr_Digits_To_Skip : Integer;
+ -- When addresses such as 0xfffffc0001dfed50 are provided, for instance
+ -- on ALPHA, indicate the number of leading digits that can be ignored,
+ -- which will avoid computational overflows. Typically only useful when
+ -- 64bit addresses are provided.
+
+ Bt_Offset_From_Call : Integer;
+ -- Offset from a backtrace address to the address of the corresponding
+ -- call instruction. This should always be 0, except on platforms where
+ -- the backtrace addresses actually correspond to return and not call
+ -- points. In such cases, a negative value is most likely.
+ end record;
+
+ -- Configuration for each of the architectures
+ Arch_List : array (Architecture'Range) of Arch_Record :=
+ (WINDOWS_POWERPC =>
+ (Addr2line_Binary => null,
+ Nm_Binary => null,
+ Addr_Digits_To_Skip => 0,
+ Bt_Offset_From_Call => -4),
+ WINDOWS_M68K =>
+ (Addr2line_Binary => null,
+ Nm_Binary => null,
+ Addr_Digits_To_Skip => 0,
+ Bt_Offset_From_Call => -4),
+ SOLARIS_POWERPC =>
+ (Addr2line_Binary => null,
+ Nm_Binary => null,
+ Addr_Digits_To_Skip => 0,
+ Bt_Offset_From_Call => 0),
+ DEC_ALPHA =>
+ (Addr2line_Binary => null,
+ Nm_Binary => null,
+ Addr_Digits_To_Skip => 8,
+ Bt_Offset_From_Call => 0)
+ );
+
+ -- Current architecture
+ Cur_Arch : Architecture;
+
+ -- State of architecture detection
+ Detect_Success : Boolean := False;
+
+ -----------------------
+ -- Local subprograms --
+ -----------------------
+
+ procedure Error (Msg : String);
+ pragma No_Return (Error);
+ -- Prints the message and then terminates the program
+
+ procedure Usage;
+ -- Displays the short help message and then terminates the program
+
+ function Get_Reference_Offset return Integer;
+ -- Computes the static offset of the reference symbol by calling nm
+
+ function Get_Value_From_Hex_Arg (Arg : Natural) return Integer;
+ -- Threats the argument number Arg as a C-style hexadecimal literal
+ -- and returns its integer value
+
+ function Hex_Image (Value : Integer) return String_Access;
+ -- Returns access to a string that contains hexadecimal image of Value
+
+ -- Separate functions that provide build-time customization:
+
+ procedure Detect_Arch;
+ -- Saves in Cur_Arch the current architecture, based on the name of
+ -- vxaddr2line instance and properties of the host. Detect_Success is False
+ -- if detection fails
+
+ -----------------
+ -- Detect_Arch --
+ -----------------
+
+ procedure Detect_Arch is
+ Name : String := Base_Name (Command_Name);
+ Proc : String := Name (Name'First .. Index (Name, "-") - 1);
+ Target : String := Name (Name'First .. Index (Name, "vxaddr2line") - 1);
+
+ begin
+ Detect_Success := False;
+
+ if Proc = "" then
+ return;
+ end if;
+
+ if Proc = "alpha" then
+ Cur_Arch := DEC_ALPHA;
+ else
+ -- Let's detect the host.
+ -- ??? A naive implementation that can't distinguish between Unixes
+ if Directory_Separator = '/' then
+ Cur_Arch := Architecture'Value ("solaris_" & Proc);
+ else
+ Cur_Arch := Architecture'Value ("windows_" & Proc);
+ end if;
+ end if;
+
+ if Arch_List (Cur_Arch).Addr2line_Binary = null then
+ Arch_List (Cur_Arch).Addr2line_Binary := new String'
+ (Target & "addr2line");
+ end if;
+ if Arch_List (Cur_Arch).Nm_Binary = null then
+ Arch_List (Cur_Arch).Nm_Binary := new String'
+ (Target & "nm");
+ end if;
+
+ Detect_Success := True;
+
+ exception
+ when others =>
+ return;
+ end Detect_Arch;
+
+
+ -----------
+ -- Error --
+ -----------
+
+ procedure Error (Msg : String) is
+ begin
+ Put_Line (Msg);
+ OS_Exit (1);
+ raise Program_Error;
+ end Error;
+
+
+ --------------------------
+ -- Get_Reference_Offset --
+ --------------------------
+
+ function Get_Reference_Offset return Integer is
+ Nm_Cmd : constant String_Access :=
+ Locate_Exec_On_Path (Arch_List (Cur_Arch).Nm_Binary.all);
+
+ Nm_Args : Argument_List :=
+ (new String'("-P"),
+ new String'(Argument (1)));
+
+ Forever : aliased String := "^@@@@";
+ Reference : aliased String := Ref_Symbol & "\s+\S\s+([\da-fA-F]+)";
+
+ Pd : Process_Descriptor;
+ Result : Expect_Match;
+
+ begin
+ -- If Nm is not found, abort
+
+ if Nm_Cmd = null then
+ Error ("Couldn't find " & Arch_List (Cur_Arch).Nm_Binary.all);
+ end if;
+
+ Non_Blocking_Spawn
+ (Pd, Nm_Cmd.all, Nm_Args, Buffer_Size => 0, Err_To_Out => True);
+
+ -- Expect a string containing the reference symbol
+
+ Expect (Pd, Result,
+ Regexp_Array'(1 => Reference'Unchecked_Access),
+ Timeout => -1);
+
+ -- If we are here, the pattern was matched successfully
+
+ declare
+ Match_String : String := Expect_Out_Match (Pd);
+ Matches : Match_Array (0 .. 1);
+ Value : Integer;
+
+ begin
+ Match (Reference, Match_String, Matches);
+ Value := Integer'Value
+ ("16#"
+ & Match_String (Matches (1).First .. Matches (1).Last) & "#");
+
+ -- Expect a string that will never be emitted, so that the
+ -- process can be correctly terminated (with Process_Died)
+
+ Expect (Pd, Result,
+ Regexp_Array'(1 => Forever'Unchecked_Access),
+ Timeout => -1);
+
+ exception
+ when Process_Died =>
+ return Value;
+ end;
+
+ -- We can not get here
+
+ raise Program_Error;
+
+ exception
+ when Invalid_Process =>
+ Error ("Could not spawn a process " & Nm_Cmd.all);
+
+ when others =>
+
+ -- The process died without matching the reference symbol or the
+ -- format wasn't recognized.
+
+ Error ("Unexpected output from " & Nm_Cmd.all);
+ end Get_Reference_Offset;
+
+ ----------------------------
+ -- Get_Value_From_Hex_Arg --
+ ----------------------------
+
+ function Get_Value_From_Hex_Arg (Arg : Natural) return Integer is
+ Offset : Natural;
+ Cur_Arg : String := Argument (Arg);
+
+ begin
+ -- Skip "0x" prefix if present
+
+ if Cur_Arg'Length > 2 and then Cur_Arg (1 .. 2) = "0x" then
+ Offset := 3;
+ else
+ Offset := 1;
+ end if;
+
+ -- Add architecture-specific offset
+
+ Offset := Offset + Arch_List (Cur_Arch).Addr_Digits_To_Skip;
+
+ -- Convert to value
+
+ return Integer'Value ("16#" & Cur_Arg (Offset .. Cur_Arg'Last) & "#");
+ end Get_Value_From_Hex_Arg;
+
+ ---------------
+ -- Hex_Image --
+ ---------------
+
+ function Hex_Image (Value : Integer) return String_Access is
+ Result : String (1 .. 20);
+ Start_Pos : Natural;
+
+ begin
+ Put (Result, Value, 16);
+ Start_Pos := Index (Result, "16#") + 3;
+ return new String'(Result (Start_Pos .. Result'Last - 1));
+ end Hex_Image;
+
+ -----------
+ -- Usage --
+ -----------
+
+ procedure Usage is
+ begin
+ Put_Line ("Usage : " & Base_Name (Command_Name)
+ & " <executable> <"
+ & Ref_Symbol & " offset on target> <addr1> ...");
+
+ OS_Exit (1);
+ end Usage;
+
+ Ref_Static_Offset, Ref_Runtime_Address, Bt_Address : Integer;
+
+ Addr2line_Cmd : String_Access;
+
+ Addr2line_Args : Argument_List (1 .. 501);
+ -- We expect that there won't be more than 500 backtrace frames
+
+ Addr2line_Args_Count : Natural;
+
+ Success : Boolean;
+
+-- Start of processing for VxAddr2Line
+
+begin
+
+ Detect_Arch;
+
+ -- There should be at least two arguments
+
+ if Argument_Count < 2 then
+ Usage;
+ end if;
+
+ -- ??? HARD LIMIT! There should be at most 501 arguments
+
+ if Argument_Count > 501 then
+ Error ("Too many backtrace frames");
+ end if;
+
+ -- Do we have a valid architecture?
+
+ if not Detect_Success then
+ Put_Line ("Couldn't detect the architecture");
+ return;
+ end if;
+
+ Addr2line_Cmd :=
+ Locate_Exec_On_Path (Arch_List (Cur_Arch).Addr2line_Binary.all);
+
+ -- If Addr2line is not found, abort
+
+ if Addr2line_Cmd = null then
+ Error ("Couldn't find " & Arch_List (Cur_Arch).Addr2line_Binary.all);
+ end if;
+
+ -- The first argument specifies the image file. Check if it exists.
+
+ if not Is_Regular_File (Argument (1)) then
+ Error ("Couldn't find the executable " & Argument (1));
+ end if;
+
+ -- The second argument specifies the reference symbol runtime address.
+ -- Let's parse and store it
+
+ Ref_Runtime_Address := Get_Value_From_Hex_Arg (2);
+
+ -- Run nm command to get the reference symbol static offset
+
+ Ref_Static_Offset := Get_Reference_Offset;
+
+ -- Build addr2line parameters. First, the standard part
+
+ Addr2line_Args (1) := new String'("--exe=" & Argument (1));
+ Addr2line_Args_Count := 1;
+
+ -- Now, append to this the adjusted backtraces in arguments 4 and further
+
+ for J in 3 .. Argument_Count loop
+
+ -- Basically, for each address in the runtime backtrace ...
+
+ -- o We compute its offset relatively to the runtime address of the
+ -- reference symbol,
+
+ -- and then ...
+
+ -- o We add this offset to the static one for the reference symbol in
+ -- the executable to find the executable offset corresponding to the
+ -- backtrace address.
+
+ Bt_Address := Get_Value_From_Hex_Arg (J);
+
+ Bt_Address :=
+ Bt_Address - Ref_Runtime_Address
+ + Ref_Static_Offset
+ + Arch_List (Cur_Arch).Bt_Offset_From_Call;
+
+ Addr2line_Args_Count := Addr2line_Args_Count + 1;
+ Addr2line_Args (Addr2line_Args_Count) := Hex_Image (Bt_Address);
+ end loop;
+
+ -- Run the resulting command
+
+ Spawn (Addr2line_Cmd.all,
+ Addr2line_Args (1 .. Addr2line_Args_Count), Success);
+
+exception
+ when others =>
+
+ -- Mask all exceptions
+
+ return;
+end VxAddr2Line;
diff --git a/gcc/ada/widechar.adb b/gcc/ada/widechar.adb
index f0d5771486d..89514359e53 100644
--- a/gcc/ada/widechar.adb
+++ b/gcc/ada/widechar.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -153,6 +153,7 @@ package body Widechar is
function WC_Skip is new Char_Sequence_To_Wide_Char (Skip_Char);
Discard : Wide_Character;
+ pragma Warnings (Off, Discard);
begin
Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method);
diff --git a/gcc/ada/xeinfo.adb b/gcc/ada/xeinfo.adb
index e3137211c67..272112d77b4 100644
--- a/gcc/ada/xeinfo.adb
+++ b/gcc/ada/xeinfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -86,6 +86,9 @@ procedure XEinfo is
Rtn : VString := Nul;
Term : VString := Nul;
+ InB : File_Type;
+ -- Used to read initial header from body
+
InF : File_Type;
-- Used to read full text of both spec and body
@@ -243,12 +246,10 @@ begin
Create (Ofile, Out_File, "a-einfo.h");
end if;
+ Open (InB, In_File, "einfo.adb");
Open (InF, In_File, "einfo.ads");
Lineno := 0;
-
- -- Write header to output file
-
loop
Line := Get_Line (InF);
Lineno := Lineno + 1;
@@ -257,7 +258,6 @@ begin
Match (Line,
"-- S p e c ",
"-- C Header File ");
-
Match (Line, "--", "/*");
Match (Line, Rtab (2) * A & "--", M);
Replace (M, A & "*/");
@@ -377,7 +377,7 @@ begin
while Match (Line, Get_FN) loop
- -- Non-inlined function
+ -- Non-inlined funcion
if not Present (Inlined, FN) then
Put_Line (Ofile, "");
@@ -404,6 +404,7 @@ begin
-- Read body to find inlined functions
+ Close (InB);
Close (InF);
Open (InF, In_File, "einfo.adb");
Lineno := 0;
diff --git a/gcc/ada/xnmake.adb b/gcc/ada/xnmake.adb
index 32600baa2f6..fc26a0bfd67 100644
--- a/gcc/ada/xnmake.adb
+++ b/gcc/ada/xnmake.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -91,9 +91,6 @@ procedure XNmake is
wsp : Pattern := Span (' ' & ASCII.HT);
- -- Note: in following patterns, we break up the word revision to
- -- avoid RCS getting enthusiastic about updating the reference!
-
Body_Only : Pattern := BreakX (' ') * X & Span (' ') & "-- body only";
Spec_Only : Pattern := BreakX (' ') * X & Span (' ') & "-- spec only";
@@ -194,8 +191,6 @@ procedure XNmake is
-- Start of processing for XNmake
begin
- -- Capture our revision (following line updated by RCS)
-
Lineno := 0;
NWidth := 28;
Anchored_Mode := True;
diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb
index 93be4f86900..8e332ec6276 100644
--- a/gcc/ada/xr_tabls.adb
+++ b/gcc/ada/xr_tabls.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-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- --
@@ -19,105 +19,284 @@
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+with Types; use Types;
with Osint;
-with Unchecked_Deallocation;
+with Hostparm;
-with Ada.IO_Exceptions;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
with Ada.Strings.Fixed;
with Ada.Strings;
with Ada.Text_IO;
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-with GNAT.IO_Aux;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.HTable; use GNAT.HTable;
+with GNAT.Heap_Sort_G;
package body Xr_Tabls is
- function Base_File_Name (File : String) return String;
- -- Return the base file name for File (ie not including the directory)
+ type HTable_Headers is range 1 .. 10000;
+
+ procedure Set_Next (E : File_Reference; Next : File_Reference);
+ function Next (E : File_Reference) return File_Reference;
+ function Get_Key (E : File_Reference) return Cst_String_Access;
+ function Hash (F : Cst_String_Access) return HTable_Headers;
+ function Equal (F1, F2 : Cst_String_Access) return Boolean;
+ -- The five subprograms above are used to instanciate the static
+ -- htable to store the files that should be processed.
+
+ package File_HTable is new GNAT.HTable.Static_HTable
+ (Header_Num => HTable_Headers,
+ Element => File_Record,
+ Elmt_Ptr => File_Reference,
+ Null_Ptr => null,
+ Set_Next => Set_Next,
+ Next => Next,
+ Key => Cst_String_Access,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => Equal);
+ -- A hash table to store all the files referenced in the
+ -- application. The keys in this htable are the name of the files
+ -- themselves, therefore it is assumed that the source path
+ -- doesn't contain twice the same source or ALI file name
+
+ type Unvisited_Files_Record;
+ type Unvisited_Files_Access is access Unvisited_Files_Record;
+ type Unvisited_Files_Record is record
+ File : File_Reference;
+ Next : Unvisited_Files_Access;
+ end record;
+ -- A special list, in addition to File_HTable, that only stores
+ -- the files that haven't been visited so far. Note that the File
+ -- list points to some data in File_HTable, and thus should never be freed.
+
+ function Next (E : Declaration_Reference) return Declaration_Reference;
+ procedure Set_Next (E, Next : Declaration_Reference);
+ function Get_Key (E : Declaration_Reference) return Cst_String_Access;
+ -- The subprograms above are used to instanciate the static
+ -- htable to store the entities that have been found in the application
+
+ package Entities_HTable is new GNAT.HTable.Static_HTable
+ (Header_Num => HTable_Headers,
+ Element => Declaration_Record,
+ Elmt_Ptr => Declaration_Reference,
+ Null_Ptr => null,
+ Set_Next => Set_Next,
+ Next => Next,
+ Key => Cst_String_Access,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => Equal);
+ -- A hash table to store all the entities defined in the
+ -- application. For each entity, we store a list of its reference
+ -- locations as well.
+ -- The keys in this htable should be created with Key_From_Ref,
+ -- and are the file, line and column of the declaration, which are
+ -- unique for every entity.
+
+ Entities_Count : Natural := 0;
+ -- Number of entities in Entities_HTable. This is used in the end
+ -- when sorting the table.
+
+ Longest_File_Name_In_Table : Natural := 0;
+ Unvisited_Files : Unvisited_Files_Access := null;
+ Directories : Project_File_Ptr;
+ Default_Match : Boolean := False;
+ -- The above need commenting ???
+
+ function Parse_Gnatls_Src return String;
+ -- Return the standard source directories (taking into account the
+ -- ADA_INCLUDE_PATH environment variable, if Osint.Add_Default_Search_Dirs
+ -- was called first).
+
+ function Parse_Gnatls_Obj return String;
+ -- Return the standard object directories (taking into account the
+ -- ADA_OBJECTS_PATH environment variable).
+
+ function Key_From_Ref
+ (File_Ref : File_Reference;
+ Line : Natural;
+ Column : Natural)
+ return String;
+ -- Return a key for the symbol declared at File_Ref, Line,
+ -- Column. This key should be used for lookup in Entity_HTable
+
+ function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean;
+ -- Compare two declarations. The comparison is case-insensitive.
+
+ function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean;
+ -- Compare two references
+
+ procedure Store_References
+ (Decl : Declaration_Reference;
+ Get_Writes : Boolean := False;
+ Get_Reads : Boolean := False;
+ Get_Bodies : Boolean := False;
+ Get_Declaration : Boolean := False;
+ Arr : in out Reference_Array;
+ Index : in out Natural);
+ -- Store in Arr, starting at Index, all the references to Decl.
+ -- The Get_* parameters can be used to indicate which references should be
+ -- stored.
+ -- Constraint_Error will be raised if Arr is not big enough.
+
+ procedure Sort (Arr : in out Reference_Array);
+ -- Sort an array of references.
+ -- Arr'First must be 1.
+
+ --------------
+ -- Set_Next --
+ --------------
+
+ procedure Set_Next (E : File_Reference; Next : File_Reference) is
+ begin
+ E.Next := Next;
+ end Set_Next;
+
+ procedure Set_Next
+ (E : Declaration_Reference; Next : Declaration_Reference) is
+ begin
+ E.Next := Next;
+ end Set_Next;
+
+ -------------
+ -- Get_Key --
+ -------------
+
+ function Get_Key (E : File_Reference) return Cst_String_Access is
+ begin
+ return E.File;
+ end Get_Key;
- function Dir_Name (File : String; Base : String := "") return String;
- -- Return the directory name of File, or "" if there is no directory part
- -- in File.
- -- This includes the last separator at the end, and always return an
- -- absolute path name (directories are relative to Base, or the current
- -- directory if Base is "")
+ function Get_Key (E : Declaration_Reference) return Cst_String_Access is
+ begin
+ return E.Key;
+ end Get_Key;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : Cst_String_Access) return HTable_Headers is
+ function H is new GNAT.HTable.Hash (HTable_Headers);
+
+ begin
+ return H (F.all);
+ end Hash;
- Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator;
+ -----------
+ -- Equal --
+ -----------
- Files : File_Table;
- Entities : Entity_Table;
- Directories : Project_File_Ptr;
- Default_Match : Boolean := False;
+ function Equal (F1, F2 : Cst_String_Access) return Boolean is
+ begin
+ return F1.all = F2.all;
+ end Equal;
+
+ ------------------
+ -- Key_From_Ref --
+ ------------------
+
+ function Key_From_Ref
+ (File_Ref : File_Reference;
+ Line : Natural;
+ Column : Natural)
+ return String
+ is
+ begin
+ return File_Ref.File.all & Natural'Image (Line) & Natural'Image (Column);
+ end Key_From_Ref;
---------------------
-- Add_Declaration --
---------------------
function Add_Declaration
- (File_Ref : File_Reference;
- Symbol : String;
- Line : Natural;
- Column : Natural;
- Decl_Type : Character)
- return Declaration_Reference
+ (File_Ref : File_Reference;
+ Symbol : String;
+ Line : Natural;
+ Column : Natural;
+ Decl_Type : Character;
+ Remove_Only : Boolean := False;
+ Symbol_Match : Boolean := True)
+ return Declaration_Reference
is
- The_Entities : Declaration_Reference := Entities.Table;
- New_Decl : Declaration_Reference;
- Result : Compare_Result;
- Prev : Declaration_Reference := null;
+ procedure Unchecked_Free is new Ada.Unchecked_Deallocation
+ (Declaration_Record, Declaration_Reference);
- begin
- -- Check if the identifier already exists in the table
+ Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column);
- while The_Entities /= null loop
- Result := Compare (The_Entities, File_Ref, Line, Column, Symbol);
- exit when Result = GreaterThan;
+ New_Decl : Declaration_Reference :=
+ Entities_HTable.Get (Key'Unchecked_Access);
- if Result = Equal then
- return The_Entities;
- end if;
+ Is_Parameter : Boolean := False;
- Prev := The_Entities;
- The_Entities := The_Entities.Next;
- end loop;
-
- -- Insert the Declaration in the table
-
- New_Decl :=
- new Declaration_Record'
- (Symbol_Length => Symbol'Length,
- Symbol => Symbol,
- Decl => (File => File_Ref,
- Line => Line,
- Column => Column,
- Source_Line => Null_Unbounded_String,
- Next => null),
- Decl_Type => Decl_Type,
- Body_Ref => null,
- Ref_Ref => null,
- Modif_Ref => null,
- Match => Default_Match
- or else Match (File_Ref, Line, Column),
- Par_Symbol => null,
- Next => null);
-
- if Prev = null then
- New_Decl.Next := Entities.Table;
- Entities.Table := New_Decl;
- else
- New_Decl.Next := Prev.Next;
- Prev.Next := New_Decl;
+ begin
+ -- Insert the Declaration in the table. There might already be a
+ -- declaration in the table if the entity is a parameter, so we
+ -- need to check that first.
+
+ if New_Decl /= null and then New_Decl.Symbol_Length = 0 then
+ Is_Parameter := New_Decl.Is_Parameter;
+ Entities_HTable.Remove (Key'Unrestricted_Access);
+ Entities_Count := Entities_Count - 1;
+ Free (New_Decl.Key);
+ Unchecked_Free (New_Decl);
+ New_Decl := null;
end if;
- if New_Decl.Match then
- Files.Longest_Name := Natural'Max (File_Ref.File'Length,
- Files.Longest_Name);
+ -- The declaration might also already be there for parent types. In
+ -- this case, we should keep the entry, since some other entries are
+ -- pointing to it.
+
+ if New_Decl = null
+ and then not Remove_Only
+ then
+ New_Decl :=
+ new Declaration_Record'
+ (Symbol_Length => Symbol'Length,
+ Symbol => Symbol,
+ Key => new String'(Key),
+ Decl => new Reference_Record'
+ (File => File_Ref,
+ Line => Line,
+ Column => Column,
+ Source_Line => null,
+ Next => null),
+ Is_Parameter => Is_Parameter,
+ Decl_Type => Decl_Type,
+ Body_Ref => null,
+ Ref_Ref => null,
+ Modif_Ref => null,
+ Match => Symbol_Match
+ and then
+ (Default_Match
+ or else Match (File_Ref, Line, Column)),
+ Par_Symbol => null,
+ Next => null);
+
+ Entities_HTable.Set (New_Decl);
+ Entities_Count := Entities_Count + 1;
+
+ if New_Decl.Match then
+ Longest_File_Name_In_Table :=
+ Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
+ end if;
+
+ elsif New_Decl /= null
+ and then not New_Decl.Match
+ then
+ New_Decl.Match := Default_Match
+ or else Match (File_Ref, Line, Column);
end if;
return New_Decl;
@@ -127,52 +306,46 @@ package body Xr_Tabls is
-- Add_To_Xref_File --
----------------------
- procedure Add_To_Xref_File
+ function Add_To_Xref_File
(File_Name : String;
- File_Existed : out Boolean;
- Ref : out File_Reference;
Visited : Boolean := True;
Emit_Warning : Boolean := False;
Gnatchop_File : String := "";
- Gnatchop_Offset : Integer := 0)
+ Gnatchop_Offset : Integer := 0) return File_Reference
is
- The_Files : File_Reference := Files.Table;
- Base : constant String := Base_File_Name (File_Name);
- Dir : constant String := Xr_Tabls.Dir_Name (File_Name);
- Dir_Acc : String_Access := null;
+ Base : aliased constant String := Base_Name (File_Name);
+ Dir : constant String := Dir_Name (File_Name);
+ Dir_Acc : GNAT.OS_Lib.String_Access := null;
+ Ref : File_Reference;
begin
-- Do we have a directory name as well?
- if Dir /= "" then
- Dir_Acc := new String' (Dir);
+ if File_Name /= Base then
+ Dir_Acc := new String'(Dir);
end if;
- -- Check if the file already exists in the table
+ Ref := File_HTable.Get (Base'Unchecked_Access);
+ if Ref = null then
+ Ref := new File_Record'
+ (File => new String'(Base),
+ Dir => Dir_Acc,
+ Lines => null,
+ Visited => Visited,
+ Emit_Warning => Emit_Warning,
+ Gnatchop_File => new String'(Gnatchop_File),
+ Gnatchop_Offset => Gnatchop_Offset,
+ Next => null);
+ File_HTable.Set (Ref);
- while The_Files /= null loop
+ if not Visited then
- if The_Files.File = File_Name then
- File_Existed := True;
- Ref := The_Files;
- return;
- end if;
+ -- Keep a separate list for faster access
- The_Files := The_Files.Next;
- end loop;
-
- Ref := new File_Record'
- (File_Length => Base'Length,
- File => Base,
- Dir => Dir_Acc,
- Lines => null,
- Visited => Visited,
- Emit_Warning => Emit_Warning,
- Gnatchop_File => new String' (Gnatchop_File),
- Gnatchop_Offset => Gnatchop_Offset,
- Next => Files.Table);
- Files.Table := Ref;
- File_Existed := False;
+ Set_Unvisited (Ref);
+ end if;
+ end if;
+ return Ref;
end Add_To_Xref_File;
--------------
@@ -202,21 +375,11 @@ package body Xr_Tabls is
File_Ref : File_Reference)
is
begin
- Declaration.Par_Symbol := new Declaration_Record'
- (Symbol_Length => Symbol'Length,
- Symbol => Symbol,
- Decl => (File => File_Ref,
- Line => Line,
- Column => Column,
- Source_Line => Null_Unbounded_String,
- Next => null),
- Decl_Type => ' ',
- Body_Ref => null,
- Ref_Ref => null,
- Modif_Ref => null,
- Match => False,
- Par_Symbol => null,
- Next => null);
+ Declaration.Par_Symbol :=
+ Add_Declaration
+ (File_Ref, Symbol, Line, Column,
+ Decl_Type => ' ',
+ Symbol_Match => False);
end Add_Parent;
-------------------
@@ -224,37 +387,55 @@ package body Xr_Tabls is
-------------------
procedure Add_Reference
- (Declaration : Declaration_Reference;
- File_Ref : File_Reference;
- Line : Natural;
- Column : Natural;
- Ref_Type : Character)
+ (Declaration : Declaration_Reference;
+ File_Ref : File_Reference;
+ Line : Natural;
+ Column : Natural;
+ Ref_Type : Character;
+ Labels_As_Ref : Boolean)
is
- procedure Free is new Unchecked_Deallocation
- (Reference_Record, Reference);
-
- Ref : Reference;
- Prev : Reference := null;
- Result : Compare_Result;
- New_Ref : Reference := new Reference_Record'
- (File => File_Ref,
- Line => Line,
- Column => Column,
- Source_Line => Null_Unbounded_String,
- Next => null);
+ New_Ref : Reference;
begin
case Ref_Type is
- when 'b' | 'c' =>
- Ref := Declaration.Body_Ref;
+ when 'b' | 'c' | 'm' | 'r' | 'i' | ' ' | 'x' =>
+ null;
- when 'r' | 'i' | 'l' | ' ' | 'x' =>
- Ref := Declaration.Ref_Ref;
+ when 'l' | 'w' =>
+ if not Labels_As_Ref then
+ return;
+ end if;
- when 'm' =>
- Ref := Declaration.Modif_Ref;
+ when '=' | '<' | '>' | '^' =>
- when 'e' | 't' | 'p' =>
+ -- Create a dummy declaration in the table to report it as a
+ -- parameter. Note that the current declaration for the subprogram
+ -- comes before the declaration of the parameter.
+
+ declare
+ Key : constant String :=
+ Key_From_Ref (File_Ref, Line, Column);
+ New_Decl : Declaration_Reference;
+
+ begin
+ New_Decl := new Declaration_Record'
+ (Symbol_Length => 0,
+ Symbol => "",
+ Key => new String'(Key),
+ Decl => null,
+ Is_Parameter => True,
+ Decl_Type => ' ',
+ Body_Ref => null,
+ Ref_Ref => null,
+ Modif_Ref => null,
+ Match => False,
+ Par_Symbol => null,
+ Next => null);
+ Entities_HTable.Set (New_Decl);
+ Entities_Count := Entities_Count + 1;
+ end;
+
+ when 'e' | 'z' | 't' | 'p' | 'P' | 'k' | 'd' =>
return;
when others =>
@@ -262,53 +443,43 @@ package body Xr_Tabls is
return;
end case;
- -- Check if the reference already exists
-
- while Ref /= null loop
- Result := Compare (New_Ref, Ref);
- exit when Result = LessThan;
+ New_Ref := new Reference_Record'
+ (File => File_Ref,
+ Line => Line,
+ Column => Column,
+ Source_Line => null,
+ Next => null);
- if Result = Equal then
- Free (New_Ref);
- return;
- end if;
+ -- We can insert the reference in the list directly, since all
+ -- the references will appear only once in the ALI file
+ -- corresponding to the file where they are referenced.
+ -- This saves a lot of time compared to checking the list to check
+ -- if it exists.
- Prev := Ref;
- Ref := Ref.Next;
- end loop;
+ case Ref_Type is
+ when 'b' | 'c' =>
+ New_Ref.Next := Declaration.Body_Ref;
+ Declaration.Body_Ref := New_Ref;
- -- Insert it in the list
+ when 'r' | 'i' | 'l' | ' ' | 'x' | 'w' =>
+ New_Ref.Next := Declaration.Ref_Ref;
+ Declaration.Ref_Ref := New_Ref;
- if Prev /= null then
- New_Ref.Next := Prev.Next;
- Prev.Next := New_Ref;
+ when 'm' =>
+ New_Ref.Next := Declaration.Modif_Ref;
+ Declaration.Modif_Ref := New_Ref;
- else
- case Ref_Type is
- when 'b' | 'c' =>
- New_Ref.Next := Declaration.Body_Ref;
- Declaration.Body_Ref := New_Ref;
-
- when 'r' | 'i' | 'l' | ' ' | 'x' =>
- New_Ref.Next := Declaration.Ref_Ref;
- Declaration.Ref_Ref := New_Ref;
-
- when 'm' =>
- New_Ref.Next := Declaration.Modif_Ref;
- Declaration.Modif_Ref := New_Ref;
-
- when others =>
- null;
- end case;
- end if;
+ when others =>
+ null;
+ end case;
if not Declaration.Match then
Declaration.Match := Match (File_Ref, Line, Column);
end if;
if Declaration.Match then
- Files.Longest_Name := Natural'Max (File_Ref.File'Length,
- Files.Longest_Name);
+ Longest_File_Name_In_Table :=
+ Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
end if;
end Add_Reference;
@@ -317,150 +488,91 @@ package body Xr_Tabls is
-------------------
function ALI_File_Name (Ada_File_Name : String) return String is
- Index : Natural := Ada.Strings.Fixed.Index
- (Ada_File_Name, ".", Going => Ada.Strings.Backward);
+
+ -- ??? Should ideally be based on the naming scheme defined in
+ -- project files.
+
+ Index : constant Natural :=
+ Ada.Strings.Fixed.Index
+ (Ada_File_Name, ".", Going => Ada.Strings.Backward);
begin
if Index /= 0 then
- return Ada_File_Name (Ada_File_Name'First .. Index)
- & "ali";
+ return Ada_File_Name (Ada_File_Name'First .. Index) & "ali";
else
return Ada_File_Name & ".ali";
end if;
end ALI_File_Name;
- --------------------
- -- Base_File_Name --
- --------------------
-
- function Base_File_Name (File : String) return String is
- begin
- for J in reverse File'Range loop
- if File (J) = '/' or else File (J) = Dir_Sep then
- return File (J + 1 .. File'Last);
- end if;
- end loop;
-
- return File;
- end Base_File_Name;
-
- -------------
- -- Compare --
- -------------
+ ------------------
+ -- Is_Less_Than --
+ ------------------
- function Compare
- (Ref1 : Reference;
- Ref2 : Reference)
- return Compare_Result
- is
+ function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean is
begin
if Ref1 = null then
- return GreaterThan;
+ return False;
elsif Ref2 = null then
- return LessThan;
+ return True;
end if;
- if Ref1.File.File < Ref2.File.File then
- return LessThan;
+ if Ref1.File.File.all < Ref2.File.File.all then
+ return True;
- elsif Ref1.File.File = Ref2.File.File then
- if Ref1.Line < Ref2.Line then
- return LessThan;
+ elsif Ref1.File.File.all = Ref2.File.File.all then
+ return (Ref1.Line < Ref2.Line
+ or else (Ref1.Line = Ref2.Line
+ and then Ref1.Column < Ref2.Column));
+ end if;
- elsif Ref1.Line = Ref2.Line then
- if Ref1.Column < Ref2.Column then
- return LessThan;
- elsif Ref1.Column = Ref2.Column then
- return Equal;
- else
- return GreaterThan;
- end if;
+ return False;
+ end Is_Less_Than;
- else
- return GreaterThan;
- end if;
+ ------------------
+ -- Is_Less_Than --
+ ------------------
- else
- return GreaterThan;
- end if;
- end Compare;
+ function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean
+ is
+ -- We cannot store the data case-insensitive in the table,
+ -- since we wouldn't be able to find the right casing for the
+ -- display later on.
- -------------
- -- Compare --
- -------------
+ S1 : constant String := To_Lower (Decl1.Symbol);
+ S2 : constant String := To_Lower (Decl2.Symbol);
- function Compare
- (Decl1 : Declaration_Reference;
- File2 : File_Reference;
- Line2 : Integer;
- Col2 : Integer;
- Symb2 : String)
- return Compare_Result
- is
begin
- if Decl1 = null then
- return GreaterThan;
+ if S1 < S2 then
+ return True;
+ elsif S1 > S2 then
+ return False;
end if;
- if Decl1.Symbol < Symb2 then
- return LessThan;
- elsif Decl1.Symbol > Symb2 then
- return GreaterThan;
- end if;
-
- if Decl1.Decl.File.File < Get_File (File2) then
- return LessThan;
-
- elsif Decl1.Decl.File.File = Get_File (File2) then
- if Decl1.Decl.Line < Line2 then
- return LessThan;
-
- elsif Decl1.Decl.Line = Line2 then
- if Decl1.Decl.Column < Col2 then
- return LessThan;
-
- elsif Decl1.Decl.Column = Col2 then
- return Equal;
-
- else
- return GreaterThan;
- end if;
-
- else
- return GreaterThan;
- end if;
-
- else
- return GreaterThan;
- end if;
- end Compare;
+ return Decl1.Key.all < Decl2.Key.all;
+ end Is_Less_Than;
-------------------------
-- Create_Project_File --
-------------------------
- procedure Create_Project_File
- (Name : String)
- is
+ procedure Create_Project_File (Name : String) is
use Ada.Strings.Unbounded;
Obj_Dir : Unbounded_String := Null_Unbounded_String;
Src_Dir : Unbounded_String := Null_Unbounded_String;
- Build_Dir : Unbounded_String;
-
- Gnatls_Src_Cache : Unbounded_String;
- Gnatls_Obj_Cache : Unbounded_String;
+ Build_Dir : GNAT.OS_Lib.String_Access := new String'("");
F : File_Descriptor;
Len : Positive;
File_Name : aliased String := Name & ASCII.NUL;
begin
-
-- Read the size of the file
+
F := Open_Read (File_Name'Address, Text);
-- Project file not found
+
if F /= Invalid_FD then
Len := Positive (File_Length (F));
@@ -468,6 +580,7 @@ package body Xr_Tabls is
Buffer : String (1 .. Len);
Index : Positive := Buffer'First;
Last : Positive;
+
begin
Len := Read (F, Buffer'Address, Len);
Close (F);
@@ -477,7 +590,7 @@ package body Xr_Tabls is
while Index <= Buffer'Last loop
- -- find the end of line
+ -- Find the end of line
Last := Index;
while Last <= Buffer'Last
@@ -498,11 +611,8 @@ package body Xr_Tabls is
Index := Index + 1;
end loop;
- Build_Dir :=
- To_Unbounded_String (Buffer (Index .. Last - 1));
- if Buffer (Last - 1) /= Dir_Sep then
- Append (Build_Dir, Dir_Sep);
- end if;
+ Free (Build_Dir);
+ Build_Dir := new String'(Buffer (Index .. Last - 1));
end if;
Index := Last + 1;
@@ -522,7 +632,7 @@ package body Xr_Tabls is
Index := Buffer'First;
while Index <= Buffer'Last loop
- -- find the end of line
+ -- Find the end of line
Last := Index;
while Last <= Buffer'Last
@@ -535,40 +645,18 @@ package body Xr_Tabls is
if Index <= Buffer'Last - 7
and then Buffer (Index .. Index + 7) = "src_dir="
then
- declare
- S : String := Ada.Strings.Fixed.Trim
- (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both);
- begin
- -- A relative directory ?
- if S (S'First) /= Dir_Sep then
- Append (Src_Dir, Build_Dir);
- end if;
-
- if S (S'Last) = Dir_Sep then
- Append (Src_Dir, S & " ");
- else
- Append (Src_Dir, S & Dir_Sep & " ");
- end if;
- end;
+ Append (Src_Dir, Normalize_Pathname
+ (Name => Ada.Strings.Fixed.Trim
+ (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both),
+ Directory => Build_Dir.all) & Path_Separator);
elsif Index <= Buffer'Last - 7
and then Buffer (Index .. Index + 7) = "obj_dir="
then
- declare
- S : String := Ada.Strings.Fixed.Trim
- (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both);
- begin
- -- A relative directory ?
- if S (S'First) /= Dir_Sep then
- Append (Obj_Dir, Build_Dir);
- end if;
-
- if S (S'Last) = Dir_Sep then
- Append (Obj_Dir, S & " ");
- else
- Append (Obj_Dir, S & Dir_Sep & " ");
- end if;
- end;
+ Append (Obj_Dir, Normalize_Pathname
+ (Name => Ada.Strings.Fixed.Trim
+ (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both),
+ Directory => Build_Dir.all) & Path_Separator);
end if;
-- In case we had a ASCII.CR/ASCII.LF end of line, skip the
@@ -584,16 +672,24 @@ package body Xr_Tabls is
end;
end if;
- Parse_Gnatls (Gnatls_Src_Cache, Gnatls_Obj_Cache);
+ Osint.Add_Default_Search_Dirs;
- Directories := new Project_File'
- (Src_Dir_Length => Length (Src_Dir) + Length (Gnatls_Src_Cache),
- Obj_Dir_Length => Length (Obj_Dir) + Length (Gnatls_Obj_Cache),
- Src_Dir => To_String (Src_Dir & Gnatls_Src_Cache),
- Obj_Dir => To_String (Obj_Dir & Gnatls_Obj_Cache),
- Src_Dir_Index => 1,
- Obj_Dir_Index => 1,
- Last_Obj_Dir_Start => 0);
+ declare
+ Src : constant String := Parse_Gnatls_Src;
+ Obj : constant String := Parse_Gnatls_Obj;
+
+ begin
+ Directories := new Project_File'
+ (Src_Dir_Length => Length (Src_Dir) + Src'Length,
+ Obj_Dir_Length => Length (Obj_Dir) + Obj'Length,
+ Src_Dir => To_String (Src_Dir) & Src,
+ Obj_Dir => To_String (Obj_Dir) & Obj,
+ Src_Dir_Index => 1,
+ Obj_Dir_Index => 1,
+ Last_Obj_Dir_Start => 0);
+ end;
+
+ Free (Build_Dir);
end Create_Project_File;
---------------------
@@ -602,137 +698,10 @@ package body Xr_Tabls is
function Current_Obj_Dir return String is
begin
- return Directories.Obj_Dir (Directories.Last_Obj_Dir_Start
- .. Directories.Obj_Dir_Index - 2);
+ return Directories.Obj_Dir
+ (Directories.Last_Obj_Dir_Start .. Directories.Obj_Dir_Index - 2);
end Current_Obj_Dir;
- --------------
- -- Dir_Name --
- --------------
-
- function Dir_Name (File : String; Base : String := "") return String is
- begin
- for J in reverse File'Range loop
- if File (J) = '/' or else File (J) = Dir_Sep then
-
- -- Is this an absolute directory ?
- if File (File'First) = '/'
- or else File (File'First) = Dir_Sep
- then
- return File (File'First .. J);
-
- -- Else do we know the base directory ?
- elsif Base /= "" then
- return Base & File (File'First .. J);
-
- else
- declare
- Max_Path : Integer;
- pragma Import (C, Max_Path, "__gnat_max_path_len");
-
- Base2 : Dir_Name_Str (1 .. Max_Path);
- Last : Natural;
- begin
- Get_Current_Dir (Base2, Last);
- return Base2 (Base2'First .. Last) & File (File'First .. J);
- end;
- end if;
- end if;
- end loop;
- return "";
- end Dir_Name;
-
- -------------------
- -- Find_ALI_File --
- -------------------
-
- function Find_ALI_File (Short_Name : String) return String is
- use type Ada.Strings.Unbounded.String_Access;
- Old_Obj_Dir : constant Integer := Directories.Obj_Dir_Index;
-
- begin
- Reset_Obj_Dir;
-
- loop
- declare
- Obj_Dir : String := Next_Obj_Dir;
- begin
- exit when Obj_Dir'Length = 0;
- if GNAT.IO_Aux.File_Exists (Obj_Dir & Short_Name) then
- Directories.Obj_Dir_Index := Old_Obj_Dir;
- return Obj_Dir;
- end if;
- end;
- end loop;
-
- -- Finally look in the standard directories
-
- Directories.Obj_Dir_Index := Old_Obj_Dir;
- return "";
- end Find_ALI_File;
-
- ----------------------
- -- Find_Source_File --
- ----------------------
-
- function Find_Source_File (Short_Name : String) return String is
- use type Ada.Strings.Unbounded.String_Access;
-
- begin
- Reset_Src_Dir;
- loop
- declare
- Src_Dir : String := Next_Src_Dir;
- begin
- exit when Src_Dir'Length = 0;
-
- if GNAT.IO_Aux.File_Exists (Src_Dir & Short_Name) then
- return Src_Dir;
- end if;
- end;
- end loop;
-
- -- Finally look in the standard directories
-
- return "";
- end Find_Source_File;
-
- ----------------
- -- First_Body --
- ----------------
-
- function First_Body (Decl : Declaration_Reference) return Reference is
- begin
- return Decl.Body_Ref;
- end First_Body;
-
- -----------------------
- -- First_Declaration --
- -----------------------
-
- function First_Declaration return Declaration_Reference is
- begin
- return Entities.Table;
- end First_Declaration;
-
- -----------------
- -- First_Modif --
- -----------------
-
- function First_Modif (Decl : Declaration_Reference) return Reference is
- begin
- return Decl.Modif_Ref;
- end First_Modif;
-
- ---------------------
- -- First_Reference --
- ---------------------
-
- function First_Reference (Decl : Declaration_Reference) return Reference is
- begin
- return Decl.Ref_Ref;
- end First_Reference;
-
----------------
-- Get_Column --
----------------
@@ -759,20 +728,10 @@ package body Xr_Tabls is
Column : Natural)
return Declaration_Reference
is
- The_Entities : Declaration_Reference := Entities.Table;
- begin
- while The_Entities /= null loop
- if The_Entities.Decl.Line = Line
- and then The_Entities.Decl.Column = Column
- and then The_Entities.Decl.File = File_Ref
- then
- return The_Entities;
- else
- The_Entities := The_Entities.Next;
- end if;
- end loop;
+ Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column);
- return Empty_Declaration;
+ begin
+ return Entities_HTable.Get (Key'Unchecked_Access);
end Get_Declaration;
----------------------
@@ -809,9 +768,11 @@ package body Xr_Tabls is
function Get_File
(File : File_Reference;
With_Dir : in Boolean := False;
- Strip : Natural := 0)
+ Strip : Natural := 0)
return String
is
+ Tmp : GNAT.OS_Lib.String_Access;
+
function Internal_Strip (Full_Name : String) return String;
-- Internal function to process the Strip parameter
@@ -820,8 +781,10 @@ package body Xr_Tabls is
--------------------
function Internal_Strip (Full_Name : String) return String is
- Unit_End, Extension_Start : Natural;
- S : Natural := Strip;
+ Unit_End : Natural;
+ Extension_Start : Natural;
+ S : Natural;
+
begin
if Strip = 0 then
return Full_Name;
@@ -838,6 +801,7 @@ package body Xr_Tabls is
-- Strip the right number of subunit_names
+ S := Strip;
Unit_End := Extension_Start - 1;
while Unit_End >= Full_Name'First
and then S > 0
@@ -845,6 +809,7 @@ package body Xr_Tabls is
if Full_Name (Unit_End) = '-' then
S := S - 1;
end if;
+
Unit_End := Unit_End - 1;
end loop;
@@ -856,23 +821,33 @@ package body Xr_Tabls is
end if;
end Internal_Strip;
+ -- Start of processing for Get_File;
+
begin
-- If we do not want the full path name
if not With_Dir then
- return Internal_Strip (File.File);
+ return Internal_Strip (File.File.all);
end if;
if File.Dir = null then
+ if Ada.Strings.Fixed.Tail (File.File.all, 3) = "ali" then
+ Tmp := Locate_Regular_File
+ (Internal_Strip (File.File.all), Directories.Obj_Dir);
+ else
+ Tmp := Locate_Regular_File
+ (File.File.all, Directories.Src_Dir);
+ end if;
- if Ada.Strings.Fixed.Tail (File.File, 3) = "ali" then
- File.Dir := new String'(Find_ALI_File (File.File));
+ if Tmp = null then
+ File.Dir := new String'("");
else
- File.Dir := new String'(Find_Source_File (File.File));
+ File.Dir := new String'(Dir_Name (Tmp.all));
+ Free (Tmp);
end if;
end if;
- return Internal_Strip (File.Dir.all & File.File);
+ return Internal_Strip (File.Dir.all & File.File.all);
end Get_File;
------------------
@@ -889,7 +864,10 @@ package body Xr_Tabls is
-----------------------
function Get_Gnatchop_File
- (File : File_Reference; With_Dir : Boolean := False) return String is
+ (File : File_Reference;
+ With_Dir : Boolean := False)
+ return String
+ is
begin
if File.Gnatchop_File.all = "" then
return Get_File (File, With_Dir);
@@ -898,22 +876,19 @@ package body Xr_Tabls is
end if;
end Get_Gnatchop_File;
- -----------------------
- -- Get_Gnatchop_File --
- -----------------------
-
function Get_Gnatchop_File
- (Ref : Reference; With_Dir : Boolean := False) return String is
+ (Ref : Reference;
+ With_Dir : Boolean := False)
+ return String
+ is
begin
return Get_Gnatchop_File (Ref.File, With_Dir);
end Get_Gnatchop_File;
- -----------------------
- -- Get_Gnatchop_File --
- -----------------------
-
function Get_Gnatchop_File
- (Decl : Declaration_Reference; With_Dir : Boolean := False) return String
+ (Decl : Declaration_Reference;
+ With_Dir : Boolean := False)
+ return String
is
begin
return Get_Gnatchop_File (Decl.Decl.File, With_Dir);
@@ -941,7 +916,8 @@ package body Xr_Tabls is
function Get_Parent
(Decl : Declaration_Reference)
- return Declaration_Reference is
+ return Declaration_Reference
+ is
begin
return Decl.Par_Symbol;
end Get_Parent;
@@ -952,12 +928,20 @@ package body Xr_Tabls is
function Get_Source_Line (Ref : Reference) return String is
begin
- return To_String (Ref.Source_Line);
+ if Ref.Source_Line /= null then
+ return Ref.Source_Line.all;
+ else
+ return "";
+ end if;
end Get_Source_Line;
function Get_Source_Line (Decl : Declaration_Reference) return String is
begin
- return To_String (Decl.Decl.Source_Line);
+ if Decl.Decl.Source_Line /= null then
+ return Decl.Decl.Source_Line.all;
+ else
+ return "";
+ end if;
end Get_Source_Line;
----------------
@@ -978,202 +962,201 @@ package body Xr_Tabls is
return Decl.Decl_Type;
end Get_Type;
- -----------------------
- -- Grep_Source_Files --
- -----------------------
-
- procedure Grep_Source_Files is
- Decl : Declaration_Reference := First_Declaration;
-
- type Simple_Ref;
- type Simple_Ref_Access is access Simple_Ref;
- type Simple_Ref is record
- Ref : Reference;
- Next : Simple_Ref_Access;
- end record;
- List : Simple_Ref_Access := null;
- -- This structure is used to speed up the parsing of Ada sources:
- -- Every reference found by parsing the .ali files is inserted in this
- -- list, sorted by filename and line numbers. This allows avoiding
- -- parsing a same ada file multiple times
-
- procedure Free is new Unchecked_Deallocation
- (Simple_Ref, Simple_Ref_Access);
- -- Clear an element of the list
-
- procedure Grep_List;
- -- For each reference in the list, parse the file and find the
- -- source line
-
- procedure Insert_In_Order (Ref : Reference);
- -- Insert a new reference in the list, ordered by line numbers
-
- procedure Insert_List_Ref (First_Ref : Reference);
- -- Process a list of references
-
- ---------------
- -- Grep_List --
- ---------------
-
- procedure Grep_List is
- Line : String (1 .. 1024);
- Last : Natural;
- File : Ada.Text_IO.File_Type;
- Line_Number : Natural;
- Pos : Natural;
- Save_List : Simple_Ref_Access := List;
- Current_File : File_Reference;
+ ----------
+ -- Sort --
+ ----------
- begin
- while List /= null loop
+ procedure Sort (Arr : in out Reference_Array) is
+ Tmp : Reference;
- -- Makes sure we can find and read the file
+ function Lt (Op1, Op2 : Natural) return Boolean;
+ procedure Move (From, To : Natural);
+ -- See GNAT.Heap_Sort_G
- Current_File := List.Ref.File;
- Line_Number := 0;
+ --------
+ -- Lt --
+ --------
- begin
- Ada.Text_IO.Open (File,
- Ada.Text_IO.In_File,
- Get_File (List.Ref, True));
+ function Lt (Op1, Op2 : Natural) return Boolean is
+ begin
+ if Op1 = 0 then
+ return Is_Less_Than (Tmp, Arr (Op2));
+ elsif Op2 = 0 then
+ return Is_Less_Than (Arr (Op1), Tmp);
+ else
+ return Is_Less_Than (Arr (Op1), Arr (Op2));
+ end if;
+ end Lt;
- -- Read the file and find every relevant lines
+ ----------
+ -- Move --
+ ----------
- while List /= null
- and then List.Ref.File = Current_File
- and then not Ada.Text_IO.End_Of_File (File)
- loop
- Ada.Text_IO.Get_Line (File, Line, Last);
- Line_Number := Line_Number + 1;
+ procedure Move (From, To : Natural) is
+ begin
+ if To = 0 then
+ Tmp := Arr (From);
+ elsif From = 0 then
+ Arr (To) := Tmp;
+ else
+ Arr (To) := Arr (From);
+ end if;
+ end Move;
- while List /= null
- and then Line_Number = List.Ref.Line
- loop
+ package Ref_Sort is new GNAT.Heap_Sort_G (Move, Lt);
- -- Skip the leading blanks on the line
+ -- Start of processing for Sort
- Pos := 1;
- while Line (Pos) = ' '
- or else Line (Pos) = ASCII.HT
- loop
- Pos := Pos + 1;
- end loop;
+ begin
+ Ref_Sort.Sort (Arr'Last);
+ end Sort;
- List.Ref.Source_Line :=
- To_Unbounded_String (Line (Pos .. Last));
+ -----------------------
+ -- Grep_Source_Files --
+ -----------------------
- -- Find the next element in the list
+ procedure Grep_Source_Files is
+ Length : Natural := 0;
+ Decl : Declaration_Reference := Entities_HTable.Get_First;
+ Arr : Reference_Array_Access;
+ Index : Natural;
+ End_Index : Natural;
+ Current_File : File_Reference;
+ Current_Line : Cst_String_Access;
+ Buffer : GNAT.OS_Lib.String_Access;
+ Ref : Reference;
+ Line : Natural;
- List := List.Next;
- end loop;
+ begin
+ -- Create a temporary array, where all references will be
+ -- sorted by files. This way, we only have to read the source
+ -- files once.
- end loop;
+ while Decl /= null loop
- Ada.Text_IO.Close (File);
+ -- Add 1 for the declaration itself
- -- If the Current_File was not found, just skip it
+ Length := Length + References_Count (Decl, True, True, True) + 1;
+ Decl := Entities_HTable.Get_Next;
+ end loop;
- exception
- when Ada.IO_Exceptions.Name_Error =>
- null;
- end;
+ Arr := new Reference_Array (1 .. Length);
+ Index := Arr'First;
- -- If the line or the file were not found
+ Decl := Entities_HTable.Get_First;
+ while Decl /= null loop
+ Store_References (Decl, True, True, True, True, Arr.all, Index);
+ Decl := Entities_HTable.Get_Next;
+ end loop;
- while List /= null
- and then List.Ref.File = Current_File
- loop
- List := List.Next;
- end loop;
+ Sort (Arr.all);
- end loop;
+ -- Now traverse the whole array and find the appropriate source
+ -- lines.
- -- Clear the list
+ for R in Arr'Range loop
+ Ref := Arr (R);
- while Save_List /= null loop
- List := Save_List;
- Save_List := Save_List.Next;
- Free (List);
- end loop;
- end Grep_List;
+ if Ref.File /= Current_File then
+ Free (Buffer);
+ begin
+ Read_File (Get_File (Ref.File, With_Dir => True), Buffer);
+ End_Index := Buffer'First - 1;
+ Line := 0;
+ exception
+ when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error =>
+ Line := Natural'Last;
+ end;
+ Current_File := Ref.File;
+ end if;
- ---------------------
- -- Insert_In_Order --
- ---------------------
+ if Ref.Line > Line then
- procedure Insert_In_Order (Ref : Reference) is
- Iter : Simple_Ref_Access := List;
- Prev : Simple_Ref_Access := null;
+ -- Do not free Current_Line, it is referenced by the last
+ -- Ref we processed.
- begin
- while Iter /= null loop
+ loop
+ Index := End_Index + 1;
- -- If we have found the file, sort by lines
+ loop
+ End_Index := End_Index + 1;
+ exit when End_Index > Buffer'Last
+ or else Buffer (End_Index) = ASCII.LF;
+ end loop;
- if Iter.Ref.File = Ref.File then
+ -- Skip spaces at beginning of line
- while Iter /= null
- and then Iter.Ref.File = Ref.File
+ while Index < End_Index and then
+ (Buffer (Index) = ' ' or else Buffer (Index) = ASCII.HT)
loop
- if Iter.Ref.Line > Ref.Line then
-
- if Iter = List then
- List := new Simple_Ref'(Ref, List);
- else
- Prev.Next := new Simple_Ref'(Ref, Iter);
- end if;
- return;
- end if;
-
- Prev := Iter;
- Iter := Iter.Next;
+ Index := Index + 1;
end loop;
- if Iter = List then
- List := new Simple_Ref'(Ref, List);
- else
- Prev.Next := new Simple_Ref'(Ref, Iter);
- end if;
+ Line := Line + 1;
+ exit when Ref.Line = Line;
+ end loop;
- return;
- end if;
+ Current_Line := new String'(Buffer (Index .. End_Index - 1));
+ end if;
- Prev := Iter;
- Iter := Iter.Next;
- end loop;
+ Ref.Source_Line := Current_Line;
+ end loop;
- -- The file was not already in the list, insert it
+ Free (Buffer);
+ Free (Arr);
+ end Grep_Source_Files;
- List := new Simple_Ref'(Ref, List);
- end Insert_In_Order;
+ ---------------
+ -- Read_File --
+ ---------------
- ---------------------
- -- Insert_List_Ref --
- ---------------------
+ procedure Read_File
+ (File_Name : String;
+ Contents : out GNAT.OS_Lib.String_Access)
+ is
+ Name_0 : constant String := File_Name & ASCII.NUL;
+ FD : constant File_Descriptor := Open_Read (Name_0'Address, Binary);
+ Length : Natural;
- procedure Insert_List_Ref (First_Ref : Reference) is
- Ref : Reference := First_Ref;
+ begin
+ if FD = Invalid_FD then
+ raise Ada.Text_IO.Name_Error;
+ end if;
+
+ -- Include room for EOF char
+
+ Length := Natural (File_Length (FD));
+
+ declare
+ Buffer : String (1 .. Length + 1);
+ This_Read : Integer;
+ Read_Ptr : Natural := 1;
begin
- while Ref /= Empty_Reference loop
- Insert_In_Order (Ref);
- Ref := Next (Ref);
+ loop
+ This_Read := Read (FD,
+ A => Buffer (Read_Ptr)'Address,
+ N => Length + 1 - Read_Ptr);
+ Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
+ exit when This_Read <= 0;
end loop;
- end Insert_List_Ref;
- -- Start of processing for Grep_Source_Files
+ Buffer (Read_Ptr) := EOF;
+ Contents := new String'(Buffer (1 .. Read_Ptr));
- begin
- while Decl /= Empty_Declaration loop
- Insert_In_Order (Decl.Decl'Access);
- Insert_List_Ref (First_Body (Decl));
- Insert_List_Ref (First_Reference (Decl));
- Insert_List_Ref (First_Modif (Decl));
- Decl := Next (Decl);
- end loop;
+ -- Things are not simple on VMS due to the plethora of file types
+ -- and organizations. It seems clear that there shouldn't be more
+ -- bytes read than are contained in the file though.
- Grep_List;
- end Grep_Source_Files;
+ if (Hostparm.OpenVMS and then Read_Ptr > Length + 1)
+ or else (not Hostparm.OpenVMS and then Read_Ptr /= Length + 1)
+ then
+ raise Ada.Text_IO.End_Error;
+ end if;
+
+ Close (FD);
+ end;
+ end Read_File;
-----------------------
-- Longest_File_Name --
@@ -1181,7 +1164,7 @@ package body Xr_Tabls is
function Longest_File_Name return Natural is
begin
- return Files.Longest_Name;
+ return Longest_File_Name_In_Table;
end Longest_File_Name;
-----------
@@ -1223,18 +1206,14 @@ package body Xr_Tabls is
-- Next --
----------
- function Next (Decl : Declaration_Reference) return Declaration_Reference is
+ function Next (E : File_Reference) return File_Reference is
begin
- return Decl.Next;
+ return E.Next;
end Next;
- ----------
- -- Next --
- ----------
-
- function Next (Ref : Reference) return Reference is
+ function Next (E : Declaration_Reference) return Declaration_Reference is
begin
- return Ref.Next;
+ return E.Next;
end Next;
------------------
@@ -1242,15 +1221,17 @@ package body Xr_Tabls is
------------------
function Next_Obj_Dir return String is
- First : Integer := Directories.Obj_Dir_Index;
- Last : Integer := Directories.Obj_Dir_Index;
+ First : constant Integer := Directories.Obj_Dir_Index;
+ Last : Integer;
begin
+ Last := Directories.Obj_Dir_Index;
+
if Last > Directories.Obj_Dir_Length then
return String'(1 .. 0 => ' ');
end if;
- while Directories.Obj_Dir (Last) /= ' ' loop
+ while Directories.Obj_Dir (Last) /= Path_Separator loop
Last := Last + 1;
end loop;
@@ -1259,76 +1240,109 @@ package body Xr_Tabls is
return Directories.Obj_Dir (First .. Last - 1);
end Next_Obj_Dir;
- ------------------
- -- Next_Src_Dir --
- ------------------
-
- function Next_Src_Dir return String is
- First : Integer := Directories.Src_Dir_Index;
- Last : Integer := Directories.Src_Dir_Index;
-
- begin
- if Last > Directories.Src_Dir_Length then
- return String'(1 .. 0 => ' ');
- end if;
-
- while Directories.Src_Dir (Last) /= ' ' loop
- Last := Last + 1;
- end loop;
-
- Directories.Src_Dir_Index := Last + 1;
- return Directories.Src_Dir (First .. Last - 1);
- end Next_Src_Dir;
-
-------------------------
-- Next_Unvisited_File --
-------------------------
function Next_Unvisited_File return File_Reference is
- The_Files : File_Reference := Files.Table;
-
- begin
- while The_Files /= null loop
- if not The_Files.Visited then
- The_Files.Visited := True;
- return The_Files;
- end if;
+ procedure Unchecked_Free is new Ada.Unchecked_Deallocation
+ (Unvisited_Files_Record, Unvisited_Files_Access);
- The_Files := The_Files.Next;
- end loop;
+ Ref : File_Reference;
+ Tmp : Unvisited_Files_Access;
- return Empty_File;
+ begin
+ if Unvisited_Files = null then
+ return Empty_File;
+ else
+ Tmp := Unvisited_Files;
+ Ref := Unvisited_Files.File;
+ Unvisited_Files := Unvisited_Files.Next;
+ Unchecked_Free (Tmp);
+ return Ref;
+ end if;
end Next_Unvisited_File;
- ------------------
- -- Parse_Gnatls --
- ------------------
+ ----------------------
+ -- Parse_Gnatls_Src --
+ ----------------------
- procedure Parse_Gnatls
- (Gnatls_Src_Cache : out Ada.Strings.Unbounded.Unbounded_String;
- Gnatls_Obj_Cache : out Ada.Strings.Unbounded.Unbounded_String)
- is
- begin
- Osint.Add_Default_Search_Dirs;
+ function Parse_Gnatls_Src return String is
+ Length : Natural;
+ begin
+ Length := 0;
for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
- Ada.Strings.Unbounded.Append (Gnatls_Src_Cache, "./" & ' ');
+ Length := Length + 2;
else
- Ada.Strings.Unbounded.Append
- (Gnatls_Src_Cache, Osint.Dir_In_Src_Search_Path (J).all & ' ');
+ Length := Length + Osint.Dir_In_Src_Search_Path (J)'Length + 1;
end if;
end loop;
+ declare
+ Result : String (1 .. Length);
+ L : Natural;
+
+ begin
+ L := Result'First;
+ for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
+ if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
+ Result (L .. L + 1) := "." & Path_Separator;
+ L := L + 2;
+
+ else
+ Result (L .. L + Osint.Dir_In_Src_Search_Path (J)'Length - 1) :=
+ Osint.Dir_In_Src_Search_Path (J).all;
+ L := L + Osint.Dir_In_Src_Search_Path (J)'Length;
+ Result (L) := Path_Separator;
+ L := L + 1;
+ end if;
+ end loop;
+
+ return Result;
+ end;
+ end Parse_Gnatls_Src;
+
+ ----------------------
+ -- Parse_Gnatls_Obj --
+ ----------------------
+
+ function Parse_Gnatls_Obj return String is
+ Length : Natural;
+
+ begin
+ Length := 0;
for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop
if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then
- Ada.Strings.Unbounded.Append (Gnatls_Obj_Cache, "./" & ' ');
+ Length := Length + 2;
else
- Ada.Strings.Unbounded.Append
- (Gnatls_Obj_Cache, Osint.Dir_In_Obj_Search_Path (J).all & ' ');
+ Length := Length + Osint.Dir_In_Obj_Search_Path (J)'Length + 1;
end if;
end loop;
- end Parse_Gnatls;
+
+ declare
+ Result : String (1 .. Length);
+ L : Natural;
+
+ begin
+ L := Result'First;
+ for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop
+ if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then
+ Result (L .. L + 1) := "." & Path_Separator;
+ L := L + 2;
+ else
+ Result (L .. L + Osint.Dir_In_Obj_Search_Path (J)'Length - 1) :=
+ Osint.Dir_In_Obj_Search_Path (J).all;
+ L := L + Osint.Dir_In_Obj_Search_Path (J)'Length;
+ Result (L) := Path_Separator;
+ L := L + 1;
+ end if;
+ end loop;
+
+ return Result;
+ end;
+ end Parse_Gnatls_Obj;
-------------------
-- Reset_Obj_Dir --
@@ -1339,15 +1353,6 @@ package body Xr_Tabls is
Directories.Obj_Dir_Index := 1;
end Reset_Obj_Dir;
- -------------------
- -- Reset_Src_Dir --
- -------------------
-
- procedure Reset_Src_Dir is
- begin
- Directories.Src_Dir_Index := 1;
- end Reset_Src_Dir;
-
-----------------------
-- Set_Default_Match --
-----------------------
@@ -1357,34 +1362,273 @@ package body Xr_Tabls is
Default_Match := Value;
end Set_Default_Match;
- -------------------
- -- Set_Directory --
- -------------------
+ ----------
+ -- Free --
+ ----------
- procedure Set_Directory
- (File : in File_Reference;
- Dir : in String)
- is
+ procedure Free (Str : in out Cst_String_Access) is
+ function Convert is new Ada.Unchecked_Conversion
+ (Cst_String_Access, GNAT.OS_Lib.String_Access);
+
+ S : GNAT.OS_Lib.String_Access := Convert (Str);
+
+ begin
+ Free (S);
+ Str := null;
+ end Free;
+
+ ---------------------
+ -- Reset_Directory --
+ ---------------------
+
+ procedure Reset_Directory (File : File_Reference) is
begin
- File.Dir := new String'(Dir);
- end Set_Directory;
+ Free (File.Dir);
+ end Reset_Directory;
-------------------
-- Set_Unvisited --
-------------------
- procedure Set_Unvisited (File_Ref : in File_Reference) is
- The_Files : File_Reference := Files.Table;
+ procedure Set_Unvisited (File_Ref : File_Reference) is
+ F : constant String := Get_File (File_Ref, With_Dir => False);
begin
- while The_Files /= null loop
- if The_Files = File_Ref then
- The_Files.Visited := False;
- return;
+ File_Ref.Visited := False;
+
+ -- ??? Do not add a source file to the list. This is true at
+ -- least for gnatxref, and probably for gnatfind as wel
+
+ if F'Length > 4
+ and then F (F'Last - 3 .. F'Last) = ".ali"
+ then
+ Unvisited_Files := new Unvisited_Files_Record'
+ (File => File_Ref,
+ Next => Unvisited_Files);
+ end if;
+ end Set_Unvisited;
+
+ ----------------------
+ -- Get_Declarations --
+ ----------------------
+
+ function Get_Declarations
+ (Sorted : Boolean := True)
+ return Declaration_Array_Access
+ is
+ Arr : Declaration_Array_Access :=
+ new Declaration_Array (1 .. Entities_Count);
+ Decl : Declaration_Reference := Entities_HTable.Get_First;
+ Index : Natural := Arr'First;
+ Tmp : Declaration_Reference;
+
+ procedure Move (From : Natural; To : Natural);
+ function Lt (Op1, Op2 : Natural) return Boolean;
+ -- See GNAT.Heap_Sort_G
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (Op1, Op2 : Natural) return Boolean is
+ begin
+ if Op1 = 0 then
+ return Is_Less_Than (Tmp, Arr (Op2));
+ elsif Op2 = 0 then
+ return Is_Less_Than (Arr (Op1), Tmp);
+ else
+ return Is_Less_Than (Arr (Op1), Arr (Op2));
end if;
+ end Lt;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ if To = 0 then
+ Tmp := Arr (From);
+ elsif From = 0 then
+ Arr (To) := Tmp;
+ else
+ Arr (To) := Arr (From);
+ end if;
+ end Move;
+
+ package Decl_Sort is new GNAT.Heap_Sort_G (Move, Lt);
- The_Files := The_Files.Next;
+ -- Start of processing for Get_Declarations
+
+ begin
+ while Decl /= null loop
+ Arr (Index) := Decl;
+ Index := Index + 1;
+ Decl := Entities_HTable.Get_Next;
end loop;
- end Set_Unvisited;
+
+ if Sorted and then Arr'Length /= 0 then
+ Decl_Sort.Sort (Entities_Count);
+ end if;
+
+ return Arr;
+ end Get_Declarations;
+
+ ----------------------
+ -- References_Count --
+ ----------------------
+
+ function References_Count
+ (Decl : Declaration_Reference;
+ Get_Reads : Boolean := False;
+ Get_Writes : Boolean := False;
+ Get_Bodies : Boolean := False)
+ return Natural
+ is
+ function List_Length (E : Reference) return Natural;
+ -- Return the number of references in E
+
+ -----------------
+ -- List_Length --
+ -----------------
+
+ function List_Length (E : Reference) return Natural is
+ L : Natural := 0;
+ E1 : Reference := E;
+
+ begin
+ while E1 /= null loop
+ L := L + 1;
+ E1 := E1.Next;
+ end loop;
+
+ return L;
+ end List_Length;
+
+ Length : Natural := 0;
+
+ -- Start of processing for References_Count
+
+ begin
+ if Get_Reads then
+ Length := List_Length (Decl.Ref_Ref);
+ end if;
+
+ if Get_Writes then
+ Length := Length + List_Length (Decl.Modif_Ref);
+ end if;
+
+ if Get_Bodies then
+ Length := Length + List_Length (Decl.Body_Ref);
+ end if;
+
+ return Length;
+ end References_Count;
+
+ ----------------------
+ -- Store_References --
+ ----------------------
+
+ procedure Store_References
+ (Decl : Declaration_Reference;
+ Get_Writes : Boolean := False;
+ Get_Reads : Boolean := False;
+ Get_Bodies : Boolean := False;
+ Get_Declaration : Boolean := False;
+ Arr : in out Reference_Array;
+ Index : in out Natural)
+ is
+ procedure Add (List : Reference);
+ -- Add all the references in List to Arr
+
+ ---------
+ -- Add --
+ ---------
+
+ procedure Add (List : Reference) is
+ E : Reference := List;
+ begin
+ while E /= null loop
+ Arr (Index) := E;
+ Index := Index + 1;
+ E := E.Next;
+ end loop;
+ end Add;
+
+ -- Start of processing for Store_References
+
+ begin
+ if Get_Declaration then
+ Add (Decl.Decl);
+ end if;
+
+ if Get_Reads then
+ Add (Decl.Ref_Ref);
+ end if;
+
+ if Get_Writes then
+ Add (Decl.Modif_Ref);
+ end if;
+
+ if Get_Bodies then
+ Add (Decl.Body_Ref);
+ end if;
+ end Store_References;
+
+ --------------------
+ -- Get_References --
+ --------------------
+
+ function Get_References
+ (Decl : Declaration_Reference;
+ Get_Reads : Boolean := False;
+ Get_Writes : Boolean := False;
+ Get_Bodies : Boolean := False)
+ return Reference_Array_Access
+ is
+ Length : constant Natural :=
+ References_Count (Decl, Get_Reads, Get_Writes, Get_Bodies);
+
+ Arr : constant Reference_Array_Access :=
+ new Reference_Array (1 .. Length);
+
+ Index : Natural := Arr'First;
+
+ begin
+ Store_References
+ (Decl => Decl,
+ Get_Writes => Get_Writes,
+ Get_Reads => Get_Reads,
+ Get_Bodies => Get_Bodies,
+ Get_Declaration => False,
+ Arr => Arr.all,
+ Index => Index);
+
+ if Arr'Length /= 0 then
+ Sort (Arr.all);
+ end if;
+
+ return Arr;
+ end Get_References;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (Arr : in out Reference_Array_Access) is
+ procedure Internal is new Ada.Unchecked_Deallocation
+ (Reference_Array, Reference_Array_Access);
+ begin
+ Internal (Arr);
+ end Free;
+
+ ------------------
+ -- Is_Parameter --
+ ------------------
+
+ function Is_Parameter (Decl : Declaration_Reference) return Boolean is
+ begin
+ return Decl.Is_Parameter;
+ end Is_Parameter;
end Xr_Tabls;
diff --git a/gcc/ada/xr_tabls.ads b/gcc/ada/xr_tabls.ads
index f15ebd7e7f8..794dcb9498a 100644
--- a/gcc/ada/xr_tabls.ads
+++ b/gcc/ada/xr_tabls.ads
@@ -19,11 +19,12 @@
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-with Ada.Strings.Unbounded;
+with GNAT.OS_Lib;
package Xr_Tabls is
@@ -32,46 +33,20 @@ package Xr_Tabls is
-------------------
function ALI_File_Name (Ada_File_Name : String) return String;
- -- Returns the ali file name corresponding to Ada_File_Name, using the
- -- information provided in gnat.adc if it exists
-
- procedure Create_Project_File
- (Name : String);
- -- Open and parse a new project file
- -- If the file Name could not be open or is not a valid project file
- -- then a project file associated with the standard default directories
- -- is returned
-
- function Find_ALI_File (Short_Name : String) return String;
- -- Returns the directory name for the file Short_Name
- -- takes into account the obj_dir lines in the project file,
- -- and the default paths for Gnat
-
- function Find_Source_File (Short_Name : String) return String;
- -- Returns the directory name for the file Short_Name
- -- takes into account the src_dir lines in the project file,
- -- and the default paths for Gnat
-
- function Next_Src_Dir return String;
- -- Returns the next directory to visit to find related source files
- -- If there are no more such directory, Length = 0
+ -- Returns the ali file name corresponding to Ada_File_Name.
+
+ procedure Create_Project_File (Name : String);
+ -- Open and parse a new project file. If the file Name could not be
+ -- opened or is not a valid project file, then a project file associated
+ -- with the standard default directories is returned
function Next_Obj_Dir return String;
-- Returns the next directory to visit to find related ali files
- -- If there are no more such directory, Length = 0
+ -- If there are no more such directories, returns a null string.
function Current_Obj_Dir return String;
-- Returns the obj_dir which was returned by the last Next_Obj_Dir call
- procedure Parse_Gnatls
- (Gnatls_Src_Cache : out Ada.Strings.Unbounded.Unbounded_String;
- Gnatls_Obj_Cache : out Ada.Strings.Unbounded.Unbounded_String);
- -- Parse the output of Gnatls, to find the standard
- -- directories for source files
-
- procedure Reset_Src_Dir;
- -- Reset the iterator for Src_Dir
-
procedure Reset_Obj_Dir;
-- Reset the iterator for Obj_Dir
@@ -82,24 +57,37 @@ package Xr_Tabls is
type Declaration_Reference is private;
Empty_Declaration : constant Declaration_Reference;
+ type Declaration_Array is array (Natural range <>) of Declaration_Reference;
+ type Declaration_Array_Access is access Declaration_Array;
+
type File_Reference is private;
Empty_File : constant File_Reference;
type Reference is private;
Empty_Reference : constant Reference;
- type File_Table is limited private;
- type Entity_Table is limited private;
+ type Reference_Array is array (Natural range <>) of Reference;
+ type Reference_Array_Access is access Reference_Array;
+
+ procedure Free (Arr : in out Reference_Array_Access);
function Add_Declaration
- (File_Ref : File_Reference;
- Symbol : String;
- Line : Natural;
- Column : Natural;
- Decl_Type : Character)
- return Declaration_Reference;
+ (File_Ref : File_Reference;
+ Symbol : String;
+ Line : Natural;
+ Column : Natural;
+ Decl_Type : Character;
+ Remove_Only : Boolean := False;
+ Symbol_Match : Boolean := True)
+ return Declaration_Reference;
-- Add a new declaration in the table and return the index to it.
- -- Decl_Type is the type of the entity
+ -- Decl_Type is the type of the entity Any previous instance of this
+ -- entity in the htable is removed. If Remove_Only is True, then any
+ -- previous instance is removed, but the new entity is never inserted.
+ -- Symbol_Match should be set to False if the name of the symbol doesn't
+ -- match the pattern from the command line. In that case, the entity will
+ -- not be output by gnatfind. If Symbol_Match is True, the entity will only
+ -- be output if the file name itself matches.
procedure Add_Parent
(Declaration : in out Declaration_Reference;
@@ -110,17 +98,15 @@ package Xr_Tabls is
-- The parent declaration (Symbol in file File_Ref at position Line and
-- Column) information is added to Declaration.
- procedure Add_To_Xref_File
+ function Add_To_Xref_File
(File_Name : String;
- File_Existed : out Boolean;
- Ref : out File_Reference;
Visited : Boolean := True;
Emit_Warning : Boolean := False;
Gnatchop_File : String := "";
- Gnatchop_Offset : Integer := 0);
+ Gnatchop_Offset : Integer := 0)
+ return File_Reference;
-- Add a new reference to a file in the table. Ref is used to return the
- -- index in the table where this file is stored On exit, File_Existed is
- -- True if the file was already in the table Visited is the value which
+ -- index in the table where this file is stored. Visited is the value which
-- will be used in the table (if True, the file will not be returned by
-- Next_Unvisited_File). If Emit_Warning is True and the ali file does
-- not exist or does not have cross-referencing information, then a
@@ -133,35 +119,49 @@ package Xr_Tabls is
(File : File_Reference;
Line : Natural;
Column : Natural);
- -- Add a new reference in a file, which the user has provided
- -- on the command line. This is used for a optimized matching
- -- algorithm.
+ -- Add a new reference in a file, which the user has provided on the
+ -- command line. This is used for an optimized matching algorithm.
procedure Add_Reference
- (Declaration : Declaration_Reference;
- File_Ref : File_Reference;
- Line : Natural;
- Column : Natural;
- Ref_Type : Character);
+ (Declaration : Declaration_Reference;
+ File_Ref : File_Reference;
+ Line : Natural;
+ Column : Natural;
+ Ref_Type : Character;
+ Labels_As_Ref : Boolean);
-- Add a new reference (Ref_Type = 'r'), body (Ref_Type = 'b') or
- -- modification (Ref_Type = 'm') to an entity
-
- type Compare_Result is (LessThan, Equal, GreaterThan);
- function Compare (Ref1, Ref2 : Reference) return Compare_Result;
- function Compare
- (Decl1 : Declaration_Reference;
- File2 : File_Reference;
- Line2 : Integer;
- Col2 : Integer;
- Symb2 : String)
- return Compare_Result;
- -- Compare two references
-
- function First_Body (Decl : Declaration_Reference) return Reference;
- function First_Declaration return Declaration_Reference;
- function First_Modif (Decl : Declaration_Reference) return Reference;
- function First_Reference (Decl : Declaration_Reference) return Reference;
- -- Initialize the iterators
+ -- modification (Ref_Type = 'm') to an entity. If Labels_As_Ref is True,
+ -- then the references to the entity after the end statements ("end Foo")
+ -- are counted as actual references. This means that the entity will never
+ -- be reported as unreferenced (for instance in the case of gnatxref -u).
+
+ function Get_Declarations
+ (Sorted : Boolean := True)
+ return Declaration_Array_Access;
+ -- Return a sorted list of all the declarations in the application.
+ -- Freeing this array is the responsability of the caller, however it
+ -- shouldn't free the actual contents of the array, which are pointers
+ -- to internal data
+
+ function References_Count
+ (Decl : Declaration_Reference;
+ Get_Reads : Boolean := False;
+ Get_Writes : Boolean := False;
+ Get_Bodies : Boolean := False)
+ return Natural;
+ -- Return the number of references in Decl for the categories specified
+ -- by the Get_* parameters (read-only accesses, write accesses and bodies)
+
+ function Get_References
+ (Decl : Declaration_Reference;
+ Get_Reads : Boolean := False;
+ Get_Writes : Boolean := False;
+ Get_Bodies : Boolean := False)
+ return Reference_Array_Access;
+ -- Return a sorted list of all references to the entity in decl.
+ -- The parameters Get_* are used to specify what kind of references
+ -- should be merged and returned (read-only accesses, write accesses
+ -- and bodies).
function Get_Column (Decl : Declaration_Reference) return String;
function Get_Column (Ref : Reference) return String;
@@ -176,7 +176,7 @@ package Xr_Tabls is
function Get_Parent
(Decl : Declaration_Reference)
- return Declaration_Reference;
+ return Declaration_Reference;
-- Returns reference to Decl's parent declaration
function Get_Emit_Warning (File : File_Reference) return Boolean;
@@ -230,17 +230,24 @@ package Xr_Tabls is
function Get_Line (Ref : Reference) return String;
function Get_Symbol (Decl : Declaration_Reference) return String;
function Get_Type (Decl : Declaration_Reference) return Character;
- -- Functions that return the content of a declaration
+ function Is_Parameter (Decl : Declaration_Reference) return Boolean;
+ -- Functions that return the contents of a declaration
function Get_Source_Line (Ref : Reference) return String;
function Get_Source_Line (Decl : Declaration_Reference) return String;
-- Return the source line associated with the reference
procedure Grep_Source_Files;
- -- Parse all the source files which have at least one reference, and
- -- grep the appropriate lines so that we'll be able to display them.
- -- This function should be called once all the .ali files have been
- -- parsed, and only if the appropriate user switch has been used.
+ -- Parse all the source files which have at least one reference,
+ -- and grep the appropriate source lines so that we'll be able to
+ -- display them. This function should be called once all the .ali
+ -- files have been parsed, and only if the appropriate user switch
+ -- has been used (gnatfind -s).
+ --
+ -- Note: To save memory, the strings for the source lines are shared.
+ -- Thus it is no longer possible to free the references, or we would
+ -- free the same chunk multiple times. It doesn't matter, though, since
+ -- this is only called once, prior to exiting gnatfind.
function Longest_File_Name return Natural;
-- Returns the longest file name found
@@ -256,27 +263,35 @@ package Xr_Tabls is
-- Returns True if File:Line:Column was given on the command line
-- by the user
- function Next (Decl : Declaration_Reference) return Declaration_Reference;
- function Next (Ref : Reference) return Reference;
- -- Returns the next declaration, or Empty_Declaration
-
function Next_Unvisited_File return File_Reference;
-- Returns the next unvisited library file in the list
- -- If there is no more unvisited file, return Empty_File
+ -- If there is no more unvisited file, return Empty_File.
+ -- Two calls to this subprogram will return different files.
procedure Set_Default_Match (Value : Boolean);
-- Set the default value for match in declarations.
-- This is used so that if no file was provided in the
-- command line, then every file match
- procedure Set_Directory
- (File : File_Reference;
- Dir : String);
- -- Set the directory for a file
+ procedure Reset_Directory (File : File_Reference);
+ -- Reset the cached directory for file. Next time Get_File is
+ -- called, the directory willl be recomputed.
- procedure Set_Unvisited (File_Ref : in File_Reference);
+ procedure Set_Unvisited (File_Ref : File_Reference);
-- Set File_Ref as unvisited. So Next_Unvisited_File will return it.
+ procedure Read_File
+ (File_Name : String;
+ Contents : out GNAT.OS_Lib.String_Access);
+ -- Reads File_Name into the newly allocated strig Contents. A
+ -- Types.EOF character will be added to the returned Contents to
+ -- simplify parsing. Name_Error is raised if the file was not found.
+ -- End_Error is raised if the file could not be read correctly. For
+ -- most systems correct reading means that the number of bytes read
+ -- is equal to the file size. The exception is OpenVMS where correct
+ -- reading means that the number of bytes read is less than or equal
+ -- to the file size.
+
private
type Project_File (Src_Dir_Length, Obj_Dir_Length : Natural) is record
Src_Dir : String (1 .. Src_Dir_Length);
@@ -291,8 +306,6 @@ private
-- This is actually a list of all the directories to be searched,
-- either for source files or for library files
- type String_Access is access all String;
-
type Ref_In_File;
type Ref_In_File_Ptr is access all Ref_In_File;
@@ -306,14 +319,17 @@ private
type File_Reference is access all File_Record;
Empty_File : constant File_Reference := null;
+ type Cst_String_Access is access constant String;
- type File_Record (File_Length : Natural) is record
- File : String (1 .. File_Length);
- Dir : String_Access := null;
+ procedure Free (Str : in out Cst_String_Access);
+
+ type File_Record is record
+ File : Cst_String_Access;
+ Dir : GNAT.OS_Lib.String_Access;
Lines : Ref_In_File_Ptr := null;
Visited : Boolean := False;
Emit_Warning : Boolean := False;
- Gnatchop_File : String_Access := null;
+ Gnatchop_File : GNAT.OS_Lib.String_Access := null;
Gnatchop_Offset : Integer := 0;
Next : File_Reference := null;
end record;
@@ -322,6 +338,9 @@ private
-- extracted From. Gnatchop_Offset contains the index of the first line of
-- File within Gnatchop_File. These two fields are used to properly support
-- gnatchop files and pragma Source_Reference.
+ --
+ -- Lines is used for files that were given on the command line, to
+ -- memorize the lines and columns that the user specified.
type Reference_Record;
type Reference is access all Reference_Record;
@@ -332,12 +351,13 @@ private
File : File_Reference;
Line : Natural;
Column : Natural;
- Source_Line : Ada.Strings.Unbounded.Unbounded_String;
+ Source_Line : Cst_String_Access;
Next : Reference := null;
end record;
-- File is a reference to the Ada source file
-- Source_Line is the Line as it appears in the source file. This
- -- field is only used when the switch is set on the command line
+ -- field is only used when the switch is set on the command line of
+ -- gnatfind.
type Declaration_Record;
type Declaration_Reference is access all Declaration_Record;
@@ -345,30 +365,22 @@ private
Empty_Declaration : constant Declaration_Reference := null;
type Declaration_Record (Symbol_Length : Natural) is record
- Symbol : String (1 .. Symbol_Length);
- Decl : aliased Reference_Record;
- Decl_Type : Character;
- Body_Ref : Reference := null;
- Ref_Ref : Reference := null;
- Modif_Ref : Reference := null;
- Match : Boolean := False;
- Par_Symbol : Declaration_Reference := null;
- Next : Declaration_Reference := null;
- end record;
-
- type File_Table is record
- Table : File_Reference := null;
- Longest_Name : Natural := 0;
- end record;
-
- type Entity_Table is record
- Table : Declaration_Reference := null;
+ Key : Cst_String_Access;
+ Symbol : String (1 .. Symbol_Length);
+ Decl : Reference;
+ Is_Parameter : Boolean := False; -- True if entity is subprog param
+ Decl_Type : Character;
+ Body_Ref : Reference := null;
+ Ref_Ref : Reference := null;
+ Modif_Ref : Reference := null;
+ Match : Boolean := False;
+ Par_Symbol : Declaration_Reference := null;
+ Next : Declaration_Reference := null;
end record;
+ -- The lists of referenced (Body_Ref, Ref_Ref and Modif_Ref) are
+ -- kept unsorted until the results needs to be printed. This saves
+ -- lots of time while the internal tables are created.
- pragma Inline (First_Body);
- pragma Inline (First_Declaration);
- pragma Inline (First_Modif);
- pragma Inline (First_Reference);
pragma Inline (Get_Column);
pragma Inline (Get_Emit_Warning);
pragma Inline (Get_File);
@@ -377,6 +389,4 @@ private
pragma Inline (Get_Symbol);
pragma Inline (Get_Type);
pragma Inline (Longest_File_Name);
- pragma Inline (Next);
-
end Xr_Tabls;
diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb
index fcdac58f225..713a91baf83 100644
--- a/gcc/ada/xref_lib.adb
+++ b/gcc/ada/xref_lib.adb
@@ -2,7 +2,7 @@
-- --
-- GNAT COMPILER COMPONENTS --
-- --
--- X R E F _ L I B --
+-- X R E F _ L I B --
-- --
-- B o d y --
-- --
@@ -19,16 +19,19 @@
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Osint;
-with Output; use Output;
-with Types; use Types;
+with Output; use Output;
+with Types; use Types;
+
with Unchecked_Deallocation;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
+with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Command_Line; use GNAT.Command_Line;
with GNAT.IO_Aux; use GNAT.IO_Aux;
@@ -45,31 +48,38 @@ package body Xref_Lib is
Pipe : constant Character := '|';
-- First character on xref lines in the .ali file
- EOF : constant Character := ASCII.SUB;
- -- Special character to signal end of file. Not required in input file,
- -- but should be properly treated if present. See also Read_File.
-
No_Xref_Information : exception;
-- Exception raised when there is no cross-referencing information in
-- the .ali files
- subtype File_Offset is Natural;
-
- procedure Read_File
- (FD : File_Descriptor;
- Contents : out String_Access;
- Success : out Boolean);
- -- Reads file associated with FS into the newly allocated
- -- string Contents. An EOF character will be added to the
- -- returned Contents to simplify parsing.
- -- [VMS] Success is true iff the number of bytes read is less than or
- -- equal to the file size.
- -- [Other] Success is true iff the number of bytes read is equal to
- -- the file size.
-
- procedure Parse_EOL (Source : access String; Ptr : in out Positive);
+ procedure Parse_EOL
+ (Source : access String;
+ Ptr : in out Positive;
+ Skip_Continuation_Line : Boolean := False);
-- On return Source (Ptr) is the first character of the next line
-- or EOF. Source.all must be terminated by EOF.
+ --
+ -- If Skip_Continuation_Line is True, this subprogram skips as many
+ -- lines as required when the second or more lines starts with '.'
+ -- (continuation lines in ALI files).
+
+ function Current_Xref_File (File : ALI_File) return File_Reference;
+ -- Return the file matching the last 'X' line we found while parsing
+ -- the ALI file.
+
+ function File_Name (File : ALI_File; Num : Positive) return File_Reference;
+ -- Returns the dependency file name number Num
+
+ function Get_Full_Type (Decl : Declaration_Reference) return String;
+ -- Returns the full type corresponding to a type letter as found in
+ -- the .ali files.
+
+ procedure Open
+ (Name : in String;
+ File : out ALI_File;
+ Dependencies : in Boolean := False);
+ -- Open a new ALI file. If Dependencies is True, the insert every library
+ -- file 'with'ed in the files database (used for gnatxref)
procedure Parse_Identifier_Info
(Pattern : Search_Pattern;
@@ -77,20 +87,24 @@ package body Xref_Lib is
Local_Symbols : Boolean;
Der_Info : Boolean := False;
Type_Tree : Boolean := False;
- Wide_Search : Boolean := True);
+ Wide_Search : Boolean := True;
+ Labels_As_Ref : Boolean := True);
-- Output the file and the line where the identifier was referenced,
-- If Local_Symbols is False then only the publicly visible symbols
- -- will be processed
+ -- will be processed.
+ --
+ -- If Labels_As_Ref is true, then the references to the entities after
+ -- the end statements ("end Foo") will be counted as actual references.
+ -- The entity will never be reported as unreferenced by gnatxref -u
procedure Parse_Token
(Source : access String;
Ptr : in out Positive;
Token_Ptr : out Positive);
-- Skips any separators and stores the start of the token in Token_Ptr.
- -- Then stores the position of the next separator in Ptr.
- -- On return Source (Token_Ptr .. Ptr - 1) is the token.
- -- Separators are space and ASCII.HT.
- -- Parse_Token will never skip to the next line.
+ -- Then stores the position of the next separator in Ptr. On return
+ -- Source (Token_Ptr .. Ptr - 1) is the token. Separators are space
+ -- and ASCII.HT. Parse_Token will never skip to the next line.
procedure Parse_Number
(Source : access String;
@@ -103,6 +117,16 @@ package body Xref_Lib is
-- Reads and processes "X..." lines in the ALI file
-- and updates the File.X_File information.
+ procedure Skip_To_First_X_Line
+ (File : in out ALI_File;
+ D_Lines : Boolean;
+ W_Lines : Boolean);
+ -- Skip the lines in the ALI file until the first cross-reference line
+ -- (^X...) is found. Search is started from the beginning of the file.
+ -- If not such line is found, No_Xref_Information is raised.
+ -- If W_Lines is false, then the lines "^W" are not parsed.
+ -- If D_Lines is false, then the lines "^D" are not parsed.
+
----------------
-- Add_Entity --
----------------
@@ -112,24 +136,23 @@ package body Xref_Lib is
Entity : String;
Glob : Boolean := False)
is
- File_Start : Natural;
- Line_Start : Natural;
- Col_Start : Natural;
- Line_Num : Natural := 0;
- Col_Num : Natural := 0;
- File_Ref : File_Reference := Empty_File;
- File_Existed : Boolean;
- Has_Pattern : Boolean := False;
+ File_Start : Natural;
+ Line_Start : Natural;
+ Col_Start : Natural;
+ Line_Num : Natural := 0;
+ Col_Num : Natural := 0;
+ File_Ref : File_Reference := Empty_File;
+ Has_Pattern : Boolean := False;
begin
-- Find the end of the first item in Entity (pattern or file?)
-- If there is no ':', we only have a pattern
File_Start := Index (Entity, ":");
- if File_Start = 0 then
- -- If the regular expression is invalid, just consider it as a string
+ -- If the regular expression is invalid, just consider it as a string
+ if File_Start = 0 then
begin
Pattern.Entity := Compile (Entity, Glob, False);
Pattern.Initialized := True;
@@ -162,19 +185,18 @@ package body Xref_Lib is
-- If there is a dot in the pattern, then it is a file name
if (Glob and then
- Index (Entity (Entity'First .. File_Start - 1), ".") /= 0)
- or else
- (not Glob
- and then Index (Entity (Entity'First .. File_Start - 1),
+ Index (Entity (Entity'First .. File_Start - 1), ".") /= 0)
+ or else
+ (not Glob
+ and then Index (Entity (Entity'First .. File_Start - 1),
"\.") /= 0)
then
- Pattern.Entity := Compile (".*", False);
+ Pattern.Entity := Compile (".*", False);
Pattern.Initialized := True;
- File_Start := Entity'First;
+ File_Start := Entity'First;
else
- -- If the regular expression is invalid,
- -- just consider it as a string
+ -- If the regular expression is invalid, just consider it as a string
begin
Pattern.Entity :=
@@ -251,16 +273,16 @@ package body Xref_Lib is
end if;
end if;
- Add_To_Xref_File (Entity (File_Start .. Line_Start - 1),
- File_Existed,
- File_Ref,
- Visited => True);
- Add_Line (File_Ref, Line_Num, Col_Num);
- Add_To_Xref_File
- (ALI_File_Name (Entity (File_Start .. Line_Start - 1)),
- File_Existed, File_Ref,
- Visited => False,
- Emit_Warning => True);
+ File_Ref :=
+ Add_To_Xref_File
+ (Entity (File_Start .. Line_Start - 1), Visited => True);
+ Pattern.File_Ref := File_Ref;
+ Add_Line (Pattern.File_Ref, Line_Num, Col_Num);
+ File_Ref :=
+ Add_To_Xref_File
+ (ALI_File_Name (Entity (File_Start .. Line_Start - 1)),
+ Visited => False,
+ Emit_Warning => True);
end Add_Entity;
-------------------
@@ -268,9 +290,8 @@ package body Xref_Lib is
-------------------
procedure Add_Xref_File (File : String) is
- File_Ref : File_Reference := Empty_File;
- File_Existed : Boolean;
- Iterator : Expansion_Iterator;
+ File_Ref : File_Reference := Empty_File;
+ Iterator : Expansion_Iterator;
procedure Add_Xref_File_Internal (File : String);
-- Do the actual addition of the file
@@ -285,26 +306,16 @@ package body Xref_Lib is
-- not official usage, since the intention is obvious
if Tail (File, 4) = ".ali" then
- Add_To_Xref_File
- (File,
- File_Existed,
- File_Ref,
- Visited => False,
- Emit_Warning => True);
+ File_Ref := Add_To_Xref_File
+ (File, Visited => False, Emit_Warning => True);
-- Normal non-ali file case
else
- Add_To_Xref_File
- (File,
- File_Existed,
- File_Ref,
- Visited => True);
+ File_Ref := Add_To_Xref_File (File, Visited => True);
- Add_To_Xref_File
+ File_Ref := Add_To_Xref_File
(ALI_File_Name (File),
- File_Existed,
- File_Ref,
Visited => False,
Emit_Warning => True);
end if;
@@ -400,7 +411,6 @@ package body Xref_Lib is
My_Dir : Rec_DIR;
Dir_Ent : File_Name_String;
Last : Natural;
- File_Existed : Boolean;
File_Ref : File_Reference;
function Open_Next_Dir return Boolean;
@@ -420,7 +430,7 @@ package body Xref_Lib is
Obj_Dir : constant String := Next_Obj_Dir;
begin
- -- If there was no more Obj_Dir line
+ -- Case of no more Obj_Dir lines
if Obj_Dir'Length = 0 then
return False;
@@ -430,6 +440,7 @@ package body Xref_Lib is
exit;
exception
+
-- Could not open the directory
when Directory_Error => null;
@@ -442,6 +453,8 @@ package body Xref_Lib is
-- Start of processing for Find_ALI_Files
begin
+ Reset_Obj_Dir;
+
if Open_Next_Dir then
loop
Read (My_Dir.Dir, Dir_Ent, Last);
@@ -454,12 +467,8 @@ package body Xref_Lib is
end if;
elsif Last > 4 and then Dir_Ent (Last - 3 .. Last) = ".ali" then
- Add_To_Xref_File
- (Dir_Ent (1 .. Last),
- File_Existed,
- File_Ref,
- Visited => False);
- Set_Directory (File_Ref, Current_Obj_Dir);
+ File_Ref :=
+ Add_To_Xref_File (Dir_Ent (1 .. Last), Visited => False);
end if;
end loop;
end if;
@@ -469,9 +478,29 @@ package body Xref_Lib is
-- Get_Full_Type --
-------------------
- function Get_Full_Type (Abbrev : Character) return String is
+ function Get_Full_Type (Decl : Declaration_Reference) return String is
+
+ function Param_String return String;
+ -- Return the string to display depending on whether Decl is a
+ -- parameter or not
+
+ ------------------
+ -- Param_String --
+ ------------------
+
+ function Param_String return String is
+ begin
+ if Is_Parameter (Decl) then
+ return "parameter ";
+ else
+ return "";
+ end if;
+ end Param_String;
+
+ -- Start of processing for Get_Full_Type
+
begin
- case Abbrev is
+ case Get_Type (Decl) is
when 'A' => return "array type";
when 'B' => return "boolean type";
when 'C' => return "class-wide type";
@@ -488,19 +517,21 @@ package body Xref_Lib is
when 'W' => return "protected type";
when 'a' => return "array type";
- when 'b' => return "boolean object";
- when 'c' => return "class-wide object";
- when 'd' => return "decimal object";
- when 'e' => return "enumeration object";
- when 'f' => return "float object";
- when 'i' => return "integer object";
- when 'm' => return "modular object";
- when 'o' => return "fixed object";
- when 'p' => return "access object";
- when 'r' => return "record object";
- when 's' => return "string object";
- when 't' => return "task object";
- when 'w' => return "protected object";
+ when 'b' => return Param_String & "boolean object";
+ when 'c' => return Param_String & "class-wide object";
+ when 'd' => return Param_String & "decimal object";
+ when 'e' => return Param_String & "enumeration object";
+ when 'f' => return Param_String & "float object";
+ when 'i' => return Param_String & "integer object";
+ when 'm' => return Param_String & "modular object";
+ when 'o' => return Param_String & "fixed object";
+ when 'p' => return Param_String & "access object";
+ when 'r' => return Param_String & "record object";
+ when 's' => return Param_String & "string object";
+ when 't' => return Param_String & "task object";
+ when 'w' => return Param_String & "protected object";
+ when 'x' => return Param_String & "abstract procedure";
+ when 'y' => return Param_String & "abstract function";
when 'K' => return "package";
when 'k' => return "generic package";
@@ -516,71 +547,38 @@ package body Xref_Lib is
when 'X' => return "exception";
when 'Y' => return "entry";
- -- The above should be the only possibilities, but for a
- -- tool like this we don't want to bomb if we find something
- -- else, so just return ??? when we have an unknown Abbrev value
+ when '+' => return "private type";
+
+ -- The above should be the only possibilities, but for this kind
+ -- of informational output, we don't want to bomb if we find
+ -- something else, so just return three question marks when we
+ -- have an unknown Abbrev value
when others =>
- return "???";
+ return "??? (" & Get_Type (Decl) & ")";
end case;
end Get_Full_Type;
- -----------
- -- Match --
- -----------
-
- function Match
- (Pattern : Search_Pattern;
- Symbol : String)
- return Boolean
- is
- begin
- -- Get the entity name
-
- return Match (Symbol, Pattern.Entity);
- end Match;
-
- ----------
- -- Open --
- ----------
+ --------------------------
+ -- Skip_To_First_X_Line --
+ --------------------------
- procedure Open
- (Name : String;
- File : out ALI_File;
- Dependencies : Boolean := False)
+ procedure Skip_To_First_X_Line
+ (File : in out ALI_File;
+ D_Lines : Boolean;
+ W_Lines : Boolean)
is
- Name_0 : constant String := Name & ASCII.NUL;
- Num_Dependencies : Natural := 0;
- File_Existed : Boolean;
- File_Ref : File_Reference;
- FD : File_Descriptor;
- Success : Boolean := False;
Ali : String_Access renames File.Buffer;
Token : Positive;
- Ptr : Positive;
+ Ptr : Positive := Ali'First;
+ Num_Dependencies : Natural := 0;
+ File_Ref : File_Reference;
File_Start : Positive;
File_End : Positive;
Gnatchop_Offset : Integer;
Gnatchop_Name : Positive;
begin
- if File.Buffer /= null then
- Free (File.Buffer);
- end if;
-
- Init (File.Dep);
-
- FD := Open_Read (Name_0'Address, Binary);
-
- if FD = Invalid_FD then
- raise No_Xref_Information;
- end if;
-
- Read_File (FD, Ali, Success);
- Close (FD);
-
- Ptr := Ali'First;
-
-- Read all the lines possibly processing with-clauses and dependency
-- information and exit on finding the first Xref line.
-- A fall-through of the loop means that there is no xref information
@@ -588,12 +586,12 @@ package body Xref_Lib is
while Ali (Ptr) /= EOF loop
- if Ali (Ptr) = 'D' then
+ if D_Lines and then Ali (Ptr) = 'D' then
+
-- Found dependency information. Format looks like:
- -- D source-name time-stamp checksum [subunit-name] \
- -- [line:file-name]
+ -- D src-nam time-stmp checksum [subunit-name] [line:file-name]
- -- Skip the D and parse the filename
+ -- Skip the D and parse the filenam
Ptr := Ptr + 1;
Parse_Token (Ali, Ptr, Token);
@@ -612,6 +610,7 @@ package body Xref_Lib is
end if;
-- Did we have a gnatchop-ed file with a pragma Source_Reference ?
+
Gnatchop_Offset := 0;
if Ali (Token) in '0' .. '9' then
@@ -619,19 +618,19 @@ package body Xref_Lib is
while Ali (Gnatchop_Name) /= ':' loop
Gnatchop_Name := Gnatchop_Name + 1;
end loop;
+
Gnatchop_Offset :=
2 - Natural'Value (Ali (Token .. Gnatchop_Name - 1));
Token := Gnatchop_Name + 1;
end if;
- Add_To_Xref_File
+ File.Dep.Table (Num_Dependencies) := Add_To_Xref_File
(Ali (File_Start .. File_End),
- File_Existed,
- File.Dep.Table (Num_Dependencies),
Gnatchop_File => Ali (Token .. Ptr - 1),
Gnatchop_Offset => Gnatchop_Offset);
- elsif Dependencies and then Ali (Ptr) = 'W' then
+ elsif W_Lines and then Ali (Ptr) = 'W' then
+
-- Found with-clause information. Format looks like:
-- "W debug%s debug.adb debug.ali"
@@ -641,13 +640,11 @@ package body Xref_Lib is
Parse_Token (Ali, Ptr, Token);
Parse_Token (Ali, Ptr, Token);
- Add_To_Xref_File
- (Ali (Token .. Ptr - 1),
- File_Existed,
- File_Ref,
- Visited => False);
+ File_Ref := Add_To_Xref_File
+ (Ali (Token .. Ptr - 1), Visited => False);
elsif Ali (Ptr) = 'X' then
+
-- Found a cross-referencing line - stop processing
File.Current_Line := Ptr;
@@ -659,33 +656,70 @@ package body Xref_Lib is
end loop;
raise No_Xref_Information;
+ end Skip_To_First_X_Line;
+
+ ----------
+ -- Open --
+ ----------
+
+ procedure Open
+ (Name : String;
+ File : out ALI_File;
+ Dependencies : Boolean := False)
+ is
+ Ali : String_Access renames File.Buffer;
+
+ begin
+ if File.Buffer /= null then
+ Free (File.Buffer);
+ end if;
+
+ Init (File.Dep);
+
+ begin
+ Read_File (Name, Ali);
+
+ exception
+ when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error =>
+ raise No_Xref_Information;
+ end;
+
+ Skip_To_First_X_Line (File, D_Lines => True, W_Lines => Dependencies);
end Open;
---------------
-- Parse_EOL --
---------------
- procedure Parse_EOL (Source : access String; Ptr : in out Positive) is
+ procedure Parse_EOL
+ (Source : access String;
+ Ptr : in out Positive;
+ Skip_Continuation_Line : Boolean := False)
+ is
begin
- -- Skip to end of line
-
- while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF
- and then Source (Ptr) /= EOF
loop
- Ptr := Ptr + 1;
- end loop;
+ -- Skip to end of line
- if Source (Ptr) /= EOF then
- Ptr := Ptr + 1; -- skip CR or LF
- end if;
+ while Source (Ptr) /= ASCII.CR and then Source (Ptr) /= ASCII.LF
+ and then Source (Ptr) /= EOF
+ loop
+ Ptr := Ptr + 1;
+ end loop;
+
+ if Source (Ptr) /= EOF then
+ Ptr := Ptr + 1; -- skip CR or LF
+ end if;
- -- Skip past CR/LF or LF/CR combination
+ -- Skip past CR/LF or LF/CR combination
- if (Source (Ptr) = ASCII.CR or else Source (Ptr) = ASCII.LF)
- and then Source (Ptr) /= Source (Ptr - 1)
- then
- Ptr := Ptr + 1;
- end if;
+ if (Source (Ptr) = ASCII.CR or else Source (Ptr) = ASCII.LF)
+ and then Source (Ptr) /= Source (Ptr - 1)
+ then
+ Ptr := Ptr + 1;
+ end if;
+
+ exit when not Skip_Continuation_Line or else Source (Ptr) /= '.';
+ end loop;
end Parse_EOL;
---------------------------
@@ -698,7 +732,8 @@ package body Xref_Lib is
Local_Symbols : Boolean;
Der_Info : Boolean := False;
Type_Tree : Boolean := False;
- Wide_Search : Boolean := True)
+ Wide_Search : Boolean := True;
+ Labels_As_Ref : Boolean := True)
is
Ptr : Positive renames File.Current_Line;
Ali : String_Access renames File.Buffer;
@@ -734,19 +769,6 @@ package body Xref_Lib is
E_Name : Positive; -- Pointer to begin of entity name
E_Type : Character; -- Type of current entity
- procedure Skip_Line;
- -- skip current line and continuation line
-
- procedure Skip_Line is
- begin
- loop
- Parse_EOL (Ali, Ptr);
- exit when Ali (Ptr) /= '.';
- end loop;
- end Skip_Line;
-
- -- Start of processing for Get_Symbol_Name
-
begin
-- Look for the X lines corresponding to unit Eun
@@ -757,7 +779,7 @@ package body Xref_Lib is
exit when E_Eun = Eun;
end if;
- Skip_Line;
+ Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
end loop;
-- Here we are in the right Ali section, we now look for the entity
@@ -766,8 +788,10 @@ package body Xref_Lib is
loop
Parse_Number (Ali, Ptr, E_Line);
E_Type := Ali (Ptr);
+ exit when Ali (Ptr) = EOF;
Ptr := Ptr + 1;
Parse_Number (Ali, Ptr, E_Col);
+ exit when Ali (Ptr) = EOF;
Ptr := Ptr + 1;
if Line = E_Line and then Col = E_Col then
@@ -775,7 +799,8 @@ package body Xref_Lib is
return Ali (E_Name .. Ptr - 1);
end if;
- Skip_Line;
+ Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
+ exit when Ali (Ptr) = EOF;
end loop;
-- We were not able to find the symbol, this should not happend but
@@ -800,6 +825,17 @@ package body Xref_Lib is
Ptr := Ptr + 1;
end if;
+ -- Ignore some of the entities (labels,...)
+
+ case E_Type is
+ when 'l' | 'L' | 'q' =>
+ Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
+ return;
+
+ when others =>
+ null;
+ end case;
+
Parse_Number (Ali, Ptr, E_Col);
E_Global := False;
@@ -815,15 +851,13 @@ package body Xref_Lib is
if (not Local_Symbols and not E_Global)
or else (Pattern.Initialized
- and then not Match (Pattern, Ali (E_Name .. Ptr - 1)))
+ and then not Match (Ali (E_Name .. Ptr - 1), Pattern.Entity))
or else (E_Name >= Ptr)
then
- -- Skip rest of this line and all continuation lines
-
- loop
- Parse_EOL (Ali, Ptr);
- exit when Ali (Ptr) /= '.';
- end loop;
+ Decl_Ref := Add_Declaration
+ (File.X_File, Ali (E_Name .. Ptr - 1), E_Line, E_Col, E_Type,
+ Remove_Only => True);
+ Parse_EOL (Ali, Ptr, Skip_Continuation_Line => True);
return;
end if;
@@ -836,7 +870,6 @@ package body Xref_Lib is
or else Ali (Ptr) = '('
or else Ali (Ptr) = '{'
then
-
-- Here we have a type derivation information. The format is
-- <3|12I45> which means that the current entity is derived from the
-- type defined in unit number 3, line 12 column 45. The pipe and
@@ -893,15 +926,27 @@ package body Xref_Lib is
-- on or if we want to output the type hierarchy
if Der_Info or else Type_Tree then
- Add_Parent
- (Decl_Ref,
- Get_Symbol_Name (P_Eun, P_Line, P_Column),
- P_Line,
- P_Column,
- File.Dep.Table (P_Eun));
+ declare
+ Symbol : constant String :=
+ Get_Symbol_Name (P_Eun, P_Line, P_Column);
+
+ begin
+ if Symbol /= "???" then
+ Add_Parent
+ (Decl_Ref,
+ Symbol,
+ P_Line,
+ P_Column,
+ File.Dep.Table (P_Eun));
+ end if;
+ end;
end if;
- if Type_Tree then
+ if Type_Tree
+ and then (Pattern.File_Ref = Empty_File
+ or else
+ Pattern.File_Ref = Current_Xref_File (File))
+ then
Search_Parent_Tree : declare
Pattern : Search_Pattern; -- Parent type pattern
File_Pos_Backup : Positive;
@@ -913,7 +958,7 @@ package body Xref_Lib is
& ':' & Get_Gnatchop_File (File.Dep.Table (P_Eun))
& ':' & Get_Line (Get_Parent (Decl_Ref))
& ':' & Get_Column (Get_Parent (Decl_Ref)),
- False);
+ False);
-- No default match is needed to look for the parent type
-- since we are using the fully qualified symbol name:
@@ -921,34 +966,25 @@ package body Xref_Lib is
Set_Default_Match (False);
- -- The parent type is defined in the same unit as the
- -- derived type. So we want to revisit the unit.
+ -- The parent hierarchy is defined in the same unit as
+ -- the derived type. So we want to revisit the unit.
File_Pos_Backup := File.Current_Line;
- if File.Dep.Table (P_Eun) = File_Ref then
-
- -- set file pointer at the start of the xref lines
-
- File.Current_Line := File.Xref_Line;
-
- Revisit_ALI_File : declare
- File_Existed : Boolean;
- File_Ref : File_Reference;
-
- begin
- Add_To_Xref_File
- (ALI_File_Name
- (Get_File (File.Dep.Table (P_Eun))),
- File_Existed,
- File_Ref,
- Visited => False);
- Set_Unvisited (File_Ref);
- end Revisit_ALI_File;
- end if;
-
- Search (Pattern,
- Local_Symbols, False, False, Der_Info, Type_Tree);
+ Skip_To_First_X_Line
+ (File, D_Lines => False, W_Lines => False);
+
+ while File.Buffer (File.Current_Line) /= EOF loop
+ Parse_X_Filename (File);
+ Parse_Identifier_Info
+ (Pattern => Pattern,
+ File => File,
+ Local_Symbols => False,
+ Der_Info => Der_Info,
+ Type_Tree => True,
+ Wide_Search => False,
+ Labels_As_Ref => Labels_As_Ref);
+ end loop;
File.Current_Line := File_Pos_Backup;
end Search_Parent_Tree;
@@ -968,6 +1004,7 @@ package body Xref_Lib is
elsif Ali (Ptr) = '=' then
declare
P_Line, P_Column : Natural;
+
begin
Ptr := Ptr + 1;
Parse_Number (Ali, Ptr, P_Line);
@@ -980,14 +1017,11 @@ package body Xref_Lib is
if Wide_Search then
declare
- File_Existed : Boolean;
File_Ref : File_Reference;
File_Name : constant String :=
Get_Gnatchop_File (File.X_File);
-
begin
- Add_To_Xref_File
- (ALI_File_Name (File_Name), File_Existed, File_Ref, False);
+ File_Ref := Add_To_Xref_File (ALI_File_Name (File_Name), False);
end;
end if;
@@ -1016,17 +1050,34 @@ package body Xref_Lib is
Ptr := Ptr + 1;
end if;
+ -- Imported entities might special indication as to their external
+ -- name:
+ -- 5U14*Foo2 5>20 6b<c,myfoo2>22
+
+ if R_Type = 'b'
+ and then Ali (Ptr) = '<'
+ then
+ while Ptr <= Ali'Last
+ and then Ali (Ptr) /= '>'
+ loop
+ Ptr := Ptr + 1;
+ end loop;
+ Ptr := Ptr + 1;
+ end if;
+
Parse_Number (Ali, Ptr, R_Col);
-- Insert the reference or body in the table
- Add_Reference (Decl_Ref, File_Ref, R_Line, R_Col, R_Type);
+ Add_Reference
+ (Decl_Ref, File_Ref, R_Line, R_Col, R_Type, Labels_As_Ref);
-- Skip generic information, if any
if Ali (Ptr) = '[' then
declare
Num_Nested : Integer := 1;
+
begin
Ptr := Ptr + 1;
while Num_Nested /= 0 loop
@@ -1035,6 +1086,7 @@ package body Xref_Lib is
elsif Ali (Ptr) = '[' then
Num_Nested := Num_Nested + 1;
end if;
+
Ptr := Ptr + 1;
end loop;
end;
@@ -1056,9 +1108,9 @@ package body Xref_Lib is
------------------
procedure Parse_Number
- (Source : access String;
- Ptr : in out Positive;
- Number : out Natural)
+ (Source : access String;
+ Ptr : in out Positive;
+ Number : out Natural)
is
begin
-- Skip separators
@@ -1069,8 +1121,8 @@ package body Xref_Lib is
Number := 0;
while Source (Ptr) in '0' .. '9' loop
- Number := 10 * Number
- + (Character'Pos (Source (Ptr)) - Character'Pos ('0'));
+ Number :=
+ 10 * Number + (Character'Pos (Source (Ptr)) - Character'Pos ('0'));
Ptr := Ptr + 1;
end loop;
end Parse_Number;
@@ -1084,7 +1136,7 @@ package body Xref_Lib is
Ptr : in out Positive;
Token_Ptr : out Positive)
is
- In_Quotes : Boolean := False;
+ In_Quotes : Character := ASCII.NUL;
begin
-- Skip separators
@@ -1097,18 +1149,30 @@ package body Xref_Lib is
-- Find end-of-token
- while (In_Quotes or else
+ while (In_Quotes /= ASCII.NUL or else
not (Source (Ptr) = ' '
- or else Source (Ptr) = ASCII.HT
- or else Source (Ptr) = '<'
- or else Source (Ptr) = '{'
- or else Source (Ptr) = '='
- or else Source (Ptr) = '('))
+ or else Source (Ptr) = ASCII.HT
+ or else Source (Ptr) = '<'
+ or else Source (Ptr) = '{'
+ or else Source (Ptr) = '='
+ or else Source (Ptr) = '('))
and then Source (Ptr) >= ' '
loop
- if Source (Ptr) = '"' then
- In_Quotes := not In_Quotes;
- end if;
+ -- Double-quotes are used for operators
+ -- Simple-quotes are used for character constants, for instance when
+ -- they are found in an enumeration type "type A is ('+', '-');"
+
+ case Source (Ptr) is
+ when '"' | ''' =>
+ if In_Quotes = Source (Ptr) then
+ In_Quotes := ASCII.NUL;
+ elsif In_Quotes = ASCII.NUL then
+ In_Quotes := Source (Ptr);
+ end if;
+
+ when others =>
+ null;
+ end case;
Ptr := Ptr + 1;
end loop;
@@ -1142,7 +1206,6 @@ package body Xref_Lib is
Parse_EOL (Ali, Ptr);
end loop;
-
end Parse_X_Filename;
--------------------
@@ -1153,9 +1216,9 @@ package body Xref_Lib is
(References : Boolean;
Full_Path_Name : Boolean)
is
- Decl : Declaration_Reference := First_Declaration;
- Ref1 : Reference;
- Ref2 : Reference;
+ Decls : constant Declaration_Array_Access := Get_Declarations;
+ Decl : Declaration_Reference;
+ Arr : Reference_Array_Access;
procedure Print_Ref
(Ref : Reference;
@@ -1170,20 +1233,26 @@ package body Xref_Lib is
(Ref : Reference;
Msg : String := " ")
is
+ F : String_Access :=
+ Osint.To_Host_File_Spec
+ (Get_Gnatchop_File (Ref, Full_Path_Name));
+
Buffer : constant String :=
- Osint.To_Host_File_Spec
- (Get_Gnatchop_File (Ref, Full_Path_Name)).all
- & ":" & Get_Line (Ref)
- & ":" & Get_Column (Ref)
- & ": ";
+ F.all &
+ ":" & Get_Line (Ref) &
+ ":" & Get_Column (Ref) &
+ ": ";
+
Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length;
begin
+ Free (F);
Num_Blanks := Integer'Max (0, Num_Blanks);
Write_Line
(Buffer
& String'(1 .. Num_Blanks => ' ')
& Msg & " " & Get_Symbol (Decl));
+
if Get_Source_Line (Ref)'Length /= 0 then
Write_Line (" " & Get_Source_Line (Ref));
end if;
@@ -1192,35 +1261,45 @@ package body Xref_Lib is
-- Start of processing for Print_Gnatfind
begin
- while Decl /= Empty_Declaration loop
+ for D in Decls'Range loop
+ Decl := Decls (D);
+
if Match (Decl) then
-- Output the declaration
declare
Parent : constant Declaration_Reference := Get_Parent (Decl);
+
+ F : String_Access :=
+ Osint.To_Host_File_Spec
+ (Get_Gnatchop_File (Decl, Full_Path_Name));
+
Buffer : constant String :=
- Osint.To_Host_File_Spec
- (Get_Gnatchop_File (Decl, Full_Path_Name)).all
- & ":" & Get_Line (Decl)
- & ":" & Get_Column (Decl)
- & ": ";
+ F.all &
+ ":" & Get_Line (Decl) &
+ ":" & Get_Column (Decl) &
+ ": ";
+
Num_Blanks : Integer := Longest_File_Name + 10 - Buffer'Length;
begin
+ Free (F);
Num_Blanks := Integer'Max (0, Num_Blanks);
Write_Line
(Buffer & String'(1 .. Num_Blanks => ' ')
& "(spec) " & Get_Symbol (Decl));
if Parent /= Empty_Declaration then
+ F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent));
Write_Line
(Buffer & String'(1 .. Num_Blanks => ' ')
& " derived from " & Get_Symbol (Parent)
& " ("
- & Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent)).all
+ & F.all
& ':' & Get_Line (Parent)
& ':' & Get_Column (Parent) & ')');
+ Free (F);
end if;
end;
@@ -1230,30 +1309,25 @@ package body Xref_Lib is
-- Output the body (sorted)
- Ref1 := First_Body (Decl);
- while Ref1 /= Empty_Reference loop
- Print_Ref (Ref1, "(body)");
- Ref1 := Next (Ref1);
+ Arr := Get_References (Decl, Get_Bodies => True);
+
+ for R in Arr'Range loop
+ Print_Ref (Arr (R), "(body)");
end loop;
+ Free (Arr);
+
if References then
- Ref1 := First_Modif (Decl);
- Ref2 := First_Reference (Decl);
- while Ref1 /= Empty_Reference
- or else Ref2 /= Empty_Reference
- loop
- if Compare (Ref1, Ref2) = LessThan then
- Print_Ref (Ref1);
- Ref1 := Next (Ref1);
- else
- Print_Ref (Ref2);
- Ref2 := Next (Ref2);
- end if;
+ Arr := Get_References
+ (Decl, Get_Writes => True, Get_Reads => True);
+
+ for R in Arr'Range loop
+ Print_Ref (Arr (R));
end loop;
+
+ Free (Arr);
end if;
end if;
-
- Decl := Next (Decl);
end loop;
end Print_Gnatfind;
@@ -1262,41 +1336,48 @@ package body Xref_Lib is
------------------
procedure Print_Unused (Full_Path_Name : in Boolean) is
- Decl : Declaration_Reference := First_Declaration;
- Ref : Reference;
+ Decls : constant Declaration_Array_Access := Get_Declarations;
+ Decl : Declaration_Reference;
+ Arr : Reference_Array_Access;
+ F : String_Access;
begin
- while Decl /= Empty_Declaration loop
- if First_Modif (Decl) = Empty_Reference
- and then First_Reference (Decl) = Empty_Reference
+ for D in Decls'Range loop
+ Decl := Decls (D);
+
+ if References_Count
+ (Decl, Get_Reads => True, Get_Writes => True) = 0
then
+ F := Osint.To_Host_File_Spec
+ (Get_Gnatchop_File (Decl, Full_Path_Name));
Write_Str (Get_Symbol (Decl)
- & " "
- & Get_Type (Decl)
- & " "
- & Osint.To_Host_File_Spec
- (Get_Gnatchop_File (Decl, Full_Path_Name)).all
- & ':'
- & Get_Line (Decl)
- & ':'
- & Get_Column (Decl));
+ & " ("
+ & Get_Full_Type (Decl)
+ & ") "
+ & F.all
+ & ':'
+ & Get_Line (Decl)
+ & ':'
+ & Get_Column (Decl));
+ Free (F);
-- Print the body if any
- Ref := First_Body (Decl);
+ Arr := Get_References (Decl, Get_Bodies => True);
- if Ref /= Empty_Reference then
- Write_Line (' '
- & Osint.To_Host_File_Spec
- (Get_Gnatchop_File (Ref, Full_Path_Name)).all
- & ':' & Get_Line (Ref)
- & ':' & Get_Column (Ref));
- else
- Write_Eol;
- end if;
- end if;
+ for R in Arr'Range loop
+ F := Osint.To_Host_File_Spec
+ (Get_Gnatchop_File (Arr (R), Full_Path_Name));
+ Write_Str (' '
+ & F.all
+ & ':' & Get_Line (Arr (R))
+ & ':' & Get_Column (Arr (R)));
+ Free (F);
+ end loop;
- Decl := Next (Decl);
+ Write_Eol;
+ Free (Arr);
+ end if;
end loop;
end Print_Unused;
@@ -1305,40 +1386,46 @@ package body Xref_Lib is
--------------
procedure Print_Vi (Full_Path_Name : in Boolean) is
- Tab : constant Character := ASCII.HT;
- Decl : Declaration_Reference := First_Declaration;
- Ref : Reference;
+ Tab : constant Character := ASCII.HT;
+ Decls : constant Declaration_Array_Access :=
+ Get_Declarations (Sorted => False);
+ Decl : Declaration_Reference;
+ Arr : Reference_Array_Access;
+ F : String_Access;
begin
- while Decl /= Empty_Declaration loop
- Write_Line (Get_Symbol (Decl) & Tab
- & Get_File (Decl, Full_Path_Name) & Tab
- & Get_Line (Decl));
+ for D in Decls'Range loop
+ Decl := Decls (D);
+
+ F := Osint.To_Host_File_Spec (Get_File (Decl, Full_Path_Name));
+ Write_Line (Get_Symbol (Decl) & Tab & F.all & Tab & Get_Line (Decl));
+ Free (F);
-- Print the body if any
- Ref := First_Body (Decl);
+ Arr := Get_References (Decl, Get_Bodies => True);
- if Ref /= Empty_Reference then
- Write_Line (Get_Symbol (Decl) & Tab
- & Get_File (Ref, Full_Path_Name)
- & Tab
- & Get_Line (Ref));
- end if;
+ for R in Arr'Range loop
+ F := Osint.To_Host_File_Spec (Get_File (Arr (R), Full_Path_Name));
+ Write_Line
+ (Get_Symbol (Decl) & Tab & F.all & Tab & Get_Line (Arr (R)));
+ Free (F);
+ end loop;
+
+ Free (Arr);
-- Print the modifications
- Ref := First_Modif (Decl);
+ Arr := Get_References (Decl, Get_Writes => True, Get_Reads => True);
- while Ref /= Empty_Reference loop
- Write_Line (Get_Symbol (Decl) & Tab
- & Get_File (Ref, Full_Path_Name)
- & Tab
- & Get_Line (Ref));
- Ref := Next (Ref);
+ for R in Arr'Range loop
+ F := Osint.To_Host_File_Spec (Get_File (Arr (R), Full_Path_Name));
+ Write_Line
+ (Get_Symbol (Decl) & Tab & F.all & Tab & Get_Line (Arr (R)));
+ Free (F);
end loop;
- Decl := Next (Decl);
+ Free (Arr);
end loop;
end Print_Vi;
@@ -1347,9 +1434,8 @@ package body Xref_Lib is
----------------
procedure Print_Xref (Full_Path_Name : in Boolean) is
- Decl : Declaration_Reference := First_Declaration;
- Ref : Reference;
- File : File_Reference;
+ Decls : constant Declaration_Array_Access := Get_Declarations;
+ Decl : Declaration_Reference;
Margin : constant := 10;
-- Column where file names start
@@ -1363,6 +1449,15 @@ package body Xref_Lib is
procedure Print_Ref (Line, Column : String);
-- The beginning of the output is aligned on a column multiple of 9
+ procedure Print_List
+ (Decl : Declaration_Reference;
+ Msg : String;
+ Get_Reads : Boolean := False;
+ Get_Writes : Boolean := False;
+ Get_Bodies : Boolean := False);
+ -- Print a list of references. If the list is not empty, Msg will
+ -- be printed prior to the list.
+
----------------
-- New_Line80 --
----------------
@@ -1379,6 +1474,7 @@ package body Xref_Lib is
procedure Print80 (S : in String) is
Align : Natural := Margin - (Integer (Column) mod Margin);
+
begin
if Align = Margin then
Align := 0;
@@ -1412,25 +1508,76 @@ package body Xref_Lib is
Write_Str (String'(1 .. Align => ' ') & S);
end Print_Ref;
+ ----------------
+ -- Print_List --
+ ----------------
+
+ procedure Print_List
+ (Decl : Declaration_Reference;
+ Msg : String;
+ Get_Reads : Boolean := False;
+ Get_Writes : Boolean := False;
+ Get_Bodies : Boolean := False)
+ is
+ Arr : Reference_Array_Access :=
+ Get_References
+ (Decl,
+ Get_Writes => Get_Writes,
+ Get_Reads => Get_Reads,
+ Get_Bodies => Get_Bodies);
+ File : File_Reference := Empty_File;
+ F : String_Access;
+
+ begin
+ if Arr'Length /= 0 then
+ Write_Eol;
+ Write_Str (Msg);
+ end if;
+
+ for R in Arr'Range loop
+ if Get_File_Ref (Arr (R)) /= File then
+ if File /= Empty_File then
+ New_Line80;
+ end if;
+
+ File := Get_File_Ref (Arr (R));
+ F := Osint.To_Host_File_Spec
+ (Get_Gnatchop_File (Arr (R), Full_Path_Name));
+ Write_Str (F.all & ' ');
+ Free (F);
+ end if;
+
+ Print_Ref (Get_Line (Arr (R)), Get_Column (Arr (R)));
+ end loop;
+
+ Free (Arr);
+ end Print_List;
+
+ F : String_Access;
+
-- Start of processing for Print_Xref
begin
- while Decl /= Empty_Declaration loop
+ for D in Decls'Range loop
+ Decl := Decls (D);
+
Write_Str (Get_Symbol (Decl));
while Column < Type_Position loop
Write_Char (' ');
end loop;
- Write_Line (Get_Full_Type (Get_Type (Decl)));
+ Write_Line (Get_Full_Type (Decl));
Write_Parent_Info : declare
Parent : constant Declaration_Reference := Get_Parent (Decl);
+
begin
if Parent /= Empty_Declaration then
Write_Str (" Ptype: ");
- Print80
- (Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent)).all);
+ F := Osint.To_Host_File_Spec (Get_Gnatchop_File (Parent));
+ Print80 (F.all);
+ Free (F);
Print_Ref (Get_Line (Parent), Get_Column (Parent));
Print80 (" " & Get_Symbol (Parent));
Write_Eol;
@@ -1438,129 +1585,22 @@ package body Xref_Lib is
end Write_Parent_Info;
Write_Str (" Decl: ");
- Print80
- (Osint.To_Host_File_Spec
- (Get_Gnatchop_File (Decl, Full_Path_Name)).all & ' ');
+ F := Osint.To_Host_File_Spec
+ (Get_Gnatchop_File (Decl, Full_Path_Name));
+ Print80 (F.all & ' ');
+ Free (F);
Print_Ref (Get_Line (Decl), Get_Column (Decl));
- -- Print the body if any
-
- Ref := First_Body (Decl);
-
- if Ref /= Empty_Reference then
- Write_Eol;
- Write_Str (" Body: ");
- Print80
- (Osint.To_Host_File_Spec
- (Get_Gnatchop_File (Ref, Full_Path_Name)).all & ' ');
- Print_Ref (Get_Line (Ref), Get_Column (Ref));
- end if;
-
- -- Print the modifications if any
-
- Ref := First_Modif (Decl);
-
- if Ref /= Empty_Reference then
- Write_Eol;
- Write_Str (" Modi: ");
- end if;
-
- File := Empty_File;
-
- while Ref /= Empty_Reference loop
- if Get_File_Ref (Ref) /= File then
- if File /= Empty_File then
- New_Line80;
- end if;
-
- File := Get_File_Ref (Ref);
- Write_Str
- (Get_Gnatchop_File (Ref, Full_Path_Name) & ' ');
- Print_Ref (Get_Line (Ref), Get_Column (Ref));
-
- else
- Print_Ref (Get_Line (Ref), Get_Column (Ref));
- end if;
-
- Ref := Next (Ref);
- end loop;
-
- -- Print the references
-
- Ref := First_Reference (Decl);
-
- if Ref /= Empty_Reference then
- Write_Eol;
- Write_Str (" Ref: ");
- end if;
-
- File := Empty_File;
-
- while Ref /= Empty_Reference loop
- if Get_File_Ref (Ref) /= File then
- if File /= Empty_File then
- New_Line80;
- end if;
-
- File := Get_File_Ref (Ref);
- Write_Str
- (Osint.To_Host_File_Spec
- (Get_Gnatchop_File (Ref, Full_Path_Name)).all & ' ');
- Print_Ref (Get_Line (Ref), Get_Column (Ref));
-
- else
- Print_Ref (Get_Line (Ref), Get_Column (Ref));
- end if;
-
- Ref := Next (Ref);
- end loop;
-
+ Print_List
+ (Decl, " Body: ", Get_Bodies => True);
+ Print_List
+ (Decl, " Modi: ", Get_Writes => True);
+ Print_List
+ (Decl, " Ref: ", Get_Reads => True);
Write_Eol;
- Decl := Next (Decl);
end loop;
end Print_Xref;
- ---------------
- -- Read_File --
- ---------------
-
- procedure Read_File
- (FD : File_Descriptor;
- Contents : out String_Access;
- Success : out Boolean)
- is
- Length : constant File_Offset := File_Offset (File_Length (FD));
- -- Include room for EOF char
-
- Buffer : String (1 .. Length + 1);
-
- This_Read : Integer;
- Read_Ptr : File_Offset := 1;
-
- begin
-
- loop
- This_Read := Read (FD,
- A => Buffer (Read_Ptr)'Address,
- N => Length + 1 - Read_Ptr);
- Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
- exit when This_Read <= 0;
- end loop;
-
- Buffer (Read_Ptr) := EOF;
- Contents := new String'(Buffer (1 .. Read_Ptr));
-
- -- Things aren't simple on VMS due to the plethora of file types
- -- and organizations. It seems clear that there shouldn't be more
- -- bytes read than are contained in the file though.
-
- if Hostparm.OpenVMS then
- Success := Read_Ptr <= Length + 1;
- else
- Success := Read_Ptr = Length + 1;
- end if;
- end Read_File;
-
------------
-- Search --
------------
@@ -1576,10 +1616,10 @@ package body Xref_Lib is
type String_Access is access String;
procedure Free is new Unchecked_Deallocation (String, String_Access);
- ALIfile : ALI_File;
- File_Ref : File_Reference;
- Strip_Num : Natural := 0;
- Ali_Name : String_Access;
+ ALIfile : ALI_File;
+ File_Ref : File_Reference;
+ Strip_Num : Natural := 0;
+ Ali_Name : String_Access;
begin
-- If we want all the .ali files, then find them
@@ -1606,7 +1646,8 @@ package body Xref_Lib is
Ali_Name := new String'
(Get_File (File_Ref, With_Dir => True, Strip => Strip_Num));
- -- Striped too many things...
+ -- Stripped too many things...
+
if Ali_Name.all = "" then
if Get_Emit_Warning (File_Ref) then
Set_Standard_Error;
@@ -1618,29 +1659,45 @@ package body Xref_Lib is
Free (Ali_Name);
exit;
- -- If not found, try the parent's ALI file (this is needed for
- -- separate units and subprograms).
+ -- If not found, try the parent's ALI file (this is needed for
+ -- separate units and subprograms).
+
+ -- Reset the cached directory first, in case the separate's
+ -- ALI file is not in the same directory.
+
elsif not File_Exists (Ali_Name.all) then
Strip_Num := Strip_Num + 1;
+ Reset_Directory (File_Ref);
+
+ -- Else we finally found it
- -- Else we finally found it
else
exit;
end if;
end loop;
+ -- If we had to get the parent's ALI, insert it in the list as usual.
+ -- This is to avoid parsing it twice in case it has already been
+ -- parsed.
+
+ if Ali_Name /= null and then Strip_Num /= 0 then
+ File_Ref := Add_To_Xref_File
+ (File_Name => Ali_Name.all,
+ Visited => False);
+
-- Now that we have a file name, parse it to find any reference to
-- the entity.
- if Ali_Name /= null
+ elsif Ali_Name /= null
and then (Read_Only or else Is_Writable_File (Ali_Name.all))
then
begin
Open (Ali_Name.all, ALIfile);
while ALIfile.Buffer (ALIfile.Current_Line) /= EOF loop
Parse_X_Filename (ALIfile);
- Parse_Identifier_Info (Pattern, ALIfile, Local_Symbols,
- Der_Info, Type_Tree, Wide_Search);
+ Parse_Identifier_Info
+ (Pattern, ALIfile, Local_Symbols,
+ Der_Info, Type_Tree, Wide_Search, Labels_As_Ref => True);
end loop;
exception
@@ -1668,10 +1725,13 @@ package body Xref_Lib is
Read_Only : Boolean;
Der_Info : Boolean)
is
- ALIfile : ALI_File;
- File_Ref : File_Reference;
+ ALIfile : ALI_File;
+ File_Ref : File_Reference;
Null_Pattern : Search_Pattern;
+
begin
+ Null_Pattern.Initialized := False;
+
loop
-- Find the next unvisited file
@@ -1680,22 +1740,24 @@ package body Xref_Lib is
-- Search the object directories for the .ali file
- if Read_Only
- or else Is_Writable_File (Get_File (File_Ref, With_Dir => True))
- then
- begin
- Open (Get_File (File_Ref, With_Dir => True), ALIfile, True);
+ declare
+ F : constant String := Get_File (File_Ref, With_Dir => True);
+
+ begin
+ if Read_Only or else Is_Writable_File (F) then
+ Open (F, ALIfile, True);
while ALIfile.Buffer (ALIfile.Current_Line) /= EOF loop
Parse_X_Filename (ALIfile);
Parse_Identifier_Info
- (Null_Pattern, ALIfile, Local_Symbols, Der_Info);
+ (Null_Pattern, ALIfile, Local_Symbols, Der_Info,
+ Labels_As_Ref => False);
end loop;
+ end if;
- exception
- when No_Xref_Information => null;
- end;
- end if;
+ exception
+ when No_Xref_Information => null;
+ end;
end loop;
end Search_Xref;
diff --git a/gcc/ada/xref_lib.ads b/gcc/ada/xref_lib.ads
index dcbc5907659..1e0a14d4ce6 100644
--- a/gcc/ada/xref_lib.ads
+++ b/gcc/ada/xref_lib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -19,20 +19,21 @@
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+-- Miscellaneous utilities for the cross-referencing tool
+
with Hostparm;
+with Xr_Tabls; use Xr_Tabls;
+
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Dynamic_Tables;
-
-with Xr_Tabls; use Xr_Tabls;
with GNAT.Regexp; use GNAT.Regexp;
--- Misc. utilities for the cross-referencing tool
-
package Xref_Lib is
subtype File_Name_String is String (1 .. Hostparm.Max_Name_Length);
@@ -43,6 +44,7 @@ package Xref_Lib is
---------------------
-- Directory Input --
---------------------
+
type Rec_DIR is limited private;
-- This one is used for recursive search of .ali files
@@ -73,12 +75,6 @@ package Xref_Lib is
Invalid_Argument : exception;
-- Exception raised when there is a syntax error in the command line
- function Match
- (Pattern : Search_Pattern;
- Symbol : String)
- return Boolean;
- -- Returns true if Symbol matches one of the entities in the command line
-
-----------------------
-- Output Algorithms --
-----------------------
@@ -97,8 +93,9 @@ package Xref_Lib is
------------------------
-- General Algorithms --
------------------------
+
function Default_Project_File (Dir_Name : in String) return String;
- -- Returns the default Project file name
+ -- Returns the default Project file name for the directory Dir_Name.
procedure Search
(Pattern : Search_Pattern;
@@ -107,13 +104,20 @@ package Xref_Lib is
Read_Only : Boolean;
Der_Info : Boolean;
Type_Tree : Boolean);
- -- Search every ali file (following the Readdir rule above), for
- -- each line matching Pattern, and executes Process on these
- -- lines. If World is True, Search will look into every .ali file
- -- in the object search path. If Read_Only is True, we parse the
- -- read-only ali files too. If Der_Mode is true then the derived type
- -- information will be processed. If Type_Tree is true then the type
- -- hierarchy will be search going from pattern to the parent type
+ -- Search every ALI file for entities matching Pattern, and add
+ -- these entities to the internal symbol tables.
+ --
+ -- If Wide_Search is True, all ALI files found in the object path
+ -- are searched.
+ --
+ -- If Read_Only is True, read-only ALI files will also be parsed,
+ -- similar to gnatmake -a.
+ --
+ -- If Der_Info is true, then the derived type information will be
+ -- processed.
+ --
+ -- If Type_Tree is true, then the type hierarchy wil be searched
+ -- going from the pattern to the parent type.
procedure Search_Xref
(Local_Symbols : Boolean;
@@ -124,34 +128,6 @@ package Xref_Lib is
-- files too. If Der_Mode is true then the derived type information will
-- be processed
- ---------------
- -- ALI files --
- ---------------
-
- function Current_Xref_File
- (File : ALI_File)
- return Xr_Tabls.File_Reference;
- -- Returns the name of the file in which the last identifier
- -- is declared
-
- function File_Name
- (File : ALI_File;
- Num : Positive)
- return Xr_Tabls.File_Reference;
- -- Returns the dependency file name number Num
-
- function Get_Full_Type (Abbrev : Character) return String;
- -- Returns the full type corresponding to a type letter as found in
- -- the .ali files.
-
- procedure Open
- (Name : in String;
- File : out ALI_File;
- Dependencies : in Boolean := False);
- -- Open a new ALI file
- -- if Dependencies is True, the insert every library file 'with'ed in
- -- the files database (used for gnatxref)
-
private
type Rec_DIR is limited record
Dir : GNAT.Directory_Operations.Dir_Type;
@@ -194,6 +170,9 @@ private
-- has to be. When the user enters a file:line:column on the command
-- line, it is stored as "Entity_Name Declaration_File:line:column"
+ File_Ref : Xr_Tabls.File_Reference;
+ -- A reference to the source file, if any.
+
Initialized : Boolean := False;
-- Set to True when Entity has been initialized.
end record;
diff --git a/gcc/ada/xsnames.adb b/gcc/ada/xsnames.adb
index bf145004a6e..60368ed6fa8 100644
--- a/gcc/ada/xsnames.adb
+++ b/gcc/ada/xsnames.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -85,10 +85,6 @@ begin
Oname := Nul;
Val := 0;
- Line := A & (Natural'Value (S (Oldrev)) + 1) & " $";
- Line := Rpad (Line, 76) & "--";
- Put_Line (OutB, Line);
-
loop
Line := Get_Line (InB);
exit when Match (Line, " Preset_Names");
@@ -150,7 +146,4 @@ begin
while not End_Of_File (InB) loop
Put_Line (OutB, Get_Line (InB));
end loop;
-
- Put_Line (OutB, "-- Updated to match snames.ads revision " & Specrev);
-
end XSnames;
diff --git a/gcc/ada/xtreeprs.adb b/gcc/ada/xtreeprs.adb
index 014d1d85e97..e3a9518c889 100644
--- a/gcc/ada/xtreeprs.adb
+++ b/gcc/ada/xtreeprs.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2001 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- --
View Lorry Controller Status